6016 lines
310 KiB
EmacsLisp
6016 lines
310 KiB
EmacsLisp
|
;;; ement-room.el --- Ement room buffers -*- lexical-binding: t; -*-
|
|||
|
|
|
|||
|
|
;; Copyright (C) 2022-2023 Free Software Foundation, Inc.
|
|||
|
|
|
|||
|
|
;; Author: Adam Porter <adam@alphapapa.net>
|
|||
|
|
;; Maintainer: Adam Porter <adam@alphapapa.net>
|
|||
|
|
|
|||
|
|
;; This program 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.
|
|||
|
|
|
|||
|
|
;; This program 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 this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
|
|
|
|||
|
|
;;; Commentary:
|
|||
|
|
|
|||
|
|
;; This library implements buffers displaying events in a room.
|
|||
|
|
|
|||
|
|
;; EWOC is a great library. If I had known about it and learned it
|
|||
|
|
;; sooner, it would have saved me a lot of time in other projects.
|
|||
|
|
;; I'm glad I decided to try it for this one.
|
|||
|
|
|
|||
|
|
;;; Code:
|
|||
|
|
|
|||
|
|
;;;; Debugging
|
|||
|
|
|
|||
|
|
;; NOTE: Uncomment this form and `emacs-lisp-byte-compile-and-load' the file to enable
|
|||
|
|
;; `ement-debug' messages. This is commented out by default because, even though the
|
|||
|
|
;; messages are only displayed when `warning-minimum-log-level' is `:debug' at runtime, if
|
|||
|
|
;; that is so at expansion time, the expanded macro calls format the message and check the
|
|||
|
|
;; log level at runtime, which is not zero-cost.
|
|||
|
|
|
|||
|
|
;; (eval-and-compile
|
|||
|
|
;; (setq-local warning-minimum-log-level nil)
|
|||
|
|
;; (setq-local warning-minimum-log-level :debug))
|
|||
|
|
|
|||
|
|
;;;; Requirements
|
|||
|
|
|
|||
|
|
(require 'color)
|
|||
|
|
(require 'ewoc)
|
|||
|
|
(require 'mailcap)
|
|||
|
|
(require 'shr)
|
|||
|
|
(require 'subr-x)
|
|||
|
|
(require 'mwheel)
|
|||
|
|
(require 'dnd)
|
|||
|
|
|
|||
|
|
(require 'ement-api)
|
|||
|
|
(require 'ement-lib)
|
|||
|
|
(require 'ement-macros)
|
|||
|
|
(require 'ement-structs)
|
|||
|
|
|
|||
|
|
;;;; Structs
|
|||
|
|
|
|||
|
|
(cl-defstruct ement-room-membership-events
|
|||
|
|
"Struct grouping membership events.
|
|||
|
|
After adding events, use `ement-room-membership-events--update'
|
|||
|
|
to sort events and update other slots."
|
|||
|
|
(events nil :documentation "Membership events, latest first.")
|
|||
|
|
(earliest-ts nil :documentation "Timestamp of earliest event.")
|
|||
|
|
(latest-ts nil :documentation "Timestamp of latest event."))
|
|||
|
|
|
|||
|
|
(defun ement-room-membership-events--update (struct)
|
|||
|
|
"Return STRUCT having sorted its events and updated its slots."
|
|||
|
|
;; Like the room timeline slot, events are sorted latest-first. We also deduplicate
|
|||
|
|
;; them , because it seems that we can end up with multiple copies of a membership event
|
|||
|
|
;; (e.g. when loading old messages).
|
|||
|
|
(setf (ement-room-membership-events-events struct) (cl-delete-duplicates (ement-room-membership-events-events struct)
|
|||
|
|
:key #'ement-event-id :test #'equal)
|
|||
|
|
(ement-room-membership-events-events struct) (cl-sort (ement-room-membership-events-events struct) #'>
|
|||
|
|
:key #'ement-event-origin-server-ts)
|
|||
|
|
(ement-room-membership-events-earliest-ts struct) (ement-event-origin-server-ts
|
|||
|
|
(car (last (ement-room-membership-events-events struct))))
|
|||
|
|
(ement-room-membership-events-latest-ts struct) (ement-event-origin-server-ts
|
|||
|
|
(car (ement-room-membership-events-events struct))))
|
|||
|
|
struct)
|
|||
|
|
|
|||
|
|
;;;; Variables
|
|||
|
|
|
|||
|
|
(defvar-local ement-ewoc nil
|
|||
|
|
"EWOC for Ement room buffers.")
|
|||
|
|
|
|||
|
|
(defvar-local ement-room nil
|
|||
|
|
"Ement room for current buffer.")
|
|||
|
|
|
|||
|
|
(defvar-local ement-session nil
|
|||
|
|
"Ement session for current buffer.")
|
|||
|
|
|
|||
|
|
;; TODO: Convert some of these buffer-local variables into keys in one buffer-local map variable.
|
|||
|
|
|
|||
|
|
(defvar-local ement-room-retro-loading nil
|
|||
|
|
"Non-nil when earlier messages are being loaded.
|
|||
|
|
Used to avoid overlapping requests.")
|
|||
|
|
|
|||
|
|
(defvar-local ement-room-editing-event nil
|
|||
|
|
"When non-nil, the user is editing this event.
|
|||
|
|
Used by `ement-room-send-message'.")
|
|||
|
|
|
|||
|
|
(defvar-local ement-room-replying-to-event nil
|
|||
|
|
"When non-nil, the user is replying to this event.
|
|||
|
|
Used by `ement-room-send-message'.")
|
|||
|
|
|
|||
|
|
(defvar-local ement-room-replying-to-overlay nil
|
|||
|
|
"Used by `ement-room-write-reply'.")
|
|||
|
|
|
|||
|
|
(defvar-local ement-room-read-receipt-request nil
|
|||
|
|
"Maps event ID to request updating read receipt to that event.
|
|||
|
|
An alist of one entry.")
|
|||
|
|
|
|||
|
|
(defvar ement-room-read-string-setup-hook nil
|
|||
|
|
"Normal hook run by `ement-room-read-string' after switching to minibuffer.
|
|||
|
|
Should be used to, e.g. propagate variables to the minibuffer.")
|
|||
|
|
|
|||
|
|
(defvar ement-room-compose-hook nil
|
|||
|
|
"Hook run in compose buffers when created.
|
|||
|
|
Used to, e.g. call `ement-room-compose-org'.")
|
|||
|
|
|
|||
|
|
(declare-function ement-room-list "ement-room-list.el")
|
|||
|
|
(declare-function ement-notify-switch-to-mentions-buffer "ement-notify")
|
|||
|
|
(declare-function ement-notify-switch-to-notifications-buffer "ement-notify")
|
|||
|
|
|
|||
|
|
(defvar ement-room-mode-self-insert-keymap (make-sparse-keymap)
|
|||
|
|
"The `ement-room-mode' keymap under `ement-room-self-insert-mode'.
|
|||
|
|
|
|||
|
|
Set as the parent keymap of `ement-room-mode-effective-keymap'
|
|||
|
|
when `ement-room-self-insert-mode' is enabled.
|
|||
|
|
|
|||
|
|
This keymap is derived from the `ement-room-self-insert-chars'
|
|||
|
|
and `ement-room-self-insert-commands' user options, along with
|
|||
|
|
`ement-room-mode-map-prefix-key' which provides access to the
|
|||
|
|
full `ement-room-mode-map'. (Non-conflicting key bindings from
|
|||
|
|
`ement-room-mode-map' are also available directly).
|
|||
|
|
|
|||
|
|
This keymap is generated when `ement-room-self-insert-mode' is
|
|||
|
|
enabled, and after customizing any of the above options when the
|
|||
|
|
minor mode is enabled.
|
|||
|
|
|
|||
|
|
The hook `ement-room-mode-self-insert-keymap-update-hook' runs
|
|||
|
|
after generating this keymap.
|
|||
|
|
|
|||
|
|
Note: Emacs bug#66792 may cause `describe-keymap' to include
|
|||
|
|
unreachable key bindings from the parent `ement-room-mode-map' in
|
|||
|
|
its help output. This problem affects only the help, and we work
|
|||
|
|
around it for the `ement-room-mode' help; but when viewing the
|
|||
|
|
keymap directly the issue may be visible.")
|
|||
|
|
|
|||
|
|
(defvar ement-room-mode-map
|
|||
|
|
(let ((map (make-sparse-keymap))
|
|||
|
|
(prefixes '(("M-g" . "group:switching")
|
|||
|
|
("s" . "group:messages")
|
|||
|
|
("u" . "group:users")
|
|||
|
|
("r" . "group:room")
|
|||
|
|
("R" . "group:membership"))))
|
|||
|
|
;; Use symbols for prefix maps so that `which-key' can display their names.
|
|||
|
|
(dolist (prefix prefixes)
|
|||
|
|
(let ((cmd (define-prefix-command (make-symbol (cdr prefix)))))
|
|||
|
|
(define-key map (kbd (car prefix)) cmd)))
|
|||
|
|
|
|||
|
|
;; Menu
|
|||
|
|
(define-key map (kbd "?") #'ement-room-transient)
|
|||
|
|
|
|||
|
|
;; Movement
|
|||
|
|
(define-key map (kbd "n") #'ement-room-goto-next)
|
|||
|
|
(define-key map (kbd "N") #'end-of-buffer)
|
|||
|
|
(define-key map (kbd "p") #'ement-room-goto-prev)
|
|||
|
|
(define-key map (kbd "SPC") #'ement-room-scroll-up-mark-read)
|
|||
|
|
(define-key map (kbd "S-SPC") #'ement-room-scroll-down-command)
|
|||
|
|
(define-key map (kbd "M-g M-p") #'ement-room-goto-fully-read-marker)
|
|||
|
|
(define-key map (kbd "m") #'ement-room-mark-read)
|
|||
|
|
(define-key map [remap scroll-down-command] #'ement-room-scroll-down-command)
|
|||
|
|
(define-key map [remap mwheel-scroll] #'ement-room-mwheel-scroll)
|
|||
|
|
(define-key map (kbd "<tab>") #'forward-button)
|
|||
|
|
(define-key map (kbd "<backtab>") #'backward-button)
|
|||
|
|
|
|||
|
|
;; Switching
|
|||
|
|
(define-key map (kbd "M-g M-l") #'ement-room-list)
|
|||
|
|
(define-key map (kbd "M-g M-r") #'ement-view-room)
|
|||
|
|
(define-key map (kbd "M-g M-m") #'ement-notify-switch-to-mentions-buffer)
|
|||
|
|
(define-key map (kbd "M-g M-n") #'ement-notify-switch-to-notifications-buffer)
|
|||
|
|
(define-key map (kbd "q") #'quit-window)
|
|||
|
|
|
|||
|
|
;; Messages
|
|||
|
|
(define-key map (kbd "RET") #'ement-room-dispatch-new-message)
|
|||
|
|
(define-key map (kbd "M-RET") #'ement-room-dispatch-new-message-alt)
|
|||
|
|
(define-key map (kbd "S-<return>") #'ement-room-dispatch-reply-to-message)
|
|||
|
|
(define-key map (kbd "<insert>") #'ement-room-dispatch-edit-message)
|
|||
|
|
(define-key map (kbd "C-k") #'ement-room-delete-message)
|
|||
|
|
(define-key map (kbd "s r") #'ement-room-send-reaction)
|
|||
|
|
(define-key map (kbd "s e") #'ement-room-send-emote)
|
|||
|
|
(define-key map (kbd "s f") #'ement-room-send-file)
|
|||
|
|
(define-key map (kbd "s i") #'ement-room-send-image)
|
|||
|
|
(define-key map (kbd "v") #'ement-room-view-event)
|
|||
|
|
(define-key map (kbd "D") #'ement-room-download-file)
|
|||
|
|
|
|||
|
|
;; Users
|
|||
|
|
(define-key map (kbd "u RET") #'ement-send-direct-message)
|
|||
|
|
(define-key map (kbd "u i") #'ement-invite-user)
|
|||
|
|
(define-key map (kbd "u I") #'ement-ignore-user)
|
|||
|
|
|
|||
|
|
;; Room
|
|||
|
|
(define-key map (kbd "M-s o") #'ement-room-occur)
|
|||
|
|
(define-key map (kbd "r d") #'ement-describe-room)
|
|||
|
|
(define-key map (kbd "r m") #'ement-list-members)
|
|||
|
|
(define-key map (kbd "r t") #'ement-room-set-topic)
|
|||
|
|
(define-key map (kbd "r f") #'ement-room-set-message-format)
|
|||
|
|
(define-key map (kbd "r n") #'ement-room-set-notification-state)
|
|||
|
|
(define-key map (kbd "r N") #'ement-room-override-name)
|
|||
|
|
(define-key map (kbd "r T") #'ement-tag-room)
|
|||
|
|
|
|||
|
|
;; Room membership
|
|||
|
|
(define-key map (kbd "R c") #'ement-create-room)
|
|||
|
|
(define-key map (kbd "R j") #'ement-join-room)
|
|||
|
|
(define-key map (kbd "R l") #'ement-leave-room)
|
|||
|
|
(define-key map (kbd "R F") #'ement-forget-room)
|
|||
|
|
(define-key map (kbd "R n") #'ement-room-set-display-name)
|
|||
|
|
(define-key map (kbd "R s") #'ement-room-toggle-space)
|
|||
|
|
|
|||
|
|
;; Other
|
|||
|
|
(define-key map (kbd "g") #'ement-room-sync)
|
|||
|
|
map)
|
|||
|
|
"Keymap for Ement room buffers.")
|
|||
|
|
|
|||
|
|
(defvar ement-room-mode-effective-keymap
|
|||
|
|
(let ((map (make-sparse-keymap)))
|
|||
|
|
(set-keymap-parent map ement-room-mode-map)
|
|||
|
|
map)
|
|||
|
|
"The actual keymap used in `ement-room-mode'.
|
|||
|
|
|
|||
|
|
This keymap reflects the state of `ement-room-self-insert-mode',
|
|||
|
|
with a parent of `ement-room-mode-map' when the mode is disabled,
|
|||
|
|
or `ement-room-mode-self-insert-keymap' when the mode is enabled.")
|
|||
|
|
|
|||
|
|
(defvar ement-room-mode--advertised-keymap ement-room-mode-map
|
|||
|
|
"The keymap advertised by `ement-room-mode'.
|
|||
|
|
|
|||
|
|
This keymap should represent the functional behaviour of
|
|||
|
|
`ement-room-mode-effective-keymap' without the confusion arising
|
|||
|
|
from Emacs bug#66792 on account of the effective keymap having
|
|||
|
|
`ement-room-mode-map' as a parent if `ement-room-self-insert-mode'
|
|||
|
|
is enabled.
|
|||
|
|
|
|||
|
|
Because it does not always have `ement-room-mode-map' as a
|
|||
|
|
parent, it is possible for that map to get out of sync with the
|
|||
|
|
advertised map, but `ement-room-mode-self-insert-keymap-update'
|
|||
|
|
makes a best effort to keep it accurate.")
|
|||
|
|
|
|||
|
|
(defvar ement-room-minibuffer-map
|
|||
|
|
(let ((map (make-sparse-keymap)))
|
|||
|
|
(set-keymap-parent map minibuffer-local-map)
|
|||
|
|
(define-key map (kbd "C-c '") #'ement-room-compose-from-minibuffer)
|
|||
|
|
map)
|
|||
|
|
"Keymap used in `ement-room-read-string'.")
|
|||
|
|
|
|||
|
|
(defvar ement-room-reaction-map
|
|||
|
|
(let ((map (make-sparse-keymap)))
|
|||
|
|
(define-key map "c" #'insert-char)
|
|||
|
|
(when (commandp 'emoji-insert)
|
|||
|
|
(define-key map "i" 'emoji-insert))
|
|||
|
|
(when (commandp 'emoji-search)
|
|||
|
|
(define-key map "s" 'emoji-search))
|
|||
|
|
(when (assoc "emoji" input-method-alist)
|
|||
|
|
(define-key map "m" 'ement-room-use-emoji-input-method))
|
|||
|
|
map)
|
|||
|
|
"Keymap used in `ement-room-send-reaction'.")
|
|||
|
|
|
|||
|
|
(defvar ement-room-sender-in-headers nil
|
|||
|
|
"Non-nil when sender is displayed in headers.
|
|||
|
|
In that case, sender names are aligned to the margin edge.")
|
|||
|
|
|
|||
|
|
(defvar ement-room-messages-filter
|
|||
|
|
'((lazy_load_members . t))
|
|||
|
|
;; NOTE: The confusing differences between what /sync and /messages
|
|||
|
|
;; expect. See <https://github.com/matrix-org/matrix-doc/issues/706>.
|
|||
|
|
"Default RoomEventFilter for /messages requests.")
|
|||
|
|
|
|||
|
|
(defvar ement-room-typing-timer nil
|
|||
|
|
"Timer used to send notifications while typing.")
|
|||
|
|
|
|||
|
|
(defvar ement-room-matrix.to-url-regexp
|
|||
|
|
(rx "http" (optional "s") "://"
|
|||
|
|
"matrix.to" "/#/"
|
|||
|
|
(group (or "!" "#") (1+ (not (any "/"))))
|
|||
|
|
(optional "/" (group "$" (1+ (not (any "?" "/")))))
|
|||
|
|
(optional "?" (group (1+ anything))))
|
|||
|
|
"Regexp matching \"matrix.to\" URLs.")
|
|||
|
|
|
|||
|
|
(defvar ement-room-message-history nil
|
|||
|
|
"History list of messages entered with `ement-room' commands.
|
|||
|
|
Does not include filenames, emotes, etc.")
|
|||
|
|
|
|||
|
|
(defvar ement-room-emote-history nil
|
|||
|
|
"History list of emotes entered with `ement-room' commands.")
|
|||
|
|
|
|||
|
|
;; Variables from other files.
|
|||
|
|
(defvar ement-sessions)
|
|||
|
|
(defvar ement-syncs)
|
|||
|
|
(defvar ement-auto-sync)
|
|||
|
|
(defvar ement-users)
|
|||
|
|
(defvar ement-images-queue)
|
|||
|
|
(defvar ement-notify-limit-room-name-width)
|
|||
|
|
(defvar ement-view-room-display-buffer-action)
|
|||
|
|
|
|||
|
|
;; Defined in Emacs 28.1: silence byte-compilation warning in earlier versions.
|
|||
|
|
(defvar browse-url-handlers)
|
|||
|
|
|
|||
|
|
;;;; Customization
|
|||
|
|
|
|||
|
|
(defgroup ement-room-faces nil
|
|||
|
|
"Faces for room buffers."
|
|||
|
|
:group 'ement-room
|
|||
|
|
:group 'ement-faces)
|
|||
|
|
|
|||
|
|
(defgroup ement-room nil
|
|||
|
|
"Options for room buffers."
|
|||
|
|
:group 'ement)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-timestamp-header-align 'right
|
|||
|
|
"Where to align timestamp headers."
|
|||
|
|
:type '(choice (const :tag "Left" left)
|
|||
|
|
(const :tag "Center" center)
|
|||
|
|
(const :tag "Right" right)))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-view-hook
|
|||
|
|
'(ement-room-view-hook-room-list-auto-update)
|
|||
|
|
"Functions called when `ement-room-view' is called.
|
|||
|
|
Called with two arguments, the room and the session."
|
|||
|
|
:type 'hook)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-reaction-names-limit 3
|
|||
|
|
"Up to this many users, show a reaction's senders' names.
|
|||
|
|
If more than this many users have sent a reaction, show the
|
|||
|
|
number of senders instead (and the names in a tooltip)."
|
|||
|
|
:type 'natnum)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-hide-redacted-message-content t
|
|||
|
|
"Hide content in redacted messages.
|
|||
|
|
If nil, redacted messages' content will remain visible with a
|
|||
|
|
strikethrough face until the session is terminated (a new session
|
|||
|
|
will not receive the redacted content).
|
|||
|
|
|
|||
|
|
Disabling this option may be useful for room administrators and
|
|||
|
|
moderators, so they can see content redacted by other users and
|
|||
|
|
handle it appropriately. However, one should use this option
|
|||
|
|
with caution, as it will keep unpleasant content visible even
|
|||
|
|
after it has been redacted.
|
|||
|
|
|
|||
|
|
After changing this option, a room's buffer must be killed and
|
|||
|
|
reopened for existing messages to be rendered accordingly."
|
|||
|
|
:type '(choice (const :tag "Hide content" t)
|
|||
|
|
(const :tag "Strikethrough" nil)))
|
|||
|
|
|
|||
|
|
;;;;; Faces
|
|||
|
|
|
|||
|
|
(defface ement-room-name
|
|||
|
|
'((t (:inherit font-lock-function-name-face)))
|
|||
|
|
"Room name shown in header line."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-membership
|
|||
|
|
'((t (:height 0.8 :inherit font-lock-comment-face)))
|
|||
|
|
"Membership events (join/part)."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-reactions
|
|||
|
|
'((t (:inherit font-lock-comment-face :height 0.9)))
|
|||
|
|
"Reactions to messages (including the user count)."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-reactions-key
|
|||
|
|
'((t (:inherit ement-room-reactions :height 1.5)))
|
|||
|
|
"Reactions to messages (the key, i.e. the emoji part).
|
|||
|
|
Uses a separate face to allow the key to be shown at a different
|
|||
|
|
size, because in some fonts, emojis are too small relative to
|
|||
|
|
normal text."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-timestamp
|
|||
|
|
'((t (:inherit font-lock-comment-face)))
|
|||
|
|
"Event timestamps."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-user
|
|||
|
|
'((t (:inherit font-lock-function-name-face :weight bold :overline t)))
|
|||
|
|
"Usernames."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-self
|
|||
|
|
'((t (:inherit (font-lock-variable-name-face ement-room-user) :weight bold)))
|
|||
|
|
"Own username."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-message-text
|
|||
|
|
'((t (:inherit default)))
|
|||
|
|
"Text message bodies."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-message-emote
|
|||
|
|
'((t (:inherit italic)))
|
|||
|
|
"Emote message bodies."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-quote
|
|||
|
|
'((t (:height 0.9 :inherit font-lock-comment-face)))
|
|||
|
|
"Quoted parts of messages.
|
|||
|
|
Anything wrapped by HTML BLOCKQUOTE tag."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-redacted
|
|||
|
|
'((t (:strike-through t)))
|
|||
|
|
"Redacted messages."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-self-message
|
|||
|
|
'((t (:inherit (font-lock-variable-name-face))))
|
|||
|
|
"Oneself's message bodies.
|
|||
|
|
Note that this does not need to inherit
|
|||
|
|
`ement-room-message-text', because that face is combined with
|
|||
|
|
this one automatically."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-timestamp-header
|
|||
|
|
'((t (:inherit header-line :weight bold :height 1.1)))
|
|||
|
|
"Timestamp headers."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-mention
|
|||
|
|
;; TODO(30.1): Remove when not supporting Emacs 27 anymore.
|
|||
|
|
(if (version< emacs-version "27.1")
|
|||
|
|
'((t (:inherit hl-line)))
|
|||
|
|
'((t (:inherit hl-line :extend t))))
|
|||
|
|
"Messages that mention the local user."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-wrap-prefix
|
|||
|
|
`((t :inherit highlight))
|
|||
|
|
"Face applied to `ement-room-wrap-prefix', which see."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
;;;;; Options
|
|||
|
|
|
|||
|
|
(defcustom ement-room-ellipsis "⋮"
|
|||
|
|
"String used when abbreviating certain strings."
|
|||
|
|
:type 'string)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-avatars (display-images-p)
|
|||
|
|
"Show room avatars."
|
|||
|
|
:type 'boolean)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-avatar-max-width 32
|
|||
|
|
"Maximum width in pixels of room avatars shown in header lines."
|
|||
|
|
:type 'integer)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-avatar-max-height 32
|
|||
|
|
"Maximum height in pixels of room avatars shown in header lines."
|
|||
|
|
:type 'integer)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-coalesce-events 100
|
|||
|
|
"Coalesce certain events in room buffers.
|
|||
|
|
For example, membership events can be overwhelming in large
|
|||
|
|
rooms, especially ones bridged to IRC. This option groups them
|
|||
|
|
together so they take less space.
|
|||
|
|
|
|||
|
|
The current, naïve implementation re-renders events as they are
|
|||
|
|
coalesced, which can cause a performance problem in unusual
|
|||
|
|
circumstances, so the number of events coalesced into a single,
|
|||
|
|
rendered event may be limited."
|
|||
|
|
:type '(choice (integer :tag "Up to this many events")
|
|||
|
|
(const :tag "An unlimited number of events"
|
|||
|
|
;; NOTE: As this docstring says, in most cases it should be fine,
|
|||
|
|
;; but since in those rare cases the problem can be unusually bad
|
|||
|
|
;; (e.g. taking 15 minutes to render a room's events in
|
|||
|
|
;; <https://github.com/alphapapa/ement.el/issues/247>), we default
|
|||
|
|
;; to a safer choice.
|
|||
|
|
:doc "Note that this choice may cause performance problems in rooms with very large numbers of consecutive membership events, but in most cases it should be fine."
|
|||
|
|
t)
|
|||
|
|
(const :tag "Don't coalesce" nil)))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-header-line-format
|
|||
|
|
;; TODO: Show in new screenshots.
|
|||
|
|
'(:eval (concat (if ement-room-avatars
|
|||
|
|
(or (ement-room-avatar ement-room)
|
|||
|
|
"")
|
|||
|
|
"")
|
|||
|
|
" " (propertize (ement-room--escape-%
|
|||
|
|
(or (ement-room-display-name ement-room)
|
|||
|
|
"[no room name]"))
|
|||
|
|
'face 'ement-room-name)
|
|||
|
|
": " (propertize (ement-room--escape-%
|
|||
|
|
(or (ement-room-topic ement-room)
|
|||
|
|
"[no topic]"))
|
|||
|
|
;; Also set help-echo in case the topic is too wide to fit.
|
|||
|
|
'help-echo (ement-room-topic ement-room))))
|
|||
|
|
"Header line format for room buffers.
|
|||
|
|
See Info node `(elisp)Header lines'."
|
|||
|
|
:type 'sexp)
|
|||
|
|
(put 'ement-room-header-line-format 'risky-local-variable t)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-buffer-name-prefix "*Ement Room: "
|
|||
|
|
"Prefix for Ement room buffer names."
|
|||
|
|
:type 'string)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-buffer-name-suffix "*"
|
|||
|
|
"Suffix for Ement room buffer names."
|
|||
|
|
:type 'string)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-timestamp-format "%H:%M:%S"
|
|||
|
|
"Format string for event timestamps.
|
|||
|
|
See function `format-time-string'."
|
|||
|
|
:type '(choice (const "%H:%M:%S")
|
|||
|
|
(const "%Y-%m-%d %H:%M:%S")
|
|||
|
|
string))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-left-margin-width 0
|
|||
|
|
"Width of left margin in room buffers.
|
|||
|
|
When using a non-graphical display, this should be set slightly
|
|||
|
|
wider than when using a graphical display, to prevent sender
|
|||
|
|
display names from colliding with event text."
|
|||
|
|
:type 'integer)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-right-margin-width (length ement-room-timestamp-format)
|
|||
|
|
"Width of right margin in room buffers."
|
|||
|
|
:type 'integer)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-sender-headers t
|
|||
|
|
"Show sender headers.
|
|||
|
|
Automatically set by setting `ement-room-message-format-spec',
|
|||
|
|
but may be overridden manually."
|
|||
|
|
:type 'boolean)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-unread-only-counts-notifications t
|
|||
|
|
"Only use notification counts to mark rooms unread.
|
|||
|
|
Notification counts are set by the server based on each room's
|
|||
|
|
notification settings. Otherwise, whether a room is marked
|
|||
|
|
unread depends on the room's fully-read marker, read-receipt
|
|||
|
|
marker, whether the local user sent the latest events, etc."
|
|||
|
|
:type 'boolean)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-compose-method 'minibuffer
|
|||
|
|
"How to compose messages.
|
|||
|
|
|
|||
|
|
The value `minibuffer' means the minibuffer will be used to write
|
|||
|
|
and edit messages. You can use \
|
|||
|
|
\\<ement-room-minibuffer-map>\\[ement-room-compose-from-minibuffer] \
|
|||
|
|
to switch from the minibuffer
|
|||
|
|
to a separate compose buffer, and \\[save-buffer] in the compose buffer
|
|||
|
|
will then return you to the minibuffer to confirm the message
|
|||
|
|
before sending.
|
|||
|
|
|
|||
|
|
The value `compose-buffer' means that the minibuffer is not used --
|
|||
|
|
messages are written in a compose buffer by default, and \\[save-buffer]
|
|||
|
|
sends the composed message directly."
|
|||
|
|
:type '(choice (const :tag "Minibuffer" minibuffer)
|
|||
|
|
(const :tag "Compose buffer" compose-buffer)))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-compose-buffer-display-action
|
|||
|
|
(cons 'display-buffer-below-selected
|
|||
|
|
'((window-height . 3)
|
|||
|
|
(inhibit-same-window . t)
|
|||
|
|
(reusable-frames . nil)))
|
|||
|
|
"`display-buffer' action for displaying compose buffers.
|
|||
|
|
|
|||
|
|
See also option `ement-room-compose-buffer-window-auto-height'
|
|||
|
|
and `ement-room-compose-buffer-window-dedicated'."
|
|||
|
|
:type display-buffer--action-custom-type
|
|||
|
|
:risky t)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-compose-buffer-window-dedicated 'created
|
|||
|
|
"Whether windows for compose buffers should be dedicated.
|
|||
|
|
|
|||
|
|
A dedicated compose buffer window will not be used to display any
|
|||
|
|
other buffer, and will be deleted once the message has been sent
|
|||
|
|
or aborted (see `ement-room-compose-buffer-quit-restore-window').
|
|||
|
|
|
|||
|
|
The values t and nil mean \"always\" and \"never\" respectively.
|
|||
|
|
|
|||
|
|
The value `created' means newly-created windows are dedicated.
|
|||
|
|
\(The default `ement-room-compose-buffer-display-action' always
|
|||
|
|
creates a new window.)
|
|||
|
|
|
|||
|
|
The value `auto-height' means that windows will be dedicated if
|
|||
|
|
the option `ement-room-compose-buffer-window-auto-height' is
|
|||
|
|
enabled (this option generally keeps the windows too small to
|
|||
|
|
usefully display other buffers).
|
|||
|
|
|
|||
|
|
The value `delete' means that windows will not be dedicated, but
|
|||
|
|
they will still be deleted once the message is sent or aborted
|
|||
|
|
\(even when they have also been used to display other buffers).
|
|||
|
|
|
|||
|
|
See also `set-window-dedicated-p' and
|
|||
|
|
`switch-to-buffer-in-dedicated-window'."
|
|||
|
|
:type '(radio (const :tag "Always" t)
|
|||
|
|
(const :tag "Never" nil)
|
|||
|
|
(const :tag "Never (but always delete window)" delete)
|
|||
|
|
(const :tag "Newly-created windows" created)
|
|||
|
|
(const :tag "When auto-height enabled" auto-height)))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-compose-buffer-window-auto-height t
|
|||
|
|
"Dynamically match the compose buffer window height to its contents.
|
|||
|
|
See also `ement-room-compose-buffer-window-auto-height-max' and
|
|||
|
|
`ement-room-compose-buffer-window-auto-height-min'."
|
|||
|
|
:type 'boolean)
|
|||
|
|
|
|||
|
|
;; Experimental. Disabled by default. Set to 'height to use this.
|
|||
|
|
(defvar ement-room-compose-buffer-window-auto-height-fixed nil
|
|||
|
|
"The buffer-local `window-size-fixed' value in compose buffers.")
|
|||
|
|
|
|||
|
|
(defvar ement-room-compose-buffer-window-auto-height-pixelwise t
|
|||
|
|
"Whether to adjust the window height for pixel-precise lines.")
|
|||
|
|
|
|||
|
|
;; This is a mutex to ensure that auto-height resizing cannot trigger itself
|
|||
|
|
;; recursively. This may prevent desirable resizing in certain cases, but we
|
|||
|
|
;; get the correct result in the majority of situations, and it is simple.
|
|||
|
|
(defvar ement-room-compose-buffer-window-auto-height-resizing-p)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-compose-buffer-window-auto-height-min nil
|
|||
|
|
"If non-nil, limits the body height of the compose buffer window.
|
|||
|
|
|
|||
|
|
See also option `ement-room-compose-buffer-window-auto-height'
|
|||
|
|
and `ement-room-compose-buffer-window-auto-height-max'."
|
|||
|
|
:type '(choice (const :tag "Default" nil)
|
|||
|
|
(natnum :tag "Lines")))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-compose-buffer-window-auto-height-max nil
|
|||
|
|
"If non-nil, limits the body height of the compose buffer window.
|
|||
|
|
|
|||
|
|
See also option `ement-room-compose-buffer-window-auto-height'
|
|||
|
|
and `ement-room-compose-buffer-window-auto-height-min'."
|
|||
|
|
:type '(choice (const :tag "Default" nil)
|
|||
|
|
(natnum :tag "Lines")))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-mode-self-insert-keymap-update-hook nil
|
|||
|
|
"Hook run after rebuilding `ement-room-mode-self-insert-keymap'.
|
|||
|
|
|
|||
|
|
This happens at the time `ement-room-self-insert-mode' is
|
|||
|
|
enabled, and also if user options `ement-room-self-insert-chars',
|
|||
|
|
`ement-room-self-insert-commands', or
|
|||
|
|
`ement-room-mode-map-prefix-key' are customized while the mode is
|
|||
|
|
enabled.
|
|||
|
|
|
|||
|
|
You can use this hook to define any desired custom bindings which
|
|||
|
|
are not accounted for by those user options."
|
|||
|
|
:type 'hook)
|
|||
|
|
|
|||
|
|
(defvar ement-room-self-insert-mode)
|
|||
|
|
(defvar ement-room-self-insert-chars)
|
|||
|
|
(defvar ement-room-self-insert-commands)
|
|||
|
|
(defun ement-room-mode-self-insert-keymap-update ()
|
|||
|
|
"Rebuilds `ement-room-mode-self-insert-keymap'.
|
|||
|
|
Also rebuilds `ement-room-mode--advertised-keymap'."
|
|||
|
|
;; Must be defined ahead of `ement-room-self-insert-option-setter'.
|
|||
|
|
(let ((map (make-sparse-keymap)))
|
|||
|
|
;; Ensure that `ement-room-self-insert-chars' start a message.
|
|||
|
|
(dolist (range ement-room-self-insert-chars)
|
|||
|
|
(if (consp range)
|
|||
|
|
;; Process a range the same way that `global-map' does.
|
|||
|
|
(let ((vec1 (make-vector 1 nil))
|
|||
|
|
(from (car range))
|
|||
|
|
(to (cdr range)))
|
|||
|
|
(while (<= from to)
|
|||
|
|
(aset vec1 0 from)
|
|||
|
|
(define-key map vec1 #'ement-room-self-insert-new-message)
|
|||
|
|
(setq from (1+ from))))
|
|||
|
|
;; Else `range' is a single character.
|
|||
|
|
(define-key map (vector range) #'ement-room-self-insert-new-message)))
|
|||
|
|
;; Provide access to `ement-room-mode-map' via a prefix binding.
|
|||
|
|
(when (bound-and-true-p ement-room-mode-map-prefix-key)
|
|||
|
|
(define-key map ement-room-mode-map-prefix-key ement-room-mode-map))
|
|||
|
|
;; This is now the basis for `ement-room-mode-self-insert-keymap' and also
|
|||
|
|
;; `ement-room-mode--advertised-keymap' (when `ement-room-self-insert-mode'
|
|||
|
|
;; is enabled), but we need to keep the remaining differences between them
|
|||
|
|
;; separate. (We do still need some identical `remap' bindings for both
|
|||
|
|
;; keymaps, but we can't do that just yet.)
|
|||
|
|
(setq ement-room-mode-self-insert-keymap (copy-keymap map))
|
|||
|
|
;; To `ement-room-mode-self-insert-keymap', add `ement-room-mode-map'
|
|||
|
|
;; as the keymap parent. (This is the keymap which is actually used.)
|
|||
|
|
(set-keymap-parent ement-room-mode-self-insert-keymap ement-room-mode-map)
|
|||
|
|
(if (not (bound-and-true-p ement-room-self-insert-mode))
|
|||
|
|
;; Advertise the real `ement-room-mode-map'.
|
|||
|
|
(setq ement-room-mode--advertised-keymap ement-room-mode-map)
|
|||
|
|
;; Otherwise we base `ement-room-mode--advertised-keymap' on the same base
|
|||
|
|
;; map previously copied to `ement-room-mode-self-insert-keymap'.
|
|||
|
|
(setq ement-room-mode--advertised-keymap map)
|
|||
|
|
;; To `ement-room-mode--advertised-keymap' (the keymap displayed when
|
|||
|
|
;; `describe-mode' is called), rather than setting a parent we instead
|
|||
|
|
;; copy the non-conflicting top-level bindings from `ement-room-mode-map'.
|
|||
|
|
;; Not using a keymap parent means the advertised map doesn't see any
|
|||
|
|
;; future changes to `ement-room-mode-map', but having a keymap parent
|
|||
|
|
;; would make the `describe-mode' output very confusing on account of
|
|||
|
|
;; Emacs bug#66792, so we accept potential inaccuracy as a trade-off for
|
|||
|
|
;; showing more comprehensible help.
|
|||
|
|
;;
|
|||
|
|
;; The following will copy the `remap' keymap verbatim, clobbering any
|
|||
|
|
;; pre-existing remappings; so we do this before we define other
|
|||
|
|
;; remappings.
|
|||
|
|
(cl-labels ((copy-from (key definition)
|
|||
|
|
(unless (lookup-key ement-room-mode--advertised-keymap
|
|||
|
|
(vector key))
|
|||
|
|
(define-key ement-room-mode--advertised-keymap
|
|||
|
|
(vector key) definition))))
|
|||
|
|
;; Copy from a copy of `ement-room-mode-map', otherwise the latter will
|
|||
|
|
;; also acquire (share) the remap keybindings which are added below.
|
|||
|
|
(map-keymap #'copy-from (copy-keymap ement-room-mode-map))))
|
|||
|
|
;; Now define our additional `remap' bindings in both keymaps.
|
|||
|
|
(let ((keymaps (if (bound-and-true-p ement-room-self-insert-mode)
|
|||
|
|
(list ement-room-mode-self-insert-keymap
|
|||
|
|
ement-room-mode--advertised-keymap)
|
|||
|
|
(list ement-room-mode-self-insert-keymap))))
|
|||
|
|
(dolist (keymap keymaps)
|
|||
|
|
;; Make `self-insert-command' (and friends) start a new message.
|
|||
|
|
(dolist (cmd ement-room-self-insert-commands)
|
|||
|
|
(define-key keymap (vector 'remap cmd)
|
|||
|
|
#'ement-room-self-insert-new-message)))))
|
|||
|
|
(run-hooks 'ement-room-mode-self-insert-keymap-update-hook))
|
|||
|
|
|
|||
|
|
(defun ement-room-mode-effective-keymap-update ()
|
|||
|
|
"Sets the parent keymap for `ement-room-mode-effective-keymap'.
|
|||
|
|
|
|||
|
|
Either `ement-room-mode-self-insert-keymap' or `ement-room-mode-map',
|
|||
|
|
depending on `ement-room-self-insert-mode'."
|
|||
|
|
;; Must be defined ahead of `ement-room-self-insert-option-setter'.
|
|||
|
|
(set-keymap-parent ement-room-mode-effective-keymap
|
|||
|
|
(if (bound-and-true-p ement-room-self-insert-mode)
|
|||
|
|
ement-room-mode-self-insert-keymap
|
|||
|
|
ement-room-mode-map)))
|
|||
|
|
|
|||
|
|
(defun ement-room-self-insert-option-setter (option value)
|
|||
|
|
"Setter for options affecting `ement-room-self-insert-mode'.
|
|||
|
|
|
|||
|
|
This is the setter function for `ement-room-self-insert-chars'
|
|||
|
|
and `ement-room-self-insert-commands'.
|
|||
|
|
|
|||
|
|
Sets the value with (set-default-toplevel-value OPTION VALUE),
|
|||
|
|
and then rebuilds `ement-room-mode-self-insert-keymap'."
|
|||
|
|
;; Must be defined ahead of `ement-room-self-insert-chars' and
|
|||
|
|
;; `ement-room-self-insert-commands'.
|
|||
|
|
;;
|
|||
|
|
;; Update the variable.
|
|||
|
|
(set-default-toplevel-value option value)
|
|||
|
|
;; Update keymaps when necessary.
|
|||
|
|
(when (bound-and-true-p ement-room-self-insert-mode)
|
|||
|
|
(ement-room-mode-self-insert-keymap-update)
|
|||
|
|
(ement-room-mode-effective-keymap-update)))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-self-insert-chars
|
|||
|
|
'((33 . 62) (64 . 126))
|
|||
|
|
"Characters handled by `ement-room-self-insert-mode'.
|
|||
|
|
|
|||
|
|
These are in addition to any `self-insert-command' key bindings
|
|||
|
|
-- this list is to ensure that certain keys will be treated this
|
|||
|
|
way even when they have `ement-room-mode-map' bindings.
|
|||
|
|
|
|||
|
|
Cons cell elements represent the range from the car to the cdr
|
|||
|
|
\(inclusive). The default value covers the common \"printable\"
|
|||
|
|
ASCII characters excluding SPC (32), ? (63), and DEL (127).
|
|||
|
|
|
|||
|
|
Customizing this option updates `ement-room-mode-self-insert-keymap'
|
|||
|
|
via the setter function `ement-room-self-insert-option-setter'.
|
|||
|
|
To do the same in lisp code, set the option with `setopt'.
|
|||
|
|
|
|||
|
|
See also `ement-room-self-insert-commands'."
|
|||
|
|
:type '(repeat (choice (character :tag "Character")
|
|||
|
|
(cons :tag "Character range"
|
|||
|
|
(character :tag "From")
|
|||
|
|
(character :tag "To"))))
|
|||
|
|
:set #'ement-room-self-insert-option-setter)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-self-insert-commands
|
|||
|
|
'(self-insert-command yank)
|
|||
|
|
"Commands handled by `ement-room-self-insert-mode'.
|
|||
|
|
|
|||
|
|
When the mode is enabled, the listed commands are remapped to
|
|||
|
|
`ement-room-self-insert-new-message' such that when one of those
|
|||
|
|
commands is invoked in a room buffer, a new message will be
|
|||
|
|
started and the event which triggered the command (typically a
|
|||
|
|
`self-insert-command' key binding) will be re-issued in the
|
|||
|
|
message buffer.
|
|||
|
|
|
|||
|
|
Customizing this option updates `ement-room-mode-self-insert-keymap'
|
|||
|
|
via the setter function `ement-room-self-insert-option-setter'.
|
|||
|
|
To do the same in lisp code, set the option with `setopt'.
|
|||
|
|
|
|||
|
|
See also `ement-room-self-insert-chars'."
|
|||
|
|
:type '(repeat (function :tag "Command"))
|
|||
|
|
:set #'ement-room-self-insert-option-setter)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-mode-map-prefix-key (kbd "DEL")
|
|||
|
|
"A prefix key sequence to access `ement-room-mode-map'.
|
|||
|
|
Active when `ement-room-self-insert-mode' is enabled.
|
|||
|
|
|
|||
|
|
The default key is DEL.
|
|||
|
|
|
|||
|
|
Customizing this option updates `ement-room-mode-self-insert-keymap'
|
|||
|
|
via the setter function `ement-room-self-insert-option-setter'.
|
|||
|
|
To do the same in lisp code, set the option with `setopt'."
|
|||
|
|
:type 'key-sequence
|
|||
|
|
:set #'ement-room-self-insert-option-setter)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-reaction-picker (if (commandp 'emoji-search)
|
|||
|
|
'emoji-search
|
|||
|
|
#'insert-char)
|
|||
|
|
"Command used to select a reaction by `ement-room-send-reaction'.
|
|||
|
|
Should be set to a command that somehow prompts the user for an
|
|||
|
|
emoji and inserts it into the current buffer. In Emacs 29
|
|||
|
|
reasonable choices include `emoji-insert' which uses a transient
|
|||
|
|
interface, and `emoji-search' which uses `completing-read'. If
|
|||
|
|
those are not available, one can use `insert-char'."
|
|||
|
|
:type `(choice
|
|||
|
|
(const :tag "Complete unicode character name" insert-char)
|
|||
|
|
,@(when (commandp 'emoji-insert)
|
|||
|
|
'((const :tag "Categorized emoji menu" emoji-insert)))
|
|||
|
|
,@(when (commandp 'emoji-search)
|
|||
|
|
'((const :tag "Complete emoji name" emoji-search)))
|
|||
|
|
,@(when (assoc "emoji" input-method-alist)
|
|||
|
|
'((const :tag "Emoji input method"
|
|||
|
|
ement-room-use-emoji-input-method)))
|
|||
|
|
(const :tag "Type an emoji without assistance" ignore)
|
|||
|
|
(function :tag "Use other command")))
|
|||
|
|
|
|||
|
|
(defvar ement-room-sender-in-left-margin nil
|
|||
|
|
"Whether sender is shown in left margin.
|
|||
|
|
Set by `ement-room-message-format-spec-setter'.")
|
|||
|
|
|
|||
|
|
(defun ement-room-message-format-spec-setter (option value &optional local)
|
|||
|
|
"Set relevant options for `ement-room-message-format-spec', which see.
|
|||
|
|
To be used as that option's setter. OPTION and VALUE are
|
|||
|
|
received from setting the customization option. If LOCAL is
|
|||
|
|
non-nil, set the variables buffer-locally (i.e. when called from
|
|||
|
|
`ement-room-set-message-format'."
|
|||
|
|
(cl-macrolet ((set-vars (&rest pairs)
|
|||
|
|
;; Set variable-value pairs, locally if LOCAL is non-nil.
|
|||
|
|
`(progn
|
|||
|
|
,@(cl-loop for (symbol value) on pairs by #'cddr
|
|||
|
|
collect `(if local
|
|||
|
|
(set (make-local-variable ',symbol) ,value)
|
|||
|
|
(set ',symbol ,value))))))
|
|||
|
|
(if local
|
|||
|
|
(set (make-local-variable option) value)
|
|||
|
|
(set-default option value))
|
|||
|
|
(pcase value
|
|||
|
|
;; Try to set the margin widths smartly.
|
|||
|
|
("%B%r%R%t" ;; "Elemental"
|
|||
|
|
(set-vars ement-room-left-margin-width 0
|
|||
|
|
ement-room-right-margin-width 8
|
|||
|
|
ement-room-sender-headers t
|
|||
|
|
ement-room-sender-in-headers t
|
|||
|
|
ement-room-sender-in-left-margin nil))
|
|||
|
|
("%S%L%B%r%R%t" ;; "IRC-style using margins"
|
|||
|
|
(set-vars ement-room-left-margin-width 12
|
|||
|
|
ement-room-right-margin-width 8
|
|||
|
|
ement-room-sender-headers nil
|
|||
|
|
ement-room-sender-in-headers nil
|
|||
|
|
ement-room-sender-in-left-margin t))
|
|||
|
|
("[%t] %S> %B%r" ;; "IRC-style without margins"
|
|||
|
|
(set-vars ement-room-left-margin-width 0
|
|||
|
|
ement-room-right-margin-width 0
|
|||
|
|
ement-room-sender-headers nil
|
|||
|
|
ement-room-sender-in-headers nil
|
|||
|
|
ement-room-sender-in-left-margin nil))
|
|||
|
|
(_ (set-vars ement-room-left-margin-width
|
|||
|
|
(if (string-match-p "%L" value)
|
|||
|
|
12 0)
|
|||
|
|
ement-room-right-margin-width
|
|||
|
|
(if (string-match-p "%R" value)
|
|||
|
|
8 0)
|
|||
|
|
ement-room-sender-in-left-margin
|
|||
|
|
(if (string-match-p (rx (1+ anything) (or "%S" "%s") (1+ anything) "%L") value)
|
|||
|
|
t nil)
|
|||
|
|
;; NOTE: The following two variables may seem redundant, but one is an
|
|||
|
|
;; option that the user may override, while the other is set
|
|||
|
|
;; automatically.
|
|||
|
|
ement-room-sender-headers
|
|||
|
|
(if (string-match-p (or "%S" "%s") value)
|
|||
|
|
;; If "%S" or "%s" isn't found, assume it's to be shown in headers.
|
|||
|
|
nil t)
|
|||
|
|
ement-room-sender-in-headers
|
|||
|
|
(if (string-match-p (rx (or "%S" "%s")) value)
|
|||
|
|
;; If "%S" or "%s" isn't found, assume it's to be shown in headers.
|
|||
|
|
nil t))
|
|||
|
|
(message "Ement: When using custom message format, setting margin widths may be necessary")))
|
|||
|
|
(unless ement-room-sender-in-headers
|
|||
|
|
;; HACK: Disable overline on sender face.
|
|||
|
|
(require 'face-remap)
|
|||
|
|
(if local
|
|||
|
|
(progn
|
|||
|
|
(face-remap-reset-base 'ement-room-user)
|
|||
|
|
(face-remap-add-relative 'ement-room-user '(:overline nil)))
|
|||
|
|
(set-face-attribute 'ement-room-user nil :overline nil)))
|
|||
|
|
(unless local
|
|||
|
|
(when (and (bound-and-true-p ement-sessions) (car ement-sessions))
|
|||
|
|
;; Only display when a session is connected (not sure why `bound-and-true-p'
|
|||
|
|
;; is required to avoid compilation warnings).
|
|||
|
|
(message "Ement: Kill and reopen room buffers to display in new format")))))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-message-format-spec "%S%L%B%r%R%t"
|
|||
|
|
"Format messages according to this spec.
|
|||
|
|
It may contain these specifiers:
|
|||
|
|
|
|||
|
|
%L End of left margin
|
|||
|
|
%R Start of right margin
|
|||
|
|
%W End of wrap-prefix
|
|||
|
|
|
|||
|
|
%b Message body (plain-text)
|
|||
|
|
%B Message body (formatted if available)
|
|||
|
|
%i Event ID
|
|||
|
|
%O Room display name (used for mentions buffer)
|
|||
|
|
%r Reactions
|
|||
|
|
%s Sender ID
|
|||
|
|
%S Sender display name
|
|||
|
|
%t Event timestamp, formatted according to
|
|||
|
|
`ement-room-timestamp-format'
|
|||
|
|
|
|||
|
|
Note that margin sizes must be set manually with
|
|||
|
|
`ement-room-left-margin-width' and
|
|||
|
|
`ement-room-right-margin-width'."
|
|||
|
|
:type '(choice (const :tag "IRC-style using margins" "%S%L%B%r%R%t")
|
|||
|
|
(const :tag "IRC-style without margins" "[%t] %S> %B%r")
|
|||
|
|
(const :tag "IRC-style without margins, with wrap-prefix" "[%t] %S> %W%B%r")
|
|||
|
|
(const :tag "IRC-style with right margin, with wrap-prefix" "%S> %W%B%r%R%t")
|
|||
|
|
(const :tag "Elemental" "%B%r%R%t")
|
|||
|
|
(string :tag "Custom format"))
|
|||
|
|
:set #'ement-room-message-format-spec-setter
|
|||
|
|
:set-after '(ement-room-left-margin-width ement-room-right-margin-width
|
|||
|
|
ement-room-sender-headers)
|
|||
|
|
;; This file must be loaded before calling the setter to define the
|
|||
|
|
;; `ement-room-user' face used in it.
|
|||
|
|
:require 'ement-room)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-retro-messages-number 30
|
|||
|
|
"Number of messages to retrieve when loading earlier messages."
|
|||
|
|
:type 'integer)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-timestamp-header-format " %H:%M "
|
|||
|
|
"Format string for timestamp headers where date is unchanged.
|
|||
|
|
See function `format-time-string'. If this string ends in a
|
|||
|
|
newline, its background color will extend to the end of the
|
|||
|
|
line."
|
|||
|
|
:type '(choice (const :tag "Time-only" " %H:%M ")
|
|||
|
|
(const :tag "Always show date" " %Y-%m-%d %H:%M ")
|
|||
|
|
string))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-timestamp-header-with-date-format " %Y-%m-%d (%A)\n"
|
|||
|
|
;; FIXME: In Emacs 27+, maybe use :extend t instead of adding a newline.
|
|||
|
|
"Format string for timestamp headers where date changes.
|
|||
|
|
See function `format-time-string'. If this string ends in a
|
|||
|
|
newline, its background color will extend to the end of the
|
|||
|
|
line."
|
|||
|
|
:type '(choice (const " %Y-%m-%d (%A)\n")
|
|||
|
|
string))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-replace-edited-messages t
|
|||
|
|
"Replace edited messages with their new content.
|
|||
|
|
When nil, edited messages are displayed as new messages, leaving
|
|||
|
|
the original messages visible."
|
|||
|
|
:type 'boolean)
|
|||
|
|
|
|||
|
|
(define-obsolete-variable-alias 'ement-room-shr-use-fonts
|
|||
|
|
'ement-room-use-variable-pitch "ement-0.14")
|
|||
|
|
|
|||
|
|
(defcustom ement-room-use-variable-pitch nil
|
|||
|
|
"Use proportional fonts for message bodies.
|
|||
|
|
If non-nil, plain text message bodies are displayed in a
|
|||
|
|
variable-pitch font, and `shr-use-fonts' is enabled for rendering
|
|||
|
|
HTML-formatted message bodies (which includes most replies)."
|
|||
|
|
:type '(choice (const :tag "Disable variable-pitch fonts" nil)
|
|||
|
|
(const :tag "Enable variable-pitch fonts" t)))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-username-display-property '(raise -0.25)
|
|||
|
|
"Display property applied to username strings.
|
|||
|
|
See Info node `(elisp)Other Display Specs'."
|
|||
|
|
:type '(choice (list :tag "Raise" (const :tag "Raise" raise) (number :tag "Factor"))
|
|||
|
|
(list :tag "Height" (const height)
|
|||
|
|
(choice (list :tag "Larger" (const :tag "Larger" +) (number :tag "Steps"))
|
|||
|
|
(list :tag "Smaller" (const :tag "Smaller" -) (number :tag "Steps"))
|
|||
|
|
(number :tag "Factor")
|
|||
|
|
(function :tag "Function")
|
|||
|
|
(sexp :tag "Form"))) ))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-event-separator-display-property '(space :ascent 50)
|
|||
|
|
"Display property applied to invisible space string after events.
|
|||
|
|
Allows visual separation between events without, e.g. inserting
|
|||
|
|
newlines.
|
|||
|
|
|
|||
|
|
See Info node `(elisp)Specified Space'."
|
|||
|
|
:type 'sexp)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-timestamp-header-delta 600
|
|||
|
|
"Show timestamp header where events are at least this many seconds apart."
|
|||
|
|
:type 'integer)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-send-message-filter nil
|
|||
|
|
"Function through which to pass message content before sending.
|
|||
|
|
Used to, e.g. send an Org-formatted message by exporting it to
|
|||
|
|
HTML first."
|
|||
|
|
:type '(choice (const :tag "Send messages as-is" nil)
|
|||
|
|
(const :tag "Send messages in Org format" ement-room-send-org-filter)
|
|||
|
|
(function :tag "Custom filter function"))
|
|||
|
|
:set (lambda (option value)
|
|||
|
|
(set-default option value)
|
|||
|
|
(pcase value
|
|||
|
|
('ement-room-send-org-filter
|
|||
|
|
;; Activate in compose buffer by default.
|
|||
|
|
(add-hook 'ement-room-compose-hook #'ement-room-compose-org))
|
|||
|
|
(_ (remove-hook 'ement-room-compose-hook #'ement-room-compose-org)))))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-mark-rooms-read t
|
|||
|
|
"Mark rooms as read automatically.
|
|||
|
|
Moves read and fully-read markers in rooms on the server when
|
|||
|
|
`ement-room-scroll-up-mark-read' is called at the end of a
|
|||
|
|
buffer. When `send', also marks room as read when sending a
|
|||
|
|
message in it. When disabled, rooms may still be marked as read
|
|||
|
|
manually by calling `ement-room-mark-read'. Note that this is
|
|||
|
|
not strictly the same as read receipts."
|
|||
|
|
:type '(choice (const :tag "When scrolling past end of buffer" t)
|
|||
|
|
(const :tag "Also when sending" send)
|
|||
|
|
(const :tag "Never" nil)))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-send-typing t
|
|||
|
|
"Send typing notifications to the server while typing a message."
|
|||
|
|
:type 'boolean)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-join-view-buffer t
|
|||
|
|
"View room buffer when joining a room."
|
|||
|
|
:type 'boolean)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-leave-kill-buffer t
|
|||
|
|
"Kill room buffer when leaving a room.
|
|||
|
|
When disabled, the room's buffer will remain open, but
|
|||
|
|
Matrix-related commands in it will fail."
|
|||
|
|
:type 'boolean)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-warn-for-already-seen-messages nil
|
|||
|
|
"Warn when a sent message has already been seen.
|
|||
|
|
Such a case could very rarely indicate a reused transaction ID,
|
|||
|
|
which would prevent further messages from being sent (and would
|
|||
|
|
be solved by logging in with a new session, generating a new
|
|||
|
|
token), but most often it happens when the server echoes back a
|
|||
|
|
sent message before acknowledging the sending of the
|
|||
|
|
message (which is harmless and can be ignored)."
|
|||
|
|
:type 'boolean)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-wrap-prefix
|
|||
|
|
(concat (propertize " "
|
|||
|
|
'face 'ement-room-wrap-prefix)
|
|||
|
|
" ")
|
|||
|
|
"String prefixing certain events in room buffers.
|
|||
|
|
Events include membership events, image attachments, etc.
|
|||
|
|
Generally users should prefer to customize the face
|
|||
|
|
`ement-room-wrap-prefix' rather than this option, because this
|
|||
|
|
option's default value has that face applied to it where
|
|||
|
|
appropriate; if users customize this option, they will need to
|
|||
|
|
apply the face to the string themselves, if desired."
|
|||
|
|
:type 'string)
|
|||
|
|
|
|||
|
|
(defgroup ement-room-prism nil
|
|||
|
|
"Colorize usernames and messages in rooms."
|
|||
|
|
:group 'ement-room)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-prism 'name
|
|||
|
|
"Display users' names and messages in unique colors."
|
|||
|
|
:type '(choice (const :tag "Name only" name)
|
|||
|
|
(const :tag "Name and message" both)
|
|||
|
|
(const :tag "Neither" nil)))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-prism-addressee t
|
|||
|
|
"Show addressees' names in their respective colors.
|
|||
|
|
Applies to room member names at the beginning of messages,
|
|||
|
|
preceded by a colon or comma.
|
|||
|
|
|
|||
|
|
Note that a limitation applies to the current implementation: if
|
|||
|
|
a message from the addressee is not yet visible in a room at the
|
|||
|
|
time the addressed message is formatted, the color may not be
|
|||
|
|
applied."
|
|||
|
|
;; FIXME: When we keep a hash table of members in a room, make this
|
|||
|
|
;; smarter.
|
|||
|
|
:type 'boolean)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-prism-color-adjustment 0
|
|||
|
|
"Number used to tweak computed username colors.
|
|||
|
|
This may be used to adjust your favorite users' colors if you
|
|||
|
|
don't like the default ones. (The only way to do it is by
|
|||
|
|
experimentation--there is no direct mapping available, nor a
|
|||
|
|
per-user setting.)
|
|||
|
|
|
|||
|
|
The number is added to the hashed user ID before converting it to
|
|||
|
|
a color. Note that, since user ID hashes are ratioed against
|
|||
|
|
`most-positive-fixnum', this number must be very large in order
|
|||
|
|
to have any effect; it should be at least 1e13.
|
|||
|
|
|
|||
|
|
After changing this option, a room's buffer must be killed and
|
|||
|
|
recreated to see the effect."
|
|||
|
|
:type 'number
|
|||
|
|
:set (lambda (option value)
|
|||
|
|
(unless (or (= 0 value) (>= value 1e13))
|
|||
|
|
(user-error "This option must be a very large number, at least 1e13"))
|
|||
|
|
(set-default option value)))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-prism-minimum-contrast 6
|
|||
|
|
"Attempt to enforce this minimum contrast ratio for user faces.
|
|||
|
|
This should be a reasonable number from, e.g. 0-7 or so."
|
|||
|
|
;; Prot would almost approve of this default. :) I would go all the way
|
|||
|
|
;; to 7, but 6 already significantly dilutes the colors in some cases.
|
|||
|
|
:type 'number)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-prism-message-desaturation 25
|
|||
|
|
"Desaturate user colors by this percent for message bodies.
|
|||
|
|
Makes message bodies a bit less intense."
|
|||
|
|
:type 'integer)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-prism-message-lightening 10
|
|||
|
|
"Lighten user colors by this percent for message bodies.
|
|||
|
|
Makes message bodies a bit less intense.
|
|||
|
|
|
|||
|
|
When using a light theme, it may be necessary to use a negative
|
|||
|
|
number (to darken rather than lighten)."
|
|||
|
|
:type 'integer)
|
|||
|
|
|
|||
|
|
;;;; Macros
|
|||
|
|
|
|||
|
|
(defmacro ement-room-with-highlighted-event-at (position &rest body)
|
|||
|
|
"Highlight event at POSITION while evaluating BODY."
|
|||
|
|
;; MAYBE: Accept a marker for POSITION.
|
|||
|
|
(declare (indent 1))
|
|||
|
|
`(let (ement-room-replying-to-overlay)
|
|||
|
|
(unwind-protect
|
|||
|
|
(progn
|
|||
|
|
(ement-room-highlight-event-at ,position)
|
|||
|
|
,@body)
|
|||
|
|
(ement-room-unhighlight-event))))
|
|||
|
|
|
|||
|
|
(defmacro ement-room-with-typing (&rest body)
|
|||
|
|
"Send typing notifications around BODY.
|
|||
|
|
When `ement-room-send-typing' is enabled, typing notifications
|
|||
|
|
are sent while BODY is executing. BODY is wrapped in an
|
|||
|
|
`unwind-protect' form that cancels `ement-room-typing-timer' and
|
|||
|
|
sends a not-typing notification."
|
|||
|
|
(declare (indent defun))
|
|||
|
|
`(unwind-protect
|
|||
|
|
(progn
|
|||
|
|
(when ement-room-send-typing
|
|||
|
|
(when ement-room-typing-timer
|
|||
|
|
;; In case there are any stray ones (e.g. a user typing in
|
|||
|
|
;; more than room at once, which is possible but unlikely).
|
|||
|
|
(cancel-timer ement-room-typing-timer))
|
|||
|
|
(setf ement-room-typing-timer (run-at-time nil 15 #'ement-room--send-typing ement-session ement-room)))
|
|||
|
|
,@body)
|
|||
|
|
(when ement-room-send-typing
|
|||
|
|
(when ement-room-typing-timer
|
|||
|
|
(cancel-timer ement-room-typing-timer)
|
|||
|
|
(setf ement-room-typing-timer nil))
|
|||
|
|
;; Cancel typing notifications after sending a message. (The
|
|||
|
|
;; spec doesn't say whether this is needed, but it seems to be.)
|
|||
|
|
(ement-room--send-typing ement-session ement-room :typing nil))))
|
|||
|
|
|
|||
|
|
(defmacro ement-room-wrap-prefix (string-form &rest properties)
|
|||
|
|
"Wrap STRING-FORM with `ement-room-wrap-prefix'.
|
|||
|
|
Concats `ement-room-wrap-prefix' to STRING-FORM and applies it as
|
|||
|
|
the `wrap-prefix' property. Also applies any PROPERTIES."
|
|||
|
|
(declare (indent defun))
|
|||
|
|
`(concat ement-room-wrap-prefix
|
|||
|
|
(propertize ,string-form
|
|||
|
|
'wrap-prefix ement-room-wrap-prefix
|
|||
|
|
,@properties)))
|
|||
|
|
|
|||
|
|
(defsubst ement-room--concat-property (string property value &optional append)
|
|||
|
|
"Return STRING having concatted VALUE with PROPERTY on it.
|
|||
|
|
If APPEND, append it; otherwise prepend. Assumes PROPERTY is
|
|||
|
|
constant throughout STRING."
|
|||
|
|
(declare (indent defun))
|
|||
|
|
(let* ((old-value (get-text-property 0 property string))
|
|||
|
|
(new-value (if append
|
|||
|
|
(concat old-value value)
|
|||
|
|
(concat value old-value))))
|
|||
|
|
(propertize string property new-value)))
|
|||
|
|
|
|||
|
|
;;;;; Event highlighting
|
|||
|
|
|
|||
|
|
(defun ement-room-highlight-event-at (position)
|
|||
|
|
"Highlight event at POSITION using `ement-room-replying-to-overlay'.
|
|||
|
|
See `ement-room-with-highlighted-event-at'."
|
|||
|
|
;; MAYBE: Accept a marker for POSITION.
|
|||
|
|
(let* ((node (ewoc-locate ement-ewoc position))
|
|||
|
|
(event (ewoc-data node)))
|
|||
|
|
(unless (and (ement-event-p event)
|
|||
|
|
(ement-event-id event))
|
|||
|
|
(error "No event at point"))
|
|||
|
|
(setf ement-room-replying-to-overlay
|
|||
|
|
(make-overlay (ewoc-location node)
|
|||
|
|
;; NOTE: It doesn't seem possible to get the end position of
|
|||
|
|
;; a node, so if there is no next node, we use point-max.
|
|||
|
|
;; But this might break if we were to use an EWOC footer.
|
|||
|
|
(if (ewoc-next ement-ewoc node)
|
|||
|
|
(ewoc-location (ewoc-next ement-ewoc node))
|
|||
|
|
(point-max))))
|
|||
|
|
(overlay-put ement-room-replying-to-overlay 'face 'highlight)))
|
|||
|
|
|
|||
|
|
(defun ement-room-unhighlight-event ()
|
|||
|
|
"Delete overlay in `ement-room-replying-to-overlay'.
|
|||
|
|
See `ement-room-with-highlighted-event-at'."
|
|||
|
|
(when (overlayp ement-room-replying-to-overlay)
|
|||
|
|
(delete-overlay ement-room-replying-to-overlay))
|
|||
|
|
(setf ement-room-replying-to-overlay nil))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-highlight (compose-buffer)
|
|||
|
|
"Make `ement-room-with-highlighted-event-at' persistent while COMPOSE-BUFFER exists."
|
|||
|
|
(when-let ((overlay ement-room-replying-to-overlay))
|
|||
|
|
;; Prevent `ement-room-with-highlighted-event-at' from deleting the overlay:
|
|||
|
|
(setq ement-room-replying-to-overlay nil)
|
|||
|
|
;; Instead, make it exist for the lifetime of the compose buffer:
|
|||
|
|
(cl-flet ((delete-overlay ()
|
|||
|
|
(when (overlayp overlay)
|
|||
|
|
(delete-overlay overlay))))
|
|||
|
|
(with-current-buffer compose-buffer
|
|||
|
|
(add-hook 'kill-buffer-hook #'delete-overlay nil :local)))))
|
|||
|
|
|
|||
|
|
;;;;; Event formatting
|
|||
|
|
|
|||
|
|
;; NOTE: When adding specs, also add them to docstring
|
|||
|
|
;; for `ement-room-message-format-spec'.
|
|||
|
|
|
|||
|
|
(defvar ement-room-event-formatters nil
|
|||
|
|
"Alist mapping characters to event-formatting functions.
|
|||
|
|
Each function is called with three arguments: the event, the
|
|||
|
|
room, and the session. See macro
|
|||
|
|
`ement-room-define-event-formatter'.")
|
|||
|
|
|
|||
|
|
(defvar ement-room--format-message-margin-p nil
|
|||
|
|
"Set by margin-related event formatters.")
|
|||
|
|
|
|||
|
|
(defvar ement-room--format-message-wrap-prefix nil
|
|||
|
|
"Set by margin-related event formatters.")
|
|||
|
|
|
|||
|
|
(defmacro ement-room-define-event-formatter (char docstring &rest body)
|
|||
|
|
"Define an event formatter for CHAR with DOCSTRING and BODY.
|
|||
|
|
BODY is wrapped in a lambda form that binds `event', `room', and
|
|||
|
|
`session', and the lambda is added to the variable
|
|||
|
|
`ement-room-event-formatters', which see."
|
|||
|
|
(declare (indent defun)
|
|||
|
|
(debug (characterp stringp def-body)))
|
|||
|
|
`(setf (alist-get ,char ement-room-event-formatters nil nil #'equal)
|
|||
|
|
(lambda (event room session)
|
|||
|
|
,docstring
|
|||
|
|
,@body)))
|
|||
|
|
|
|||
|
|
(ement-room-define-event-formatter ?L
|
|||
|
|
"Text before this is shown in the left margin."
|
|||
|
|
(ignore event room session)
|
|||
|
|
(setf ement-room--format-message-margin-p t)
|
|||
|
|
(propertize " " 'left-margin-end t))
|
|||
|
|
|
|||
|
|
(ement-room-define-event-formatter ?R
|
|||
|
|
"Text after this is shown in the right margin."
|
|||
|
|
(ignore event room session)
|
|||
|
|
(setf ement-room--format-message-margin-p t)
|
|||
|
|
(propertize " " 'right-margin-start t))
|
|||
|
|
|
|||
|
|
(ement-room-define-event-formatter ?W
|
|||
|
|
"Text before this is the length of the event's wrap-prefix.
|
|||
|
|
This emulates the effect of using the left margin (the \"%L\"
|
|||
|
|
spec) without requiring all events to use the same margin width."
|
|||
|
|
(ignore event room session)
|
|||
|
|
(setf ement-room--format-message-wrap-prefix t)
|
|||
|
|
(propertize " " 'wrap-prefix-end t))
|
|||
|
|
|
|||
|
|
;; FIXME(v0.12): The quote-end may be detected in the wrong position when, e.g. a link is
|
|||
|
|
;; in the middle of the quoted part. We need to search backward from the end to find
|
|||
|
|
;; where the quote face finally ends.
|
|||
|
|
|
|||
|
|
(ement-room-define-event-formatter ?b
|
|||
|
|
"Plain-text body content."
|
|||
|
|
;; NOTE: `save-match-data' is required around calls to `ement-room--format-message-body'.
|
|||
|
|
(let* ((body (save-match-data
|
|||
|
|
(ement-room--format-message-body event session :formatted-p nil)))
|
|||
|
|
(body-length (length body))
|
|||
|
|
(face (ement-room--event-body-face event room session))
|
|||
|
|
(quote-start (ement--text-property-search-forward 'face
|
|||
|
|
(lambda (value)
|
|||
|
|
(pcase value
|
|||
|
|
('ement-room-quote t)
|
|||
|
|
((pred listp) (member 'ement-room-quote value))))
|
|||
|
|
body))
|
|||
|
|
(quote-end (when quote-start
|
|||
|
|
(ement--text-property-search-backward 'face
|
|||
|
|
(lambda (value)
|
|||
|
|
(pcase value
|
|||
|
|
('ement-room-quote t)
|
|||
|
|
((pred listp) (member 'ement-room-quote value))))
|
|||
|
|
body))))
|
|||
|
|
(add-face-text-property (or quote-end 0) body-length face 'append body)
|
|||
|
|
(when ement-room-prism-addressee
|
|||
|
|
(ement-room--add-member-face body room))
|
|||
|
|
body))
|
|||
|
|
|
|||
|
|
(ement-room-define-event-formatter ?B
|
|||
|
|
"Formatted body content (i.e. rendered HTML)."
|
|||
|
|
(let* ((body (save-match-data
|
|||
|
|
(ement-room--format-message-body event session)))
|
|||
|
|
(body-length (length body))
|
|||
|
|
(face (ement-room--event-body-face event room session))
|
|||
|
|
(quote-start (ement--text-property-search-forward 'face
|
|||
|
|
(lambda (value)
|
|||
|
|
(pcase value
|
|||
|
|
('ement-room-quote t)
|
|||
|
|
((pred listp) (member 'ement-room-quote value))))
|
|||
|
|
body))
|
|||
|
|
(quote-end (when quote-start
|
|||
|
|
(ement--text-property-search-backward 'face
|
|||
|
|
(lambda (value)
|
|||
|
|
(pcase value
|
|||
|
|
('ement-room-quote t)
|
|||
|
|
((pred listp) (member 'ement-room-quote value))))
|
|||
|
|
body :start (length body)))))
|
|||
|
|
(add-face-text-property (or quote-end 0) body-length face 'append body)
|
|||
|
|
(when ement-room-prism-addressee
|
|||
|
|
(ement-room--add-member-face body room))
|
|||
|
|
body))
|
|||
|
|
|
|||
|
|
(ement-room-define-event-formatter ?i
|
|||
|
|
"Event ID."
|
|||
|
|
;; Probably only useful for debugging, so might remove later.
|
|||
|
|
(ignore room session)
|
|||
|
|
(ement-event-id event))
|
|||
|
|
|
|||
|
|
(ement-room-define-event-formatter ?o
|
|||
|
|
"Room avatar."
|
|||
|
|
(ignore event session)
|
|||
|
|
(or (alist-get 'room-list-avatar (ement-room-local room)) ""))
|
|||
|
|
|
|||
|
|
(ement-room-define-event-formatter ?O
|
|||
|
|
"Room display name."
|
|||
|
|
(ignore event session)
|
|||
|
|
(let ((room-name (propertize (or (ement-room-display-name room)
|
|||
|
|
(ement--room-display-name room))
|
|||
|
|
'face 'ement-room-name
|
|||
|
|
'help-echo (or (ement-room-canonical-alias room)
|
|||
|
|
(ement-room-id room)))))
|
|||
|
|
;; HACK: This will probably only be used in the notifications buffers, anyway.
|
|||
|
|
(when ement-notify-limit-room-name-width
|
|||
|
|
(setf room-name (truncate-string-to-width room-name ement-notify-limit-room-name-width
|
|||
|
|
nil nil ement-room-ellipsis)))
|
|||
|
|
room-name))
|
|||
|
|
|
|||
|
|
;; NOTE: In ?s and ?S, we add nearly-invisible ASCII unit-separator characters ("")
|
|||
|
|
;; to prevent, e.g. `dabbrev-expand' from expanding display names with body text.
|
|||
|
|
|
|||
|
|
(ement-room-define-event-formatter ?s
|
|||
|
|
"Sender MXID."
|
|||
|
|
(ignore room session)
|
|||
|
|
(concat (propertize (ement-user-id (ement-event-sender event))
|
|||
|
|
'face 'ement-room-user)
|
|||
|
|
""))
|
|||
|
|
|
|||
|
|
(ement-room-define-event-formatter ?S
|
|||
|
|
"Sender display name."
|
|||
|
|
(ignore session)
|
|||
|
|
(pcase-let ((sender (ement--format-user (ement-event-sender event) room))
|
|||
|
|
((cl-struct ement-room (local (map buffer))) room))
|
|||
|
|
;; NOTE: When called from an `ement-notify' function, ROOM may have no buffer. In
|
|||
|
|
;; that case, just use the current buffer (which should be a temp buffer used to
|
|||
|
|
;; format the event).
|
|||
|
|
(with-current-buffer (or buffer (current-buffer))
|
|||
|
|
(when ement-room-sender-in-left-margin
|
|||
|
|
;; Sender in left margin: truncate/pad appropriately.
|
|||
|
|
(setf sender
|
|||
|
|
(if (< (string-width sender) ement-room-left-margin-width)
|
|||
|
|
;; Using :align-to or :width space display properties doesn't
|
|||
|
|
;; seem to have any effect in the margin, so we make a string.
|
|||
|
|
(concat (make-string (- ement-room-left-margin-width (string-width sender))
|
|||
|
|
? )
|
|||
|
|
sender)
|
|||
|
|
;; String wider than margin: truncate it.
|
|||
|
|
(ement-room--concat-property
|
|||
|
|
(truncate-string-to-width sender ement-room-left-margin-width nil nil "…")
|
|||
|
|
'help-echo (concat sender " "))))))
|
|||
|
|
;; NOTE: I'd like to add a help-echo function to display the sender ID, but the Emacs
|
|||
|
|
;; manual says that there is currently no way to make text in the margins mouse-sensitive.
|
|||
|
|
;; So `ement--format-user' returns a string propertized with `help-echo' as a string.
|
|||
|
|
(concat sender "")))
|
|||
|
|
|
|||
|
|
(ement-room-define-event-formatter ?r
|
|||
|
|
"Reactions."
|
|||
|
|
(ignore session)
|
|||
|
|
(ement-room--format-reactions event room))
|
|||
|
|
|
|||
|
|
(ement-room-define-event-formatter ?t
|
|||
|
|
"Timestamp."
|
|||
|
|
(ignore room session)
|
|||
|
|
(propertize (format-time-string ement-room-timestamp-format ;; Timestamps are in milliseconds.
|
|||
|
|
(/ (ement-event-origin-server-ts event) 1000))
|
|||
|
|
'face 'ement-room-timestamp
|
|||
|
|
'help-echo (format-time-string "%Y-%m-%d %H:%M:%S"
|
|||
|
|
(/ (ement-event-origin-server-ts event) 1000))))
|
|||
|
|
|
|||
|
|
(defconst ement-room-variable-pitch-face (or (and (facep 'shr-text) 'shr-text)
|
|||
|
|
'variable-pitch)
|
|||
|
|
"May be used when formatting plain-text messages.
|
|||
|
|
|
|||
|
|
If user option `ement-room-use-variable-pitch' is non-nil, this
|
|||
|
|
face is applied to plain-text messages for visual consistency
|
|||
|
|
with HTML messages (which will be rendered by shr.el with
|
|||
|
|
`shr-use-fonts' enabled).
|
|||
|
|
|
|||
|
|
The `shr-text' face was added in Emacs 29.1. Prior to that,
|
|||
|
|
shr.el used the `variable-pitch' face directly.")
|
|||
|
|
|
|||
|
|
(defun ement-room--event-body-face (event room session)
|
|||
|
|
"Return face definition for EVENT in ROOM on SESSION."
|
|||
|
|
(ignore room) ;; Unused for now, but keeping for consistency.
|
|||
|
|
;; This used to be a macro in --format-message, which is probably better for
|
|||
|
|
;; performance, but using a function is clearer, and avoids premature optimization.
|
|||
|
|
(pcase-let* (((cl-struct ement-event sender
|
|||
|
|
(content (map msgtype format ('m.new_content new-content)))
|
|||
|
|
(unsigned (map ('redacted_by unsigned-redacted-by)))
|
|||
|
|
(local (map ('redacted-by local-redacted-by))))
|
|||
|
|
event)
|
|||
|
|
((cl-struct ement-user (id sender-id)) sender)
|
|||
|
|
((cl-struct ement-session user) session)
|
|||
|
|
((cl-struct ement-user (id user-id)) user)
|
|||
|
|
(self-message-p (equal sender-id user-id))
|
|||
|
|
(type-face (pcase msgtype
|
|||
|
|
("m.emote" 'ement-room-message-emote)
|
|||
|
|
(_ 'ement-room-message-text)))
|
|||
|
|
(context-face (cond (self-message-p
|
|||
|
|
'ement-room-self-message)
|
|||
|
|
((or (ement-room--event-mentions-user-p event user)
|
|||
|
|
(ement--event-mentions-room-p event))
|
|||
|
|
'ement-room-mention)))
|
|||
|
|
(prism-color (unless self-message-p
|
|||
|
|
(when (eq 'both ement-room-prism)
|
|||
|
|
(or (ement-user-message-color sender)
|
|||
|
|
(setf (ement-user-message-color sender)
|
|||
|
|
(let ((message-color (color-desaturate-name (ement--user-color sender)
|
|||
|
|
ement-room-prism-message-desaturation)))
|
|||
|
|
(if (ement--color-dark-p (color-name-to-rgb (face-background 'default)))
|
|||
|
|
(color-lighten-name message-color ement-room-prism-message-lightening)
|
|||
|
|
(color-darken-name message-color ement-room-prism-message-lightening))))))))
|
|||
|
|
(redacted-face (when (or local-redacted-by unsigned-redacted-by)
|
|||
|
|
'ement-room-redacted))
|
|||
|
|
;; For visual consistency, apply the variable-pitch `shr-text' face to
|
|||
|
|
;; non-HTML messages when `ement-room-use-variable-pitch' is non-nil.
|
|||
|
|
;; (HTML messages are fontified by shr itself.)
|
|||
|
|
(shr-text-face (when (and ement-room-use-variable-pitch
|
|||
|
|
(not (equal (or format (alist-get 'format new-content))
|
|||
|
|
"org.matrix.custom.html")))
|
|||
|
|
ement-room-variable-pitch-face))
|
|||
|
|
(body-face (list :inherit (delq nil (list redacted-face context-face type-face shr-text-face)))))
|
|||
|
|
(if prism-color
|
|||
|
|
(plist-put body-face :foreground prism-color)
|
|||
|
|
body-face)))
|
|||
|
|
|
|||
|
|
(defun ement-room--add-member-face (string room)
|
|||
|
|
"Add member faces in ROOM to STRING.
|
|||
|
|
If STRING begins with the name of a member in ROOM followed by a
|
|||
|
|
colon or comma (as if STRING is a message addressing that
|
|||
|
|
member), apply that member's displayname color face to that part
|
|||
|
|
of the string.
|
|||
|
|
|
|||
|
|
Note that, if ROOM has no buffer, STRING is returned unchanged."
|
|||
|
|
;; This only looks for a member name at the beginning of the string. It would be neat to add
|
|||
|
|
;; colors to every member mentioned in a message, but that would probably not perform well.
|
|||
|
|
|
|||
|
|
;; NOTE: This function may be called by `ement-notify' functions even when the room has
|
|||
|
|
;; no buffer, and this function is designed to use events in a room buffer to more
|
|||
|
|
;; quickly find the data it needs, so, for now, if the room has no buffer, we return
|
|||
|
|
;; STRING unchanged.
|
|||
|
|
(pcase-let (((cl-struct ement-room (local (map buffer))) room))
|
|||
|
|
(if (buffer-live-p buffer)
|
|||
|
|
(save-match-data
|
|||
|
|
;; This function may be called from a chain of others that use the match data, so
|
|||
|
|
;; rather than depending on all of them to save the match data, we do it here.
|
|||
|
|
;; FIXME: Member names containing spaces aren't matched. Can this even be fixed reasonably?
|
|||
|
|
(when (string-match (rx bos (group (1+ (not blank))) (or ":" ",") (1+ blank)) string)
|
|||
|
|
(when-let* ((member-name (match-string 1 string))
|
|||
|
|
;; HACK: Since we don't currently keep a list of all
|
|||
|
|
;; members in a room, we look to see if this displayname
|
|||
|
|
;; has any mentions in the room so far.
|
|||
|
|
(user (save-match-data
|
|||
|
|
(with-current-buffer buffer
|
|||
|
|
(save-excursion
|
|||
|
|
(goto-char (point-min))
|
|||
|
|
(cl-labels ((found-sender-p (ewoc-data)
|
|||
|
|
(when (ement-event-p ewoc-data)
|
|||
|
|
(equal member-name
|
|||
|
|
(gethash (ement-event-sender ewoc-data) (ement-room-displaynames room))))))
|
|||
|
|
(cl-loop with regexp = (regexp-quote member-name)
|
|||
|
|
while (re-search-forward regexp nil t)
|
|||
|
|
;; NOTE: I don't know why, but sometimes the regexp
|
|||
|
|
;; search ends on a non-event line, like a timestamp
|
|||
|
|
;; header, so for now we just try to handle that case.
|
|||
|
|
for maybe-event = (ewoc-data (ewoc-locate ement-ewoc))
|
|||
|
|
when (found-sender-p maybe-event)
|
|||
|
|
return (ement-event-sender maybe-event)))))))
|
|||
|
|
(prism-color (or (ement-user-color user)
|
|||
|
|
(setf (ement-user-color user)
|
|||
|
|
(ement-room--user-color user)))))
|
|||
|
|
(add-face-text-property (match-beginning 1) (match-end 1)
|
|||
|
|
(list :foreground prism-color) nil string))))
|
|||
|
|
;; Room has no buffer: return STRING as-is.
|
|||
|
|
string)))
|
|||
|
|
|
|||
|
|
;;;; Bookmark support
|
|||
|
|
|
|||
|
|
;; Especially useful with Burly: <https://github.com/alphapapa/burly.el>
|
|||
|
|
|
|||
|
|
(require 'bookmark)
|
|||
|
|
|
|||
|
|
(defun ement-room-bookmark-make-record ()
|
|||
|
|
"Return a bookmark record for the current `ement-room' buffer."
|
|||
|
|
(pcase-let* (((cl-struct ement-room (id room-id) canonical-alias display-name) ement-room)
|
|||
|
|
((cl-struct ement-session user) ement-session)
|
|||
|
|
((cl-struct ement-user (id session-id)) user))
|
|||
|
|
;; MAYBE: Support bookmarking specific events in a room.
|
|||
|
|
(list (concat "Ement room: " display-name " (" canonical-alias ")")
|
|||
|
|
(cons 'session-id session-id)
|
|||
|
|
(cons 'room-id room-id)
|
|||
|
|
(cons 'handler #'ement-room-bookmark-handler))))
|
|||
|
|
|
|||
|
|
(defun ement-room-bookmark-handler (bookmark)
|
|||
|
|
"Show Ement room buffer for BOOKMARK."
|
|||
|
|
(pcase-let* ((`(,_name . ,(map session-id room-id)) bookmark)
|
|||
|
|
(session (ement-aprog1
|
|||
|
|
(alist-get session-id ement-sessions nil nil #'equal)
|
|||
|
|
(unless it
|
|||
|
|
;; MAYBE: Automatically connect.
|
|||
|
|
(user-error "Session %s not connected: call `ement-connect' first" session-id))))
|
|||
|
|
(room (ement-aprog1
|
|||
|
|
(ement-afirst (equal room-id (ement-room-id it))
|
|||
|
|
(ement-session-rooms session))
|
|||
|
|
(cl-assert it nil "Room %S not found on session %S" room-id session-id))))
|
|||
|
|
(ement-view-room room session)
|
|||
|
|
;; HACK: Put point at the end of the room buffer. This seems unusually difficult,
|
|||
|
|
;; apparently because the bookmark library itself moves point after jumping to a
|
|||
|
|
;; bookmark. My attempts at setting the buffer's and window's points after calling
|
|||
|
|
;; `ement-view-room' have had no effect. `bookmark-after-jump-hook' sounds ideal, but
|
|||
|
|
;; it does not seem to actually get run, so we use a timer that runs immediately after
|
|||
|
|
;; `bookmark-jump' returns.
|
|||
|
|
(run-at-time nil nil (lambda ()
|
|||
|
|
(goto-char (point-max))))))
|
|||
|
|
|
|||
|
|
;;;; Commands
|
|||
|
|
|
|||
|
|
(defun ement-room-override-name (name room session)
|
|||
|
|
"Set display NAME override for ROOM on SESSION.
|
|||
|
|
Interactively, with prefix, prompt for room and session,
|
|||
|
|
otherwise use current room. If NAME is the empty string, remove
|
|||
|
|
the override.
|
|||
|
|
|
|||
|
|
Sets account-data event of type
|
|||
|
|
\"org.matrix.msc3015.m.room.name.override\". This name is only
|
|||
|
|
used by clients that respect this proposed override. See
|
|||
|
|
<https://github.com/matrix-org/matrix-spec-proposals/pull/3015#issuecomment-1451017296>."
|
|||
|
|
(interactive
|
|||
|
|
(ement-with-room-and-session
|
|||
|
|
(let* ((prompt (format "Set name override (%s): " (ement--format-room ement-room)))
|
|||
|
|
(name (read-string prompt nil nil (ement-room-display-name ement-room))))
|
|||
|
|
(list name ement-room ement-session))))
|
|||
|
|
(ement-put-account-data session "org.matrix.msc3015.m.room.name.override"
|
|||
|
|
(if (string-empty-p name)
|
|||
|
|
;; `json-encode' wants an empty hash table to represent an empty map. And
|
|||
|
|
;; apparently there's no way to DELETE account-data events, so we have to re-PUT
|
|||
|
|
;; it with empty content.
|
|||
|
|
(make-hash-table)
|
|||
|
|
(ement-alist "name" name))
|
|||
|
|
:room room))
|
|||
|
|
|
|||
|
|
(defun ement-room-flush-colors ()
|
|||
|
|
"Flush generated username/message colors.
|
|||
|
|
Also, redisplay events in all open buffers. The colors will be
|
|||
|
|
regenerated according to the current background color. Helpful
|
|||
|
|
when switching themes or adjusting `ement-prism' options."
|
|||
|
|
(interactive)
|
|||
|
|
(cl-loop for user being the hash-values of ement-users
|
|||
|
|
do (setf (ement-user-color user) nil
|
|||
|
|
(ement-user-message-color user) nil))
|
|||
|
|
(dolist (buffer (buffer-list))
|
|||
|
|
(when (eq 'ement-room-mode (buffer-local-value 'major-mode buffer))
|
|||
|
|
(with-current-buffer buffer
|
|||
|
|
(let ((window-start (when (get-buffer-window buffer)
|
|||
|
|
(window-start (get-buffer-window buffer)))))
|
|||
|
|
(save-excursion
|
|||
|
|
(ewoc-refresh ement-ewoc))
|
|||
|
|
(when window-start
|
|||
|
|
(setf (window-start (get-buffer-window buffer)) window-start))))))
|
|||
|
|
;; Flush notify-background-color colors.
|
|||
|
|
(cl-loop for (_id . session) in ement-sessions
|
|||
|
|
do (cl-loop for room in (ement-session-rooms session)
|
|||
|
|
do (setf (alist-get 'notify-background-color (ement-room-local room)) nil)))
|
|||
|
|
;; NOTE: The notifications buffer can't be refreshed because each event is from a
|
|||
|
|
;; different room, and the `ement-room' variable is unset in the buffer.
|
|||
|
|
|
|||
|
|
;; (when-let (buffer (get-buffer "*Ement Notifications*"))
|
|||
|
|
;; (with-current-buffer buffer
|
|||
|
|
;; (ewoc-refresh ement-ewoc)))
|
|||
|
|
)
|
|||
|
|
|
|||
|
|
(defun ement-room-browse-url (url &rest args)
|
|||
|
|
"Browse URL, using Ement for matrix.to URLs when possible.
|
|||
|
|
Otherwise, fall back to `browse-url'. When called outside of an
|
|||
|
|
`ement-room' buffer, the variable `ement-session' must be bound
|
|||
|
|
to the session in which to look for URL's room and event. ARGS
|
|||
|
|
are passed to `browse-url'."
|
|||
|
|
(interactive)
|
|||
|
|
(when (string-match ement-room-matrix.to-url-regexp url)
|
|||
|
|
(let* ((room-id (when (string-prefix-p "!" (match-string 1 url))
|
|||
|
|
(match-string 1 url)))
|
|||
|
|
(room-alias (when (string-prefix-p "#" (match-string 1 url))
|
|||
|
|
(match-string 1 url)))
|
|||
|
|
(event-id (match-string 2 url))
|
|||
|
|
(room (when (or
|
|||
|
|
;; Compare with current buffer's room.
|
|||
|
|
(and room-id (equal room-id (ement-room-id ement-room)))
|
|||
|
|
(and room-alias (equal room-alias (ement-room-canonical-alias ement-room)))
|
|||
|
|
;; Compare with other rooms on session.
|
|||
|
|
(and room-id (cl-find room-id (ement-session-rooms ement-session)
|
|||
|
|
:key #'ement-room-id))
|
|||
|
|
(and room-alias (cl-find room-alias (ement-session-rooms ement-session)
|
|||
|
|
:key #'ement-room-canonical-alias)))
|
|||
|
|
ement-room)))
|
|||
|
|
(if room
|
|||
|
|
(progn
|
|||
|
|
;; Found room in current session: view it and find the event.
|
|||
|
|
(ement-view-room room ement-session)
|
|||
|
|
(when event-id
|
|||
|
|
(ement-room-find-event event-id)))
|
|||
|
|
;; Room not joined: offer to join it or load link in browser.
|
|||
|
|
(pcase-exhaustive
|
|||
|
|
(cadr (ement--read-multiple-choice
|
|||
|
|
(format "Room <%s> not joined on current session. Join it, or load link with browser?"
|
|||
|
|
(or room-alias room-id))
|
|||
|
|
'((?j "join" "Join room in ement.el")
|
|||
|
|
(?w "web browser" "Open URL in web browser"))
|
|||
|
|
"\
|
|||
|
|
You are not currently joined to that room. You can either join the room
|
|||
|
|
in ement.el, or visit the link URL in your web browser."))
|
|||
|
|
("join"
|
|||
|
|
(ement-join-room (or room-alias room-id) ement-session
|
|||
|
|
:then (when event-id
|
|||
|
|
(lambda (room session)
|
|||
|
|
(ement-view-room room session)
|
|||
|
|
(ement-room-find-event event-id)))))
|
|||
|
|
("web browser"
|
|||
|
|
(let ((handler (cons ement-room-matrix.to-url-regexp #'ement-room-browse-url)))
|
|||
|
|
;; Note that `browse-url-handlers' was added in 28.1;
|
|||
|
|
;; prior to that `browse-url-browser-function' served double-duty.
|
|||
|
|
;; TODO: Remove compat code when requiring Emacs >=28.
|
|||
|
|
;; (See also `ement-room-mode'.)
|
|||
|
|
(cond ((boundp 'browse-url-handlers)
|
|||
|
|
(let ((browse-url-handlers (remove handler browse-url-handlers)))
|
|||
|
|
(apply #'browse-url url args)))
|
|||
|
|
((consp browse-url-browser-function)
|
|||
|
|
(let ((browse-url-browser-function (remove handler browse-url-browser-function)))
|
|||
|
|
(apply #'browse-url url args)))
|
|||
|
|
(t
|
|||
|
|
(apply #'browse-url url args))))))))))
|
|||
|
|
|
|||
|
|
(defun ement-room-find-event (event-id)
|
|||
|
|
"Go to EVENT-ID in current buffer."
|
|||
|
|
(interactive)
|
|||
|
|
(cl-labels ((goto-event (event-id)
|
|||
|
|
(push-mark)
|
|||
|
|
(goto-char
|
|||
|
|
(ewoc-location
|
|||
|
|
(ement-room--ewoc-last-matching ement-ewoc
|
|||
|
|
(lambda (data)
|
|||
|
|
(and (ement-event-p data)
|
|||
|
|
(equal event-id (ement-event-id data)))))))))
|
|||
|
|
(if (or (cl-find event-id (ement-room-timeline ement-room)
|
|||
|
|
:key #'ement-event-id :test #'equal)
|
|||
|
|
(cl-find event-id (ement-room-state ement-room)
|
|||
|
|
:key #'ement-event-id :test #'equal))
|
|||
|
|
;; Found event in timeline: it should be in the EWOC, so go to it.
|
|||
|
|
(goto-event event-id)
|
|||
|
|
;; Event not found in timeline: try to retro-load it.
|
|||
|
|
(message "Event %s not seen in current room. Looking in history..." event-id)
|
|||
|
|
(let ((room ement-room))
|
|||
|
|
(ement-room-retro-to ement-room ement-session event-id
|
|||
|
|
;; TODO: Add an ELSE argument to `ement-room-retro-to' and use it to give
|
|||
|
|
;; a useful error here.
|
|||
|
|
:then (lambda ()
|
|||
|
|
(with-current-buffer (alist-get 'buffer (ement-room-local room))
|
|||
|
|
(goto-event event-id))))))))
|
|||
|
|
|
|||
|
|
(defun ement-room-set-composition-format (&optional localp)
|
|||
|
|
"Set message composition format.
|
|||
|
|
If LOCALP (interactively, with prefix), set in current room's
|
|||
|
|
buffer. Sets `ement-room-send-message-filter'."
|
|||
|
|
(interactive (list current-prefix-arg))
|
|||
|
|
(let* ((formats (list (cons "Plain-text" nil)
|
|||
|
|
(cons "Org-mode" #'ement-room-send-org-filter)))
|
|||
|
|
(selected-name (completing-read "Composition format: " formats nil 'require-match nil nil
|
|||
|
|
ement-room-send-message-filter))
|
|||
|
|
(selected-filter (alist-get selected-name formats nil nil #'equal)))
|
|||
|
|
(if localp
|
|||
|
|
(setq-local ement-room-send-message-filter selected-filter)
|
|||
|
|
(setq ement-room-send-message-filter selected-filter))))
|
|||
|
|
|
|||
|
|
(defun ement-room-set-message-format (format-spec)
|
|||
|
|
"Set `ement-room-message-format-spec' in current buffer to FORMAT-SPEC.
|
|||
|
|
Interactively, prompts for the spec using suggested values of the
|
|||
|
|
option."
|
|||
|
|
(interactive (list (let* ((choices (thread-last
|
|||
|
|
(get 'ement-room-message-format-spec 'custom-type)
|
|||
|
|
cdr
|
|||
|
|
(seq-filter (lambda (it)
|
|||
|
|
(eq (car it) 'const)))
|
|||
|
|
(mapcar (lambda (it)
|
|||
|
|
(cons (nth 2 it) (nth 3 it))))))
|
|||
|
|
(choice (completing-read "Format: " (mapcar #'car choices))))
|
|||
|
|
(or (alist-get choice choices nil nil #'equal)
|
|||
|
|
choice))))
|
|||
|
|
(cl-assert ement-ewoc)
|
|||
|
|
(ement-room-message-format-spec-setter 'ement-room-message-format-spec format-spec 'local)
|
|||
|
|
(setf left-margin-width ement-room-left-margin-width
|
|||
|
|
right-margin-width ement-room-right-margin-width)
|
|||
|
|
(set-window-margins nil left-margin-width right-margin-width)
|
|||
|
|
(if ement-room-sender-in-headers
|
|||
|
|
(ement-room--insert-sender-headers ement-ewoc)
|
|||
|
|
(ewoc-filter ement-ewoc (lambda (node-data)
|
|||
|
|
;; Return non-nil for nodes that should stay.
|
|||
|
|
(not (ement-user-p node-data)))))
|
|||
|
|
(ewoc-refresh ement-ewoc))
|
|||
|
|
|
|||
|
|
(defun ement-room-set-topic (session room topic)
|
|||
|
|
"Set ROOM's TOPIC on SESSION.
|
|||
|
|
Interactively, with prefix, prompt for room and session,
|
|||
|
|
otherwise use current room."
|
|||
|
|
(interactive
|
|||
|
|
(ement-with-room-and-session
|
|||
|
|
(list ement-session ement-room
|
|||
|
|
(read-string (format "New topic (%s): "
|
|||
|
|
(ement-room-display-name ement-room))
|
|||
|
|
(ement-room-topic ement-room) nil nil 'inherit-input-method))))
|
|||
|
|
(pcase-let* (((cl-struct ement-room (id room-id) display-name) room)
|
|||
|
|
(endpoint (format "rooms/%s/state/m.room.topic" (url-hexify-string room-id)))
|
|||
|
|
(data (ement-alist "topic" topic)))
|
|||
|
|
(ement-api session endpoint :method 'put :data (json-encode data)
|
|||
|
|
:then (lambda (_data)
|
|||
|
|
(message "Topic set (%s): %s" display-name topic)))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-send-file (file body room session &key (msgtype "m.file"))
|
|||
|
|
"Send FILE to ROOM on SESSION, using message BODY and MSGTYPE.
|
|||
|
|
Interactively, with prefix, prompt for room and session,
|
|||
|
|
otherwise use current room."
|
|||
|
|
;; TODO: Support URLs to remote files.
|
|||
|
|
(interactive
|
|||
|
|
(ement-with-room-and-session
|
|||
|
|
(ement-room-with-typing
|
|||
|
|
(let* ((file (read-file-name (format "Send file (%s): " (ement-room-display-name ement-room))
|
|||
|
|
nil nil 'confirm))
|
|||
|
|
(body (ement-room-read-string
|
|||
|
|
(format "Message body (%s): " (ement-room-display-name ement-room))
|
|||
|
|
(file-name-nondirectory file) 'file-name-history nil 'inherit-input-method)))
|
|||
|
|
(list file body ement-room ement-session)))))
|
|||
|
|
;; NOTE: The typing notification won't be quite right, because it'll be canceled while waiting
|
|||
|
|
;; for the file to upload. It would be awkward to handle that, so this will do for now.
|
|||
|
|
(when (yes-or-no-p (format "Upload file %S to room %S? "
|
|||
|
|
file (ement-room-display-name room)))
|
|||
|
|
(pcase-let* ((filename (file-name-nondirectory file))
|
|||
|
|
(extension (or (file-name-extension file) ""))
|
|||
|
|
(mime-type (mailcap-extension-to-mime extension))
|
|||
|
|
(data `(file ,file))
|
|||
|
|
(size (file-attribute-size (file-attributes file))))
|
|||
|
|
(ement-upload session :data data :filename filename :content-type mime-type
|
|||
|
|
:then (lambda (data)
|
|||
|
|
(message "Uploaded file %S. Sending message..." file)
|
|||
|
|
(pcase-let* (((map ('content_uri content-uri)) data)
|
|||
|
|
((cl-struct ement-room (id room-id)) room)
|
|||
|
|
(endpoint (format "rooms/%s/send/%s/%s" (url-hexify-string room-id)
|
|||
|
|
"m.room.message" (ement--update-transaction-id session)))
|
|||
|
|
;; TODO: Image height/width (maybe not easy to get in Emacs).
|
|||
|
|
(content (ement-alist "msgtype" msgtype
|
|||
|
|
"url" content-uri
|
|||
|
|
"body" body
|
|||
|
|
"filename" filename
|
|||
|
|
"info" (ement-alist "mimetype" mime-type
|
|||
|
|
"size" size))))
|
|||
|
|
(ement-api session endpoint :method 'put :data (json-encode content)
|
|||
|
|
:then (apply-partially #'ement-room-send-event-callback
|
|||
|
|
:room room :session session :content content :data))))))))
|
|||
|
|
|
|||
|
|
(defun ement-room-send-image (file body room session)
|
|||
|
|
"Send image FILE to ROOM on SESSION, using message BODY.
|
|||
|
|
Interactively, with prefix, prompt for room and session,
|
|||
|
|
otherwise use current room."
|
|||
|
|
;; TODO: Support URLs to remote files.
|
|||
|
|
(interactive
|
|||
|
|
(ement-with-room-and-session
|
|||
|
|
(ement-room-with-typing
|
|||
|
|
(let* ((file (read-file-name (format "Send image file (%s): " (ement-room-display-name ement-room))
|
|||
|
|
nil nil 'confirm))
|
|||
|
|
(body (ement-room-read-string
|
|||
|
|
(format "Message body (%s): " (ement-room-display-name ement-room))
|
|||
|
|
(file-name-nondirectory file) 'file-name-history nil 'inherit-input-method)))
|
|||
|
|
(list file body ement-room ement-session)))))
|
|||
|
|
(ement-room-send-file file body room session :msgtype "m.image"))
|
|||
|
|
|
|||
|
|
(defun ement-room-dnd-upload-file (uri _action)
|
|||
|
|
"Upload the file as specified by URI to the current room."
|
|||
|
|
(when-let ((file (dnd-get-local-file-name uri t)))
|
|||
|
|
(ement-room-send-file file (file-name-nondirectory file) ement-room ement-session
|
|||
|
|
:msgtype (if (string-prefix-p "image/" (mailcap-file-name-to-mime-type file))
|
|||
|
|
"m.image"
|
|||
|
|
"m.file"))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-join (id-or-alias session &key then)
|
|||
|
|
"Join room by ID-OR-ALIAS on SESSION.
|
|||
|
|
THEN may be a function to call after joining the room (and when
|
|||
|
|
`ement-room-join-view-buffer' is non-nil, after viewing the room
|
|||
|
|
buffer). It receives two arguments, the room and the session."
|
|||
|
|
(interactive (list (read-string "Join room (ID or alias): ")
|
|||
|
|
(or ement-session
|
|||
|
|
(ement-complete-session))))
|
|||
|
|
(cl-assert id-or-alias) (cl-assert session)
|
|||
|
|
(unless (string-match-p
|
|||
|
|
;; According to tulir in #matrix-dev:matrix.org, ": is not
|
|||
|
|
;; allowed in the localpart, all other valid unicode is
|
|||
|
|
;; allowed. (user ids and room ids are the same over
|
|||
|
|
;; federation). it's mostly a lack of validation in
|
|||
|
|
;; synapse (arbitrary unicode isn't intentionally allowed,
|
|||
|
|
;; but it's not disallowed either)". See
|
|||
|
|
;; <https://matrix.to/#/!jxlRxnrZCsjpjDubDX:matrix.org/$Cnb53UQdYnGFizM49Aje_Xs0BxVdt-be7Dnm7_k-0ho>.
|
|||
|
|
(rx bos (or "#" "!") (1+ (not (any ":")))
|
|||
|
|
":" (1+ (or alnum (any "-."))))
|
|||
|
|
id-or-alias)
|
|||
|
|
(user-error "Invalid room ID or alias (use, e.g. \"#ROOM-ALIAS:SERVER\")"))
|
|||
|
|
(let ((endpoint (format "join/%s" (url-hexify-string id-or-alias))))
|
|||
|
|
(ement-api session endpoint :method 'post :data ""
|
|||
|
|
:then (lambda (data)
|
|||
|
|
;; NOTE: This generates a symbol and sets its function value to a lambda
|
|||
|
|
;; which removes the symbol from the hook, removing itself from the hook.
|
|||
|
|
;; TODO: When requiring Emacs 27, use `letrec'.
|
|||
|
|
(pcase-let* (((map ('room_id room-id)) data)
|
|||
|
|
(then-fns (delq nil
|
|||
|
|
(list (when ement-room-join-view-buffer
|
|||
|
|
(lambda (room session)
|
|||
|
|
(ement-view-room room session)))
|
|||
|
|
then)))
|
|||
|
|
(then-fn-symbol (gensym (format "ement-join-%s" id-or-alias)))
|
|||
|
|
(then-fn (lambda (session)
|
|||
|
|
(when-let ((room (cl-loop for room in (ement-session-rooms session)
|
|||
|
|
when (equal room-id (ement-room-id room))
|
|||
|
|
return room)))
|
|||
|
|
;; In case the join event is not in this next sync
|
|||
|
|
;; response, make sure the room is found before removing
|
|||
|
|
;; the function and joining the room.
|
|||
|
|
(remove-hook 'ement-sync-callback-hook then-fn-symbol)
|
|||
|
|
;; FIXME: Probably need to unintern the symbol.
|
|||
|
|
(dolist (fn then-fns)
|
|||
|
|
(funcall fn room session))))))
|
|||
|
|
(setf (symbol-function then-fn-symbol) then-fn)
|
|||
|
|
(add-hook 'ement-sync-callback-hook then-fn-symbol)
|
|||
|
|
(message "Joined room: %s" room-id)))
|
|||
|
|
:else (lambda (plz-error)
|
|||
|
|
(pcase-let* (((cl-struct plz-error response) plz-error)
|
|||
|
|
((cl-struct plz-response status body) response)
|
|||
|
|
((map error) (json-read-from-string body)))
|
|||
|
|
(pcase status
|
|||
|
|
((or 403 429) (error "Unable to join room %s: %s" id-or-alias error))
|
|||
|
|
(_ (error "Unable to join room %s: %s %S" id-or-alias status plz-error))))))))
|
|||
|
|
(defalias 'ement-join-room #'ement-room-join)
|
|||
|
|
|
|||
|
|
(defun ement-room-goto-prev ()
|
|||
|
|
"Go to the previous message in buffer."
|
|||
|
|
(interactive)
|
|||
|
|
(if (>= (point) (- (point-max) 2))
|
|||
|
|
;; Point is actually on the last event, but it doesn't appear to be: move point to
|
|||
|
|
;; the beginning of that event.
|
|||
|
|
(ewoc-goto-node ement-ewoc (ement-room--ewoc-last-matching ement-ewoc #'ement-event-p))
|
|||
|
|
;; Go to previous event.
|
|||
|
|
(ement-room-goto-next :next-fn #'ewoc-prev)))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-goto-next (&key (next-fn #'ewoc-next))
|
|||
|
|
"Go to the next message in buffer.
|
|||
|
|
NEXT-FN is passed to `ement-room--ewoc-next-matching', which
|
|||
|
|
see."
|
|||
|
|
(interactive)
|
|||
|
|
(if-let (node (ement-room--ewoc-next-matching ement-ewoc
|
|||
|
|
(ewoc-locate ement-ewoc) #'ement-event-p next-fn))
|
|||
|
|
(ewoc-goto-node ement-ewoc node)
|
|||
|
|
(if (= (point) (point-max))
|
|||
|
|
;; Already at end of buffer: signal error.
|
|||
|
|
(user-error "End of events")
|
|||
|
|
;; Go to end-of-buffer so new messages will auto-scroll.
|
|||
|
|
(goto-char (point-max)))))
|
|||
|
|
|
|||
|
|
(defun ement-room-scroll-down-command ()
|
|||
|
|
"Scroll down, and load NUMBER earlier messages when at top."
|
|||
|
|
(interactive)
|
|||
|
|
(condition-case _err
|
|||
|
|
(scroll-down nil)
|
|||
|
|
(beginning-of-buffer
|
|||
|
|
(call-interactively #'ement-room-retro))))
|
|||
|
|
|
|||
|
|
(defun ement-room-mwheel-scroll (event)
|
|||
|
|
"Scroll according to EVENT, loading earlier messages when at top."
|
|||
|
|
(interactive "e")
|
|||
|
|
(with-selected-window (posn-window (event-start event))
|
|||
|
|
(mwheel-scroll event)
|
|||
|
|
(when (= (point-min) (window-start))
|
|||
|
|
(call-interactively #'ement-room-retro))))
|
|||
|
|
|
|||
|
|
;; TODO: Unify these retro-loading functions.
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-retro
|
|||
|
|
(room session number &key buffer
|
|||
|
|
(then (apply-partially #'ement-room-retro-callback room session)))
|
|||
|
|
;; FIXME: Naming things is hard.
|
|||
|
|
"Retrieve NUMBER older messages in ROOM on SESSION."
|
|||
|
|
(interactive (list ement-room ement-session
|
|||
|
|
(cl-typecase current-prefix-arg
|
|||
|
|
(null ement-room-retro-messages-number)
|
|||
|
|
(list (read-number "Number of messages: "))
|
|||
|
|
(number current-prefix-arg))
|
|||
|
|
:buffer (current-buffer)))
|
|||
|
|
(unless ement-room-retro-loading
|
|||
|
|
(pcase-let* (((cl-struct ement-room id prev-batch) room)
|
|||
|
|
(endpoint (format "rooms/%s/messages" (url-hexify-string id))))
|
|||
|
|
;; We use a timeout of 30, because sometimes the server can take a while to
|
|||
|
|
;; respond, especially if loading, e.g. hundreds or thousands of events.
|
|||
|
|
(ement-api session endpoint :timeout 30
|
|||
|
|
:params (remq nil
|
|||
|
|
(list (when prev-batch
|
|||
|
|
(list "from" prev-batch))
|
|||
|
|
(list "dir" "b")
|
|||
|
|
(list "limit" (number-to-string number))
|
|||
|
|
(list "filter" (json-encode ement-room-messages-filter))))
|
|||
|
|
:then then
|
|||
|
|
:else (lambda (plz-error)
|
|||
|
|
(when buffer
|
|||
|
|
(with-current-buffer buffer
|
|||
|
|
(setf ement-room-retro-loading nil)))
|
|||
|
|
(signal 'ement-api-error (list (format "Loading %s earlier messages failed" number)
|
|||
|
|
plz-error))))
|
|||
|
|
(message "Loading %s earlier messages..." number)
|
|||
|
|
(setf ement-room-retro-loading t))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-retro-to (room session event-id &key then (batch-size 100) (limit 1000))
|
|||
|
|
"Retrieve messages in ROOM on SESSION back to EVENT-ID.
|
|||
|
|
When event is found, call function THEN. Search in batches of
|
|||
|
|
BATCH-SIZE events up to a total of LIMIT."
|
|||
|
|
(declare (indent defun))
|
|||
|
|
(cl-assert
|
|||
|
|
;; Ensure the event hasn't already been retrieved.
|
|||
|
|
(not (gethash event-id (ement-session-events session))))
|
|||
|
|
(let* ((total-retrieved 0)
|
|||
|
|
;; TODO: Use letrec someday.
|
|||
|
|
(callback-symbol (gensym "ement-room-retro-to-callback-"))
|
|||
|
|
(callback (lambda (data)
|
|||
|
|
(ement-room-retro-callback room session data)
|
|||
|
|
(if (gethash event-id (ement-session-events session))
|
|||
|
|
(progn
|
|||
|
|
(message "Found event %S" event-id)
|
|||
|
|
;; FIXME: Probably need to unintern the symbol.
|
|||
|
|
(when then
|
|||
|
|
(funcall then)))
|
|||
|
|
;; FIXME: What if it hits the beginning of the timeline?
|
|||
|
|
(if (>= (cl-incf total-retrieved batch-size) limit)
|
|||
|
|
(message "%s older events retrieved without finding event %S"
|
|||
|
|
limit event-id)
|
|||
|
|
(message "Looking back for event %S (%s/%s events retrieved)"
|
|||
|
|
event-id total-retrieved limit)
|
|||
|
|
(ement-room-retro room session batch-size
|
|||
|
|
:buffer (alist-get 'buffer (ement-room-local room))
|
|||
|
|
:then callback-symbol))))))
|
|||
|
|
(fset callback-symbol callback)
|
|||
|
|
(ement-room-retro room session batch-size
|
|||
|
|
:buffer (alist-get 'buffer (ement-room-local room))
|
|||
|
|
:then callback-symbol)))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-retro-to-token (room session from to
|
|||
|
|
&key (batch-size 100) (limit 1000))
|
|||
|
|
"Retrieve messages in ROOM on SESSION back from FROM to TO.
|
|||
|
|
Retrieve batches of BATCH-SIZE up to total LIMIT. FROM and TO
|
|||
|
|
are sync batch tokens. Used for, e.g. filling gaps in
|
|||
|
|
\"limited\" sync responses."
|
|||
|
|
;; NOTE: We don't set `ement-room-retro-loading' since the room may
|
|||
|
|
;; not have a buffer. This could theoretically allow a user to
|
|||
|
|
;; overlap manual scrollback-induced loading of old messages with
|
|||
|
|
;; this gap-filling loading, but that shouldn't matter, and probably
|
|||
|
|
;; would be very rare, anyway.
|
|||
|
|
(pcase-let* (((cl-struct ement-room id) room)
|
|||
|
|
(endpoint (format "rooms/%s/messages" (url-hexify-string id)))
|
|||
|
|
(then
|
|||
|
|
(lambda (data)
|
|||
|
|
(ement-room-retro-callback room session data
|
|||
|
|
:set-prev-batch nil)
|
|||
|
|
(pcase-let* (((map end chunk) data))
|
|||
|
|
;; HACK: Comparing the END and TO tokens ought to
|
|||
|
|
;; work for determining whether we are done
|
|||
|
|
;; filling, but it isn't (maybe the server isn't
|
|||
|
|
;; returning the TO token as END when there are no
|
|||
|
|
;; more events), so instead we'll check the length
|
|||
|
|
;; of the chunk.
|
|||
|
|
(unless (< (length chunk) batch-size)
|
|||
|
|
;; More pages remain to be loaded.
|
|||
|
|
(let ((remaining-limit (- limit batch-size)))
|
|||
|
|
(if (not (> remaining-limit 0))
|
|||
|
|
;; FIXME: This leaves a gap if it's larger than 1,000 events.
|
|||
|
|
;; Probably, the limit should be configurable, but it would be good
|
|||
|
|
;; to find some way to remember the gap and fill it if the user
|
|||
|
|
;; scrolls to it later (although that might be very awkward to do).
|
|||
|
|
(display-warning 'ement-room-retro-to-token
|
|||
|
|
(format "Loaded events in %S (%S) without filling gap; not filling further"
|
|||
|
|
(ement-room-display-name room)
|
|||
|
|
(or (ement-room-canonical-alias room)
|
|||
|
|
(ement-room-id room))))
|
|||
|
|
;; FIXME: Remove this message after further testing.
|
|||
|
|
(message "Ement: Continuing to fill gap in %S (%S) (remaining limit: %s)"
|
|||
|
|
(ement-room-display-name room)
|
|||
|
|
(or (ement-room-canonical-alias room)
|
|||
|
|
(ement-room-id room))
|
|||
|
|
remaining-limit)
|
|||
|
|
(ement-room-retro-to-token
|
|||
|
|
room session end to :limit remaining-limit))))))))
|
|||
|
|
;; FIXME: Remove this message after further testing.
|
|||
|
|
(message "Ement: Filling gap in %S (%S)"
|
|||
|
|
(ement-room-display-name room)
|
|||
|
|
(or (ement-room-canonical-alias room)
|
|||
|
|
(ement-room-id room)))
|
|||
|
|
(ement-api session endpoint :timeout 30
|
|||
|
|
:params (list (list "from" from)
|
|||
|
|
(list "to" to)
|
|||
|
|
(list "dir" "b")
|
|||
|
|
(list "limit" (number-to-string batch-size))
|
|||
|
|
(list "filter" (json-encode ement-room-messages-filter)))
|
|||
|
|
:then then
|
|||
|
|
:else (lambda (plz-error)
|
|||
|
|
(signal 'ement-api-error
|
|||
|
|
(list (format "Filling gap in %S (%S) failed"
|
|||
|
|
(ement-room-display-name room)
|
|||
|
|
(or (ement-room-canonical-alias room)
|
|||
|
|
(ement-room-id room)))
|
|||
|
|
plz-error))))))
|
|||
|
|
|
|||
|
|
;; NOTE: `declare-function' doesn't recognize cl-defun forms, so this declaration doesn't work.
|
|||
|
|
(declare-function ement--sync "ement.el" t t)
|
|||
|
|
(defun ement-room-sync (session &optional force)
|
|||
|
|
"Sync SESSION (interactively, current buffer's).
|
|||
|
|
If FORCE (interactively, with prefix), cancel any outstanding
|
|||
|
|
sync requests. Also, update any room list buffers."
|
|||
|
|
(interactive (list ement-session current-prefix-arg))
|
|||
|
|
(ement--sync session :force force)
|
|||
|
|
(cl-loop for buffer in (buffer-list)
|
|||
|
|
when (member (buffer-local-value 'major-mode buffer)
|
|||
|
|
'(ement-room-list-mode ement-tabulated-room-list-mode))
|
|||
|
|
do (with-current-buffer buffer
|
|||
|
|
(revert-buffer))))
|
|||
|
|
|
|||
|
|
(defun ement-room-view-event (event)
|
|||
|
|
"Pop up buffer showing details of EVENT (interactively, the one at point).
|
|||
|
|
EVENT should be an `ement-event' or `ement-room-membership-events' struct."
|
|||
|
|
(interactive (list (ewoc-data (ewoc-locate ement-ewoc))))
|
|||
|
|
(require 'pp)
|
|||
|
|
(cl-labels ((event-alist (event)
|
|||
|
|
(ement-alist :id (ement-event-id event)
|
|||
|
|
:sender (ement-user-id (ement-event-sender event))
|
|||
|
|
:content (ement-event-content event)
|
|||
|
|
:origin-server-ts (ement-event-origin-server-ts event)
|
|||
|
|
:type (ement-event-type event)
|
|||
|
|
:state-key (ement-event-state-key event)
|
|||
|
|
:unsigned (ement-event-unsigned event)
|
|||
|
|
:receipts (ement-event-receipts event)
|
|||
|
|
:local (ement-event-local event))))
|
|||
|
|
(let* ((buffer-name (format "*Ement event: %s*"
|
|||
|
|
(cl-typecase event
|
|||
|
|
(ement-room-membership-events "[multiple events]")
|
|||
|
|
(ement-event (ement-event-id event)))))
|
|||
|
|
(event (cl-typecase event
|
|||
|
|
(ement-room-membership-events
|
|||
|
|
(mapcar #'event-alist (ement-room-membership-events-events event)))
|
|||
|
|
(ement-event (event-alist event))))
|
|||
|
|
(inhibit-read-only t))
|
|||
|
|
(with-current-buffer (get-buffer-create buffer-name)
|
|||
|
|
(erase-buffer)
|
|||
|
|
(pp event (current-buffer))
|
|||
|
|
(view-mode)
|
|||
|
|
(pop-to-buffer (current-buffer))))))
|
|||
|
|
|
|||
|
|
(defun ement-room-dispatch-new-message ()
|
|||
|
|
"Write a new message in accordance with `ement-room-compose-method'."
|
|||
|
|
(interactive)
|
|||
|
|
(call-interactively
|
|||
|
|
(cl-case ement-room-compose-method
|
|||
|
|
(compose-buffer 'ement-room-compose-message)
|
|||
|
|
(t 'ement-room-send-message))))
|
|||
|
|
|
|||
|
|
(defun ement-room-dispatch-new-message-alt ()
|
|||
|
|
"Inverse of `ement-room-dispatch-new-message'."
|
|||
|
|
(interactive)
|
|||
|
|
(call-interactively
|
|||
|
|
(cl-case ement-room-compose-method
|
|||
|
|
(compose-buffer 'ement-room-send-message)
|
|||
|
|
(t 'ement-room-compose-message))))
|
|||
|
|
|
|||
|
|
(defun ement-room-dispatch-edit-message ()
|
|||
|
|
"Edit a message in accordance with `ement-room-compose-method'."
|
|||
|
|
(interactive)
|
|||
|
|
(call-interactively
|
|||
|
|
(cl-case ement-room-compose-method
|
|||
|
|
(compose-buffer 'ement-room-compose-edit)
|
|||
|
|
(t 'ement-room-edit-message))))
|
|||
|
|
|
|||
|
|
(defun ement-room-dispatch-reply-to-message ()
|
|||
|
|
"Reply to a message in accordance with `ement-room-compose-method'."
|
|||
|
|
(interactive)
|
|||
|
|
(call-interactively
|
|||
|
|
(cl-case ement-room-compose-method
|
|||
|
|
(compose-buffer 'ement-room-compose-reply)
|
|||
|
|
(t 'ement-room-write-reply))))
|
|||
|
|
|
|||
|
|
(defun ement-room-dispatch-send-message ()
|
|||
|
|
"Send a message in accordance with `ement-room-compose-method'."
|
|||
|
|
(interactive)
|
|||
|
|
(call-interactively
|
|||
|
|
(cl-case ement-room-compose-method
|
|||
|
|
(compose-buffer #'ement-room-compose-send-direct)
|
|||
|
|
(t #'ement-room-compose-send))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-send-message (room session &key body formatted-body replying-to-event)
|
|||
|
|
"Send message to ROOM on SESSION with BODY and FORMATTED-BODY.
|
|||
|
|
Interactively, with prefix, prompt for room and session,
|
|||
|
|
otherwise use current room.
|
|||
|
|
|
|||
|
|
REPLYING-TO-EVENT may be an event the message is in reply to; the
|
|||
|
|
message will reference it appropriately.
|
|||
|
|
|
|||
|
|
If `ement-room-send-message-filter' is non-nil, the message's
|
|||
|
|
content alist is passed through it before sending. This may be
|
|||
|
|
used to, e.g. process the BODY into another format and add it to
|
|||
|
|
the content (e.g. see `ement-room-send-org-filter')."
|
|||
|
|
(interactive
|
|||
|
|
(ement-with-room-and-session
|
|||
|
|
(let* ((prompt (format "Send message (%s): " (ement-room-display-name ement-room)))
|
|||
|
|
(body (ement-room-with-typing
|
|||
|
|
(ement-room-read-string prompt nil 'ement-room-message-history
|
|||
|
|
nil 'inherit-input-method))))
|
|||
|
|
(list ement-room ement-session :body body))))
|
|||
|
|
(ement-send-message room session :body body :formatted-body formatted-body
|
|||
|
|
:replying-to-event replying-to-event :filter ement-room-send-message-filter
|
|||
|
|
:then #'ement-room-send-event-callback)
|
|||
|
|
;; NOTE: This assumes that the selected window is the buffer's window. For now
|
|||
|
|
;; this is almost surely the case, but in the future, we might let the function
|
|||
|
|
;; send messages to other rooms more easily, so this assumption might not hold.
|
|||
|
|
(when-let* ((buffer (alist-get 'buffer (ement-room-local room)))
|
|||
|
|
(window (get-buffer-window buffer)))
|
|||
|
|
(with-selected-window window
|
|||
|
|
(when (>= (window-point) (ewoc-location (ewoc-nth ement-ewoc -1)))
|
|||
|
|
;; Point is on last event: advance it to eob so that when the event is received
|
|||
|
|
;; back, the window will scroll. (This might not always be desirable, because
|
|||
|
|
;; the user might have point on that event for a reason, but I think in most
|
|||
|
|
;; cases, it will be what's expected and most helpful.)
|
|||
|
|
(setf (window-point) (point-max))))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-send-emote (room session &key body)
|
|||
|
|
"Send emote to ROOM on SESSION with BODY.
|
|||
|
|
Interactively, with prefix, prompt for room and session,
|
|||
|
|
otherwise use current room.
|
|||
|
|
|
|||
|
|
If `ement-room-send-message-filter' is non-nil, the message's
|
|||
|
|
content alist is passed through it before sending. This may be
|
|||
|
|
used to, e.g. process the BODY into another format and add it to
|
|||
|
|
the content (e.g. see `ement-room-send-org-filter')."
|
|||
|
|
(interactive
|
|||
|
|
(ement-with-room-and-session
|
|||
|
|
(let* ((prompt (format "Send emote (%s): " (ement-room-display-name ement-room)))
|
|||
|
|
(body (ement-room-with-typing
|
|||
|
|
(ement-room-read-string prompt nil 'ement-room-emote-history
|
|||
|
|
nil 'inherit-input-method))))
|
|||
|
|
(list ement-room ement-session :body body))))
|
|||
|
|
(cl-assert (not (string-empty-p body)))
|
|||
|
|
(pcase-let* (((cl-struct ement-room (id room-id) (local (map buffer))) room)
|
|||
|
|
(window (when buffer (get-buffer-window buffer)))
|
|||
|
|
(endpoint (format "rooms/%s/send/m.room.message/%s" (url-hexify-string room-id)
|
|||
|
|
(ement--update-transaction-id session)))
|
|||
|
|
(content (ement-aprog1
|
|||
|
|
(ement-alist "msgtype" "m.emote"
|
|||
|
|
"body" body))))
|
|||
|
|
(when ement-room-send-message-filter
|
|||
|
|
(setf content (funcall ement-room-send-message-filter content room)))
|
|||
|
|
(ement-api session endpoint :method 'put :data (json-encode content)
|
|||
|
|
:then (apply-partially #'ement-room-send-event-callback :room room :session session
|
|||
|
|
:content content :data)) ;; Data is added when calling back.
|
|||
|
|
;; NOTE: This assumes that the selected window is the buffer's window. For now
|
|||
|
|
;; this is almost surely the case, but in the future, we might let the function
|
|||
|
|
;; send messages to other rooms more easily, so this assumption might not hold.
|
|||
|
|
(when window
|
|||
|
|
(with-selected-window window
|
|||
|
|
(when (>= (window-point) (ewoc-location (ewoc-nth ement-ewoc -1)))
|
|||
|
|
;; Point is on last event: advance it to eob so that when the event is received
|
|||
|
|
;; back, the window will scroll. (This might not always be desirable, because
|
|||
|
|
;; the user might have point on that event for a reason, but I think in most
|
|||
|
|
;; cases, it will be what's expected and most helpful.)
|
|||
|
|
(setf (window-point) (point-max)))))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-send-event-callback (&key data room session content)
|
|||
|
|
"Callback for event-sending functions.
|
|||
|
|
DATA is the parsed JSON object. If DATA's event ID is already
|
|||
|
|
present in SESSION's events table, show an appropriate warning
|
|||
|
|
mentioning the ROOM and CONTENT."
|
|||
|
|
(pcase-let* (((map ('event_id event-id)) data))
|
|||
|
|
(when (and ement-room-warn-for-already-seen-messages
|
|||
|
|
(gethash event-id (ement-session-events session)))
|
|||
|
|
(let ((message (format "Event ID %S already seen in session %S. This may indicate a reused transaction ID, which could mean that the event was not sent to the room (%S). You may need to disconnect, delete the `ement-sessions-file', and connect again to start a new session. Alternatively, this can happen if the event's sent-confirmation is received after the event itself is received in the next sync response, in which case no action is needed."
|
|||
|
|
event-id (ement-user-id (ement-session-user session))
|
|||
|
|
(ement-room-display-name room))))
|
|||
|
|
(when content
|
|||
|
|
(setf message (concat message (format " Event content: %S" content))))
|
|||
|
|
(display-warning 'ement-room-send-event-callback message)))
|
|||
|
|
(when (eq 'send ement-room-mark-rooms-read)
|
|||
|
|
;; Move read markers.
|
|||
|
|
(when-let ((buffer (alist-get 'buffer (ement-room-local room))))
|
|||
|
|
(with-current-buffer buffer
|
|||
|
|
;; NOTE: The new event may not exist in the buffer yet, so
|
|||
|
|
;; we just have to use the last one.
|
|||
|
|
;; FIXME: When we add local echo, this can be fixed.
|
|||
|
|
(save-excursion
|
|||
|
|
(goto-char (ewoc-location
|
|||
|
|
(ement-room--ewoc-last-matching ement-ewoc #'ement-event-p)))
|
|||
|
|
(call-interactively #'ement-room-mark-read)))))))
|
|||
|
|
|
|||
|
|
(defun ement-room-edit-message-prepare ()
|
|||
|
|
"Bindings for `ement-room-edit-message' and `ement-room-compose-edit'."
|
|||
|
|
(cl-assert ement-ewoc) (cl-assert ement-session)
|
|||
|
|
;; Bindings for... `event' (from ewoc).
|
|||
|
|
(pcase-let* ((event (ewoc-data (ewoc-locate ement-ewoc)))
|
|||
|
|
;; `user' (from ement-session).
|
|||
|
|
((cl-struct ement-session user) ement-session)
|
|||
|
|
;; `sender', `body' (from event).
|
|||
|
|
((cl-struct ement-event sender (content (map body))) event))
|
|||
|
|
(unless (equal (ement-user-id sender) (ement-user-id user))
|
|||
|
|
(user-error "You may only edit your own messages"))
|
|||
|
|
;; Remove any leading asterisk from the plain-text body.
|
|||
|
|
(setf body (replace-regexp-in-string (rx bos "*" (1+ space)) "" body t t))
|
|||
|
|
(list event body)))
|
|||
|
|
|
|||
|
|
(defun ement-room-edit-message (event room session body)
|
|||
|
|
"Edit EVENT in ROOM on SESSION to have new BODY.
|
|||
|
|
The message must be one sent by the local user. If EVENT is
|
|||
|
|
itself an edit of another event, the original event is edited."
|
|||
|
|
;; See also `ement-room-compose-edit'.
|
|||
|
|
(interactive (ement-room-with-highlighted-event-at (point)
|
|||
|
|
(cl-destructuring-bind (ement-room-editing-event body)
|
|||
|
|
(ement-room-edit-message-prepare)
|
|||
|
|
(ement-room-with-typing
|
|||
|
|
(let* ((prompt (format "Edit message (%s): "
|
|||
|
|
(ement-room-display-name ement-room)))
|
|||
|
|
(body (ement-room-read-string prompt body 'ement-room-message-history
|
|||
|
|
nil 'inherit-input-method)))
|
|||
|
|
(when (string-empty-p body)
|
|||
|
|
(user-error "To delete a message, use command `ement-room-delete-message'"))
|
|||
|
|
(when (yes-or-no-p (format "Edit message to: %S? " body))
|
|||
|
|
(list ement-room-editing-event ement-room ement-session body)))))))
|
|||
|
|
(let* ((endpoint (format "rooms/%s/send/%s/%s" (url-hexify-string (ement-room-id room))
|
|||
|
|
"m.room.message" (ement--update-transaction-id session)))
|
|||
|
|
(new-content (ement-alist "body" body
|
|||
|
|
"msgtype" "m.text"))
|
|||
|
|
(_ (when ement-room-send-message-filter
|
|||
|
|
(setf new-content (funcall ement-room-send-message-filter new-content room))))
|
|||
|
|
(original-event (ement--original-event-for event session))
|
|||
|
|
(content (ement-alist "msgtype" "m.text"
|
|||
|
|
"body" body
|
|||
|
|
"m.new_content" new-content
|
|||
|
|
"m.relates_to" (ement-alist
|
|||
|
|
"rel_type" "m.replace"
|
|||
|
|
"event_id" (ement-event-id original-event)))))
|
|||
|
|
;; Prepend the asterisk after the filter may have modified the content. Note that the
|
|||
|
|
;; "m.new_content" body does not get the leading asterisk, only the "content" body,
|
|||
|
|
;; which is intended as a fallback.
|
|||
|
|
(setf body (concat "* " body))
|
|||
|
|
(ement-api session endpoint :method 'put :data (json-encode content)
|
|||
|
|
:then (apply-partially #'ement-room-send-event-callback :room room :session session
|
|||
|
|
:content content :data))))
|
|||
|
|
|
|||
|
|
(defun ement-room-delete-message (event room session &optional reason)
|
|||
|
|
"Delete EVENT in ROOM on SESSION, optionally with REASON."
|
|||
|
|
(interactive (ement-room-with-highlighted-event-at (point)
|
|||
|
|
(if (yes-or-no-p "Delete this event? ")
|
|||
|
|
(list (ewoc-data (ewoc-locate ement-ewoc))
|
|||
|
|
ement-room ement-session (read-string "Reason (optional): " nil nil nil 'inherit-input-method))
|
|||
|
|
;; HACK: This isn't really an error, but is there a cleaner way to cancel?
|
|||
|
|
(user-error "Message not deleted"))))
|
|||
|
|
(ement-redact (ement--original-event-for event session) room session reason))
|
|||
|
|
|
|||
|
|
(defun ement-room-write-reply (event)
|
|||
|
|
"Write and send a reply to EVENT.
|
|||
|
|
Interactively, to event at point."
|
|||
|
|
;; See also `ement-room-compose-reply'.
|
|||
|
|
(interactive (progn (cl-assert ement-ewoc)
|
|||
|
|
(list (ewoc-data (ewoc-locate ement-ewoc)))))
|
|||
|
|
(cl-assert ement-room) (cl-assert ement-session) (cl-assert (ement-event-p event))
|
|||
|
|
(let ((ement-room-replying-to-event event))
|
|||
|
|
(ement-room-with-highlighted-event-at (point)
|
|||
|
|
(pcase-let* ((room ement-room)
|
|||
|
|
(session ement-session)
|
|||
|
|
(prompt (format "Send reply (%s): " (ement-room-display-name room)))
|
|||
|
|
(ement-room-read-string-setup-hook
|
|||
|
|
(lambda ()
|
|||
|
|
(setq-local ement-room-replying-to-event event)))
|
|||
|
|
(body (ement-room-with-typing
|
|||
|
|
(ement-room-read-string prompt nil 'ement-room-message-history
|
|||
|
|
nil 'inherit-input-method))))
|
|||
|
|
;; NOTE: `ement-room-send-message' looks up the original event, so we pass `event'
|
|||
|
|
;; as :replying-to-event.
|
|||
|
|
(ement-room-send-message room session :body body :replying-to-event event)))))
|
|||
|
|
|
|||
|
|
(when (assoc "emoji" input-method-alist)
|
|||
|
|
(defun ement-room-use-emoji-input-method ()
|
|||
|
|
"Activate the emoji input method in the current buffer."
|
|||
|
|
(interactive)
|
|||
|
|
(set-input-method "emoji")))
|
|||
|
|
|
|||
|
|
(defun ement-room-send-reaction (key position &optional event)
|
|||
|
|
"Send reaction of KEY to event at POSITION.
|
|||
|
|
KEY should be a reaction string, e.g. \"👍\".
|
|||
|
|
|
|||
|
|
Interactively, send reaction to event at point. The user option
|
|||
|
|
`ement-room-reaction-picker' controls how the reaction string
|
|||
|
|
is selected, or rather controls the initial mechanism, since the
|
|||
|
|
user can always cancel that command with \\[keyboard-quit] and
|
|||
|
|
choose a different one using the key bindings in
|
|||
|
|
`ement-room-reaction-map' (note that other than `insert-char',
|
|||
|
|
these all require at least version 29 of Emacs):
|
|||
|
|
|
|||
|
|
\\{ement-room-reaction-map}"
|
|||
|
|
(interactive
|
|||
|
|
(let ((event (ewoc-data (ewoc-locate ement-ewoc))))
|
|||
|
|
(unless (ement-event-p event)
|
|||
|
|
(user-error "No event at point"))
|
|||
|
|
(list (minibuffer-with-setup-hook
|
|||
|
|
(lambda ()
|
|||
|
|
(setq-local after-change-functions
|
|||
|
|
(list (lambda (&rest _)
|
|||
|
|
(catch 'exit
|
|||
|
|
(exit-minibuffer))
|
|||
|
|
(throw 'selected (minibuffer-contents)))))
|
|||
|
|
(use-local-map
|
|||
|
|
(make-composed-keymap ement-room-reaction-map (current-local-map)))
|
|||
|
|
(let ((enable-recursive-minibuffers t))
|
|||
|
|
(call-interactively ement-room-reaction-picker)))
|
|||
|
|
(catch 'selected
|
|||
|
|
(read-string "Reaction: ")))
|
|||
|
|
(point))))
|
|||
|
|
;; SPEC: MSC2677 <https://github.com/matrix-org/matrix-doc/pull/2677>
|
|||
|
|
;; HACK: We could simplify this by storing the key in a text property...
|
|||
|
|
(ement-room-with-highlighted-event-at position
|
|||
|
|
(pcase-let* ((event (or event
|
|||
|
|
(ewoc-data (ewoc-locate ement-ewoc position))
|
|||
|
|
(user-error "No event at point")))
|
|||
|
|
;; NOTE: Sadly, `face-at-point' doesn't work here because, e.g. if
|
|||
|
|
;; hl-line-mode is enabled, it only returns the hl-line face.
|
|||
|
|
((cl-struct ement-event (id event-id)) event)
|
|||
|
|
((cl-struct ement-room (id room-id)) ement-room)
|
|||
|
|
(endpoint (format "rooms/%s/send/m.reaction/%s" (url-hexify-string room-id)
|
|||
|
|
(ement--update-transaction-id ement-session)))
|
|||
|
|
(content (ement-alist "m.relates_to"
|
|||
|
|
(ement-alist "rel_type" "m.annotation"
|
|||
|
|
"event_id" event-id
|
|||
|
|
"key" key))))
|
|||
|
|
(ement-api ement-session endpoint :method 'put :data (json-encode content)
|
|||
|
|
:then (apply-partially #'ement-room-send-event-callback
|
|||
|
|
:room ement-room :session ement-session :content content
|
|||
|
|
:data)))))
|
|||
|
|
|
|||
|
|
(defun ement-room-toggle-reaction (key event room session)
|
|||
|
|
"Toggle reaction of KEY to EVENT in ROOM on SESSION."
|
|||
|
|
(interactive
|
|||
|
|
(cl-labels
|
|||
|
|
((face-at-point-p (face)
|
|||
|
|
(let ((face-at-point (get-text-property (point) 'face)))
|
|||
|
|
(or (eq face face-at-point)
|
|||
|
|
(and (listp face-at-point)
|
|||
|
|
(member face face-at-point)))))
|
|||
|
|
(buffer-substring-while (beg pred &key (forward-fn #'forward-char))
|
|||
|
|
"Return substring of current buffer from BEG while PRED is true."
|
|||
|
|
(save-excursion
|
|||
|
|
(goto-char beg)
|
|||
|
|
(cl-loop while (funcall pred)
|
|||
|
|
do (funcall forward-fn)
|
|||
|
|
finally return (buffer-substring-no-properties beg (point)))))
|
|||
|
|
(key-at (pos)
|
|||
|
|
(cond ((face-at-point-p 'ement-room-reactions-key)
|
|||
|
|
(buffer-substring-while
|
|||
|
|
pos (lambda () (face-at-point-p 'ement-room-reactions-key))))
|
|||
|
|
((face-at-point-p 'ement-room-reactions)
|
|||
|
|
;; Point is in a reaction button but after the key.
|
|||
|
|
(buffer-substring-while
|
|||
|
|
(button-start (button-at pos))
|
|||
|
|
(lambda () (face-at-point-p 'ement-room-reactions-key)))))))
|
|||
|
|
(list (or (key-at (point))
|
|||
|
|
(char-to-string (read-char-by-name "Reaction (prepend \"*\" for substring search): ")))
|
|||
|
|
(ewoc-data (ewoc-locate ement-ewoc))
|
|||
|
|
ement-room ement-session)))
|
|||
|
|
(pcase-let* (((cl-struct ement-event (local (map reactions))) event)
|
|||
|
|
((cl-struct ement-session user) session)
|
|||
|
|
((cl-struct ement-user (id user-id)) user))
|
|||
|
|
(if-let (reaction-event (cl-find-if (lambda (event)
|
|||
|
|
(and (equal user-id (ement-user-id (ement-event-sender event)))
|
|||
|
|
(equal key (map-nested-elt (ement-event-content event) '(m.relates_to key)))))
|
|||
|
|
reactions))
|
|||
|
|
;; Already sent this reaction: redact it.
|
|||
|
|
(ement-redact reaction-event room session)
|
|||
|
|
;; Send reaction.
|
|||
|
|
(ement-room-send-reaction key (point)))))
|
|||
|
|
|
|||
|
|
(defun ement-room-reaction-button-action (button)
|
|||
|
|
"Push reaction BUTTON at point."
|
|||
|
|
;; TODO: Toggle reactions off with redactions (not in spec yet, but Element does it).
|
|||
|
|
(save-excursion
|
|||
|
|
(goto-char (button-start button))
|
|||
|
|
(call-interactively #'ement-room-toggle-reaction)))
|
|||
|
|
|
|||
|
|
(defun ement-room-toggle-space (room space session)
|
|||
|
|
;; Naming things is hard, but this seems the best balance between concision, ambiguity,
|
|||
|
|
;; and consistency. The docstring is always there. (Or there's the sci-fi angle:
|
|||
|
|
;; "spacing" a room...)
|
|||
|
|
"Toggle ROOM's membership in SPACE on SESSION."
|
|||
|
|
(interactive
|
|||
|
|
(ement-with-room-and-session
|
|||
|
|
:prompt-form (ement-complete-room :session ement-session
|
|||
|
|
:predicate (lambda (room) (not (ement--space-p room))) )
|
|||
|
|
(pcase-let* ((prompt (format "Toggle room %S's membership in space: "
|
|||
|
|
(ement--format-room ement-room)))
|
|||
|
|
;; TODO: Use different face for spaces the room is already in.
|
|||
|
|
(`(,space ,_session) (ement-complete-room :session ement-session :prompt prompt :suggest nil
|
|||
|
|
:predicate #'ement--space-p)))
|
|||
|
|
(list ement-room space ement-session))))
|
|||
|
|
(pcase-let* (((cl-struct ement-room (id child-id)) room)
|
|||
|
|
(routing-server (progn
|
|||
|
|
(string-match (rx (1+ (not (any ":"))) ":" (group (1+ anything))) child-id)
|
|||
|
|
(match-string 1 child-id)))
|
|||
|
|
(action (if (ement--room-in-space-p room space)
|
|||
|
|
'remove 'add))
|
|||
|
|
(data (pcase action
|
|||
|
|
('add (ement-alist "via" (vector
|
|||
|
|
;; FIXME: Finish and use the routing function.
|
|||
|
|
;; (ement--room-routing room)
|
|||
|
|
routing-server)))
|
|||
|
|
('remove (make-hash-table)))))
|
|||
|
|
(ement-put-state space "m.space.child" child-id data session
|
|||
|
|
:then (lambda (response-data)
|
|||
|
|
;; It appears that the server doesn't send the new event in the next sync (at
|
|||
|
|
;; least, not to the client that put the state), so we must simulate receiving it.
|
|||
|
|
(pcase-let* (((map event_id) response-data)
|
|||
|
|
((cl-struct ement-session user) session)
|
|||
|
|
((cl-struct ement-room (id child-id)) room)
|
|||
|
|
(fake-event (make-ement-event :id event_id :type "m.space.child"
|
|||
|
|
:sender user :state-key child-id
|
|||
|
|
:content (json-read-from-string (json-encode data)))))
|
|||
|
|
(push fake-event (ement-room-timeline space))
|
|||
|
|
(run-hook-with-args 'ement-event-hook fake-event space session))
|
|||
|
|
(ement-message "Room %S %s space %S"
|
|||
|
|
(ement--format-room room)
|
|||
|
|
(pcase action
|
|||
|
|
('add "added to")
|
|||
|
|
('remove "removed from"))
|
|||
|
|
(ement--format-room space))))))
|
|||
|
|
|
|||
|
|
;;;; Functions
|
|||
|
|
|
|||
|
|
(defun ement-room-view (room session)
|
|||
|
|
"Switch to a buffer showing ROOM on SESSION.
|
|||
|
|
Uses action `ement-view-room-display-buffer-action', which see."
|
|||
|
|
(interactive (ement-complete-room :session (ement-complete-session) :suggest nil
|
|||
|
|
:predicate (lambda (room)
|
|||
|
|
(not (ement--space-p room)))))
|
|||
|
|
(pcase-let* (((cl-struct ement-room (local (map buffer))) room))
|
|||
|
|
(unless (buffer-live-p buffer)
|
|||
|
|
(setf buffer (ement-room--buffer session room (ement-room--buffer-name room))
|
|||
|
|
(alist-get 'buffer (ement-room-local room)) buffer))
|
|||
|
|
;; FIXME: This doesn't seem to work as desired, e.g. when
|
|||
|
|
;; `ement-view-room-display-buffer-action' is set to `display-buffer-no-window'; I
|
|||
|
|
;; guess because `pop-to-buffer' selects a window.
|
|||
|
|
(pop-to-buffer buffer ement-view-room-display-buffer-action)
|
|||
|
|
(run-hook-with-args 'ement-room-view-hook room session)))
|
|||
|
|
(defalias 'ement-view-room #'ement-room-view)
|
|||
|
|
|
|||
|
|
(defun ement-room-view-hook-room-list-auto-update (_room session)
|
|||
|
|
"Call `ement-room-list-auto-update' with SESSION.
|
|||
|
|
To be used in `ement-room-view-hook', which see."
|
|||
|
|
;; This function is necessary because the hook is called with the room argument, which
|
|||
|
|
;; `ement-room-list-auto-update' doesn't need.
|
|||
|
|
(declare (function ement-room-list-auto-update "ement-room-list"))
|
|||
|
|
(ement-room-list-auto-update session))
|
|||
|
|
|
|||
|
|
(defun ement-room--buffer-name (room)
|
|||
|
|
"Return name for ROOM's buffer."
|
|||
|
|
(concat ement-room-buffer-name-prefix
|
|||
|
|
(or (ement-room-display-name room)
|
|||
|
|
(setf (ement-room-display-name room)
|
|||
|
|
(ement--room-display-name room)))
|
|||
|
|
ement-room-buffer-name-suffix))
|
|||
|
|
|
|||
|
|
(defun ement-room-goto-event (event)
|
|||
|
|
"Go to EVENT in current buffer."
|
|||
|
|
(if-let ((node (ement-room--ewoc-last-matching ement-ewoc
|
|||
|
|
(lambda (data)
|
|||
|
|
(and (ement-event-p data)
|
|||
|
|
(equal (ement-event-id event) (ement-event-id data)))))))
|
|||
|
|
(goto-char (ewoc-location node))
|
|||
|
|
(error "Event not found in buffer: %S" (ement-event-id event))))
|
|||
|
|
|
|||
|
|
(defun ement-room--event-at (pos)
|
|||
|
|
"Return event at POS or signal an error."
|
|||
|
|
;; TODO: Use this where appropriate.
|
|||
|
|
(save-excursion
|
|||
|
|
(goto-char pos)
|
|||
|
|
(cl-assert ement-ewoc)
|
|||
|
|
(let ((data (ewoc-data (ewoc-locate ement-ewoc))))
|
|||
|
|
(cl-typecase data
|
|||
|
|
(ement-event data)
|
|||
|
|
(otherwise (user-error "No event at point"))))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-retro-callback (room session data
|
|||
|
|
&key (set-prev-batch t))
|
|||
|
|
"Push new DATA to ROOM on SESSION and add events to room buffer.
|
|||
|
|
If SET-PREV-BATCH is nil, don't set ROOM's prev-batch slot to the
|
|||
|
|
\"prev_batch\" token in response DATA (this should be set,
|
|||
|
|
e.g. when filling timeline gaps as opposed to retrieving messages
|
|||
|
|
before the earliest-seen message)."
|
|||
|
|
(declare (function ement--make-event "ement.el")
|
|||
|
|
(function ement--put-event "ement.el"))
|
|||
|
|
(pcase-let* (((cl-struct ement-room local) room)
|
|||
|
|
((map _start end chunk state) data)
|
|||
|
|
((map buffer) local)
|
|||
|
|
(num-events (length chunk))
|
|||
|
|
;; We do 3 things for chunk events, so we count them 3 times when
|
|||
|
|
;; reporting progress. (We also may receive some state events for
|
|||
|
|
;; these chunk events, but we don't bother to include them in the
|
|||
|
|
;; count, and we don't report progress for them, because they are
|
|||
|
|
;; likely very few compared to the number of timeline events, which is
|
|||
|
|
;; what the user is interested in (e.g. when loading 1000 earlier
|
|||
|
|
;; messages in #emacs:matrix.org, only 31 state events were received).
|
|||
|
|
(progress-max-value (* 3 num-events)))
|
|||
|
|
;; NOTE: Put the newly retrieved events at the end of the slots, because they should be
|
|||
|
|
;; older events. But reverse them first, because we're using "dir=b", which the
|
|||
|
|
;; spec says causes the events to be returned in reverse-chronological order, and we
|
|||
|
|
;; want to process them oldest-first (important because a membership event having a
|
|||
|
|
;; user's displayname should be older than a message event sent by the user).
|
|||
|
|
;; NOTE: The events in `chunk' and `state' are vectors, so we
|
|||
|
|
;; convert them to a list before appending.
|
|||
|
|
(ement-debug num-events progress-max-value)
|
|||
|
|
(setf chunk (nreverse chunk)
|
|||
|
|
state (nreverse state))
|
|||
|
|
;; FIXME: Like `ement--push-joined-room-events', this should probably run the `ement-event-hook' on the newly seen events.
|
|||
|
|
;; Append state events.
|
|||
|
|
(cl-loop for event across-ref state
|
|||
|
|
do (setf event (ement--make-event event))
|
|||
|
|
finally do (setf (ement-room-state room)
|
|||
|
|
(append (ement-room-state room) (append state nil))))
|
|||
|
|
(ement-with-progress-reporter (:reporter ("Ement: Processing earlier events..." 0 progress-max-value))
|
|||
|
|
;; Append timeline events (in the "chunk").
|
|||
|
|
;; NOTE: It's regrettable that we have to turn the chunk vector into a list before
|
|||
|
|
;; appending it to the timeline, but we have to discard events that we've already
|
|||
|
|
;; seen.
|
|||
|
|
;; TODO: Consider looping over the vector and pushing one-by-one instead of using
|
|||
|
|
;; `seq-remove' and `append' (might be faster).
|
|||
|
|
(cl-loop for event across-ref chunk
|
|||
|
|
do (if (gethash (alist-get 'event_id event) (ement-session-events session))
|
|||
|
|
;; Duplicate event: set to nil to be ignored.
|
|||
|
|
(setf event nil)
|
|||
|
|
;; New event.
|
|||
|
|
(setf event (ement--make-event event))
|
|||
|
|
;; HACK: Put events on events table. See FIXME above about using the event hook.
|
|||
|
|
(ement--put-event event nil session))
|
|||
|
|
(ement-progress-update)
|
|||
|
|
finally do
|
|||
|
|
(setf chunk (seq-remove #'null chunk)
|
|||
|
|
(ement-room-timeline room) (append (ement-room-timeline room) chunk)))
|
|||
|
|
(when buffer
|
|||
|
|
;; Insert events into the room's buffer.
|
|||
|
|
(with-current-buffer buffer
|
|||
|
|
(save-window-excursion
|
|||
|
|
;; NOTE: See note in `ement--update-room-buffers'.
|
|||
|
|
(when-let ((buffer-window (get-buffer-window buffer)))
|
|||
|
|
(select-window buffer-window))
|
|||
|
|
;; FIXME: Use retro-loading in event handlers, or in --handle-events, anyway.
|
|||
|
|
(ement-room--process-events chunk)
|
|||
|
|
;; Don't set the slot if the response doesn't include an "end" token (that
|
|||
|
|
;; would cause subsequent retro requests to fetch events from the end of the
|
|||
|
|
;; timeline, as if we had just joined).
|
|||
|
|
(when (and set-prev-batch end)
|
|||
|
|
;; This feels a little hacky, but maybe not too bad.
|
|||
|
|
(setf (ement-room-prev-batch room) end))
|
|||
|
|
(setf ement-room-retro-loading nil)))))
|
|||
|
|
(message "Ement: Loaded %s earlier events." num-events)))
|
|||
|
|
|
|||
|
|
(defun ement-room--insert-events (events &optional retro)
|
|||
|
|
"Insert EVENTS into current buffer.
|
|||
|
|
Calls `ement-room--insert-event' for each event and inserts
|
|||
|
|
timestamp headers into appropriate places while maintaining
|
|||
|
|
point's position. If RETRO is non-nil, assume EVENTS are earlier
|
|||
|
|
than any existing events, and only insert timestamp headers up to
|
|||
|
|
the previously oldest event."
|
|||
|
|
(let (buffer-window point-node orig-first-node point-max-p)
|
|||
|
|
(when (get-buffer-window (current-buffer))
|
|||
|
|
;; HACK: See below.
|
|||
|
|
(setf buffer-window (get-buffer-window (current-buffer))
|
|||
|
|
point-max-p (= (point) (point-max))))
|
|||
|
|
(when (and buffer-window retro)
|
|||
|
|
(setf point-node (ewoc-locate ement-ewoc (window-start buffer-window))
|
|||
|
|
orig-first-node (ewoc-nth ement-ewoc 0)))
|
|||
|
|
(save-window-excursion
|
|||
|
|
;; NOTE: When inserting some events, seemingly only replies, if a different buffer's
|
|||
|
|
;; window is selected, and this buffer's window-point is at the bottom, the formatted
|
|||
|
|
;; events may be inserted into the wrong place in the buffer, even though they are
|
|||
|
|
;; inserted into the EWOC at the right place. We work around this by selecting the
|
|||
|
|
;; buffer's window while inserting events, if it has one. (I don't know if this is a bug
|
|||
|
|
;; in EWOC or in this file somewhere. But this has been particularly nasty to debug.)
|
|||
|
|
(when buffer-window
|
|||
|
|
(select-window buffer-window))
|
|||
|
|
(cl-loop for event being the elements of events
|
|||
|
|
do (ement-room--process-event event)
|
|||
|
|
do (ement-progress-update)))
|
|||
|
|
;; Since events can be received in any order, we have to check the whole buffer
|
|||
|
|
;; for where to insert new timestamp headers. (Avoiding that would require
|
|||
|
|
;; getting a list of newly inserted nodes and checking each one instead of every
|
|||
|
|
;; node in the buffer. Doing that now would probably be premature optimization,
|
|||
|
|
;; though it will likely be necessary if users keep buffers open for busy rooms
|
|||
|
|
;; for a long time, as the time to do this in each buffer will increase with the
|
|||
|
|
;; number of events. At least we only do it once per batch of events.)
|
|||
|
|
(ement-room--insert-ts-headers nil (when retro orig-first-node))
|
|||
|
|
(when ement-room-sender-in-headers
|
|||
|
|
(ement-room--insert-sender-headers ement-ewoc))
|
|||
|
|
(when buffer-window
|
|||
|
|
(cond (retro (with-selected-window buffer-window
|
|||
|
|
(set-window-start buffer-window (ewoc-location point-node))
|
|||
|
|
;; TODO: Experiment with this.
|
|||
|
|
(forward-line -1)))
|
|||
|
|
(point-max-p (set-window-point buffer-window (point-max)))))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room--send-typing (session room &key (typing t))
|
|||
|
|
"Send a typing notification for ROOM on SESSION."
|
|||
|
|
(pcase-let* (((cl-struct ement-session user) session)
|
|||
|
|
((cl-struct ement-user (id user-id)) user)
|
|||
|
|
((cl-struct ement-room (id room-id)) room)
|
|||
|
|
(endpoint (format "rooms/%s/typing/%s"
|
|||
|
|
(url-hexify-string room-id) (url-hexify-string user-id)))
|
|||
|
|
(data (ement-alist "typing" typing "timeout" 20000)))
|
|||
|
|
(ement-api session endpoint :method 'put :data (json-encode data)
|
|||
|
|
;; We don't really care about the response, I think.
|
|||
|
|
:then #'ignore)))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-mode-hook nil
|
|||
|
|
;; Due to Emacs bug#68600, define the mode hook separately to avoid the mode
|
|||
|
|
;; line constructs in the `ement-room-mode' mode name being copied verbatim
|
|||
|
|
;; into the auto-generated docstring.
|
|||
|
|
"Hook run after entering `ement-room-mode'."
|
|||
|
|
:options '(visual-line-mode)
|
|||
|
|
:type 'hook
|
|||
|
|
:group 'ement-room)
|
|||
|
|
|
|||
|
|
(define-derived-mode ement-room-mode fundamental-mode
|
|||
|
|
`("Ement-Room"
|
|||
|
|
(:eval (unless (map-elt ement-syncs ement-session)
|
|||
|
|
(propertize ":Not-syncing"
|
|||
|
|
'face 'font-lock-warning-face
|
|||
|
|
'help-echo "Automatic syncing was interrupted; press \"g\" to resume"))))
|
|||
|
|
"Major mode for Ement room buffers.
|
|||
|
|
This mode initializes a buffer to be used for showing events in
|
|||
|
|
an Ement room. It kills all local variables, removes overlays,
|
|||
|
|
and erases the buffer.
|
|||
|
|
|
|||
|
|
\\{ement-room-mode--advertised-keymap}"
|
|||
|
|
(use-local-map ement-room-mode-effective-keymap)
|
|||
|
|
(let ((inhibit-read-only t))
|
|||
|
|
(erase-buffer))
|
|||
|
|
(remove-overlays)
|
|||
|
|
(setf buffer-read-only t
|
|||
|
|
left-margin-width ement-room-left-margin-width
|
|||
|
|
right-margin-width ement-room-right-margin-width
|
|||
|
|
imenu-create-index-function #'ement-room--imenu-create-index-function
|
|||
|
|
;; TODO: Use EWOC header/footer for, e.g. typing messages.
|
|||
|
|
ement-ewoc (ewoc-create #'ement-room--pp-thing))
|
|||
|
|
;; Prevent line/wrap-prefix formatting properties being included in copied text.
|
|||
|
|
(setq-local filter-buffer-substring-function #'ement-room--buffer-substring-filter)
|
|||
|
|
;; Set the URL handler. Note that `browse-url-handlers' was added in 28.1;
|
|||
|
|
;; prior to that `browse-url-browser-function' served double-duty.
|
|||
|
|
;; TODO: Remove compat code when requiring Emacs >=28.
|
|||
|
|
;; (See also `ement-room-browse-url'.)
|
|||
|
|
(let ((handler (cons ement-room-matrix.to-url-regexp #'ement-room-browse-url)))
|
|||
|
|
(if (boundp 'browse-url-handlers)
|
|||
|
|
(setq-local browse-url-handlers (cons handler browse-url-handlers))
|
|||
|
|
(setq-local browse-url-browser-function
|
|||
|
|
(cons handler
|
|||
|
|
(if (consp browse-url-browser-function)
|
|||
|
|
browse-url-browser-function
|
|||
|
|
(and browse-url-browser-function
|
|||
|
|
(list (cons "." browse-url-browser-function))))))))
|
|||
|
|
(setq-local completion-at-point-functions
|
|||
|
|
'(ement-room--complete-members-at-point ement-room--complete-rooms-at-point))
|
|||
|
|
(setq-local dnd-protocol-alist (append '(("^file:///" . ement-room-dnd-upload-file)
|
|||
|
|
("^file:" . ement-room-dnd-upload-file))
|
|||
|
|
dnd-protocol-alist)))
|
|||
|
|
|
|||
|
|
(add-hook 'ement-room-mode-hook 'visual-line-mode)
|
|||
|
|
|
|||
|
|
;;;###autoload
|
|||
|
|
(define-minor-mode ement-room-self-insert-mode
|
|||
|
|
"When enabled, `self-insert-command' keys begin a new message.
|
|||
|
|
|
|||
|
|
The user options `ement-room-self-insert-chars' and
|
|||
|
|
`ement-room-self-insert-commands' determine the specific keys and
|
|||
|
|
commands which will have this effect.
|
|||
|
|
|
|||
|
|
When this mode is enabled, `ement-room-mode-self-insert-keymap'
|
|||
|
|
takes precedence over `ement-room-mode-map', with the shadowed
|
|||
|
|
key bindings in `ement-room-mode-map' becoming accessible via
|
|||
|
|
`ement-room-mode-map-prefix-key'.
|
|||
|
|
|
|||
|
|
If you define custom key bindings in `ement-room-mode-map', you
|
|||
|
|
should call `ement-room-self-insert-mode' after defining those
|
|||
|
|
keys (rather than before). Your bindings will be functional in
|
|||
|
|
either case, but they may not appear in the help for
|
|||
|
|
`ement-room-mode' if you define them afterwards.
|
|||
|
|
|
|||
|
|
If you bind keys in `ement-room-mode-self-insert-keymap', do so
|
|||
|
|
via `ement-room-mode-self-insert-keymap-update-hook' (see which)."
|
|||
|
|
:init-value nil
|
|||
|
|
:global t
|
|||
|
|
:keymap nil
|
|||
|
|
:group 'ement-room
|
|||
|
|
;; Ensure the self-insert and advertised keymaps are up to date.
|
|||
|
|
(if ement-room-self-insert-mode
|
|||
|
|
(ement-room-mode-self-insert-keymap-update)
|
|||
|
|
(setq ement-room-mode--advertised-keymap ement-room-mode-map))
|
|||
|
|
;; Make the local keymap used by `ement-room-mode' reflect the state
|
|||
|
|
;; of `ement-room-self-insert-mode'.
|
|||
|
|
(ement-room-mode-effective-keymap-update))
|
|||
|
|
|
|||
|
|
(defun ement-room-self-insert-new-message ()
|
|||
|
|
"Compose a new message beginning with the just-typed character."
|
|||
|
|
(interactive)
|
|||
|
|
;; Re-issue the event which triggered this command.
|
|||
|
|
;; (Typically a `self-insert-command' key binding.)
|
|||
|
|
(seq-doseq (key (reverse (this-command-keys-vector)))
|
|||
|
|
(push key unread-command-events))
|
|||
|
|
(call-interactively #'ement-room-dispatch-new-message))
|
|||
|
|
|
|||
|
|
(defun ement-room-read-string (prompt &optional initial-input history default-value inherit-input-method)
|
|||
|
|
"Call `read-from-minibuffer', binding variables and keys for Ement.
|
|||
|
|
Arguments PROMPT, INITIAL-INPUT, HISTORY, DEFAULT-VALUE, and
|
|||
|
|
INHERIT-INPUT-METHOD are as those expected by `read-string',
|
|||
|
|
which see. Runs hook `ement-room-read-string-setup-hook', which
|
|||
|
|
see."
|
|||
|
|
(let ((room ement-room)
|
|||
|
|
(session ement-session))
|
|||
|
|
(minibuffer-with-setup-hook
|
|||
|
|
(lambda ()
|
|||
|
|
"Bind keys and variables locally (to be called in minibuffer)."
|
|||
|
|
(setq-local ement-room room)
|
|||
|
|
(setq-local ement-session session)
|
|||
|
|
(setq-local completion-at-point-functions
|
|||
|
|
'(ement-room--complete-members-at-point ement-room--complete-rooms-at-point))
|
|||
|
|
(visual-line-mode 1)
|
|||
|
|
(run-hooks 'ement-room-read-string-setup-hook))
|
|||
|
|
(read-from-minibuffer prompt initial-input ement-room-minibuffer-map
|
|||
|
|
nil history default-value inherit-input-method))))
|
|||
|
|
|
|||
|
|
(defun ement-room--buffer (session room name)
|
|||
|
|
"Return buffer named NAME showing ROOM's events on SESSION.
|
|||
|
|
If ROOM has no buffer, one is made and stored in the room's local
|
|||
|
|
data slot."
|
|||
|
|
(declare (function ement-view-space "ement-directory"))
|
|||
|
|
(or (map-elt (ement-room-local room) 'buffer)
|
|||
|
|
(let ((new-buffer (generate-new-buffer name)))
|
|||
|
|
(with-current-buffer new-buffer
|
|||
|
|
(ement-room-mode)
|
|||
|
|
(setf header-line-format (when ement-room-header-line-format
|
|||
|
|
'ement-room-header-line-format)
|
|||
|
|
ement-session session
|
|||
|
|
ement-room room
|
|||
|
|
list-buffers-directory (or (ement-room-canonical-alias room)
|
|||
|
|
(ement-room-id room))
|
|||
|
|
;; Track buffer in room's slot.
|
|||
|
|
(map-elt (ement-room-local room) 'buffer) (current-buffer))
|
|||
|
|
(add-hook 'kill-buffer-hook
|
|||
|
|
(lambda ()
|
|||
|
|
(setf (map-elt (ement-room-local room) 'buffer) nil))
|
|||
|
|
nil 'local)
|
|||
|
|
(setq-local bookmark-make-record-function #'ement-room-bookmark-make-record)
|
|||
|
|
;; Set initial header and footer. (Do this before processing events, which
|
|||
|
|
;; might cause the header/footer to be changed (e.g. a tombstone event).
|
|||
|
|
(let ((header (if (cl-loop for state in (list (ement-room-state ement-room)
|
|||
|
|
(ement-room-invite-state ement-room))
|
|||
|
|
thereis (cl-find "m.room.encryption" state
|
|||
|
|
:test #'equal :key #'ement-event-type))
|
|||
|
|
(propertize "This appears to be an encrypted room, which is not natively supported by Ement.el. (See information about using Pantalaimon in Ement.el documentation.)"
|
|||
|
|
'face 'font-lock-warning-face)
|
|||
|
|
""))
|
|||
|
|
(footer (pcase (ement-room-status ement-room)
|
|||
|
|
;; Set header and footer for an invited room.
|
|||
|
|
('invite
|
|||
|
|
(concat (propertize "You've been invited to this room. "
|
|||
|
|
'face 'font-lock-warning-face)
|
|||
|
|
(propertize "[Join this room]"
|
|||
|
|
'button '(t)
|
|||
|
|
'category 'default-button
|
|||
|
|
'mouse-face 'highlight
|
|||
|
|
'follow-link t
|
|||
|
|
'action (lambda (_button)
|
|||
|
|
;; Kill the room buffer so it can be recreated after joining
|
|||
|
|
;; (which will cleanly update the room's name, footer, etc).
|
|||
|
|
(let ((room ement-room)
|
|||
|
|
(session ement-session))
|
|||
|
|
(kill-buffer)
|
|||
|
|
(message "Joining room... (buffer will be reopened after joining)")
|
|||
|
|
(ement-room-join (ement-room-id room) session))))))
|
|||
|
|
(_ (if (ement--space-p room)
|
|||
|
|
(concat (propertize "This room is a space. It is not for messaging, but only a grouping of other rooms. "
|
|||
|
|
'face 'font-lock-type-face)
|
|||
|
|
(propertize "[View rooms in this space]"
|
|||
|
|
'button '(t)
|
|||
|
|
'category 'default-button
|
|||
|
|
'mouse-face 'highlight
|
|||
|
|
'follow-link t
|
|||
|
|
'action (lambda (_button)
|
|||
|
|
;; Kill the room buffer so it can be recreated after joining
|
|||
|
|
;; (which will cleanly update the room's name, footer, etc).
|
|||
|
|
(let ((room ement-room)
|
|||
|
|
(session ement-session))
|
|||
|
|
(kill-buffer)
|
|||
|
|
(message "Viewing space...")
|
|||
|
|
(ement-view-space room session)))))
|
|||
|
|
"")))))
|
|||
|
|
(ewoc-set-hf ement-ewoc header footer))
|
|||
|
|
(setf
|
|||
|
|
;; Clear new-events, because those only matter when a buffer is already open.
|
|||
|
|
(alist-get 'new-events (ement-room-local room)) nil
|
|||
|
|
;; Set the new buffer in the room's local alist so that it
|
|||
|
|
;; can be used by event-inserting functions before this
|
|||
|
|
;; function returns, e.g. `ement-room--add-member-face'.
|
|||
|
|
(alist-get 'buffer (ement-room-local room)) new-buffer)
|
|||
|
|
;; We don't use `ement-room--insert-events' to avoid extra
|
|||
|
|
;; calls to `ement-room--insert-ts-headers'.
|
|||
|
|
;; NOTE: We handle the events in chronological order (i.e. the reverse of the
|
|||
|
|
;; stored order, which is latest-first), because some logic depends on this
|
|||
|
|
;; (e.g. processing a message-edit event before the edited event would mean the
|
|||
|
|
;; edited event would not yet be in the buffer).
|
|||
|
|
(ement-room--process-events (reverse (ement-room-state room)))
|
|||
|
|
(ement-room--process-events (reverse (ement-room-timeline room)))
|
|||
|
|
(ement-room--insert-ts-headers)
|
|||
|
|
(when ement-room-sender-in-headers
|
|||
|
|
(ement-room--insert-sender-headers ement-ewoc))
|
|||
|
|
(ement-room-move-read-markers room
|
|||
|
|
:read-event (when-let ((event (alist-get "m.read" (ement-room-account-data room) nil nil #'equal)))
|
|||
|
|
(map-nested-elt event '(content event_id)))
|
|||
|
|
:fully-read-event (when-let ((event (alist-get "m.fully_read" (ement-room-account-data room) nil nil #'equal)))
|
|||
|
|
(map-nested-elt event '(content event_id)))))
|
|||
|
|
;; Return the buffer!
|
|||
|
|
new-buffer)))
|
|||
|
|
|
|||
|
|
(defun ement-room--event-data (id)
|
|||
|
|
"Return event struct for event ID in current buffer."
|
|||
|
|
;; Search from bottom, most likely to be faster.
|
|||
|
|
(cl-loop with node = (ewoc-nth ement-ewoc -1)
|
|||
|
|
while node
|
|||
|
|
for data = (ewoc-data node)
|
|||
|
|
when (and (ement-event-p data)
|
|||
|
|
(equal id (ement-event-id data)))
|
|||
|
|
return data
|
|||
|
|
do (setf node (ewoc-prev ement-ewoc node))))
|
|||
|
|
|
|||
|
|
(defun ement-room--escape-% (string)
|
|||
|
|
"Return STRING with \"%\" escaped.
|
|||
|
|
Needed to display things in the header line."
|
|||
|
|
(replace-regexp-in-string (rx "%") "%%" string t t))
|
|||
|
|
|
|||
|
|
(defun ement-room--buffer-substring-filter (beg end &optional delete)
|
|||
|
|
"Value for `filter-buffer-substring-function' in Ement rooms.
|
|||
|
|
|
|||
|
|
Strips the `line-prefix' and `wrap-prefix' text properties which
|
|||
|
|
are used when formatting certain Matrix events, but which should
|
|||
|
|
not be copied into other buffers."
|
|||
|
|
(let ((string (funcall (default-value 'filter-buffer-substring-function)
|
|||
|
|
beg end delete)))
|
|||
|
|
(remove-list-of-text-properties
|
|||
|
|
0 (length string) '(line-prefix wrap-prefix) string)
|
|||
|
|
string))
|
|||
|
|
|
|||
|
|
;;;;; Imenu
|
|||
|
|
|
|||
|
|
(defconst ement-room-timestamp-header-imenu-format "%Y-%m-%d (%A) %H:%M"
|
|||
|
|
"Format string for timestamps in Imenu indexes.")
|
|||
|
|
|
|||
|
|
(defun ement-room--imenu-create-index-function ()
|
|||
|
|
"Return Imenu index for the current buffer.
|
|||
|
|
For use as `imenu-create-index-function'."
|
|||
|
|
(let ((timestamp-nodes (ement-room--ewoc-collect-nodes
|
|||
|
|
ement-ewoc (lambda (node)
|
|||
|
|
(pcase (ewoc-data node)
|
|||
|
|
(`(ts . ,_) t))))))
|
|||
|
|
(cl-loop for node in timestamp-nodes
|
|||
|
|
collect (pcase-let*
|
|||
|
|
((`(ts ,timestamp) (ewoc-data node))
|
|||
|
|
(formatted (format-time-string ement-room-timestamp-header-imenu-format timestamp)))
|
|||
|
|
(cons formatted (ewoc-location node))))))
|
|||
|
|
|
|||
|
|
;;;;; Occur
|
|||
|
|
|
|||
|
|
(defvar-local ement-room-occur-pred nil
|
|||
|
|
"Predicate used to refresh `ement-room-occur' buffers.")
|
|||
|
|
|
|||
|
|
(define-derived-mode ement-room-occur-mode ement-room-mode "Ement-Room-Occur")
|
|||
|
|
|
|||
|
|
(progn
|
|||
|
|
(define-key ement-room-occur-mode-map [remap ement-room-send-message] #'ement-room-occur-find-event)
|
|||
|
|
(define-key ement-room-occur-mode-map (kbd "g") #'revert-buffer)
|
|||
|
|
(define-key ement-room-occur-mode-map (kbd "n") #'ement-room-occur-next)
|
|||
|
|
(define-key ement-room-occur-mode-map (kbd "p") #'ement-room-occur-prev))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-occur (&key user-id regexp pred header)
|
|||
|
|
"Show known events in current buffer matching args in a new buffer.
|
|||
|
|
If REGEXP, show events whose sender or body content match it. Or
|
|||
|
|
if USER-ID, show events from that user. Or if PRED, show events
|
|||
|
|
matching it. HEADER is used if given, or set according to other
|
|||
|
|
arguments."
|
|||
|
|
(interactive (let* ((regexp (read-regexp "Regexp (leave empty to select user instead)"))
|
|||
|
|
(user-id (when (string-empty-p regexp)
|
|||
|
|
(ement-complete-user-id))))
|
|||
|
|
(list :regexp regexp :user-id user-id)))
|
|||
|
|
(let* ((session ement-session)
|
|||
|
|
(room ement-room)
|
|||
|
|
(occur-buffer (get-buffer-create (format "*Ement Room Occur: %s*" (ement-room-display-name room))))
|
|||
|
|
(pred (cond (pred)
|
|||
|
|
((not (string-empty-p regexp))
|
|||
|
|
(lambda (data)
|
|||
|
|
(and (ement-event-p data)
|
|||
|
|
(or (string-match regexp (ement-user-id (ement-event-sender data)))
|
|||
|
|
(when-let ((room-display-name
|
|||
|
|
(gethash (ement-event-sender data) (ement-room-displaynames room))))
|
|||
|
|
(string-match regexp room-display-name))
|
|||
|
|
(when-let ((body (alist-get 'body (ement-event-content data))))
|
|||
|
|
(string-match regexp body))))))
|
|||
|
|
(user-id
|
|||
|
|
(lambda (data)
|
|||
|
|
(and (ement-event-p data)
|
|||
|
|
(equal user-id (ement-user-id (ement-event-sender data))))))))
|
|||
|
|
(header (cond (header)
|
|||
|
|
((not (string-empty-p regexp))
|
|||
|
|
(format "Events matching %S in %s" regexp (ement-room-display-name room)))
|
|||
|
|
(user-id
|
|||
|
|
(format "Events from %s in %s" user-id (ement-room-display-name room))))))
|
|||
|
|
(with-current-buffer occur-buffer
|
|||
|
|
(let ((inhibit-read-only t))
|
|||
|
|
(erase-buffer))
|
|||
|
|
(ement-room-occur-mode)
|
|||
|
|
(setf header-line-format header
|
|||
|
|
ement-session session
|
|||
|
|
ement-room room)
|
|||
|
|
(setq-local revert-buffer-function (lambda (&rest _)
|
|||
|
|
(interactive)
|
|||
|
|
(let ((event-at-point (ewoc-data (ewoc-locate ement-ewoc))))
|
|||
|
|
(with-current-buffer (alist-get 'buffer (ement-room-local room))
|
|||
|
|
(ement-room-occur :pred pred :header header)
|
|||
|
|
(when-let ((node (ement-room--ewoc-last-matching ement-ewoc
|
|||
|
|
(lambda (data)
|
|||
|
|
(eq event-at-point data)))))
|
|||
|
|
(ewoc-goto-node ement-ewoc node))))))
|
|||
|
|
(ement-room--process-events (reverse (ement-room-state room)))
|
|||
|
|
(ement-room--process-events (reverse (ement-room-timeline room)))
|
|||
|
|
(ewoc-filter ement-ewoc pred)
|
|||
|
|
;; TODO: Insert date header before first event.
|
|||
|
|
(ement-room--insert-ts-headers))
|
|||
|
|
(pop-to-buffer occur-buffer)))
|
|||
|
|
|
|||
|
|
(defun ement-room-occur-find-event (event)
|
|||
|
|
"Find EVENT in room's main buffer."
|
|||
|
|
(interactive (list (ewoc-data (ewoc-locate ement-ewoc))))
|
|||
|
|
(pcase-let* (((cl-struct ement-room (local (map buffer))) ement-room)
|
|||
|
|
((cl-struct ement-event id) event))
|
|||
|
|
(display-buffer buffer)
|
|||
|
|
(with-selected-window (get-buffer-window buffer)
|
|||
|
|
(ement-room-find-event id))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-occur-next (&optional (n 1))
|
|||
|
|
"Go to Nth next event."
|
|||
|
|
(interactive)
|
|||
|
|
(let ((command (if (> n 0)
|
|||
|
|
#'ement-room-goto-next
|
|||
|
|
#'ement-room-goto-prev)))
|
|||
|
|
(cl-loop for i below (abs n)
|
|||
|
|
do (call-interactively command))
|
|||
|
|
(ement-room-occur-find-event (ewoc-data (ewoc-locate ement-ewoc)))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-occur-prev (&optional (n 1))
|
|||
|
|
"Go to Nth previous event."
|
|||
|
|
(interactive)
|
|||
|
|
(ement-room-occur-next (- n)))
|
|||
|
|
|
|||
|
|
;;;;; Events
|
|||
|
|
|
|||
|
|
;; Functions to handle types of events.
|
|||
|
|
|
|||
|
|
;; NOTE: At the moment, this only handles "m.typing" ephemeral events. Message
|
|||
|
|
;; events are handled elsewhere. A better framework should be designed...
|
|||
|
|
;; TODO: Define other handlers this way.
|
|||
|
|
|
|||
|
|
;; MAYBE: Should we intern these functions? That means every event
|
|||
|
|
;; handled has to concat and intern. Should we use lambdas in an
|
|||
|
|
;; alist or hash-table instead? For now let's use an alist.
|
|||
|
|
|
|||
|
|
(defvar ement-users)
|
|||
|
|
|
|||
|
|
(defvar ement-room-event-fns nil
|
|||
|
|
"Alist mapping event types to functions which process events in room buffers.")
|
|||
|
|
|
|||
|
|
;; NOTE: While transitioning to the defevent-based handler system, we
|
|||
|
|
;; define both a handle-events and handle-event function that do the
|
|||
|
|
;; same thing.
|
|||
|
|
|
|||
|
|
;; TODO: Tidy this up.
|
|||
|
|
|
|||
|
|
;; NOTE: --handle-events and --handle-event need to be called in the room
|
|||
|
|
;; buffer's window, when it has one. This is absolutely necessary,
|
|||
|
|
;; otherwise the events may be inserted at the wrong place. (I'm not
|
|||
|
|
;; sure if this is a bug in EWOC or in my code, but doing this fixes it.)
|
|||
|
|
|
|||
|
|
(defun ement-room--process-events (events)
|
|||
|
|
"Process EVENTS in current buffer.
|
|||
|
|
Calls `ement-progress-update' for each event. Calls
|
|||
|
|
`ement-room--insert-ts-headers' when done. Uses handlers defined
|
|||
|
|
in `ement-room-event-fns'. The current buffer should be a room's
|
|||
|
|
buffer."
|
|||
|
|
;; FIXME: Calling `ement-room--insert-ts-headers' is convenient, but it
|
|||
|
|
;; may also be called in functions that call this function, which may
|
|||
|
|
;; result in it being called multiple times for a single set of events.
|
|||
|
|
(cl-loop for event being the elements of events ;; EVENTS may be a list or array.
|
|||
|
|
for handler = (alist-get (ement-event-type event) ement-room-event-fns nil nil #'equal)
|
|||
|
|
when handler
|
|||
|
|
do (funcall handler event)
|
|||
|
|
do (ement-progress-update))
|
|||
|
|
(ement-room--insert-ts-headers))
|
|||
|
|
|
|||
|
|
(defun ement-room--process-event (event)
|
|||
|
|
"Process EVENT in current buffer.
|
|||
|
|
Uses handlers defined in `ement-room-event-fns'. The current
|
|||
|
|
buffer should be a room's buffer."
|
|||
|
|
(when-let ((handler (alist-get (ement-event-type event) ement-room-event-fns nil nil #'equal)))
|
|||
|
|
;; We demote any errors that happen while processing events, because it's possible for
|
|||
|
|
;; events to be malformed in unexpected ways, and that could cause an error, which
|
|||
|
|
;; would stop processing of other events and prevent further syncing. See,
|
|||
|
|
;; e.g. <https://github.com/alphapapa/ement.el/pull/61>.
|
|||
|
|
(with-demoted-errors "Ement (ement-room--process-event): Error processing event: %S"
|
|||
|
|
(funcall handler event))))
|
|||
|
|
|
|||
|
|
;;;;;; Event handlers
|
|||
|
|
|
|||
|
|
(defmacro ement-room-defevent (type &rest body)
|
|||
|
|
"Define an event handling function for events of TYPE.
|
|||
|
|
Around the BODY, the variable `event' is bound to the event being
|
|||
|
|
processed. The function is called in the room's buffer. Adds
|
|||
|
|
function to `ement-room-event-fns', which see."
|
|||
|
|
(declare (debug (stringp def-body))
|
|||
|
|
(indent defun))
|
|||
|
|
`(setf (alist-get ,type ement-room-event-fns nil nil #'string=)
|
|||
|
|
(lambda (event)
|
|||
|
|
,(concat "`ement-room' handler function for " type " events.")
|
|||
|
|
,@body)))
|
|||
|
|
|
|||
|
|
(ement-room-defevent "m.reaction"
|
|||
|
|
(pcase-let* (((cl-struct ement-event content) event)
|
|||
|
|
((map ('m.relates_to relates-to)) content)
|
|||
|
|
((map ('event_id related-id) ('rel_type rel-type) _key) relates-to))
|
|||
|
|
;; TODO: Handle other rel_types?
|
|||
|
|
(pcase rel-type
|
|||
|
|
("m.annotation"
|
|||
|
|
;; Look for related event in timeline.
|
|||
|
|
(if-let ((related-event (cl-loop with fake-event = (make-ement-event :id related-id)
|
|||
|
|
for timeline-event in (ement-room-timeline ement-room)
|
|||
|
|
when (ement--events-equal-p fake-event timeline-event)
|
|||
|
|
return timeline-event)))
|
|||
|
|
;; Found related event: add reaction to local slot and invalidate node.
|
|||
|
|
(progn
|
|||
|
|
;; Every time a room buffer is made, these reaction events are processed again, so we use pushnew to
|
|||
|
|
;; avoid duplicates. (In the future, as event-processing is refactored, this may not be necessary.)
|
|||
|
|
(cl-pushnew event (map-elt (ement-event-local related-event) 'reactions))
|
|||
|
|
(when-let ((nodes (ement-room--ewoc-last-matching ement-ewoc
|
|||
|
|
(lambda (data)
|
|||
|
|
(and (ement-event-p data)
|
|||
|
|
(equal related-id (ement-event-id data)))))))
|
|||
|
|
(ewoc-invalidate ement-ewoc nodes)))
|
|||
|
|
;; No known related event: discard.
|
|||
|
|
;; TODO: Is this the correct thing to do?
|
|||
|
|
(ement-debug "No known related event for" event))))))
|
|||
|
|
|
|||
|
|
(ement-room-defevent "m.room.power_levels"
|
|||
|
|
(ement-room--insert-event event))
|
|||
|
|
|
|||
|
|
(defun ement-room--format-power-levels-event (event room _session)
|
|||
|
|
"Return power-levels EVENT in ROOM formatted as a string."
|
|||
|
|
(pcase-let (((cl-struct ement-event sender
|
|||
|
|
(content (map ('users new-users)))
|
|||
|
|
(unsigned (map ('prev_content (map ('users old-users))))))
|
|||
|
|
event))
|
|||
|
|
(when old-users
|
|||
|
|
(pcase-let* ((sender-id (ement-user-id sender))
|
|||
|
|
(sender-displayname (ement--user-displayname-in room sender))
|
|||
|
|
(`(,changed-user-id-symbol . ,new-level)
|
|||
|
|
(cl-find-if (lambda (new-user)
|
|||
|
|
(let ((old-user (cl-find (car new-user) old-users
|
|||
|
|
:key #'car)))
|
|||
|
|
(or (not old-user)
|
|||
|
|
(not (equal (cdr new-user) (cdr old-user))))))
|
|||
|
|
new-users))
|
|||
|
|
(changed-user-id (symbol-name changed-user-id-symbol))
|
|||
|
|
(changed-user (when changed-user-id-symbol
|
|||
|
|
(gethash changed-user-id ement-users)))
|
|||
|
|
(user-displayname (if changed-user
|
|||
|
|
(ement--user-displayname-in room changed-user)
|
|||
|
|
changed-user-id)))
|
|||
|
|
(ement-room-wrap-prefix
|
|||
|
|
(if (not changed-user)
|
|||
|
|
(format "%s sent a power-level event"
|
|||
|
|
(propertize sender-displayname
|
|||
|
|
'help-echo sender-id))
|
|||
|
|
(format "%s set %s's power level to %s"
|
|||
|
|
(propertize sender-displayname
|
|||
|
|
'help-echo sender-id)
|
|||
|
|
(propertize user-displayname 'help-echo changed-user-id)
|
|||
|
|
new-level))
|
|||
|
|
'face 'ement-room-membership)))))
|
|||
|
|
|
|||
|
|
(ement-room-defevent "m.room.canonical_alias"
|
|||
|
|
(ement-room--insert-event event))
|
|||
|
|
|
|||
|
|
(defun ement-room--format-canonical-alias-event (event room _session)
|
|||
|
|
"Return canonical alias EVENT in ROOM formatted as a string."
|
|||
|
|
(pcase-let (((cl-struct ement-event sender
|
|||
|
|
;; TODO: Include alt_aliases, maybe.
|
|||
|
|
;; TODO: Include old alias when it is being replaced.
|
|||
|
|
(content (map alias)))
|
|||
|
|
event))
|
|||
|
|
(ement-room-wrap-prefix
|
|||
|
|
(format "%s set the canonical alias to <%s>"
|
|||
|
|
(propertize (ement--user-displayname-in room sender)
|
|||
|
|
'help-echo (ement-user-id sender))
|
|||
|
|
alias)
|
|||
|
|
'face 'ement-room-membership)))
|
|||
|
|
|
|||
|
|
(ement-room-defevent "m.room.redaction"
|
|||
|
|
;; We handle redaction events here rather than an `ement-defevent' handler. This way we
|
|||
|
|
;; do less work for events in rooms that the user isn't looking at, at the cost of doing
|
|||
|
|
;; a bit more work when a room's buffer is prepared.
|
|||
|
|
(pcase-let* (((cl-struct ement-event (local (map ('redacts redacted-id)))) event)
|
|||
|
|
((cl-struct ement-room timeline) ement-room)
|
|||
|
|
(redacted-event (cl-find redacted-id timeline
|
|||
|
|
:key #'ement-event-id :test #'equal))
|
|||
|
|
(redacted-edit-events (cl-remove-if-not (lambda (timeline-event)
|
|||
|
|
(pcase-let (((cl-struct ement-event
|
|||
|
|
(content
|
|||
|
|
(map ('m.relates_to
|
|||
|
|
(map ('event_id related-id)
|
|||
|
|
('rel_type rel-type))))))
|
|||
|
|
timeline-event))
|
|||
|
|
(and (equal redacted-id related-id)
|
|||
|
|
(equal "m.replace" rel-type))))
|
|||
|
|
timeline)))
|
|||
|
|
(ement-debug event redacted-event redacted-edit-events)
|
|||
|
|
(cl-loop for edit-event in redacted-edit-events
|
|||
|
|
do (cl-pushnew event (alist-get 'redacted-by (ement-event-local edit-event))))
|
|||
|
|
(when redacted-event
|
|||
|
|
(cl-pushnew event (alist-get 'redacted-by (ement-event-local redacted-event)))
|
|||
|
|
(pcase-let* (((cl-struct ement-event (content
|
|||
|
|
(map ('m.relates_to
|
|||
|
|
(map ('event_id related-id)
|
|||
|
|
('rel_type rel-type))))))
|
|||
|
|
redacted-event))
|
|||
|
|
(pcase rel-type
|
|||
|
|
("m.annotation"
|
|||
|
|
;; Redacted annotation/reaction. NOTE: Since we link annotations in a -room
|
|||
|
|
;; event handler (rather than in a non-room handler), we also unlink redacted
|
|||
|
|
;; ones here.
|
|||
|
|
(when-let (annotated-event (cl-find related-id timeline
|
|||
|
|
:key #'ement-event-id :test #'equal))
|
|||
|
|
;; Remove it from the related event's local slot.
|
|||
|
|
(setf (map-elt (ement-event-local annotated-event) 'reactions)
|
|||
|
|
(cl-remove redacted-id (map-elt (ement-event-local annotated-event) 'reactions)
|
|||
|
|
:key #'ement-event-id :test #'equal))
|
|||
|
|
;; Invalidate the related event's node.
|
|||
|
|
(when-let (node (ement-room--ewoc-last-matching ement-ewoc
|
|||
|
|
(lambda (data)
|
|||
|
|
(and (ement-event-p data)
|
|||
|
|
(equal related-id (ement-event-id data))))))
|
|||
|
|
(ewoc-invalidate ement-ewoc node)))))))
|
|||
|
|
;; Invalidate the redacted event's node.
|
|||
|
|
(when-let ((node (ement-room--ewoc-last-matching ement-ewoc
|
|||
|
|
(lambda (data)
|
|||
|
|
(and (ement-event-p data)
|
|||
|
|
(pcase-let (((cl-struct ement-event id
|
|||
|
|
(content
|
|||
|
|
(map ('m.relates_to
|
|||
|
|
(map ('event_id related-id)
|
|||
|
|
('rel_type rel-type))))))
|
|||
|
|
data))
|
|||
|
|
(or (equal redacted-id id)
|
|||
|
|
(and (equal "m.replace" rel-type)
|
|||
|
|
(equal redacted-id related-id)))))))))
|
|||
|
|
(ement-debug node)
|
|||
|
|
(ewoc-invalidate ement-ewoc node))))
|
|||
|
|
|
|||
|
|
(ement-room-defevent "m.typing"
|
|||
|
|
(pcase-let* (((cl-struct ement-session user) ement-session)
|
|||
|
|
((cl-struct ement-user (id local-user-id)) user)
|
|||
|
|
((cl-struct ement-event content) event)
|
|||
|
|
((map ('user_ids user-ids)) content)
|
|||
|
|
(usernames) (footer))
|
|||
|
|
(setf user-ids (delete local-user-id user-ids))
|
|||
|
|
(if (zerop (length user-ids))
|
|||
|
|
(setf footer "")
|
|||
|
|
(setf usernames (cl-loop for id across user-ids
|
|||
|
|
for user = (gethash id ement-users)
|
|||
|
|
if user
|
|||
|
|
collect (ement--user-displayname-in ement-room user)
|
|||
|
|
else collect id)
|
|||
|
|
footer (propertize (concat "Typing: " (string-join usernames ", "))
|
|||
|
|
'face 'font-lock-comment-face)))
|
|||
|
|
(with-silent-modifications
|
|||
|
|
(ewoc-set-hf ement-ewoc "" footer))))
|
|||
|
|
|
|||
|
|
(ement-room-defevent "m.room.avatar"
|
|||
|
|
(ement-room--insert-event event))
|
|||
|
|
|
|||
|
|
(ement-room-defevent "org.matrix.msc3015.m.room.name.override"
|
|||
|
|
(ignore event)
|
|||
|
|
(setf (ement-room-display-name ement-room) (ement--room-display-name ement-room))
|
|||
|
|
(rename-buffer (ement-room--buffer-name ement-room)))
|
|||
|
|
|
|||
|
|
(ement-room-defevent "m.room.member"
|
|||
|
|
(with-silent-modifications
|
|||
|
|
(ement-room--insert-event event)))
|
|||
|
|
|
|||
|
|
(ement-room-defevent "m.room.message"
|
|||
|
|
(pcase-let* (((cl-struct ement-event content unsigned) event)
|
|||
|
|
((map ('m.relates_to (map ('rel_type rel-type) ('event_id replaces-event-id)))) content)
|
|||
|
|
((map ('m.relations (map ('m.replace (map ('event_id replaced-by-id)))))) unsigned))
|
|||
|
|
(if (and ement-room-replace-edited-messages
|
|||
|
|
replaces-event-id (equal "m.replace" rel-type))
|
|||
|
|
;; Event replaces existing event: find and replace it in buffer if possible, otherwise insert it.
|
|||
|
|
(or (ement-room--replace-event event)
|
|||
|
|
(progn
|
|||
|
|
(ement-debug "Unable to replace event ID: inserting instead." replaces-event-id)
|
|||
|
|
(ement-room--insert-event event)))
|
|||
|
|
;; New event.
|
|||
|
|
(if replaced-by-id
|
|||
|
|
(ement-debug "Event replaced: not inserting." replaced-by-id)
|
|||
|
|
;; Not replaced: insert it.
|
|||
|
|
(ement-room--insert-event event)))))
|
|||
|
|
|
|||
|
|
(ement-room-defevent "m.room.tombstone"
|
|||
|
|
(pcase-let* (((cl-struct ement-event content) event)
|
|||
|
|
((map body ('replacement_room new-room-id)) content)
|
|||
|
|
(session ement-session)
|
|||
|
|
(button (ement--button-buttonize
|
|||
|
|
(propertize new-room-id 'help-echo "Join replacement room")
|
|||
|
|
(lambda (_)
|
|||
|
|
(ement-room-join new-room-id session))))
|
|||
|
|
(banner (format "This room has been replaced. Explanation:%S Replacement room: <%s>" body button)))
|
|||
|
|
(add-face-text-property 0 (length banner) 'font-lock-warning-face t banner)
|
|||
|
|
;; NOTE: We assume that no more typing events will be received,
|
|||
|
|
;; which would replace the footer.
|
|||
|
|
(ement-room--insert-event event)
|
|||
|
|
(ewoc-set-hf ement-ewoc banner banner)))
|
|||
|
|
|
|||
|
|
;;;;; Read markers
|
|||
|
|
|
|||
|
|
;; Marking rooms as read and showing lines where marks are.
|
|||
|
|
|
|||
|
|
(ement-room-defevent "m.read"
|
|||
|
|
(ement-room-move-read-markers ement-room
|
|||
|
|
:read-event (ement-event-id event)))
|
|||
|
|
|
|||
|
|
(ement-room-defevent "m.fully_read"
|
|||
|
|
(ement-room-move-read-markers ement-room
|
|||
|
|
:fully-read-event (ement-event-id event)))
|
|||
|
|
|
|||
|
|
(defvar-local ement-room-read-receipt-marker nil
|
|||
|
|
"EWOC node for the room's read-receipt marker.")
|
|||
|
|
|
|||
|
|
(defvar-local ement-room-fully-read-marker nil
|
|||
|
|
"EWOC node for the room's fully-read marker.")
|
|||
|
|
|
|||
|
|
(defface ement-room-read-receipt-marker
|
|||
|
|
'((t (:inherit show-paren-match)))
|
|||
|
|
"Read marker line in rooms."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defface ement-room-fully-read-marker
|
|||
|
|
'((t (:inherit isearch)))
|
|||
|
|
"Fully read marker line in rooms."
|
|||
|
|
:group 'ement-room-faces)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-send-read-receipts t
|
|||
|
|
"Whether to send read receipts.
|
|||
|
|
Also controls whether the read-receipt marker in a room is moved
|
|||
|
|
automatically."
|
|||
|
|
:type 'boolean
|
|||
|
|
:group 'ement-room)
|
|||
|
|
|
|||
|
|
(defun ement-room-read-receipt-idle-timer ()
|
|||
|
|
"Update read receipts in visible Ement room buffers.
|
|||
|
|
To be called from timer stored in
|
|||
|
|
`ement-read-receipt-idle-timer'."
|
|||
|
|
(when ement-room-send-read-receipts
|
|||
|
|
(dolist (window (window-list))
|
|||
|
|
(when (and (eq 'ement-room-mode (buffer-local-value 'major-mode (window-buffer window)))
|
|||
|
|
(buffer-local-value 'ement-room (window-buffer window)))
|
|||
|
|
(ement-room-update-read-receipt window)))))
|
|||
|
|
|
|||
|
|
(defun ement-room-update-read-receipt (window)
|
|||
|
|
"Update read receipt for room displayed in WINDOW.
|
|||
|
|
Also, mark room's buffer as unmodified."
|
|||
|
|
(with-selected-window window
|
|||
|
|
(let ((read-receipt-node (ement-room--ewoc-last-matching ement-ewoc
|
|||
|
|
(lambda (node-data)
|
|||
|
|
(eq 'ement-room-read-receipt-marker node-data))))
|
|||
|
|
(window-end-node (or (ewoc-locate ement-ewoc (window-end nil t))
|
|||
|
|
(ewoc-nth ement-ewoc -1))))
|
|||
|
|
(when (or
|
|||
|
|
;; The window's end has been scrolled to or past the position of the
|
|||
|
|
;; receipt marker.
|
|||
|
|
(and read-receipt-node
|
|||
|
|
(>= (window-end nil t) (ewoc-location read-receipt-node)))
|
|||
|
|
;; The read receipt is outside of retrieved events.
|
|||
|
|
(not read-receipt-node))
|
|||
|
|
(let* ((event-node (when window-end-node
|
|||
|
|
;; It seems like `window-end-node' shouldn't ever be nil,
|
|||
|
|
;; but just in case...
|
|||
|
|
(cl-typecase (ewoc-data window-end-node)
|
|||
|
|
(ement-event window-end-node)
|
|||
|
|
(t (ement-room--ewoc-next-matching ement-ewoc window-end-node
|
|||
|
|
#'ement-event-p #'ewoc-prev)))))
|
|||
|
|
(node-after-event (ewoc-next ement-ewoc event-node))
|
|||
|
|
(event))
|
|||
|
|
(when event-node
|
|||
|
|
(unless (or (when node-after-event
|
|||
|
|
(<= (ewoc-location node-after-event) (window-end nil t)))
|
|||
|
|
(>= (window-end) (point-max)))
|
|||
|
|
;; The entire event is not visible: use the previous event. (NOTE: This
|
|||
|
|
;; isn't quite perfect, because apparently `window-end' considers a position
|
|||
|
|
;; visible if even one pixel of its line is visible. This will have to be
|
|||
|
|
;; good enough for now.)
|
|||
|
|
;; FIXME: Workaround that an entire line's height need not be displayed for it to be considered so.
|
|||
|
|
(setf event-node (ement-room--ewoc-next-matching ement-ewoc event-node
|
|||
|
|
#'ement-event-p #'ewoc-prev)))
|
|||
|
|
(setf event (ewoc-data event-node))
|
|||
|
|
;; Mark the buffer as not modified so that will not contribute to its being
|
|||
|
|
;; considered unread. NOTE: This will mean that any room buffer displayed in
|
|||
|
|
;; a window will have its buffer marked unmodified when this function is
|
|||
|
|
;; called. This is probably for the best.
|
|||
|
|
(set-buffer-modified-p nil)
|
|||
|
|
(unless (alist-get event ement-room-read-receipt-request)
|
|||
|
|
;; No existing request for this event: cancel any outstanding request and
|
|||
|
|
;; send a new one.
|
|||
|
|
(when-let ((request-process (car (map-values ement-room-read-receipt-request))))
|
|||
|
|
(when (process-live-p request-process)
|
|||
|
|
(interrupt-process request-process)))
|
|||
|
|
(setf ement-room-read-receipt-request nil)
|
|||
|
|
(setf (alist-get event ement-room-read-receipt-request)
|
|||
|
|
(ement-room-mark-read ement-room ement-session
|
|||
|
|
:read-event event)))))))))
|
|||
|
|
|
|||
|
|
(defun ement-room-goto-fully-read-marker ()
|
|||
|
|
"Move to the fully-read marker in the current room."
|
|||
|
|
(interactive)
|
|||
|
|
(if-let ((fully-read-pos (when ement-room-fully-read-marker
|
|||
|
|
(ewoc-location ement-room-fully-read-marker))))
|
|||
|
|
(with-suppressed-warnings ((obsolete point))
|
|||
|
|
;; I like using `point' as a GV, and I object to its being obsoleted (and said so
|
|||
|
|
;; on emacs-devel).
|
|||
|
|
(setf (point) fully-read-pos (window-start) fully-read-pos))
|
|||
|
|
;; Unlike the fully-read marker, there doesn't seem to be a
|
|||
|
|
;; simple way to get the user's read-receipt marker. So if
|
|||
|
|
;; we haven't seen either marker in the retrieved events, we
|
|||
|
|
;; go back to the fully-read marker.
|
|||
|
|
(if-let* ((fully-read-event (alist-get "m.fully_read" (ement-room-account-data ement-room) nil nil #'equal))
|
|||
|
|
(fully-read-event-id (map-nested-elt fully-read-event '(content event_id))))
|
|||
|
|
;; Fully-read account-data event is known.
|
|||
|
|
(if (gethash fully-read-event-id (ement-session-events ement-session))
|
|||
|
|
;; The fully-read event (i.e. the message event that was read, not the
|
|||
|
|
;; account-data event) is already retrieved, but the marker is not present in
|
|||
|
|
;; the buffer (this shouldn't happen, but somehow, it can): Reset the marker,
|
|||
|
|
;; which should work around the problem.
|
|||
|
|
(ement-room-mark-read ement-room ement-session
|
|||
|
|
:fully-read-event (gethash fully-read-event-id (ement-session-events ement-session)))
|
|||
|
|
;; Fully-read event not retrieved: search for it in room history.
|
|||
|
|
(let ((buffer (current-buffer)))
|
|||
|
|
(message "Searching for first unread event...")
|
|||
|
|
(ement-room-retro-to ement-room ement-session fully-read-event-id
|
|||
|
|
:then (lambda ()
|
|||
|
|
(with-current-buffer buffer
|
|||
|
|
;; HACK: Should probably call this function elsewhere, in a hook or something.
|
|||
|
|
(ement-room-move-read-markers ement-room)
|
|||
|
|
(ement-room-goto-fully-read-marker))))))
|
|||
|
|
(error "Room has no fully-read event"))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-mark-read (room session &key read-event fully-read-event)
|
|||
|
|
"Mark ROOM on SESSION as read on the server.
|
|||
|
|
Set \"m.read\" to READ-EVENT and \"m.fully_read\" to
|
|||
|
|
FULLY-READ-EVENT. Return the API request.
|
|||
|
|
|
|||
|
|
Interactively, mark both types as read up to event at point."
|
|||
|
|
(declare (indent defun))
|
|||
|
|
(interactive
|
|||
|
|
(progn
|
|||
|
|
(cl-assert (equal 'ement-room-mode major-mode) nil
|
|||
|
|
"This command is to be used in `ement-room-mode' buffers")
|
|||
|
|
(let* ((node (ewoc-locate ement-ewoc))
|
|||
|
|
(event-at-point (cl-typecase (ewoc-data node)
|
|||
|
|
(ement-event (ewoc-data node))
|
|||
|
|
(t (when-let ((prev-event-node (ement-room--ewoc-next-matching ement-ewoc node
|
|||
|
|
#'ement-event-p #'ewoc-prev)))
|
|||
|
|
(ewoc-data prev-event-node)))))
|
|||
|
|
(last-event (ewoc-data (ement-room--ewoc-last-matching ement-ewoc #'ement-event-p)))
|
|||
|
|
(event-to-mark-read (if (eq event-at-point last-event)
|
|||
|
|
;; The node is at the end of the buffer: use the last event in the timeline
|
|||
|
|
;; instead of the last node in the EWOC, because the last event in the timeline
|
|||
|
|
;; might not be the last event in the EWOC (e.g. a reaction to an earlier event).
|
|||
|
|
(car (ement-room-timeline ement-room))
|
|||
|
|
event-at-point)))
|
|||
|
|
(list ement-room ement-session
|
|||
|
|
:read-event event-to-mark-read
|
|||
|
|
:fully-read-event event-to-mark-read))))
|
|||
|
|
(cl-assert room) (cl-assert session) (cl-assert (or read-event fully-read-event))
|
|||
|
|
(if (not fully-read-event)
|
|||
|
|
;; Sending only a read receipt, which uses a different endpoint
|
|||
|
|
;; than when setting the fully-read marker or both.
|
|||
|
|
(ement-room-send-receipt room session read-event)
|
|||
|
|
;; Setting the fully-read marker, and maybe the "m.read" one too.
|
|||
|
|
(pcase-let* (((cl-struct ement-room (id room-id)) room)
|
|||
|
|
(endpoint (format "rooms/%s/read_markers" (url-hexify-string room-id)))
|
|||
|
|
(data (ement-alist "m.fully_read" (ement-event-id fully-read-event))))
|
|||
|
|
(when read-event
|
|||
|
|
(push (cons "m.read" (ement-event-id read-event)) data))
|
|||
|
|
;; NOTE: See similar code in `ement-room-update-read-receipt'.
|
|||
|
|
(let ((request-process (ement-api session endpoint :method 'post :data (json-encode data)
|
|||
|
|
:then (lambda (_data)
|
|||
|
|
(ement-room-move-read-markers room
|
|||
|
|
:read-event read-event :fully-read-event fully-read-event))
|
|||
|
|
:else (lambda (plz-error)
|
|||
|
|
(pcase (plz-error-message plz-error)
|
|||
|
|
("curl process interrupted"
|
|||
|
|
;; Ignore this, because it happens when we
|
|||
|
|
;; update a read marker before the previous
|
|||
|
|
;; update request is completed.
|
|||
|
|
nil)
|
|||
|
|
(_ (signal 'ement-api-error
|
|||
|
|
(list (format "Ement: (ement-room-mark-read) Unexpected API error: %s"
|
|||
|
|
plz-error)
|
|||
|
|
plz-error))))))))
|
|||
|
|
(when-let ((room-buffer (alist-get 'buffer (ement-room-local room))))
|
|||
|
|
;; NOTE: Ideally we would do this before sending the new request, but to make
|
|||
|
|
;; the code much simpler, we do it afterward.
|
|||
|
|
(with-current-buffer room-buffer
|
|||
|
|
(when-let ((request-process (car (map-values ement-room-read-receipt-request))))
|
|||
|
|
(when (process-live-p request-process)
|
|||
|
|
(interrupt-process request-process)))
|
|||
|
|
(setf ement-room-read-receipt-request nil
|
|||
|
|
(alist-get read-event ement-room-read-receipt-request) request-process)))))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-send-receipt (room session event &key (type "m.read"))
|
|||
|
|
"Send receipt of TYPE for EVENT to ROOM on SESSION."
|
|||
|
|
(pcase-let* (((cl-struct ement-room (id room-id)) room)
|
|||
|
|
((cl-struct ement-event (id event-id)) event)
|
|||
|
|
(endpoint (format "rooms/%s/receipt/%s/%s"
|
|||
|
|
(url-hexify-string room-id) type
|
|||
|
|
(url-hexify-string event-id))))
|
|||
|
|
(ement-api session endpoint :method 'post :data "{}"
|
|||
|
|
:then (pcase type
|
|||
|
|
("m.read" (lambda (_data)
|
|||
|
|
(ement-room-move-read-markers room
|
|||
|
|
:read-event event)))
|
|||
|
|
;; No other type is yet specified.
|
|||
|
|
(_ #'ignore)))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-move-read-markers
|
|||
|
|
(room &key
|
|||
|
|
(read-event (when-let ((event (alist-get "m.read" (ement-room-account-data room) nil nil #'equal)))
|
|||
|
|
(map-nested-elt event '(content event_id))))
|
|||
|
|
(fully-read-event (when-let ((event (alist-get "m.fully_read" (ement-room-account-data room) nil nil #'equal)))
|
|||
|
|
(map-nested-elt event '(content event_id)))))
|
|||
|
|
"Move read markers in ROOM to READ-EVENT and FULLY-READ-EVENT.
|
|||
|
|
Each event may be an `ement-event' struct or an event ID. This
|
|||
|
|
updates the markers in ROOM's buffer, not on the server; see
|
|||
|
|
`ement-room-mark-read' for that."
|
|||
|
|
(declare (indent defun))
|
|||
|
|
(cl-labels ((update-marker (symbol to-event)
|
|||
|
|
(let* ((old-node (symbol-value symbol))
|
|||
|
|
(new-event-id (cl-etypecase to-event
|
|||
|
|
(ement-event (ement-event-id to-event))
|
|||
|
|
(string to-event)))
|
|||
|
|
;; FIXME: Some events, like reactions, are not inserted into the
|
|||
|
|
;; EWOC directly, and if a read marker refers to such an event, the
|
|||
|
|
;; place for the read marker will not be found.
|
|||
|
|
(event-node (ement-room--ewoc-last-matching ement-ewoc
|
|||
|
|
(lambda (data)
|
|||
|
|
(and (ement-event-p data)
|
|||
|
|
(equal (ement-event-id data) new-event-id)))))
|
|||
|
|
(inhibit-read-only t))
|
|||
|
|
(with-silent-modifications
|
|||
|
|
(when old-node
|
|||
|
|
(ewoc-delete ement-ewoc old-node))
|
|||
|
|
(set symbol (when event-node
|
|||
|
|
;; If the event hasn't been inserted into the buffer yet,
|
|||
|
|
;; this might be nil. That shouldn't happen, but...
|
|||
|
|
(ewoc-enter-after ement-ewoc event-node symbol)))))))
|
|||
|
|
(when-let ((buffer (alist-get 'buffer (ement-room-local room))))
|
|||
|
|
;; MAYBE: Error if no buffer? Or does it matter?
|
|||
|
|
(with-current-buffer buffer
|
|||
|
|
(when read-event
|
|||
|
|
(update-marker 'ement-room-read-receipt-marker read-event))
|
|||
|
|
(when fully-read-event
|
|||
|
|
(update-marker 'ement-room-fully-read-marker fully-read-event))))
|
|||
|
|
;; NOTE: Return nil so that, in the event this function is called manually with `eval-expression',
|
|||
|
|
;; it does not cause an error due to the return value being an EWOC node, which is a structure too
|
|||
|
|
;; big and/or circular to print. (This was one of those bugs that only happens WHEN debugging.)
|
|||
|
|
nil))
|
|||
|
|
|
|||
|
|
(defun ement-room-scroll-up-mark-read ()
|
|||
|
|
"Scroll buffer contents up, move fully read marker, and bury when at end.
|
|||
|
|
Moves fully read marker to the top of the window (when the
|
|||
|
|
marker's position is within the range of received events). At
|
|||
|
|
end-of-buffer, moves fully read marker to after the last event,
|
|||
|
|
buries the buffer and shows the next unread room, if any."
|
|||
|
|
(declare (function ement-tabulated-room-list-next-unread "ement-tabulated-room-list")
|
|||
|
|
(function ement-room-list-next-unread "ement-room-list"))
|
|||
|
|
(interactive)
|
|||
|
|
(if (= (window-point) (point-max))
|
|||
|
|
(progn
|
|||
|
|
;; At the bottom of the buffer: mark read and show next unread room.
|
|||
|
|
(when ement-room-mark-rooms-read
|
|||
|
|
(ement-room-mark-read ement-room ement-session
|
|||
|
|
:read-event (ewoc-data (ement-room--ewoc-last-matching ement-ewoc
|
|||
|
|
(lambda (data) (ement-event-p data))))
|
|||
|
|
:fully-read-event (ewoc-data (ement-room--ewoc-last-matching ement-ewoc
|
|||
|
|
(lambda (data) (ement-event-p data))))))
|
|||
|
|
(set-buffer-modified-p nil)
|
|||
|
|
(if-let ((rooms-window (cl-find-if (lambda (window)
|
|||
|
|
(member (buffer-name (window-buffer window))
|
|||
|
|
'("*Ement Taxy*" "*Ement Rooms*")))
|
|||
|
|
(window-list))))
|
|||
|
|
;; Rooms buffer already displayed: select its window and move to next unread room.
|
|||
|
|
(progn
|
|||
|
|
(select-window rooms-window)
|
|||
|
|
(funcall (pcase-exhaustive major-mode
|
|||
|
|
('ement-tabulated-room-list-mode #'ement-tabulated-room-list-next-unread)
|
|||
|
|
('ement-room-list-mode #'ement-room-list-next-unread))))
|
|||
|
|
;; Rooms buffer not displayed: bury this room buffer, which should usually
|
|||
|
|
;; result in another room buffer or the rooms list buffer being displayed.
|
|||
|
|
(bury-buffer))
|
|||
|
|
(when (member major-mode '(ement-tabulated-room-list-mode ement-room-list-mode))
|
|||
|
|
;; Back in the room-list buffer: revert it.
|
|||
|
|
(revert-buffer)))
|
|||
|
|
;; Not at the bottom of the buffer: scroll.
|
|||
|
|
(condition-case _err
|
|||
|
|
(scroll-up-command)
|
|||
|
|
(end-of-buffer (set-window-point nil (point-max))))
|
|||
|
|
(when-let* ((node (ewoc-locate ement-ewoc (window-start)))
|
|||
|
|
(event-node (ement-room--ewoc-next-matching ement-ewoc node
|
|||
|
|
#'ement-event-p #'ewoc-prev))
|
|||
|
|
(fully-read-pos (and ement-room-fully-read-marker
|
|||
|
|
(ewoc-location ement-room-fully-read-marker)))
|
|||
|
|
((< fully-read-pos (ewoc-location event-node))))
|
|||
|
|
;; Move fully-read marker to top of window.
|
|||
|
|
(ement-room-mark-read ement-room ement-session :fully-read-event (ewoc-data event-node)))))
|
|||
|
|
|
|||
|
|
;;;;; EWOC
|
|||
|
|
|
|||
|
|
(cl-defun ement-room--ewoc-next-matching (ewoc node pred &optional (move-fn #'ewoc-next))
|
|||
|
|
"Return the next node in EWOC after NODE that PRED is true of.
|
|||
|
|
PRED is called with node's data. Moves to next node by MOVE-FN."
|
|||
|
|
(declare (indent defun))
|
|||
|
|
(cl-loop do (setf node (funcall move-fn ewoc node))
|
|||
|
|
until (or (null node)
|
|||
|
|
(funcall pred (ewoc-data node)))
|
|||
|
|
finally return node))
|
|||
|
|
|
|||
|
|
(defun ement-room--ewoc-last-matching (ewoc predicate)
|
|||
|
|
"Return the last node in EWOC matching PREDICATE.
|
|||
|
|
PREDICATE is called with node's data. Searches backward from
|
|||
|
|
last node."
|
|||
|
|
(declare (indent defun))
|
|||
|
|
;; Intended to be like `ewoc-collect', but returning as soon as a match is found.
|
|||
|
|
(cl-loop with node = (ewoc-nth ewoc -1)
|
|||
|
|
while node
|
|||
|
|
when (funcall predicate (ewoc-data node))
|
|||
|
|
return node
|
|||
|
|
do (setf node (ewoc-prev ewoc node))))
|
|||
|
|
|
|||
|
|
(defun ement-room--ewoc-collect-nodes (ewoc predicate)
|
|||
|
|
"Collect all nodes in EWOC matching PREDICATE.
|
|||
|
|
PREDICATE is called with the full node."
|
|||
|
|
;; Intended to be like `ewoc-collect', but working with the full node instead of just the node's data.
|
|||
|
|
(cl-loop with node = (ewoc-nth ewoc 0)
|
|||
|
|
do (setf node (ewoc-next ewoc node))
|
|||
|
|
while node
|
|||
|
|
when (funcall predicate node)
|
|||
|
|
collect node))
|
|||
|
|
|
|||
|
|
(defun ement-room--insert-ts-headers (&optional start-node end-node)
|
|||
|
|
"Insert timestamp headers into current buffer's `ement-ewoc'.
|
|||
|
|
Inserts headers between START-NODE and END-NODE, which default to
|
|||
|
|
the first and last nodes in the buffer, respectively."
|
|||
|
|
(let* ((type-predicate (lambda (node-data)
|
|||
|
|
(and (ement-event-p node-data)
|
|||
|
|
(not (equal "m.room.member" (ement-event-type node-data))))))
|
|||
|
|
(ewoc ement-ewoc)
|
|||
|
|
(end-node (or end-node
|
|||
|
|
(ewoc-nth ewoc -1)))
|
|||
|
|
(end-pos (if end-node
|
|||
|
|
(ewoc-location end-node)
|
|||
|
|
;; HACK: Trying to work around a bug in case the
|
|||
|
|
;; room doesn't seem to have any events yet.
|
|||
|
|
(point-max)))
|
|||
|
|
(node-b (or start-node (ewoc-nth ewoc 0)))
|
|||
|
|
node-a)
|
|||
|
|
;; On the first loop iteration, node-a is set to the first matching
|
|||
|
|
;; node after node-b; then it's set to the first node after node-a.
|
|||
|
|
(while (and (setf node-a (ement-room--ewoc-next-matching ewoc (or node-a node-b) type-predicate)
|
|||
|
|
node-b (when node-a
|
|||
|
|
(ement-room--ewoc-next-matching ewoc node-a type-predicate)))
|
|||
|
|
(not (or (> (ewoc-location node-a) end-pos)
|
|||
|
|
(when node-b
|
|||
|
|
(> (ewoc-location node-b) end-pos)))))
|
|||
|
|
(cl-labels ((format-event (event)
|
|||
|
|
(format "TS:%S (%s) Sender:%s Message:%S"
|
|||
|
|
(/ (ement-event-origin-server-ts (ewoc-data event)) 1000)
|
|||
|
|
(format-time-string "%Y-%m-%d %H:%M:%S"
|
|||
|
|
(/ (ement-event-origin-server-ts (ewoc-data event)) 1000))
|
|||
|
|
(ement-user-id (ement-event-sender (ewoc-data event)))
|
|||
|
|
(when (alist-get 'body (ement-event-content (ewoc-data event)))
|
|||
|
|
(substring-no-properties
|
|||
|
|
(truncate-string-to-width (alist-get 'body (ement-event-content (ewoc-data event))) 20))))))
|
|||
|
|
(ement-debug "Comparing event timestamps:"
|
|||
|
|
(list 'A (format-event node-a))
|
|||
|
|
(list 'B (format-event node-b))))
|
|||
|
|
;; NOTE: Matrix timestamps are in milliseconds.
|
|||
|
|
(let* ((a-ts (/ (ement-event-origin-server-ts (ewoc-data node-a)) 1000))
|
|||
|
|
(b-ts (/ (ement-event-origin-server-ts (ewoc-data node-b)) 1000))
|
|||
|
|
(diff-seconds (- b-ts a-ts))
|
|||
|
|
(ement-room-timestamp-header-format ement-room-timestamp-header-format))
|
|||
|
|
(when (and (>= diff-seconds ement-room-timestamp-header-delta)
|
|||
|
|
(not (when-let ((node-after-a (ewoc-next ewoc node-a)))
|
|||
|
|
(pcase (ewoc-data node-after-a)
|
|||
|
|
(`(ts . ,_) t)
|
|||
|
|
((or 'ement-room-read-receipt-marker 'ement-room-fully-read-marker) t)))))
|
|||
|
|
(unless (equal (time-to-days a-ts) (time-to-days b-ts))
|
|||
|
|
;; Different date: bind format to print date.
|
|||
|
|
(let ((ement-room-timestamp-header-format ement-room-timestamp-header-with-date-format))
|
|||
|
|
;; Insert the date-only header.
|
|||
|
|
(setf node-a (ewoc-enter-after ewoc node-a (list 'ts b-ts)))))
|
|||
|
|
(with-silent-modifications
|
|||
|
|
;; Avoid marking a buffer as modified just because we inserted a ts
|
|||
|
|
;; header (this function may be called after other events which shouldn't
|
|||
|
|
;; cause it to be marked modified, like moving the read markers).
|
|||
|
|
(ewoc-enter-after ewoc node-a (list 'ts b-ts))))))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room--insert-sender-headers
|
|||
|
|
(ewoc &optional (start-node (ewoc-nth ewoc 0)) (end-node (ewoc-nth ewoc -1)))
|
|||
|
|
;; TODO: Use this in appropriate places.
|
|||
|
|
"Insert sender headers into EWOC.
|
|||
|
|
Inserts headers between START-NODE and END-NODE, which default to
|
|||
|
|
the first and last nodes in the buffer, respectively."
|
|||
|
|
(cl-labels ((message-event-p (data)
|
|||
|
|
(and (ement-event-p data)
|
|||
|
|
(equal "m.room.message" (ement-event-type data)))))
|
|||
|
|
(when (and start-node (not (message-event-p (ewoc-data start-node))))
|
|||
|
|
;; Start node not a message event: forward to next message event (and if none are
|
|||
|
|
;; found, there's nothing to do).
|
|||
|
|
(setf start-node (ement-room--ewoc-next-matching ewoc start-node #'message-event-p)))
|
|||
|
|
(when end-node
|
|||
|
|
;; Set end node to first message event after it. (This simplifies the loop by
|
|||
|
|
;; continuing until finding `end-node' or the last node, and ensures we fix headers
|
|||
|
|
;; after any inserted messages.)
|
|||
|
|
(setf end-node (ement-room--ewoc-next-matching ewoc end-node #'message-event-p)))
|
|||
|
|
(let ((event-node start-node) prev-node)
|
|||
|
|
(while (and event-node (not (eq event-node end-node)))
|
|||
|
|
(setf prev-node
|
|||
|
|
;; Find previous message or user header.
|
|||
|
|
(ement-room--ewoc-next-matching ewoc event-node
|
|||
|
|
(lambda (data)
|
|||
|
|
(or (ement-user-p data) (message-event-p data)))
|
|||
|
|
#'ewoc-prev))
|
|||
|
|
(let ((sender (ement-event-sender (ewoc-data event-node))))
|
|||
|
|
(cond ((not prev-node)
|
|||
|
|
;; No previous message/sender: insert sender.
|
|||
|
|
(ewoc-enter-before ewoc event-node sender))
|
|||
|
|
((ement-user-p (ewoc-data prev-node))
|
|||
|
|
;; Previous node is a sender.
|
|||
|
|
(unless (equal sender (ewoc-data prev-node))
|
|||
|
|
;; Previous node is the wrong sender: fix it.
|
|||
|
|
(ewoc-set-data prev-node sender)))
|
|||
|
|
((and (message-event-p (ewoc-data prev-node))
|
|||
|
|
(not (equal sender (ement-event-sender (ewoc-data prev-node)))))
|
|||
|
|
;; Previous node is a message from a different sender: insert header.
|
|||
|
|
(ewoc-enter-before ewoc event-node sender))))
|
|||
|
|
(setf event-node (ement-room--ewoc-next-matching ewoc event-node #'message-event-p))))))
|
|||
|
|
|
|||
|
|
(defun ement-room--coalesce-nodes (a b ewoc)
|
|||
|
|
"Try to coalesce events in nodes A and B in EWOC.
|
|||
|
|
Return absorbing node if coalesced."
|
|||
|
|
;; NOTE: This does not coalesce two `ement-room-membership-events' nodes; it only
|
|||
|
|
;; coalesces an individual membership event into another one or into an
|
|||
|
|
;; `ement-room-membership-events' node.
|
|||
|
|
;; TODO: Allow two `ement-room-membership-events' nodes to be coalesced.
|
|||
|
|
(cl-labels ((coalescable-p (node)
|
|||
|
|
(or (and (ement-event-p (ewoc-data node))
|
|||
|
|
(member (ement-event-type (ewoc-data node)) '("m.room.member")))
|
|||
|
|
(ement-room-membership-events-p (ewoc-data node)))))
|
|||
|
|
(when (and (coalescable-p a) (coalescable-p b))
|
|||
|
|
(let* ((absorbing-node (if (or (ement-room-membership-events-p (ewoc-data a))
|
|||
|
|
(not (ement-room-membership-events-p (ewoc-data b))))
|
|||
|
|
a b))
|
|||
|
|
(absorbed-node (if (eq absorbing-node a) b a)))
|
|||
|
|
(when (cl-etypecase (ewoc-data absorbing-node)
|
|||
|
|
(ement-room-membership-events
|
|||
|
|
(pcase-exhaustive ement-room-coalesce-events
|
|||
|
|
((pred integerp)
|
|||
|
|
(< (length (ement-room-membership-events-events (ewoc-data absorbing-node)))
|
|||
|
|
ement-room-coalesce-events))
|
|||
|
|
(`t t)))
|
|||
|
|
(ement-event
|
|||
|
|
(setf (ewoc-data absorbing-node)
|
|||
|
|
(ement-room-membership-events--update
|
|||
|
|
(make-ement-room-membership-events
|
|||
|
|
:events (list (ewoc-data absorbing-node)))))))
|
|||
|
|
(push (ewoc-data absorbed-node)
|
|||
|
|
(ement-room-membership-events-events (ewoc-data absorbing-node)))
|
|||
|
|
(ement-room-membership-events--update (ewoc-data absorbing-node))
|
|||
|
|
(ewoc-delete ewoc absorbed-node)
|
|||
|
|
(ewoc-invalidate ewoc absorbing-node)
|
|||
|
|
absorbing-node)))))
|
|||
|
|
|
|||
|
|
(defun ement-room--insert-event (event)
|
|||
|
|
"Insert EVENT into current buffer."
|
|||
|
|
(cl-labels ((format-event (event)
|
|||
|
|
(format "TS:%S (%s) Sender:%s Message:%S"
|
|||
|
|
(/ (ement-event-origin-server-ts event) 1000)
|
|||
|
|
(format-time-string "%Y-%m-%d %H:%M:%S"
|
|||
|
|
(/ (ement-event-origin-server-ts event) 1000))
|
|||
|
|
(ement-user-id (ement-event-sender event))
|
|||
|
|
(when (alist-get 'body (ement-event-content event))
|
|||
|
|
(substring-no-properties
|
|||
|
|
(truncate-string-to-width (alist-get 'body (ement-event-content event)) 20)))))
|
|||
|
|
(find-node-if (ewoc pred &key (move #'ewoc-prev) (start (ewoc-nth ewoc -1)))
|
|||
|
|
"Return node in EWOC whose data matches PRED.
|
|||
|
|
Search starts from node START and moves by NEXT."
|
|||
|
|
(cl-loop for node = start then (funcall move ewoc node)
|
|||
|
|
while node
|
|||
|
|
when (funcall pred (ewoc-data node))
|
|||
|
|
return node))
|
|||
|
|
(timestamped-node-p (data)
|
|||
|
|
(pcase data
|
|||
|
|
((pred ement-event-p) t)
|
|||
|
|
((pred ement-room-membership-events-p) t)
|
|||
|
|
(`(ts . ,_) t)))
|
|||
|
|
(read-marker-p
|
|||
|
|
(data) (member data '(ement-room-fully-read-marker
|
|||
|
|
ement-room-read-receipt-marker)))
|
|||
|
|
(node-ts (data)
|
|||
|
|
(pcase data
|
|||
|
|
((pred ement-event-p) (ement-event-origin-server-ts data))
|
|||
|
|
((pred ement-room-membership-events-p)
|
|||
|
|
;; Not sure whether to use earliest or latest ts; let's try this for now.
|
|||
|
|
(ement-room-membership-events-earliest-ts data))
|
|||
|
|
(`(ts ,ts)
|
|||
|
|
;; Matrix server timestamps are in ms, so we must convert back.
|
|||
|
|
(* 1000 ts))))
|
|||
|
|
(node< (a b)
|
|||
|
|
"Return non-nil if event A's timestamp is before B's."
|
|||
|
|
(< (node-ts a) (node-ts b))))
|
|||
|
|
(ement-debug "INSERTING NEW EVENT: " (format-event event))
|
|||
|
|
(let* ((ewoc ement-ewoc)
|
|||
|
|
(event-node-before (ement-room--ewoc-node-before ewoc event #'node< :pred #'timestamped-node-p))
|
|||
|
|
new-node)
|
|||
|
|
;; HACK: Insert after any read markers.
|
|||
|
|
(cl-loop for node-after-node-before = (ewoc-next ewoc event-node-before)
|
|||
|
|
while node-after-node-before
|
|||
|
|
while (read-marker-p (ewoc-data node-after-node-before))
|
|||
|
|
do (setf event-node-before node-after-node-before))
|
|||
|
|
(setf new-node (if (not event-node-before)
|
|||
|
|
(progn
|
|||
|
|
(ement-debug "No event before it: add first.")
|
|||
|
|
(if-let ((first-node (ewoc-nth ewoc 0)))
|
|||
|
|
(progn
|
|||
|
|
(ement-debug "EWOC not empty.")
|
|||
|
|
(if (and (ement-user-p (ewoc-data first-node))
|
|||
|
|
(equal (ement-event-sender event)
|
|||
|
|
(ewoc-data first-node)))
|
|||
|
|
(progn
|
|||
|
|
(ement-debug "First node is header for this sender: insert after it, instead.")
|
|||
|
|
(setf event-node-before first-node)
|
|||
|
|
(ewoc-enter-after ewoc first-node event))
|
|||
|
|
(ement-debug "First node is not header for this sender: insert first.")
|
|||
|
|
(ewoc-enter-first ewoc event)))
|
|||
|
|
(ement-debug "EWOC empty: add first.")
|
|||
|
|
(ewoc-enter-first ewoc event)))
|
|||
|
|
(ement-debug "Found event before new event: insert after it.")
|
|||
|
|
(when-let ((next-node (ewoc-next ewoc event-node-before)))
|
|||
|
|
(when (and (ement-user-p (ewoc-data next-node))
|
|||
|
|
(equal (ement-event-sender event)
|
|||
|
|
(ewoc-data next-node)))
|
|||
|
|
(ement-debug "Next node is header for this sender: insert after it, instead.")
|
|||
|
|
(setf event-node-before next-node)))
|
|||
|
|
(ement-debug "Inserting after event"
|
|||
|
|
;; NOTE: `format-event' is only for debugging, and it
|
|||
|
|
;; doesn't handle user headers, so commenting it out or now.
|
|||
|
|
;; (format-event (ewoc-data event-node-before))
|
|||
|
|
|
|||
|
|
;; NOTE: And it's *Very Bad* to pass the raw node data
|
|||
|
|
;; to `ement-debug', because it makes event insertion
|
|||
|
|
;; *Very Slow*. So we just comment that out for now.
|
|||
|
|
;; (ewoc-data event-node-before)
|
|||
|
|
)
|
|||
|
|
(ewoc-enter-after ewoc event-node-before event)))
|
|||
|
|
(when ement-room-coalesce-events
|
|||
|
|
;; Try to coalesce events.
|
|||
|
|
;; TODO: Move this to a separate function and call it from where this function is called.
|
|||
|
|
(setf new-node (or (when event-node-before
|
|||
|
|
(ement-room--coalesce-nodes event-node-before new-node ewoc))
|
|||
|
|
(when (ewoc-next ewoc new-node)
|
|||
|
|
(ement-room--coalesce-nodes new-node (ewoc-next ewoc new-node) ewoc))
|
|||
|
|
new-node)))
|
|||
|
|
(when ement-room-sender-in-headers
|
|||
|
|
(ement-room--insert-sender-headers ewoc new-node new-node))
|
|||
|
|
;; Return new node.
|
|||
|
|
new-node)))
|
|||
|
|
|
|||
|
|
(defun ement-room--replace-event (new-event)
|
|||
|
|
"Replace appropriate event with NEW-EVENT in current buffer.
|
|||
|
|
If replaced event is not found, return nil, otherwise non-nil."
|
|||
|
|
(let* ((ewoc ement-ewoc)
|
|||
|
|
(old-event-node (ement-room--ewoc-last-matching ewoc
|
|||
|
|
(lambda (data)
|
|||
|
|
(cl-typecase data
|
|||
|
|
(ement-event (ement--events-equal-p data new-event)))))))
|
|||
|
|
(when old-event-node
|
|||
|
|
;; TODO: Record old events in new event's local data, and make it accessible when inspecting the new event.
|
|||
|
|
(let ((node-before (ewoc-prev ewoc old-event-node))
|
|||
|
|
(inhibit-read-only t))
|
|||
|
|
(ewoc-delete ewoc old-event-node)
|
|||
|
|
(if node-before
|
|||
|
|
(ewoc-enter-after ewoc node-before new-event)
|
|||
|
|
(ewoc-enter-first ewoc new-event))))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room--ewoc-node-before (ewoc data <-fn
|
|||
|
|
&key (from 'last) (pred #'identity))
|
|||
|
|
"Return node in EWOC that matches PRED and belongs before DATA by <-FN.
|
|||
|
|
Search from FROM (either `first' or `last')."
|
|||
|
|
(cl-assert (member from '(first last)))
|
|||
|
|
(if (null (ewoc-nth ewoc 0))
|
|||
|
|
(ement-debug "EWOC is empty: returning nil.")
|
|||
|
|
(ement-debug "EWOC has data: add at appropriate place.")
|
|||
|
|
(cl-labels ((next-matching (ewoc node next-fn pred)
|
|||
|
|
(cl-loop do (setf node (funcall next-fn ewoc node))
|
|||
|
|
until (or (null node)
|
|||
|
|
(funcall pred (ewoc-data node)))
|
|||
|
|
finally return node)))
|
|||
|
|
(let* ((next-fn (pcase from ('first #'ewoc-next) ('last #'ewoc-prev)))
|
|||
|
|
(start-node (ewoc-nth ewoc (pcase from ('first 0) ('last -1)))))
|
|||
|
|
(unless (funcall pred (ewoc-data start-node))
|
|||
|
|
(setf start-node (next-matching ewoc start-node next-fn pred)))
|
|||
|
|
(if (funcall <-fn (ewoc-data start-node) data)
|
|||
|
|
(progn
|
|||
|
|
(ement-debug "New data goes before start node.")
|
|||
|
|
start-node)
|
|||
|
|
(ement-debug "New data goes after start node: find node before new data.")
|
|||
|
|
(let ((compare-node start-node))
|
|||
|
|
(cl-loop while (setf compare-node (next-matching ewoc compare-node next-fn pred))
|
|||
|
|
until (funcall <-fn (ewoc-data compare-node) data)
|
|||
|
|
finally return (if compare-node
|
|||
|
|
(progn
|
|||
|
|
(ement-debug "Found place: enter there.")
|
|||
|
|
compare-node)
|
|||
|
|
(ement-debug "Reached end of collection: insert there.")
|
|||
|
|
(pcase from
|
|||
|
|
('first (ewoc-nth ewoc -1))
|
|||
|
|
('last nil))))))))))
|
|||
|
|
|
|||
|
|
;;;;; Formatting
|
|||
|
|
|
|||
|
|
(defun ement-room--pp-thing (thing)
|
|||
|
|
"Pretty-print THING.
|
|||
|
|
To be used as the pretty-printer for `ewoc-create'. THING may be
|
|||
|
|
an `ement-event' or `ement-user' struct, or a list like `(ts
|
|||
|
|
TIMESTAMP)', where TIMESTAMP is a Unix timestamp number of
|
|||
|
|
seconds."
|
|||
|
|
;; TODO: Use handlers to insert so e.g. membership events can be inserted silently.
|
|||
|
|
|
|||
|
|
;; TODO: Use `cl-defmethod' and define methods for each of these THING types. (I've
|
|||
|
|
;; benchmarked thoroughly and found no difference in performance between using
|
|||
|
|
;; `cl-defmethod' and using a `defun' with `pcase', so as long as the `cl-defmethod'
|
|||
|
|
;; specializer is sufficient, I see no reason not to use it.)
|
|||
|
|
(pcase-exhaustive thing
|
|||
|
|
((pred ement-event-p)
|
|||
|
|
(insert "" (ement-room--format-event thing ement-room ement-session)))
|
|||
|
|
((pred ement-user-p)
|
|||
|
|
(insert (propertize (ement--format-user thing)
|
|||
|
|
'display ement-room-username-display-property)))
|
|||
|
|
(`(ts ,(and (pred numberp) ts)) ;; Insert a date header.
|
|||
|
|
(let* ((string (format-time-string ement-room-timestamp-header-format ts))
|
|||
|
|
(width (string-width string))
|
|||
|
|
(maybe-newline (if (equal ement-room-timestamp-header-format ement-room-timestamp-header-with-date-format)
|
|||
|
|
;; HACK: Rather than using another variable, compare the format strings to
|
|||
|
|
;; determine whether the date is changing: if so, add a newline before the header.
|
|||
|
|
(progn
|
|||
|
|
(cl-incf width 3)
|
|||
|
|
"\n")
|
|||
|
|
""))
|
|||
|
|
(alignment-space (pcase ement-room-timestamp-header-align
|
|||
|
|
('right (propertize " "
|
|||
|
|
'display `(space :align-to (- text ,(1+ width)))))
|
|||
|
|
('center (propertize " "
|
|||
|
|
'display `(space :align-to (- center ,(/ (1+ width) 2)))))
|
|||
|
|
(_ " "))))
|
|||
|
|
(insert maybe-newline
|
|||
|
|
alignment-space
|
|||
|
|
(propertize string
|
|||
|
|
'face 'ement-room-timestamp-header))))
|
|||
|
|
((or 'ement-room-read-receipt-marker 'ement-room-fully-read-marker)
|
|||
|
|
(insert (propertize " "
|
|||
|
|
'display '(space :width text :height (1))
|
|||
|
|
'face thing)))
|
|||
|
|
((pred ement-room-membership-events-p)
|
|||
|
|
(let ((formatted-events (ement-room--format-membership-events thing ement-room)))
|
|||
|
|
(add-face-text-property 0 (length formatted-events)
|
|||
|
|
'ement-room-membership 'append formatted-events)
|
|||
|
|
(insert (ement-room-wrap-prefix formatted-events))))))
|
|||
|
|
|
|||
|
|
;; (defun ement-room--format-event (event)
|
|||
|
|
;; "Format `ement-event' EVENT."
|
|||
|
|
;; (pcase-let* (((cl-struct ement-event sender type content origin-server-ts) event)
|
|||
|
|
;; ((map body format ('formatted_body formatted-body)) content)
|
|||
|
|
;; (ts (/ origin-server-ts 1000)) ; Matrix timestamps are in milliseconds.
|
|||
|
|
;; (body (if (not formatted-body)
|
|||
|
|
;; body
|
|||
|
|
;; (pcase format
|
|||
|
|
;; ("org.matrix.custom.html"
|
|||
|
|
;; (ement-room--render-html formatted-body))
|
|||
|
|
;; (_ (format "[unknown formatted-body format: %s] %s" format body)))))
|
|||
|
|
;; (timestamp (propertize
|
|||
|
|
;; " " 'display `((margin left-margin)
|
|||
|
|
;; ,(propertize (format-time-string ement-room-timestamp-format ts)
|
|||
|
|
;; 'face 'ement-room-timestamp))))
|
|||
|
|
;; (body-face (pcase type
|
|||
|
|
;; ("m.room.member" 'ement-room-membership)
|
|||
|
|
;; (_ (if (equal (ement-user-id sender)
|
|||
|
|
;; (ement-user-id (ement-session-user ement-session)))
|
|||
|
|
;; 'ement-room-self-message 'default))))
|
|||
|
|
;; (string (pcase type
|
|||
|
|
;; ("m.room.message" body)
|
|||
|
|
;; ("m.room.member" "")
|
|||
|
|
;; (_ (format "[unknown event-type: %s] %s" type body)))))
|
|||
|
|
;; (add-face-text-property 0 (length body) body-face 'append body)
|
|||
|
|
;; (prog1 (concat timestamp string)
|
|||
|
|
;; ;; Hacky or elegant? We return the string, but for certain event
|
|||
|
|
;; ;; types, we also insert a widget (this function is called by
|
|||
|
|
;; ;; EWOC with point at the insertion position). Seems to work...
|
|||
|
|
;; (pcase type
|
|||
|
|
;; ("m.room.member"
|
|||
|
|
;; (widget-create 'ement-room-membership
|
|||
|
|
;; :button-face 'ement-room-membership
|
|||
|
|
;; :value (list (alist-get 'membership content))))))))
|
|||
|
|
|
|||
|
|
(defun ement-room--format-event (event room session)
|
|||
|
|
"Return EVENT in ROOM on SESSION formatted.
|
|||
|
|
Formats according to `ement-room-message-format-spec', which see."
|
|||
|
|
(concat (pcase (ement-event-type event)
|
|||
|
|
;; TODO: Define these with a macro, like the defevent and format-spec ones.
|
|||
|
|
("m.room.message" (ement-room--format-message event room session))
|
|||
|
|
("m.room.member"
|
|||
|
|
(widget-create 'ement-room-membership
|
|||
|
|
:button-face 'ement-room-membership
|
|||
|
|
:value event)
|
|||
|
|
"")
|
|||
|
|
("m.reaction"
|
|||
|
|
;; Handled by defevent-based handler.
|
|||
|
|
"")
|
|||
|
|
("m.room.avatar"
|
|||
|
|
(ement-room-wrap-prefix
|
|||
|
|
(format "%s changed the room's avatar."
|
|||
|
|
(propertize (ement--user-displayname-in room (ement-event-sender event))
|
|||
|
|
'help-echo (ement-user-id (ement-event-sender event))))
|
|||
|
|
'face 'ement-room-membership))
|
|||
|
|
("m.room.power_levels"
|
|||
|
|
(ement-room--format-power-levels-event event room session))
|
|||
|
|
("m.room.canonical_alias"
|
|||
|
|
(ement-room--format-canonical-alias-event event room session))
|
|||
|
|
(_ (ement-room-wrap-prefix
|
|||
|
|
(format "[sender:%s type:%s]"
|
|||
|
|
(ement-user-id (ement-event-sender event))
|
|||
|
|
(ement-event-type event))
|
|||
|
|
'help-echo (format "%S" (ement-event-content event)))))
|
|||
|
|
(propertize " "
|
|||
|
|
'display ement-room-event-separator-display-property)))
|
|||
|
|
|
|||
|
|
(defun ement-room--format-reactions (event room)
|
|||
|
|
"Return formatted reactions to EVENT in ROOM."
|
|||
|
|
;; TODO: Like other events, pop to a buffer showing the raw reaction events when a key is pressed.
|
|||
|
|
(cl-labels
|
|||
|
|
((format-reaction (ks)
|
|||
|
|
(pcase-let* ((`(,key . ,senders) ks)
|
|||
|
|
(key (propertize key 'face 'ement-room-reactions-key))
|
|||
|
|
(count (propertize (format " (%s)"
|
|||
|
|
(if (length> senders ement-room-reaction-names-limit)
|
|||
|
|
(length senders)
|
|||
|
|
(senders-names senders room)))
|
|||
|
|
'face 'ement-room-reactions))
|
|||
|
|
(string
|
|||
|
|
(propertize (concat key count)
|
|||
|
|
'button '(t)
|
|||
|
|
'category 'default-button
|
|||
|
|
'action #'ement-room-reaction-button-action
|
|||
|
|
'follow-link t
|
|||
|
|
'help-echo (lambda (_window buffer _pos)
|
|||
|
|
;; NOTE: If the reaction key string is a Unicode character composed
|
|||
|
|
;; with, e.g. "VARIATION SELECTOR-16", `string-to-char' ignores the
|
|||
|
|
;; composed modifier/variation-selector and just returns the first
|
|||
|
|
;; character of the string. This should be fine, since it's just
|
|||
|
|
;; for the tooltip.
|
|||
|
|
(concat
|
|||
|
|
(get-char-code-property (string-to-char key) 'name) ": "
|
|||
|
|
(senders-names senders (buffer-local-value 'ement-room buffer))))))
|
|||
|
|
(local-user-p (cl-member (ement-user-id (ement-session-user ement-session)) senders
|
|||
|
|
:key #'ement-user-id :test #'equal)))
|
|||
|
|
(when local-user-p
|
|||
|
|
(add-face-text-property 0 (length string) '(:box (:style pressed-button) :inverse-video t)
|
|||
|
|
nil string))
|
|||
|
|
(ement--remove-face-property string 'button)
|
|||
|
|
string))
|
|||
|
|
(senders-names (senders room)
|
|||
|
|
(cl-loop for sender in senders
|
|||
|
|
collect (ement--user-displayname-in room sender)
|
|||
|
|
into names
|
|||
|
|
finally return (string-join names ", "))))
|
|||
|
|
(if-let ((reactions (map-elt (ement-event-local event) 'reactions)))
|
|||
|
|
(cl-loop with keys-senders
|
|||
|
|
for reaction in reactions
|
|||
|
|
for key = (map-nested-elt (ement-event-content reaction) '(m.relates_to key))
|
|||
|
|
for sender = (ement-event-sender reaction)
|
|||
|
|
do (push sender (alist-get key keys-senders nil nil #'string=))
|
|||
|
|
finally do (setf keys-senders (cl-sort keys-senders #'> :key (lambda (pair) (length (cdr pair)))))
|
|||
|
|
finally return (concat "\n " (mapconcat #'format-reaction keys-senders " ")))
|
|||
|
|
"")))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room--format-message (event room session &optional (format ement-room-message-format-spec))
|
|||
|
|
"Return EVENT in ROOM on SESSION formatted according to FORMAT.
|
|||
|
|
Format defaults to `ement-room-message-format-spec', which see."
|
|||
|
|
;; Bind this locally so formatters can modify it for this call.
|
|||
|
|
(let ((ement-room--format-message-margin-p)
|
|||
|
|
(left-margin-width ement-room-left-margin-width)
|
|||
|
|
(right-margin-width ement-room-right-margin-width))
|
|||
|
|
;; Copied from `format-spec'.
|
|||
|
|
(with-current-buffer
|
|||
|
|
(or (get-buffer " *ement-room--format-message*")
|
|||
|
|
;; TODO: Kill this buffer when disconnecting from all sessions.
|
|||
|
|
(with-current-buffer (get-buffer-create " *ement-room--format-message*")
|
|||
|
|
(setq buffer-undo-list t)
|
|||
|
|
(current-buffer)))
|
|||
|
|
(erase-buffer)
|
|||
|
|
;; Pretend this is a room buffer.
|
|||
|
|
(setf ement-session session
|
|||
|
|
ement-room room)
|
|||
|
|
;; HACK: Setting these buffer-locally in a temp buffer is ugly.
|
|||
|
|
(setq-local ement-room-left-margin-width left-margin-width)
|
|||
|
|
(setq-local ement-room-right-margin-width right-margin-width)
|
|||
|
|
(insert format)
|
|||
|
|
(goto-char (point-min))
|
|||
|
|
(while (search-forward "%" nil t)
|
|||
|
|
(cond
|
|||
|
|
((eq (char-after) ?%)
|
|||
|
|
;; Quoted percent sign.
|
|||
|
|
(delete-char 1))
|
|||
|
|
((looking-at "\\([-0-9.]*\\)\\([a-zA-Z]\\)")
|
|||
|
|
;; Valid format spec.
|
|||
|
|
(let* ((num (match-string 1))
|
|||
|
|
(spec (string-to-char (match-string 2)))
|
|||
|
|
(_
|
|||
|
|
;; We delete the specifier now, because the formatter may change the
|
|||
|
|
;; match data, and we already have what we need.
|
|||
|
|
(delete-region (1- (match-beginning 0)) (match-end 0)))
|
|||
|
|
(formatter (or (alist-get spec ement-room-event-formatters)
|
|||
|
|
(error "Invalid format character: `%%%c'" spec)))
|
|||
|
|
(val (or (funcall formatter event room session)
|
|||
|
|
(let ((print-level 1))
|
|||
|
|
(propertize (format "[Event has no value for spec \"?%s\"]" (char-to-string spec))
|
|||
|
|
'face 'font-lock-comment-face
|
|||
|
|
'help-echo (format "%S" event)))))
|
|||
|
|
;; Pad result to desired length.
|
|||
|
|
(text (format (concat "%" num "s") val)))
|
|||
|
|
(insert text)))
|
|||
|
|
(t
|
|||
|
|
;; Signal an error on bogus format strings.
|
|||
|
|
(error "ement-room--format-message: Invalid format string: %S" format))))
|
|||
|
|
;; Propertize margin text.
|
|||
|
|
(when ement-room--format-message-wrap-prefix
|
|||
|
|
(when-let ((wrap-prefix-end (next-single-property-change (point-min) 'wrap-prefix-end)))
|
|||
|
|
(goto-char wrap-prefix-end)
|
|||
|
|
(delete-char 1)
|
|||
|
|
(let* ((prefix-width (string-width (buffer-substring-no-properties
|
|||
|
|
(line-beginning-position) (point))))
|
|||
|
|
(prefix (propertize " " 'display `((space :width ,prefix-width)))))
|
|||
|
|
;; We apply the prefix to the entire event as `wrap-prefix', and to just the
|
|||
|
|
;; body as `line-prefix'.
|
|||
|
|
(put-text-property (point-min) (point-max) 'wrap-prefix prefix)
|
|||
|
|
(put-text-property (point) (point-max) 'line-prefix prefix))))
|
|||
|
|
(when ement-room--format-message-margin-p
|
|||
|
|
(when-let ((left-margin-end (next-single-property-change (point-min) 'left-margin-end)))
|
|||
|
|
(goto-char left-margin-end)
|
|||
|
|
(delete-char 1)
|
|||
|
|
(let ((left-margin-text-width (string-width (buffer-substring-no-properties (point-min) (point)))))
|
|||
|
|
;; It would be preferable to not have to allocate a string to
|
|||
|
|
;; calculate the display width, but I don't know of another way.
|
|||
|
|
(put-text-property (point-min) (point)
|
|||
|
|
'display `((margin left-margin)
|
|||
|
|
,(buffer-substring (point-min) (point))))
|
|||
|
|
(save-excursion
|
|||
|
|
(goto-char (point-min))
|
|||
|
|
;; Insert a string with a display specification that causes it to be displayed in the
|
|||
|
|
;; left margin as a space that displays with the width of the difference between the
|
|||
|
|
;; left margin's width and the display width of the text in the left margin (whew).
|
|||
|
|
;; This is complicated, but it seems to work (minus a possible Emacs/Gtk bug that
|
|||
|
|
;; sometimes causes the space to have a little "junk" displayed in it at times, but
|
|||
|
|
;; that's not our fault). (And this is another example of how well-documented Emacs
|
|||
|
|
;; is: this was only possible by carefully reading the Elisp manual.)
|
|||
|
|
(insert (propertize " " 'display `((margin left-margin)
|
|||
|
|
(space :width (- left-margin ,left-margin-text-width))))))))
|
|||
|
|
(when-let ((right-margin-start (next-single-property-change (point-min) 'right-margin-start)))
|
|||
|
|
(goto-char right-margin-start)
|
|||
|
|
(delete-char 1)
|
|||
|
|
(let ((string (buffer-substring (point) (point-max))))
|
|||
|
|
;; Relocate its text to the beginning so it won't be
|
|||
|
|
;; displayed at the last line of wrapped messages.
|
|||
|
|
(delete-region (point) (point-max))
|
|||
|
|
(goto-char (point-min))
|
|||
|
|
(insert-and-inherit
|
|||
|
|
(propertize " "
|
|||
|
|
'display `((margin right-margin) ,string))))))
|
|||
|
|
(buffer-string))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room--format-message-body (event session &key (formatted-p t))
|
|||
|
|
"Return formatted body of \"m.room.message\" EVENT on SESSION.
|
|||
|
|
If FORMATTED-P, return the formatted body content, when available."
|
|||
|
|
(pcase-let* (((cl-struct ement-event content
|
|||
|
|
(unsigned (map ('redacted_by unsigned-redacted-by)))
|
|||
|
|
(local (map ('redacted-by local-redacted-by))))
|
|||
|
|
event)
|
|||
|
|
((map ('body main-body) msgtype ('format content-format) ('formatted_body formatted-body)
|
|||
|
|
('m.relates_to (map ('rel_type rel-type)))
|
|||
|
|
('m.new_content (map ('body new-body) ('formatted_body new-formatted-body)
|
|||
|
|
('format new-content-format))))
|
|||
|
|
content)
|
|||
|
|
(body (or new-body main-body))
|
|||
|
|
(formatted-body (or new-formatted-body formatted-body))
|
|||
|
|
(body (if (or (not formatted-p) (not formatted-body))
|
|||
|
|
;; Copy the string so as not to add face properties to the one in the struct.
|
|||
|
|
(copy-sequence body)
|
|||
|
|
(pcase (or new-content-format content-format)
|
|||
|
|
("org.matrix.custom.html"
|
|||
|
|
(save-match-data
|
|||
|
|
(ement-room--render-html formatted-body)))
|
|||
|
|
(_ (format "[unknown body format: %s] %s"
|
|||
|
|
(or new-content-format content-format) body)))))
|
|||
|
|
(appendix (pcase msgtype
|
|||
|
|
;; TODO: Face for m.notices.
|
|||
|
|
((or "m.text" "m.emote" "m.notice") nil)
|
|||
|
|
("m.image" (ement-room--format-m.image event session))
|
|||
|
|
("m.file" (ement-room--format-m.file event))
|
|||
|
|
("m.video" (ement-room--format-m.video event))
|
|||
|
|
("m.audio" (ement-room--format-m.audio event))
|
|||
|
|
(_ (if (or local-redacted-by unsigned-redacted-by)
|
|||
|
|
nil
|
|||
|
|
(format "[unsupported msgtype: %s]" msgtype ))))))
|
|||
|
|
(when body
|
|||
|
|
;; HACK: Once I got an error when body was nil, so let's avoid that.
|
|||
|
|
(setf body (ement-room--linkify-urls body)))
|
|||
|
|
;; HACK: Ensure body isn't nil (e.g. redacted messages can have empty bodies).
|
|||
|
|
(unless body
|
|||
|
|
(setf body (copy-sequence
|
|||
|
|
;; Yes, copying this string is necessary here too, otherwise a single
|
|||
|
|
;; string will be used across every call to this function, whose face
|
|||
|
|
;; properties will be added to every time in other functions, which will
|
|||
|
|
;; make a very big mess of face properties if a room's buffer is opened
|
|||
|
|
;; and closed a few times.
|
|||
|
|
(if (or local-redacted-by unsigned-redacted-by)
|
|||
|
|
"[redacted]"
|
|||
|
|
"[message has no body content]"))))
|
|||
|
|
(when appendix
|
|||
|
|
(setf body (concat body " " appendix)))
|
|||
|
|
(when (equal "m.replace" rel-type)
|
|||
|
|
;; Message is an edit.
|
|||
|
|
(setf body (concat body " " (propertize "[edited]" 'face 'font-lock-comment-face))))
|
|||
|
|
(when (and (or local-redacted-by unsigned-redacted-by)
|
|||
|
|
ement-room-hide-redacted-message-content)
|
|||
|
|
;; Message is redacted and hiding is enabled: override the body to hide the content.
|
|||
|
|
;; (This is a bit of a hack, since we've already prepared the body at this point,
|
|||
|
|
;; but retrofitting this into the existing logic is more than I want to do right
|
|||
|
|
;; now. There are probably 3 or 4 different ways and places we could handle
|
|||
|
|
;; redaction of content, and this seems like the simplest.)
|
|||
|
|
(setf body "[redacted]"))
|
|||
|
|
body))
|
|||
|
|
|
|||
|
|
(defun ement-room--render-html (string)
|
|||
|
|
"Return rendered version of HTML STRING.
|
|||
|
|
HTML is rendered to Emacs text using `shr-insert-document'."
|
|||
|
|
(with-current-buffer
|
|||
|
|
(or (get-buffer " *ement-room--render-html*")
|
|||
|
|
;; TODO: Kill this buffer when disconnecting from all sessions.
|
|||
|
|
(with-current-buffer (get-buffer-create " *ement-room--render-html*")
|
|||
|
|
(setq buffer-undo-list t)
|
|||
|
|
(current-buffer)))
|
|||
|
|
(erase-buffer)
|
|||
|
|
(insert string)
|
|||
|
|
(save-excursion
|
|||
|
|
;; NOTE: We workaround `shr`'s not indenting the blockquote properly (it
|
|||
|
|
;; doesn't seem to compensate for the margin). I don't know exactly how
|
|||
|
|
;; `shr-tag-blockquote' and `shr-mark-fill' and `shr-fill-line' and
|
|||
|
|
;; `shr-indentation' work together, but through trial-and-error, this
|
|||
|
|
;; seems to work. It even seems to work properly when a window is
|
|||
|
|
;; resized (i.e. the wrapping is adjusted automatically by redisplay
|
|||
|
|
;; rather than requiring the message to be re-rendered to HTML).
|
|||
|
|
(let ((shr-use-fonts ement-room-use-variable-pitch)
|
|||
|
|
(old-fn (symbol-function 'shr-tag-blockquote))) ;; Bind to a var to avoid unknown-function linting errors.
|
|||
|
|
(cl-letf (((symbol-function 'shr-fill-line) #'ignore)
|
|||
|
|
((symbol-function 'shr-tag-blockquote)
|
|||
|
|
(lambda (dom)
|
|||
|
|
(let ((beg (point-marker)))
|
|||
|
|
(funcall old-fn dom)
|
|||
|
|
(add-text-properties beg (point-max)
|
|||
|
|
'( wrap-prefix " "
|
|||
|
|
line-prefix " "))
|
|||
|
|
;; NOTE: We use our own gv, `ement-text-property'; very convenient.
|
|||
|
|
(add-face-text-property beg (point-max) 'ement-room-quote 'append)))))
|
|||
|
|
(shr-insert-document
|
|||
|
|
(libxml-parse-html-region (point-min) (point-max))))))
|
|||
|
|
(string-trim (buffer-substring (point) (point-max)))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room--event-mentions-user-p (event user &optional (room ement-room))
|
|||
|
|
"Return non-nil if EVENT in ROOM mentions USER."
|
|||
|
|
(pcase-let* (((cl-struct ement-event content) event)
|
|||
|
|
((map body formatted_body) content)
|
|||
|
|
(body (or formatted_body body)))
|
|||
|
|
;; FIXME: `ement--user-displayname-in' may not be returning the right result for the
|
|||
|
|
;; local user, so test the displayname slot too. (But even that may be nil sometimes?
|
|||
|
|
;; Something needs to be fixed...)
|
|||
|
|
;; HACK: So we use the username slot, which was created just for this, for now.
|
|||
|
|
(when body
|
|||
|
|
(cl-macrolet ((matches-body-p
|
|||
|
|
(form) `(when-let ((string ,form))
|
|||
|
|
(string-match-p (regexp-quote string) body))))
|
|||
|
|
(or (matches-body-p (ement-user-username user))
|
|||
|
|
(matches-body-p (ement--user-displayname-in room user))
|
|||
|
|
(matches-body-p (ement-user-id user)))))))
|
|||
|
|
|
|||
|
|
(defun ement-room--linkify-urls (string)
|
|||
|
|
"Return STRING with URLs in it made clickable."
|
|||
|
|
;; Is there an existing Emacs function to do this? I couldn't find one.
|
|||
|
|
;; Yes, maybe: `goto-address-mode'. TODO: Try goto-address-mode.
|
|||
|
|
(with-temp-buffer
|
|||
|
|
(insert string)
|
|||
|
|
(goto-char (point-min))
|
|||
|
|
(cl-loop while (re-search-forward (rx bow "http" (optional "s") "://" (1+ (not space)))
|
|||
|
|
nil 'noerror)
|
|||
|
|
do (make-text-button (match-beginning 0) (match-end 0)
|
|||
|
|
'mouse-face 'highlight
|
|||
|
|
'face 'link
|
|||
|
|
'help-echo (match-string 0)
|
|||
|
|
'action #'browse-url-at-mouse
|
|||
|
|
'follow-link t))
|
|||
|
|
(buffer-string)))
|
|||
|
|
|
|||
|
|
;; NOTE: This function is not useful when displaynames are shown in the margin, because
|
|||
|
|
;; margins are not mouse-interactive in Emacs, therefore the help-echo function is called
|
|||
|
|
;; with the string and the position in the string, which leaves the buffer position
|
|||
|
|
;; unknown. So we have to set the help-echo to a string rather than a function. But the
|
|||
|
|
;; function may be useful in the future, so leaving it commented for now.
|
|||
|
|
|
|||
|
|
;; (defun ement-room--user-help-echo (window _object pos)
|
|||
|
|
;; "Return user ID string for POS in WINDOW.
|
|||
|
|
;; For use as a `help-echo' function on `ement-user' headings."
|
|||
|
|
;; (let ((data (with-selected-window window
|
|||
|
|
;; (ewoc-data (ewoc-locate ement-ewoc pos)))))
|
|||
|
|
;; (cl-typecase data
|
|||
|
|
;; (ement-event (ement-user-id (ement-event-sender data)))
|
|||
|
|
;; (ement-user (ement-user-id data)))))
|
|||
|
|
|
|||
|
|
(defun ement-room--user-color (user)
|
|||
|
|
"Return a color in which to display USER's messages."
|
|||
|
|
(cl-labels ((relative-luminance (rgb)
|
|||
|
|
;; Copy of `modus-themes-wcag-formula', an elegant
|
|||
|
|
;; implementation by Protesilaos Stavrou. Also see
|
|||
|
|
;; <https://en.wikipedia.org/wiki/Relative_luminance> and
|
|||
|
|
;; <https://www.w3.org/TR/WCAG20/#relativeluminancedef>.
|
|||
|
|
(cl-loop for k in '(0.2126 0.7152 0.0722)
|
|||
|
|
for x in rgb
|
|||
|
|
sum (* k (if (<= x 0.03928)
|
|||
|
|
(/ x 12.92)
|
|||
|
|
(expt (/ (+ x 0.055) 1.055) 2.4)))))
|
|||
|
|
(contrast-ratio (a b)
|
|||
|
|
;; Copy of `modus-themes-contrast'; see above.
|
|||
|
|
(let ((ct (/ (+ (relative-luminance a) 0.05)
|
|||
|
|
(+ (relative-luminance b) 0.05))))
|
|||
|
|
(max ct (/ ct))))
|
|||
|
|
(increase-contrast (color against target toward)
|
|||
|
|
(let ((gradient (cdr (color-gradient color toward 20)))
|
|||
|
|
new-color)
|
|||
|
|
(cl-loop do (setf new-color (pop gradient))
|
|||
|
|
while new-color
|
|||
|
|
until (>= (contrast-ratio new-color against) target)
|
|||
|
|
;; Avoid infinite loop in case of weirdness
|
|||
|
|
;; by returning color as a fallback.
|
|||
|
|
finally return (or new-color color)))))
|
|||
|
|
(let* ((id (ement-user-id user))
|
|||
|
|
(id-hash (float (+ (abs (sxhash id)) ement-room-prism-color-adjustment)))
|
|||
|
|
;; TODO: Wrap-around the value to get the color I want.
|
|||
|
|
(ratio (/ id-hash (float most-positive-fixnum)))
|
|||
|
|
(color-num (round (* (* 255 255 255) ratio)))
|
|||
|
|
(color-rgb (list (/ (float (logand color-num 255)) 255)
|
|||
|
|
(/ (float (ash (logand color-num 65280) -8)) 255)
|
|||
|
|
(/ (float (ash (logand color-num 16711680) -16)) 255)))
|
|||
|
|
(background-rgb (color-name-to-rgb (face-background 'default))))
|
|||
|
|
(when (< (contrast-ratio color-rgb background-rgb) ement-room-prism-minimum-contrast)
|
|||
|
|
(setf color-rgb (increase-contrast color-rgb background-rgb ement-room-prism-minimum-contrast
|
|||
|
|
(color-name-to-rgb (face-foreground 'default)))))
|
|||
|
|
(apply #'color-rgb-to-hex (append color-rgb (list 2))))))
|
|||
|
|
|
|||
|
|
;;;;; Compose buffer
|
|||
|
|
|
|||
|
|
;; Compose messages in a separate buffer, like `org-edit-special'.
|
|||
|
|
|
|||
|
|
(defvar-local ement-room-compose-buffer nil
|
|||
|
|
"Non-nil in buffers that are composing a message to a room.")
|
|||
|
|
|
|||
|
|
(cl-defun ement-room-compose-message (room session &key body)
|
|||
|
|
"Compose a message to ROOM on SESSION.
|
|||
|
|
Interactively, with prefix, prompt for room and session,
|
|||
|
|
otherwise use current room. With BODY, use it as the initial
|
|||
|
|
message contents."
|
|||
|
|
(interactive
|
|||
|
|
(ement-with-room-and-session
|
|||
|
|
(list ement-room ement-session)))
|
|||
|
|
(let* ((compose-buffer (generate-new-buffer (format "*Ement compose: %s*" (ement--room-display-name ement-room))))
|
|||
|
|
(send-message-filter ement-room-send-message-filter))
|
|||
|
|
(ement-room-compose-highlight compose-buffer)
|
|||
|
|
(with-current-buffer compose-buffer
|
|||
|
|
(ement-room-init-compose-buffer room session)
|
|||
|
|
(setf ement-room-send-message-filter send-message-filter)
|
|||
|
|
;; TODO: Make mode configurable.
|
|||
|
|
(when body
|
|||
|
|
(insert body))
|
|||
|
|
|
|||
|
|
;; FIXME: Inexplicably, this doesn't do anything, so we comment it out for now.
|
|||
|
|
;; (add-function :override (local 'org-mode)
|
|||
|
|
;; ;; HACK: Since `org-mode' kills buffer-local variables we need, we add
|
|||
|
|
;; ;; buffer-local advice to prevent that from happening in case a user enables it.
|
|||
|
|
;; (lambda (&rest _ignore)
|
|||
|
|
;; (message "Use `ement-room-compose-org' to activate Org in this buffer")))
|
|||
|
|
|
|||
|
|
;; NOTE: Surprisingly, we don't run this hook in `ement-room-init-compose-buffer',
|
|||
|
|
;; because if a function in that hook calls the init function (like
|
|||
|
|
;; `ement-room-compose-org' does), it makes `run-hooks' recursive. As long as this
|
|||
|
|
;; is the only function that makes the compose buffer, and as long as none of the
|
|||
|
|
;; hooks do anything that activating `org-mode' nullifies, this should be okay...
|
|||
|
|
(run-hooks 'ement-room-compose-hook))
|
|||
|
|
;; Display the compose buffer. This might obscure the room buffer's window
|
|||
|
|
;; point, so minimise the amount of scrolling which occurs to restore that
|
|||
|
|
;; to a visible position.
|
|||
|
|
(pop-to-buffer compose-buffer ement-room-compose-buffer-display-action)
|
|||
|
|
(unless ement-room-compose-buffer-window-auto-height
|
|||
|
|
(let ((scroll-conservatively 101))
|
|||
|
|
(redisplay)))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-edit (event room session body)
|
|||
|
|
"Edit EVENT in ROOM on SESSION to have new BODY, using a compose buffer.
|
|||
|
|
The message must be one sent by the local user."
|
|||
|
|
;; See also `ement-room-edit-message'.
|
|||
|
|
(interactive (cl-destructuring-bind (event body)
|
|||
|
|
(ement-room-edit-message-prepare)
|
|||
|
|
(list event ement-room ement-session body)))
|
|||
|
|
(cl-assert (ement-event-p event)) (cl-assert room) (cl-assert session)
|
|||
|
|
(let ((ement-room-editing-event event))
|
|||
|
|
(ement-room-with-highlighted-event-at (point)
|
|||
|
|
(ement-room-compose-message room session :body body))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-reply (event)
|
|||
|
|
"Write and send a reply to EVENT, using a compose buffer.
|
|||
|
|
Interactively, to event at point."
|
|||
|
|
;; See also `ement-room-write-reply'.
|
|||
|
|
(interactive (progn (cl-assert ement-ewoc)
|
|||
|
|
(list (ewoc-data (ewoc-locate ement-ewoc)))))
|
|||
|
|
(cl-assert ement-room) (cl-assert ement-session) (cl-assert (ement-event-p event))
|
|||
|
|
(let ((ement-room-replying-to-event event))
|
|||
|
|
(ement-room-with-highlighted-event-at (point)
|
|||
|
|
(ement-room-compose-message ement-room ement-session))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-from-minibuffer ()
|
|||
|
|
"Edit the current message in a compose buffer.
|
|||
|
|
To be called from a minibuffer opened from
|
|||
|
|
`ement-room-read-string'."
|
|||
|
|
(interactive)
|
|||
|
|
(cl-assert (minibufferp)) (cl-assert ement-room) (cl-assert ement-session)
|
|||
|
|
;; TODO: When requiring Emacs 27, use `letrec'.
|
|||
|
|
;; HACK: I can't seem to find a better way to do this, to exit the minibuffer without exiting this command too.
|
|||
|
|
(let* ((body (minibuffer-contents))
|
|||
|
|
(compose-fn-symbol (gensym (format "ement-compose-%s" (or (ement-room-canonical-alias ement-room)
|
|||
|
|
(ement-room-id ement-room)))))
|
|||
|
|
(input-method current-input-method) ; Capture this value from the minibuffer.
|
|||
|
|
(send-message-filter ement-room-send-message-filter)
|
|||
|
|
(replying-to-event ement-room-replying-to-event)
|
|||
|
|
(editing-event ement-room-editing-event)
|
|||
|
|
(compose-fn (lambda ()
|
|||
|
|
;; HACK: Since exiting the minibuffer restores the previous window configuration,
|
|||
|
|
;; we have to do some magic to get the new compose buffer to appear.
|
|||
|
|
;; TODO: Use letrec with Emacs 27.
|
|||
|
|
(remove-hook 'minibuffer-exit-hook compose-fn-symbol)
|
|||
|
|
;; FIXME: Probably need to unintern the symbol.
|
|||
|
|
(ement-room-compose-message ement-room ement-session :body body)
|
|||
|
|
;; FIXME: This doesn't propagate the send-message-filter to the minibuffer.
|
|||
|
|
(setf ement-room-send-message-filter send-message-filter)
|
|||
|
|
(setq-local ement-room-replying-to-event replying-to-event
|
|||
|
|
ement-room-editing-event editing-event)
|
|||
|
|
(cond (replying-to-event
|
|||
|
|
(setq-local header-line-format
|
|||
|
|
(concat header-line-format
|
|||
|
|
(format " (Replying to message from %s)"
|
|||
|
|
(ement--user-displayname-in
|
|||
|
|
ement-room (ement-event-sender replying-to-event))))))
|
|||
|
|
(editing-event
|
|||
|
|
(setq-local header-line-format (concat header-line-format " (Editing message)"))))
|
|||
|
|
(let* ((compose-buffer (current-buffer))
|
|||
|
|
(show-buffer-fn-symbol (gensym "ement-show-compose-buffer"))
|
|||
|
|
(show-buffer-fn (lambda ()
|
|||
|
|
(remove-hook 'window-configuration-change-hook show-buffer-fn-symbol)
|
|||
|
|
;; FIXME: Probably need to unintern the symbol.
|
|||
|
|
(pop-to-buffer compose-buffer ement-room-compose-buffer-display-action)
|
|||
|
|
(set-input-method input-method))))
|
|||
|
|
(fset show-buffer-fn-symbol show-buffer-fn)
|
|||
|
|
(add-hook 'window-configuration-change-hook show-buffer-fn-symbol)))))
|
|||
|
|
(fset compose-fn-symbol compose-fn)
|
|||
|
|
(add-hook 'minibuffer-exit-hook compose-fn-symbol)
|
|||
|
|
;; Deactivate minibuffer's input method, otherwise subsequent
|
|||
|
|
;; minibuffers will have it, too.
|
|||
|
|
(deactivate-input-method)
|
|||
|
|
(abort-recursive-edit)))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-buffer-string-trimmed ()
|
|||
|
|
"Like `buffer-string' trimmed with `string-trim'."
|
|||
|
|
(buffer-substring-no-properties (progn (goto-char (point-min))
|
|||
|
|
(skip-chars-forward " \t\r\n")
|
|||
|
|
(point))
|
|||
|
|
(progn (goto-char (point-max))
|
|||
|
|
(skip-chars-backward " \t\r\n")
|
|||
|
|
(point))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-send-prepare ()
|
|||
|
|
"Bindings for `ement-room-compose-send' and `ement-room-compose-send-direct'."
|
|||
|
|
(cl-assert ement-room-compose-buffer)
|
|||
|
|
(cl-assert ement-room) (cl-assert ement-session)
|
|||
|
|
;; Capture the necessary values from the compose buffer before killing it and
|
|||
|
|
;; switching back to the room buffer. Return the values as a list.
|
|||
|
|
(let ((body (ement-room-compose-buffer-string-trimmed))
|
|||
|
|
(input-method current-input-method)
|
|||
|
|
(send-message-filter ement-room-send-message-filter)
|
|||
|
|
(replying-to-event ement-room-replying-to-event)
|
|||
|
|
(editing-event ement-room-editing-event)
|
|||
|
|
(room ement-room)
|
|||
|
|
(session ement-session))
|
|||
|
|
(ement-room-compose-buffer-quit-restore-window)
|
|||
|
|
(ement-view-room room session)
|
|||
|
|
(add-to-history 'ement-room-message-history body)
|
|||
|
|
(list body input-method send-message-filter replying-to-event editing-event room session)))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-send ()
|
|||
|
|
"Prompt to send the current compose buffer's contents.
|
|||
|
|
To be called from an `ement-room-compose' buffer.
|
|||
|
|
See also `ement-room-compose-send-direct'."
|
|||
|
|
(interactive)
|
|||
|
|
(cl-destructuring-bind (body input-method send-message-filter
|
|||
|
|
replying-to-event editing-event room session)
|
|||
|
|
(ement-room-compose-send-prepare)
|
|||
|
|
(let* ((prompt (format "Send message (%s): " (ement-room-display-name room)))
|
|||
|
|
(current-input-method input-method) ; Bind around read-string call.
|
|||
|
|
(ement-room-send-message-filter send-message-filter)
|
|||
|
|
(body (if (or editing-event replying-to-event)
|
|||
|
|
(let ((pos (ewoc-location (ement-room--ewoc-last-matching ement-ewoc
|
|||
|
|
(lambda (data)
|
|||
|
|
(eq data (or editing-event
|
|||
|
|
replying-to-event)))))))
|
|||
|
|
(ement-room-with-highlighted-event-at pos
|
|||
|
|
(ement-room-read-string prompt body 'ement-room-message-history
|
|||
|
|
nil 'inherit-input-method)))
|
|||
|
|
(ement-room-read-string prompt body 'ement-room-message-history
|
|||
|
|
nil 'inherit-input-method))))
|
|||
|
|
(if editing-event
|
|||
|
|
(ement-room-edit-message (ement--original-event-for editing-event session)
|
|||
|
|
room session body)
|
|||
|
|
(ement-room-send-message room session
|
|||
|
|
:body body
|
|||
|
|
:replying-to-event (and replying-to-event
|
|||
|
|
(ement--original-event-for
|
|||
|
|
replying-to-event session)))))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-send-direct ()
|
|||
|
|
"Directly send the current compose buffer's contents.
|
|||
|
|
To be called from an `ement-room-compose' buffer.
|
|||
|
|
See also `ement-room-compose-send'."
|
|||
|
|
(interactive)
|
|||
|
|
(cl-destructuring-bind (body _input-method send-message-filter
|
|||
|
|
replying-to-event editing-event room session)
|
|||
|
|
(ement-room-compose-send-prepare)
|
|||
|
|
(let ((ement-room-send-message-filter send-message-filter))
|
|||
|
|
(if editing-event
|
|||
|
|
(ement-room-edit-message (ement--original-event-for editing-event session)
|
|||
|
|
room session body)
|
|||
|
|
(ement-room-send-message room session
|
|||
|
|
:body body
|
|||
|
|
:replying-to-event (and replying-to-event
|
|||
|
|
(ement--original-event-for
|
|||
|
|
replying-to-event session)))))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-abort (&optional no-history)
|
|||
|
|
"Kill the compose buffer and window.
|
|||
|
|
With prefix arg NO-HISTORY, do not add to `ement-room-message-history'."
|
|||
|
|
(interactive "P")
|
|||
|
|
(let ((body (ement-room-compose-buffer-string-trimmed))
|
|||
|
|
(room ement-room))
|
|||
|
|
(unless no-history
|
|||
|
|
(add-to-history 'ement-room-message-history body))
|
|||
|
|
(ement-room-compose-buffer-quit-restore-window)
|
|||
|
|
;; Make sure we end up with the associated room buffer selected.
|
|||
|
|
(when-let ((win (catch 'room-win
|
|||
|
|
(walk-windows
|
|||
|
|
(lambda (win)
|
|||
|
|
(with-selected-window win
|
|||
|
|
(and (derived-mode-p 'ement-room-mode)
|
|||
|
|
(bound-and-true-p ement-room)
|
|||
|
|
(eq ement-room room)
|
|||
|
|
(throw 'room-win win))))))))
|
|||
|
|
(select-window win))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-abort-no-history ()
|
|||
|
|
"Kill the compose buffer and window without adding to the history."
|
|||
|
|
(interactive)
|
|||
|
|
(ement-room-compose-abort t))
|
|||
|
|
|
|||
|
|
(defun ement-room-init-compose-buffer (room session)
|
|||
|
|
"Set up the current buffer as a compose buffer.
|
|||
|
|
Sets ROOM and SESSION buffer-locally, binds `save-buffer' in
|
|||
|
|
a copy of the local keymap, and sets `header-line-format'."
|
|||
|
|
;; Using a macro for this seems awkward but necessary.
|
|||
|
|
(setq-local ement-room room)
|
|||
|
|
(setq-local ement-session session)
|
|||
|
|
(setq-local ement-room-replying-to-event ement-room-replying-to-event)
|
|||
|
|
(setq-local ement-room-editing-event ement-room-editing-event)
|
|||
|
|
(setf ement-room-compose-buffer t)
|
|||
|
|
(setq-local completion-at-point-functions
|
|||
|
|
(append '(ement-room--complete-members-at-point ement-room--complete-rooms-at-point)
|
|||
|
|
completion-at-point-functions))
|
|||
|
|
(setq-local dabbrev-select-buffers-function #'ement-compose-dabbrev-select-buffers
|
|||
|
|
dabbrev-friend-buffer-function #'ement-room-mode-p)
|
|||
|
|
(setq-local yank-excluded-properties
|
|||
|
|
(append '(line-prefix wrap-prefix)
|
|||
|
|
(default-value 'yank-excluded-properties)))
|
|||
|
|
(add-hook 'isearch-mode-hook 'ement-room-compose-history-isearch-setup nil t)
|
|||
|
|
;; FIXME: Compose with local map?
|
|||
|
|
(use-local-map (if (current-local-map)
|
|||
|
|
(copy-keymap (current-local-map))
|
|||
|
|
(make-sparse-keymap)))
|
|||
|
|
;; When `ement-room-self-insert-mode' is enabled, deleting the final character of the
|
|||
|
|
;; message aborts and kills the compose buffer.
|
|||
|
|
(local-set-key [remap delete-backward-char]
|
|||
|
|
`(menu-item "" ement-room-compose-abort-no-history
|
|||
|
|
:filter ,(lambda (cmd)
|
|||
|
|
(and ement-room-self-insert-mode
|
|||
|
|
(<= (buffer-size) 1)
|
|||
|
|
(save-restriction (widen) (eobp))
|
|||
|
|
cmd))))
|
|||
|
|
(local-set-key [remap save-buffer] #'ement-room-dispatch-send-message)
|
|||
|
|
(local-set-key (kbd "C-c C-k") #'ement-room-compose-abort)
|
|||
|
|
(local-set-key (kbd "M-p") #'ement-room-compose-history-prev-message)
|
|||
|
|
(local-set-key (kbd "M-n") #'ement-room-compose-history-next-message)
|
|||
|
|
(local-set-key (kbd "M-r") #'ement-room-compose-history-isearch-backward)
|
|||
|
|
(local-set-key (kbd "C-M-r") #'ement-room-compose-history-isearch-backward-regexp)
|
|||
|
|
(setq header-line-format
|
|||
|
|
(concat (substitute-command-keys
|
|||
|
|
(format " Press \\[save-buffer] to send message to room (%s), or \\[ement-room-compose-abort] to cancel."
|
|||
|
|
(ement-room-display-name room)))
|
|||
|
|
(cond (ement-room-replying-to-event
|
|||
|
|
(format " (Replying to message from %s)"
|
|||
|
|
(ement--user-displayname-in
|
|||
|
|
ement-room (ement-event-sender
|
|||
|
|
ement-room-replying-to-event))))
|
|||
|
|
(ement-room-editing-event
|
|||
|
|
" (Editing message)"))))
|
|||
|
|
;; Adjust the window height automatically.
|
|||
|
|
(when ement-room-compose-buffer-window-auto-height
|
|||
|
|
(add-hook 'post-command-hook
|
|||
|
|
#'ement-room-compose-buffer-window-auto-height nil :local)
|
|||
|
|
;; Our `window-min-height' comprises header & mode line + body lines.
|
|||
|
|
(setq-local window-min-height
|
|||
|
|
(+ 2 (if ement-room-compose-buffer-window-auto-height-min
|
|||
|
|
(max 1 ement-room-compose-buffer-window-auto-height-min)
|
|||
|
|
1)))
|
|||
|
|
(when ement-room-compose-buffer-window-auto-height-fixed
|
|||
|
|
(setq-local window-size-fixed
|
|||
|
|
ement-room-compose-buffer-window-auto-height-fixed))
|
|||
|
|
;; The following helps when `window--sanitize-window-sizes' adjusts all
|
|||
|
|
;; windows in a frame (e.g. when splitting windows), as otherwise any
|
|||
|
|
;; existing compose buffer windows are liable to be resized line-wise,
|
|||
|
|
;; resulting in excess padding being introduced.
|
|||
|
|
(when ement-room-compose-buffer-window-auto-height-pixelwise
|
|||
|
|
(setq-local window-resize-pixelwise t)))
|
|||
|
|
;; Other compose buffer window behaviours.
|
|||
|
|
(add-hook 'window-state-change-functions
|
|||
|
|
#'ement-room-compose-buffer-window-state-change-handler nil :local)
|
|||
|
|
(add-hook 'window-buffer-change-functions
|
|||
|
|
#'ement-room-compose-buffer-window-buffer-change-handler nil :local))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-buffer-window-auto-height ()
|
|||
|
|
"Ensure that the compose buffer displays the whole message.
|
|||
|
|
|
|||
|
|
Called via `post-command-hook' if option
|
|||
|
|
`ement-room-compose-buffer-window-auto-height' is non-nil."
|
|||
|
|
;; We use `post-command-hook' (rather than, say, `after-change-functions'),
|
|||
|
|
;; because the required window height might change for reasons other than text
|
|||
|
|
;; editing (e.g. changes to the window's width or the font size).
|
|||
|
|
;;
|
|||
|
|
;; Note that changes to the default face size (e.g. via `text-scale-adjust')
|
|||
|
|
;; affect `default-line-height', invalidating the cache even when the text
|
|||
|
|
;; itself didn't change.
|
|||
|
|
;;
|
|||
|
|
;; The following may also clear the cache in order to force a recalculation:
|
|||
|
|
;; - `ement-room-compose-buffer-window-state-change-handler'
|
|||
|
|
;; - `ement-room-compose-buffer-window-buffer-change-handler'
|
|||
|
|
;;
|
|||
|
|
;; Global mutex `ement-room-compose-buffer-window-auto-height-resizing-p'
|
|||
|
|
;; ensures that we cannot run recursively. We also resize only the selected
|
|||
|
|
;; window, even if there are compose buffers displayed in other windows which
|
|||
|
|
;; might also be affected. This conservative approach can prevent desirable
|
|||
|
|
;; resizing in some cases, but restricting our behaviour this way keeps things
|
|||
|
|
;; simple so that we needn't consider potential issues such as endless cycles
|
|||
|
|
;; of conflicting resizes.
|
|||
|
|
;;
|
|||
|
|
;; Perfection would in any case be non-trivial -- consider two compose windows
|
|||
|
|
;; side-by-side in a horizontal split, each showing a different compose buffer
|
|||
|
|
;; with a different desired height. We cannot have the "correct" size for
|
|||
|
|
;; both simultaneously. The best thing to do would be to maintain the tallest
|
|||
|
|
;; height amongst all conflicting windows at all times -- but that is, again,
|
|||
|
|
;; considerably more complex.
|
|||
|
|
;;
|
|||
|
|
;; Most of the time the window arrangements are expected to be very simple and
|
|||
|
|
;; so a more comprehensive solution, while possible, is not worth the added
|
|||
|
|
;; complexity -- our relatively simplistic approach is good enough for the
|
|||
|
|
;; vast majority of situations.
|
|||
|
|
|
|||
|
|
;; Skip resizing if we are being called recursively...
|
|||
|
|
(unless (or (bound-and-true-p ement-room-compose-buffer-window-auto-height-resizing-p)
|
|||
|
|
;; ...or there are no other windows to resize...
|
|||
|
|
(window-full-height-p)
|
|||
|
|
;; ...or we have just switched to this buffer from another buffer
|
|||
|
|
;; (we may be cycling window buffers, and about to switch again).
|
|||
|
|
(and (window-old-buffer)
|
|||
|
|
(not (eq (window-old-buffer) (current-buffer)))))
|
|||
|
|
;; Manipulate the window body height.
|
|||
|
|
(let* ((pixelwise (and ement-room-compose-buffer-window-auto-height-pixelwise
|
|||
|
|
(display-graphic-p)))
|
|||
|
|
(lineheight (and pixelwise (default-line-height)))
|
|||
|
|
(buflines (max 1 (count-screen-lines nil nil t)))
|
|||
|
|
(cache (if pixelwise
|
|||
|
|
(* buflines lineheight)
|
|||
|
|
buflines))
|
|||
|
|
(wcache (window-parameter
|
|||
|
|
nil 'ement-room-compose-buffer-window-auto-height-cache)))
|
|||
|
|
;; Do nothing if the desired height has not changed.
|
|||
|
|
(unless (and wcache (eql cache wcache))
|
|||
|
|
;; Otherwise resize the window...
|
|||
|
|
(set-window-parameter
|
|||
|
|
nil 'ement-room-compose-buffer-window-auto-height-cache cache)
|
|||
|
|
(let* ((ement-room-compose-buffer-window-auto-height-resizing-p t)
|
|||
|
|
(minheight (if ement-room-compose-buffer-window-auto-height-min
|
|||
|
|
(max 1 ement-room-compose-buffer-window-auto-height-min)
|
|||
|
|
1))
|
|||
|
|
(maxheight ement-room-compose-buffer-window-auto-height-max)
|
|||
|
|
(maxlines (or (and maxheight (min buflines maxheight))
|
|||
|
|
buflines))
|
|||
|
|
(reqlines (max maxlines minheight)))
|
|||
|
|
(if pixelwise
|
|||
|
|
;; In GUI frames we should do this in pixels, as the line-based
|
|||
|
|
;; `window-resize' DELTA is based on the default frame character
|
|||
|
|
;; height, rather than the buffer's `default-line-height', which
|
|||
|
|
;; doesn't take face remapping (e.g. `text-scale-adjust') into
|
|||
|
|
;; account and would therefore enlarge the window by the wrong
|
|||
|
|
;; value. Pixel-based resizing also lets us eliminate vertical
|
|||
|
|
;; padding resulting from the body lines being a different height
|
|||
|
|
;; to the mode- and/or header-line height (which can easily happen
|
|||
|
|
;; in GUI frames and is distractingly obvious in a small window
|
|||
|
|
;; which is supposed to fit its content).
|
|||
|
|
(let* ((window-resize-pixelwise t)
|
|||
|
|
(pixheight (* lineheight reqlines))
|
|||
|
|
(pixels (- pixheight (window-body-height nil t))))
|
|||
|
|
(when-let ((pixels (window-resizable nil pixels nil t t)))
|
|||
|
|
(window-resize nil pixels nil t t)))
|
|||
|
|
;; In terminal frames we deal in lines rather than pixels.
|
|||
|
|
(let ((delta (- reqlines (window-body-height))))
|
|||
|
|
(when-let ((delta (window-resizable nil delta nil t)))
|
|||
|
|
(window-resize nil delta nil t))))
|
|||
|
|
;; Ask Emacs to "preserve" the new height. So long as the window
|
|||
|
|
;; maintains this height and is displaying this specific buffer, Emacs
|
|||
|
|
;; will avoid unnecessary height changes from side-effects of commands
|
|||
|
|
;; such as `balance-windows'. Explicit height changes are allowed.
|
|||
|
|
;; We must update this parameter every time we change the height so
|
|||
|
|
;; that the "preserved" height value is always correct.
|
|||
|
|
(window-preserve-size nil nil t)
|
|||
|
|
;; In most cases we can fit the whole buffer in the resized window.
|
|||
|
|
(set-window-start nil (point-min) :noforce)
|
|||
|
|
;; The resizing might have obscured the room buffer's window point, so
|
|||
|
|
;; minimise the amount of scrolling which occurs to restore that to a
|
|||
|
|
;; visible position.
|
|||
|
|
(let ((scroll-conservatively 101))
|
|||
|
|
(redisplay)))))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-buffer-window-state-change-handler (win)
|
|||
|
|
"Called via buffer-local `window-state-change-functions' in compose buffers.
|
|||
|
|
|
|||
|
|
Called for any window WIN showing a compose buffer if that window
|
|||
|
|
has been added or assigned another buffer, changed size, or been
|
|||
|
|
selected or deselected.
|
|||
|
|
|
|||
|
|
This prevents a compose buffer window being stuck at the wrong
|
|||
|
|
height (until the number of lines changes again) if something
|
|||
|
|
other than the auto-height feature resizes the window. We simply
|
|||
|
|
flush the auto-height cache, thus ensuring the required height is
|
|||
|
|
recalculated on the next cycle).
|
|||
|
|
|
|||
|
|
See also `ement-room-compose-buffer-window-buffer-change-handler'."
|
|||
|
|
;; Ignore the window state changes triggered by our auto-height resizing.
|
|||
|
|
;;
|
|||
|
|
;; Also do nothing if the state change is for the selected window, as
|
|||
|
|
;; the buffer-local `post-command-hook' is already dealing with that
|
|||
|
|
;; case. We only care about window state changes which are triggered
|
|||
|
|
;; from elsewhere. This means we skip the case whereby the selected
|
|||
|
|
;; window has just switched to the compose buffer, and so we use
|
|||
|
|
;; `window-buffer-change-functions' as well to capture that case.
|
|||
|
|
;; (See `ement-room-compose-buffer-window-buffer-change-handler'.)
|
|||
|
|
(when ement-room-compose-buffer-window-auto-height
|
|||
|
|
(unless (or (bound-and-true-p ement-room-compose-buffer-window-auto-height-resizing-p)
|
|||
|
|
(eq win (selected-window)))
|
|||
|
|
;; Clear the auto-height cache for this window.
|
|||
|
|
(set-window-parameter
|
|||
|
|
win 'ement-room-compose-buffer-window-auto-height-cache nil))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-buffer-window-buffer-change-handler (win)
|
|||
|
|
"Called via buffer-local `window-buffer-change-functions' in compose buffers.
|
|||
|
|
|
|||
|
|
Called for any window WIN showing a compose buffer if that window
|
|||
|
|
has just been created or assigned that buffer.
|
|||
|
|
|
|||
|
|
Flush the auto-height cache for any window which switches to
|
|||
|
|
displaying a compose buffer, to ensure the required height is
|
|||
|
|
recalculated on the next cycle.
|
|||
|
|
|
|||
|
|
Also detect whether a composer buffer's window was created for
|
|||
|
|
that purpose, as this information affects the behaviour of
|
|||
|
|
`ement-room-compose-buffer-quit-restore-window'.
|
|||
|
|
|
|||
|
|
See also `ement-room-compose-buffer-window-state-change-handler'."
|
|||
|
|
(with-selected-window win
|
|||
|
|
(when ement-room-compose-buffer-window-auto-height
|
|||
|
|
;; Clear the auto-height cache for this window.
|
|||
|
|
(set-window-parameter
|
|||
|
|
win 'ement-room-compose-buffer-window-auto-height-cache nil))
|
|||
|
|
;; Establish whether we've processed this window before, and whether it was
|
|||
|
|
;; created to display a compose buffer. We set a window property the first
|
|||
|
|
;; time that we see the window, so if it's set at all, we've seen it before.
|
|||
|
|
(unless (assq 'ement-room-compose-buffer-window-created-p (window-parameters win))
|
|||
|
|
;; If the window has never shown any other buffer, then it was created
|
|||
|
|
;; specifically to display a compose buffer.
|
|||
|
|
(let ((created-for-compose-p (set-window-parameter
|
|||
|
|
win 'ement-room-compose-buffer-window-created-p
|
|||
|
|
(not (window-prev-buffers win)))))
|
|||
|
|
;; Process `ement-room-compose-buffer-window-dedicated' when the compose
|
|||
|
|
;; buffer is first displayed in this window, to decide whether the
|
|||
|
|
;; window should be dedicated to the buffer.
|
|||
|
|
(when (cl-case ement-room-compose-buffer-window-dedicated
|
|||
|
|
(created created-for-compose-p)
|
|||
|
|
(auto-height ement-room-compose-buffer-window-auto-height)
|
|||
|
|
(delete nil)
|
|||
|
|
(t ement-room-compose-buffer-window-dedicated))
|
|||
|
|
(set-window-dedicated-p win t))))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-buffer-quit-restore-window ()
|
|||
|
|
"Kill the current compose buffer and deal appropriately with its window.
|
|||
|
|
|
|||
|
|
The default `ement-room-compose-buffer-window-dedicated' value
|
|||
|
|
ensures that the window is dedicated and therefore that it will
|
|||
|
|
be deleted.
|
|||
|
|
|
|||
|
|
A non-dedicated window which has displayed another buffer at any
|
|||
|
|
point will not be deleted."
|
|||
|
|
;; N.b. This function exists primarily for documentation purposes,
|
|||
|
|
;; to clarify the side-effect of using a dedicated window.
|
|||
|
|
(when (eq ement-room-compose-buffer-window-dedicated 'delete)
|
|||
|
|
;; `quit-restore-window' always deletes a dedicated window.
|
|||
|
|
(set-window-dedicated-p nil t))
|
|||
|
|
(quit-restore-window nil 'kill))
|
|||
|
|
|
|||
|
|
(declare-function dabbrev--select-buffers "dabbrev")
|
|||
|
|
|
|||
|
|
(defun ement-compose-dabbrev-select-buffers ()
|
|||
|
|
"Used as `dabbrev-select-buffers-function' in compose buffers."
|
|||
|
|
(let ((buflist (dabbrev--select-buffers))
|
|||
|
|
(roombuf (map-elt (ement-room-local ement-room) 'buffer)))
|
|||
|
|
(if (and roombuf (buffer-live-p roombuf))
|
|||
|
|
(cons roombuf (delq roombuf buflist))
|
|||
|
|
buflist)))
|
|||
|
|
|
|||
|
|
(defun ement-room-mode-p (buffer)
|
|||
|
|
"Non-nil if BUFFER has `ement-room-mode' as its major mode.
|
|||
|
|
Used with `dabbrev-friend-buffer-function'."
|
|||
|
|
(with-current-buffer buffer
|
|||
|
|
(derived-mode-p 'ement-room-mode)))
|
|||
|
|
|
|||
|
|
;;; Message history for compose buffers. Isearch code is derived from comint.el.
|
|||
|
|
|
|||
|
|
(defvar-local ement-room--compose-message-history-index -1)
|
|||
|
|
(defvar-local ement-room--compose-message-history-initial "")
|
|||
|
|
(defvar-local ement-room--compose-history-isearch nil)
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-message-history-insert (hist-pos &optional with-message)
|
|||
|
|
"Insert text of the absolute history position HIST-POS."
|
|||
|
|
;; Store the not-from-history buffer message.
|
|||
|
|
(when (< ement-room--compose-message-history-index 0)
|
|||
|
|
(setq ement-room--compose-message-history-initial
|
|||
|
|
(ement-room-compose-buffer-string-trimmed)))
|
|||
|
|
;; Update the index.
|
|||
|
|
(setq ement-room--compose-message-history-index (or hist-pos -1))
|
|||
|
|
(when (and with-message hist-pos (>= hist-pos 0))
|
|||
|
|
(let ((message-log-max nil))
|
|||
|
|
(message "History item %d" hist-pos)))
|
|||
|
|
;; Update the buffer.
|
|||
|
|
(erase-buffer)
|
|||
|
|
(insert (if (< ement-room--compose-message-history-index 0)
|
|||
|
|
ement-room--compose-message-history-initial
|
|||
|
|
(or (nth ement-room--compose-message-history-index
|
|||
|
|
ement-room-message-history)
|
|||
|
|
(format "[invalid ement message history element %d]"
|
|||
|
|
ement-room--compose-message-history-index)))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-history-prev-message (arg)
|
|||
|
|
"Cycle backward through message history, after saving current message.
|
|||
|
|
With a numeric prefix ARG, go back ARG messages."
|
|||
|
|
(interactive "*p")
|
|||
|
|
(let ((len (length ement-room-message-history)))
|
|||
|
|
;; Valid index values: -1 <= idx < len.
|
|||
|
|
(cond ((<= len 0)
|
|||
|
|
(user-error "Empty message history"))
|
|||
|
|
((eql arg 0)) ;; No-op.
|
|||
|
|
((and (> arg 0) (>= ement-room--compose-message-history-index (1- len)))
|
|||
|
|
(user-error "Beginning of history; no preceding item"))
|
|||
|
|
((and (< arg 0) (< ement-room--compose-message-history-index 0))
|
|||
|
|
(user-error "End of history; no next item"))
|
|||
|
|
(t
|
|||
|
|
;; It's still possible to move in the specified direction.
|
|||
|
|
(ement-room-compose-message-history-insert
|
|||
|
|
(let ((hist-pos (+ arg ement-room--compose-message-history-index)))
|
|||
|
|
(cond ((>= hist-pos len) (1- len))
|
|||
|
|
((< hist-pos -1) -1)
|
|||
|
|
(t hist-pos)))
|
|||
|
|
:with-message)))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-history-next-message (arg)
|
|||
|
|
"Cycle forward through message history, after saving current message.
|
|||
|
|
With a numeric prefix ARG, go forward ARG messages."
|
|||
|
|
(interactive "*p")
|
|||
|
|
(ement-room-compose-history-prev-message (- arg)))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-history-isearch-backward ()
|
|||
|
|
"Search for a string in the message history using Isearch.
|
|||
|
|
Use \\[isearch-backward] and \\[isearch-forward] to continue searching."
|
|||
|
|
(interactive)
|
|||
|
|
(setq ement-room--compose-history-isearch t)
|
|||
|
|
(isearch-backward nil t))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-history-isearch-backward-regexp ()
|
|||
|
|
"Search for a regular expression in the message history using Isearch.
|
|||
|
|
Use \\[isearch-backward] and \\[isearch-forward] to continue searching."
|
|||
|
|
(interactive)
|
|||
|
|
(setq ement-room--compose-history-isearch t)
|
|||
|
|
(isearch-backward-regexp nil t))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-history-isearch-setup ()
|
|||
|
|
"Set up Isearch to search `ement-room-message-history'.
|
|||
|
|
Intended to be added to `isearch-mode-hook' in an ement compose buffer."
|
|||
|
|
(when (eq ement-room--compose-history-isearch t)
|
|||
|
|
(setq isearch-message-prefix-add "history ")
|
|||
|
|
(setq-local isearch-search-fun-function
|
|||
|
|
#'ement-room-compose-history-isearch-search)
|
|||
|
|
(setq-local isearch-message-function
|
|||
|
|
#'ement-room-compose-history-isearch-message)
|
|||
|
|
(setq-local isearch-wrap-function
|
|||
|
|
#'ement-room-compose-history-isearch-wrap)
|
|||
|
|
(setq-local isearch-push-state-function
|
|||
|
|
#'ement-room-compose-history-isearch-push-state)
|
|||
|
|
(setq-local isearch-lazy-count nil)
|
|||
|
|
(add-hook 'isearch-mode-end-hook 'ement-room-compose-history-isearch-end nil t)))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-history-isearch-end ()
|
|||
|
|
"Clean up the buffer after terminating Isearch.
|
|||
|
|
Called via `isearch-mode-end-hook'."
|
|||
|
|
(setq isearch-message-prefix-add nil)
|
|||
|
|
(setq isearch-search-fun-function 'isearch-search-fun-default)
|
|||
|
|
(setq isearch-wrap-function nil)
|
|||
|
|
(setq isearch-push-state-function nil)
|
|||
|
|
;; Force isearch to not change mark.
|
|||
|
|
(setq isearch-opoint (point))
|
|||
|
|
(kill-local-variable 'isearch-lazy-count)
|
|||
|
|
(remove-hook 'isearch-mode-end-hook 'ement-room-compose-history-isearch-end t)
|
|||
|
|
(unless isearch-suspended
|
|||
|
|
(setq ement-room--compose-history-isearch nil)))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-history-isearch-search ()
|
|||
|
|
"Return the search function for Isearch in message history.
|
|||
|
|
This function is used as the value of `isearch-search-fun-function'."
|
|||
|
|
#'ement-room-compose-history-isearch-function)
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-history-isearch-function (string bound noerror)
|
|||
|
|
"Isearch in message history."
|
|||
|
|
(let ((search-fun
|
|||
|
|
;; Use standard functions to search within message text
|
|||
|
|
(isearch-search-fun-default))
|
|||
|
|
found)
|
|||
|
|
(or
|
|||
|
|
;; 1. First try searching in the initial message
|
|||
|
|
(funcall search-fun string nil noerror)
|
|||
|
|
;; 2. If the above search fails, start putting next/prev history elements in the
|
|||
|
|
;; buffer successively, and search the string in them. Do this only when bound is
|
|||
|
|
;; nil (i.e. not while lazy-highlighting search strings in the current message).
|
|||
|
|
(unless bound
|
|||
|
|
(condition-case nil
|
|||
|
|
(progn
|
|||
|
|
(while (not found)
|
|||
|
|
(if isearch-forward
|
|||
|
|
(ement-room-compose-history-next-message 1)
|
|||
|
|
(ement-room-compose-history-prev-message 1))
|
|||
|
|
(goto-char (if isearch-forward (point-min) (point-max)))
|
|||
|
|
(setq isearch-barrier (point)
|
|||
|
|
isearch-opoint (point))
|
|||
|
|
;; After putting the next/prev history element, search the string in
|
|||
|
|
;; them again, until `ement-room-compose-history-next-message' or
|
|||
|
|
;; `ement-room-compose-history-prev-message' raises an error at the
|
|||
|
|
;; beginning/end of history.
|
|||
|
|
(setq found (funcall search-fun string nil noerror)))
|
|||
|
|
;; Return point of the new search result.
|
|||
|
|
(point))
|
|||
|
|
;; Return nil on any isearch errors, including the "no next/preceding item"
|
|||
|
|
;; user-errors signalled from `ement-room-compose-history-prev-message'.
|
|||
|
|
(error nil))))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-history-isearch-message (&optional c-q-hack ellipsis)
|
|||
|
|
"Display the isearch message.
|
|||
|
|
This function is used as the value of `isearch-message-function'."
|
|||
|
|
(setq isearch-message-prefix-add
|
|||
|
|
(if (and isearch-success
|
|||
|
|
(not isearch-error)
|
|||
|
|
(>= ement-room--compose-message-history-index 0))
|
|||
|
|
(format "history item %d: "
|
|||
|
|
ement-room--compose-message-history-index)
|
|||
|
|
"history "))
|
|||
|
|
(isearch-message c-q-hack ellipsis))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-history-isearch-wrap ()
|
|||
|
|
"Wrap the history search when search fails.
|
|||
|
|
Move point to the first history element for a forward search,
|
|||
|
|
or to the last history element for a backward search.
|
|||
|
|
This function is used as the value of `isearch-wrap-function'."
|
|||
|
|
;; When `ement-room-compose-history-isearch-search' fails on reaching the
|
|||
|
|
;; beginning/end of the history, wrap the search to the first/last
|
|||
|
|
;; input history element.
|
|||
|
|
(ement-room-compose-message-history-insert
|
|||
|
|
(if isearch-forward
|
|||
|
|
(1- (length ement-room-message-history))
|
|||
|
|
-1))
|
|||
|
|
(goto-char (if isearch-forward (point-min) (point-max))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-history-isearch-push-state ()
|
|||
|
|
"Save a function restoring the state of input history search.
|
|||
|
|
Save `ement-room--compose-message-history-index' to the additional state parameter
|
|||
|
|
in the search status stack.
|
|||
|
|
This function is used as the value of `isearch-push-state-function'."
|
|||
|
|
(let ((index ement-room--compose-message-history-index))
|
|||
|
|
(lambda (cmd)
|
|||
|
|
(ement-room-compose-history-isearch-pop-state cmd index))))
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-history-isearch-pop-state (_cmd hist-pos)
|
|||
|
|
"Restore the input history search state.
|
|||
|
|
Go to the history element by the absolute history position HIST-POS.
|
|||
|
|
See `ement-room-compose-history-isearch-push-state'."
|
|||
|
|
(ement-room-compose-message-history-insert hist-pos))
|
|||
|
|
|
|||
|
|
;;;;; Widgets
|
|||
|
|
|
|||
|
|
(require 'widget)
|
|||
|
|
|
|||
|
|
(define-widget 'ement-room-membership 'item
|
|||
|
|
"Widget for membership events."
|
|||
|
|
;; FIXME: This makes it hard to add a timestamp according to the buffer's message format spec.
|
|||
|
|
;; NOTE: The widget needs something before and after "%v" to correctly apply the
|
|||
|
|
;; `ement-room-membership' face. We could use a zero-width space, but that won't work on
|
|||
|
|
;; a TTY. So we use a regular space but replace it with nothing with a display spec.
|
|||
|
|
:format (let ((zws (propertize " " 'display "")))
|
|||
|
|
(concat "%{" zws "%v" zws "%}"))
|
|||
|
|
:sample-face 'ement-room-membership
|
|||
|
|
:value-create (lambda (widget)
|
|||
|
|
(pcase-let* ((event (widget-value widget)))
|
|||
|
|
(insert (ement-room-wrap-prefix
|
|||
|
|
(ement-room--format-member-event event ement-room))))))
|
|||
|
|
|
|||
|
|
(defun ement-room--format-member-event (event room)
|
|||
|
|
"Return formatted string for \"m.room.member\" EVENT in ROOM."
|
|||
|
|
;; SPEC: Section 9.3.4: "m.room.member".
|
|||
|
|
(pcase-let* (((cl-struct ement-event sender state-key
|
|||
|
|
(content (map reason ('avatar_url new-avatar-url)
|
|||
|
|
('membership new-membership) ('displayname new-displayname)))
|
|||
|
|
(unsigned (map ('prev_content (map ('avatar_url old-avatar-url)
|
|||
|
|
('membership prev-membership)
|
|||
|
|
('displayname prev-displayname))))))
|
|||
|
|
event)
|
|||
|
|
(sender-name (ement--user-displayname-in ement-room sender)))
|
|||
|
|
(cl-macrolet ((nes (var)
|
|||
|
|
;; For "non-empty-string". Needed because the displayname can be
|
|||
|
|
;; an empty string, but apparently is never null. (Note that the
|
|||
|
|
;; argument should be a variable, never any other form, to avoid
|
|||
|
|
;; multiple evaluation.)
|
|||
|
|
`(when (and ,var (not (string-empty-p ,var)))
|
|||
|
|
,var))
|
|||
|
|
(sender-name-id-string ()
|
|||
|
|
`(propertize sender-name
|
|||
|
|
'help-echo (ement-user-id sender)))
|
|||
|
|
(new-displayname-sender-name-state-key-string ()
|
|||
|
|
`(propertize (or (nes new-displayname) (nes sender-name) (nes state-key))
|
|||
|
|
'help-echo state-key))
|
|||
|
|
(sender-name-state-key-string ()
|
|||
|
|
`(propertize sender-name
|
|||
|
|
'help-echo state-key))
|
|||
|
|
(prev-displayname-id-string ()
|
|||
|
|
`(propertize (or prev-displayname sender-name)
|
|||
|
|
'help-echo (ement-user-id sender))))
|
|||
|
|
(pcase-exhaustive new-membership
|
|||
|
|
("invite"
|
|||
|
|
(pcase prev-membership
|
|||
|
|
((or "leave" '())
|
|||
|
|
(format "%s invited %s"
|
|||
|
|
(sender-name-id-string)
|
|||
|
|
(new-displayname-sender-name-state-key-string)))
|
|||
|
|
(_ (format "%s sent unrecognized invite event for %s"
|
|||
|
|
(sender-name-id-string)
|
|||
|
|
(new-displayname-sender-name-state-key-string)))))
|
|||
|
|
("join"
|
|||
|
|
(pcase prev-membership
|
|||
|
|
("invite"
|
|||
|
|
(format "%s accepted invitation to join"
|
|||
|
|
(sender-name-state-key-string)))
|
|||
|
|
("join"
|
|||
|
|
(cond ((not (equal new-displayname prev-displayname))
|
|||
|
|
(propertize (format "%s changed name to %s"
|
|||
|
|
prev-displayname (or new-displayname (ement--user-displayname-in room sender)))
|
|||
|
|
'help-echo state-key))
|
|||
|
|
((not (equal new-avatar-url old-avatar-url))
|
|||
|
|
(format "%s changed avatar"
|
|||
|
|
(new-displayname-sender-name-state-key-string)))
|
|||
|
|
(t (format "Unrecognized membership event for %s"
|
|||
|
|
(sender-name-state-key-string)))))
|
|||
|
|
("leave"
|
|||
|
|
(format "%s rejoined"
|
|||
|
|
(sender-name-state-key-string)))
|
|||
|
|
(`nil
|
|||
|
|
(format "%s joined"
|
|||
|
|
(new-displayname-sender-name-state-key-string)))
|
|||
|
|
(_ (format "%s sent unrecognized join event for %s"
|
|||
|
|
(sender-name-id-string)
|
|||
|
|
(new-displayname-sender-name-state-key-string)))))
|
|||
|
|
("leave"
|
|||
|
|
(pcase prev-membership
|
|||
|
|
("invite"
|
|||
|
|
(pcase state-key
|
|||
|
|
((pred (equal (ement-user-id sender)))
|
|||
|
|
(format "%s rejected invitation"
|
|||
|
|
(sender-name-id-string)))
|
|||
|
|
(_ (format "%s revoked %s's invitation"
|
|||
|
|
(sender-name-id-string)
|
|||
|
|
(new-displayname-sender-name-state-key-string)))))
|
|||
|
|
("join"
|
|||
|
|
(pcase state-key
|
|||
|
|
((pred (equal (ement-user-id sender)))
|
|||
|
|
(format "%s left%s"
|
|||
|
|
(prev-displayname-id-string)
|
|||
|
|
(if reason
|
|||
|
|
(format " (%S)" reason)
|
|||
|
|
"")))
|
|||
|
|
(_ (format "%s kicked %s%s"
|
|||
|
|
(sender-name-id-string)
|
|||
|
|
(propertize (or prev-displayname state-key)
|
|||
|
|
'help-echo state-key)
|
|||
|
|
(if reason
|
|||
|
|
(format " (%S)" reason)
|
|||
|
|
"")))))
|
|||
|
|
("ban"
|
|||
|
|
(format "%s unbanned %s"
|
|||
|
|
(sender-name-id-string)
|
|||
|
|
state-key))
|
|||
|
|
(_ (format "%s left%s"
|
|||
|
|
(prev-displayname-id-string)
|
|||
|
|
(if reason
|
|||
|
|
(format " (%S)" reason)
|
|||
|
|
"")))))
|
|||
|
|
("ban"
|
|||
|
|
(pcase prev-membership
|
|||
|
|
((or "invite" "leave")
|
|||
|
|
(format "%s banned %s%s"
|
|||
|
|
(sender-name-id-string)
|
|||
|
|
(propertize (or prev-displayname state-key)
|
|||
|
|
'help-echo state-key)
|
|||
|
|
(if reason
|
|||
|
|
(format " (%S)" reason)
|
|||
|
|
"")))
|
|||
|
|
("join"
|
|||
|
|
(format "%s kicked and banned %s%s"
|
|||
|
|
(sender-name-id-string)
|
|||
|
|
(propertize (or prev-displayname state-key)
|
|||
|
|
'help-echo state-key)
|
|||
|
|
(if reason
|
|||
|
|
(format " (%S)" reason)
|
|||
|
|
"")))
|
|||
|
|
(_ (format "%s sent unrecognized ban event for %s"
|
|||
|
|
(sender-name-id-string)
|
|||
|
|
(propertize (or prev-displayname state-key)
|
|||
|
|
'help-echo state-key)))))))))
|
|||
|
|
|
|||
|
|
;; NOTE: Widgets are only currently used for single membership events, not grouped ones.
|
|||
|
|
|
|||
|
|
(defun ement-room--format-membership-events (struct room)
|
|||
|
|
"Return string for STRUCT in ROOM.
|
|||
|
|
STRUCT should be an `ement-room-membership-events' struct."
|
|||
|
|
(cl-labels ((event-user (event)
|
|||
|
|
(propertize (if-let (user (gethash (ement-event-state-key event) ement-users))
|
|||
|
|
(ement--user-displayname-in room user)
|
|||
|
|
(ement-event-state-key event))
|
|||
|
|
'help-echo (concat (ement-room--format-member-event event room)
|
|||
|
|
" <" (ement-event-state-key event) ">")))
|
|||
|
|
(old-membership (event)
|
|||
|
|
(map-nested-elt (ement-event-unsigned event) '(prev_content membership)))
|
|||
|
|
(new-membership (event)
|
|||
|
|
(alist-get 'membership (ement-event-content event))))
|
|||
|
|
(pcase-let* (((cl-struct ement-room-membership-events events) struct))
|
|||
|
|
(pcase (length events)
|
|||
|
|
(0 (warn "No events in `ement-room-membership-events' struct"))
|
|||
|
|
(1 (ement-room--format-member-event (car events) room))
|
|||
|
|
(_ (let* ((left-events (cl-remove-if-not (lambda (event)
|
|||
|
|
(and (equal "leave" (new-membership event))
|
|||
|
|
(not (member (old-membership event) '("ban" "invite")))))
|
|||
|
|
events))
|
|||
|
|
(join-events (cl-remove-if-not (lambda (event)
|
|||
|
|
(and (equal "join" (new-membership event))
|
|||
|
|
(not (equal "join" (old-membership event)))))
|
|||
|
|
events))
|
|||
|
|
(rejoin-events (cl-remove-if-not (lambda (event)
|
|||
|
|
(and (equal "join" (new-membership event))
|
|||
|
|
(equal "leave" (old-membership event))))
|
|||
|
|
events))
|
|||
|
|
(invite-events (cl-remove-if-not (lambda (event)
|
|||
|
|
(equal "invite" (new-membership event)))
|
|||
|
|
events))
|
|||
|
|
(reject-events (cl-remove-if-not (lambda (event)
|
|||
|
|
(and (equal "invite" (old-membership event))
|
|||
|
|
(equal "leave" (new-membership event))))
|
|||
|
|
events))
|
|||
|
|
(ban-events (cl-remove-if-not (lambda (event)
|
|||
|
|
(and (member (old-membership event) '("invite" "leave"))
|
|||
|
|
(equal "ban" (new-membership event))))
|
|||
|
|
events))
|
|||
|
|
(unban-events (cl-remove-if-not (lambda (event)
|
|||
|
|
(and (equal "ban" (old-membership event))
|
|||
|
|
(equal "leave" (new-membership event))))
|
|||
|
|
events))
|
|||
|
|
(kicked-events (cl-remove-if-not (lambda (event)
|
|||
|
|
(and (equal "join" (old-membership event))
|
|||
|
|
(equal "leave" (new-membership event))
|
|||
|
|
(not (equal (ement-user-id (ement-event-sender event))
|
|||
|
|
(ement-event-state-key event)))))
|
|||
|
|
events))
|
|||
|
|
(kick-and-ban-events (cl-remove-if-not (lambda (event)
|
|||
|
|
(and (equal "join" (old-membership event))
|
|||
|
|
(equal "ban" (new-membership event))))
|
|||
|
|
events))
|
|||
|
|
(rename-events (cl-remove-if-not (lambda (event)
|
|||
|
|
(and (equal "join" (old-membership event))
|
|||
|
|
(equal "join" (new-membership event))
|
|||
|
|
(equal (alist-get 'avatar_url (ement-event-content event))
|
|||
|
|
(map-nested-elt (ement-event-unsigned event)
|
|||
|
|
'(prev_content avatar_url)))))
|
|||
|
|
events))
|
|||
|
|
(avatar-events (cl-remove-if-not (lambda (event)
|
|||
|
|
(and (equal "join" (old-membership event))
|
|||
|
|
(equal "join" (new-membership event))
|
|||
|
|
(not (equal (alist-get 'avatar_url (ement-event-content event))
|
|||
|
|
(map-nested-elt (ement-event-unsigned event)
|
|||
|
|
'(prev_content avatar_url))))))
|
|||
|
|
events))
|
|||
|
|
join-and-leave-events rejoin-and-leave-events kicked-and-rejoined-events)
|
|||
|
|
;; Remove apparent duplicates between join/rejoin events.
|
|||
|
|
(setf join-events (cl-delete-if (lambda (event)
|
|||
|
|
(cl-find (ement-event-state-key event) rejoin-events
|
|||
|
|
:test #'equal :key #'ement-event-state-key))
|
|||
|
|
join-events)
|
|||
|
|
rejoin-events (cl-delete-if (lambda (event)
|
|||
|
|
(cl-find (ement-event-state-key event) join-events
|
|||
|
|
:test #'equal :key #'ement-event-state-key))
|
|||
|
|
rejoin-events)
|
|||
|
|
join-and-leave-events (cl-loop for join-event in join-events
|
|||
|
|
for left-event = (cl-find (ement-event-state-key join-event) left-events
|
|||
|
|
:test #'equal :key #'ement-event-state-key)
|
|||
|
|
when left-event
|
|||
|
|
collect left-event
|
|||
|
|
and do (setf join-events (cl-delete (ement-event-state-key join-event) join-events
|
|||
|
|
:test #'equal :key #'ement-event-state-key)
|
|||
|
|
left-events (cl-delete (ement-event-state-key left-event) left-events
|
|||
|
|
:test #'equal :key #'ement-event-state-key)))
|
|||
|
|
kicked-and-rejoined-events (cl-loop for rejoin-event in rejoin-events
|
|||
|
|
for kicked-event = (cl-find (ement-event-state-key rejoin-event) kicked-events
|
|||
|
|
:test #'equal :key #'ement-event-state-key)
|
|||
|
|
when kicked-event collect kicked-event
|
|||
|
|
and do (setf rejoin-events (cl-delete (ement-event-state-key kicked-event) rejoin-events
|
|||
|
|
:test #'equal :key #'ement-event-state-key)
|
|||
|
|
left-events (cl-delete (ement-event-state-key kicked-event) left-events
|
|||
|
|
:test #'equal :key #'ement-event-state-key)))
|
|||
|
|
rejoin-and-leave-events (cl-loop for rejoin-event in rejoin-events
|
|||
|
|
for left-event = (cl-find (ement-event-state-key rejoin-event) left-events
|
|||
|
|
:test #'equal :key #'ement-event-state-key)
|
|||
|
|
when left-event
|
|||
|
|
collect left-event
|
|||
|
|
and do (setf rejoin-events (cl-delete
|
|||
|
|
(ement-event-state-key rejoin-event) rejoin-events
|
|||
|
|
:test #'equal :key #'ement-event-state-key)
|
|||
|
|
left-events (cl-delete (ement-event-state-key left-event) left-events
|
|||
|
|
:test #'equal :key #'ement-event-state-key))))
|
|||
|
|
(format "Membership: %s."
|
|||
|
|
(string-join (cl-loop for (type . events)
|
|||
|
|
in (ement-alist "rejoined" rejoin-events
|
|||
|
|
"joined" join-events
|
|||
|
|
"left" left-events
|
|||
|
|
"joined and left" join-and-leave-events
|
|||
|
|
"was kicked and rejoined" kicked-and-rejoined-events
|
|||
|
|
"rejoined and left" rejoin-and-leave-events
|
|||
|
|
"invited" invite-events
|
|||
|
|
"rejected invitation" reject-events
|
|||
|
|
"banned" ban-events
|
|||
|
|
"unbanned" unban-events
|
|||
|
|
"kicked and banned" kick-and-ban-events
|
|||
|
|
"changed name" rename-events
|
|||
|
|
"changed avatar" avatar-events)
|
|||
|
|
for users = (mapcar #'event-user
|
|||
|
|
(cl-delete-duplicates
|
|||
|
|
events :key #'ement-event-state-key))
|
|||
|
|
for number = (length users)
|
|||
|
|
when events
|
|||
|
|
collect (format "%s %s (%s)" number
|
|||
|
|
(propertize type 'face 'bold)
|
|||
|
|
(string-join users ", ")))
|
|||
|
|
"; "))))))))
|
|||
|
|
|
|||
|
|
;;;;; Images
|
|||
|
|
|
|||
|
|
;; Downloading and displaying images in messages, room/user avatars, etc.
|
|||
|
|
|
|||
|
|
(require 'image)
|
|||
|
|
|
|||
|
|
(defvar ement-room-image-keymap
|
|||
|
|
(let ((map (make-sparse-keymap)))
|
|||
|
|
(set-keymap-parent map image-map)
|
|||
|
|
(define-key map (kbd "M-RET") #'ement-room-image-scale)
|
|||
|
|
(define-key map (kbd "RET") #'ement-room-image-show)
|
|||
|
|
(define-key map [mouse-1] #'ement-room-image-scale-mouse)
|
|||
|
|
(define-key map [double-mouse-1] #'ement-room-image-show-mouse)
|
|||
|
|
map)
|
|||
|
|
"Keymap for images in room buffers.")
|
|||
|
|
|
|||
|
|
(defgroup ement-room-images nil
|
|||
|
|
"Showing images in rooms."
|
|||
|
|
:group 'ement-room)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-images t
|
|||
|
|
"Download and show images in messages, avatars, etc."
|
|||
|
|
:type 'boolean
|
|||
|
|
:set (lambda (option value)
|
|||
|
|
(if (or (fboundp 'imagemagick-types)
|
|||
|
|
(when (fboundp 'image-transforms-p)
|
|||
|
|
(image-transforms-p)))
|
|||
|
|
(set-default option value)
|
|||
|
|
(set-default option nil)
|
|||
|
|
(when (and value (display-images-p))
|
|||
|
|
(display-warning 'ement "This Emacs was not built with ImageMagick support, nor does it support Cairo/XRender scaling, so images can't be displayed in Ement")))))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-image-thumbnail-height 0.2
|
|||
|
|
"Scale thumbnail images to this multiple of the window body height.
|
|||
|
|
Should be a number between 0 and 1.
|
|||
|
|
See also `ement-room-image-thumbnail-height-min'."
|
|||
|
|
:type '(number :tag "Multiple of the window body height"))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-image-thumbnail-height-min 30
|
|||
|
|
"Minimum height in pixels when scaling thumbnail images.
|
|||
|
|
See also `ement-room-image-thumbnail-height'."
|
|||
|
|
:type 'natnum)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-image-initial-height ement-room-image-thumbnail-height
|
|||
|
|
"Limit images' initial display height.
|
|||
|
|
If a number, it should be no larger than 1 (because Emacs can't
|
|||
|
|
display images larger than the window body height)."
|
|||
|
|
:type '(choice (const :tag "Use full window height (or width)" nil)
|
|||
|
|
(number :tag "Multiple of the window body height")))
|
|||
|
|
|
|||
|
|
(defcustom ement-room-image-margin 5
|
|||
|
|
"How many pixels to add as an extra margin around the image."
|
|||
|
|
:type 'natnum)
|
|||
|
|
|
|||
|
|
(defcustom ement-room-image-relief 2
|
|||
|
|
"Width in pixels of shadow rectangle around the image.
|
|||
|
|
If negative, shadows are drawn so that the image appears as a
|
|||
|
|
pressed button; otherwise, it appears as an unpressed button."
|
|||
|
|
:type 'integer)
|
|||
|
|
|
|||
|
|
(defun ement-room-image-scale-mouse (event)
|
|||
|
|
"Toggle scale of image at mouse EVENT.
|
|||
|
|
Scale image to fit within the window's body. If image is already
|
|||
|
|
fit to the window, reduce its max-height to 10% of the window's
|
|||
|
|
height."
|
|||
|
|
(interactive "e")
|
|||
|
|
(let* ((pos (event-start event))
|
|||
|
|
(window (posn-window pos)))
|
|||
|
|
(with-selected-window window
|
|||
|
|
(ement-room-image-scale (posn-point pos)))))
|
|||
|
|
|
|||
|
|
(defun ement-room-image-scale (pos)
|
|||
|
|
"Toggle scale of image at POS.
|
|||
|
|
Scale image to fit the window body. If the image already fits
|
|||
|
|
the window body, reduce its max-height in accordance with user
|
|||
|
|
options `ement-room-image-thumbnail-height' and
|
|||
|
|
`ement-room-image-thumbnail-height-min'."
|
|||
|
|
(interactive "d")
|
|||
|
|
(pcase-let* ((image (get-text-property pos 'display))
|
|||
|
|
(max-height (image-property image :max-height))
|
|||
|
|
(xy (posn-x-y (posn-at-point pos)))
|
|||
|
|
(window-width (window-body-width nil t))
|
|||
|
|
(max-width (- window-width (car xy)))
|
|||
|
|
(window-height (window-body-height nil t))
|
|||
|
|
(use-window-body-size (not (and (numberp max-height)
|
|||
|
|
(= window-height max-height))))
|
|||
|
|
;; Image scaling commands set :max-height and friends to nil.
|
|||
|
|
;; See <https://github.com/alphapapa/ement.el/issues/39>.
|
|||
|
|
(new-height (if use-window-body-size
|
|||
|
|
window-height
|
|||
|
|
(max ement-room-image-thumbnail-height-min
|
|||
|
|
;; Emacs doesn't like floats as the max-height.
|
|||
|
|
(truncate (* window-height
|
|||
|
|
ement-room-image-thumbnail-height))))))
|
|||
|
|
(when (fboundp 'imagemagick-types)
|
|||
|
|
;; Only do this when ImageMagick is supported.
|
|||
|
|
;; FIXME: When requiring Emacs 27+, remove this (I guess?).
|
|||
|
|
(setf (image-property image :type) 'imagemagick))
|
|||
|
|
;; Set :scale to nil since image scaling commands might have changed it.
|
|||
|
|
(setf (image-property image :scale) nil
|
|||
|
|
(image-property image :max-width) max-width
|
|||
|
|
(image-property image :max-height) new-height)
|
|||
|
|
;; When maximising, eliminate all padding around the image, so that the line
|
|||
|
|
;; height will not exceed the window height. This prevents window scrolling
|
|||
|
|
;; issues. Set the window start to ensure the image is displayed in full.
|
|||
|
|
(if use-window-body-size
|
|||
|
|
(setf (image-property image :relief) nil
|
|||
|
|
(image-property image :margin) nil
|
|||
|
|
(window-start) pos)
|
|||
|
|
(setf (image-property image :relief) ement-room-image-relief
|
|||
|
|
(image-property image :margin) ement-room-image-margin))))
|
|||
|
|
|
|||
|
|
(defun ement-room-image-show-mouse (event)
|
|||
|
|
"Show image at mouse EVENT in a new buffer."
|
|||
|
|
(interactive "e")
|
|||
|
|
(let* ((pos (event-start event))
|
|||
|
|
(window (posn-window pos)))
|
|||
|
|
(with-selected-window window
|
|||
|
|
(ement-room-image-show (posn-point pos)))))
|
|||
|
|
|
|||
|
|
(defun ement-room-image-show (pos)
|
|||
|
|
"Show image at POS in a new buffer."
|
|||
|
|
(interactive "d")
|
|||
|
|
(pcase-let* ((image (copy-sequence (get-text-property pos 'display)))
|
|||
|
|
(ement-event (ewoc-data (ewoc-locate ement-ewoc pos)))
|
|||
|
|
((cl-struct ement-event id) ement-event)
|
|||
|
|
(buffer-name (format "*Ement image: %s*" id)))
|
|||
|
|
(when (fboundp 'imagemagick-types)
|
|||
|
|
;; Only do this when ImageMagick is supported.
|
|||
|
|
;; FIXME: When requiring Emacs 27+, remove this (I guess?).
|
|||
|
|
(setf (image-property image :type) 'imagemagick))
|
|||
|
|
(setf (image-property image :scale) 1.0
|
|||
|
|
(image-property image :max-width) nil
|
|||
|
|
(image-property image :max-height) nil)
|
|||
|
|
(unless (get-buffer buffer-name)
|
|||
|
|
(with-current-buffer (get-buffer-create buffer-name)
|
|||
|
|
(erase-buffer)
|
|||
|
|
(insert-image image)
|
|||
|
|
(image-mode)))
|
|||
|
|
(pop-to-buffer buffer-name
|
|||
|
|
'((display-buffer-pop-up-frame
|
|||
|
|
(pop-up-frame-parameters . ((fullscreen . t) (maximized . t))))))))
|
|||
|
|
|
|||
|
|
(cl-defun ement-room--image-download (event session &key then else (authenticatedp t))
|
|||
|
|
"Download image EVENT on SESSION and call THEN, else ELSE.
|
|||
|
|
If AUTHENTICATEDP, send authenticated request to new
|
|||
|
|
endpoint (Matrix 1.11, MSC3911); otherwise send old-style,
|
|||
|
|
unauthenticated request to old endpoint."
|
|||
|
|
(declare (indent defun))
|
|||
|
|
(pcase-let* (((cl-struct ement-event content) event)
|
|||
|
|
((map ('url mxc)) content))
|
|||
|
|
(ement--media-request mxc session :then then :else else
|
|||
|
|
:queue ement-images-queue :authenticatedp authenticatedp)))
|
|||
|
|
|
|||
|
|
(defun ement-room--format-m.image (event session)
|
|||
|
|
"Return \"m.image\" EVENT on SESSION formatted as a string.
|
|||
|
|
When `ement-room-images' is non-nil, also download it and then
|
|||
|
|
show it in the buffer."
|
|||
|
|
(pcase-let* (((cl-struct ement-event (local event-local)) event)
|
|||
|
|
;; HACK: Get the room's buffer from the variable (the current buffer
|
|||
|
|
;; will be a temp formatting buffer when this is called, but it still
|
|||
|
|
;; inherits the `ement-room' variable from the room buffer, thankfully).
|
|||
|
|
((cl-struct ement-room local) ement-room)
|
|||
|
|
((map buffer) local)
|
|||
|
|
;; TODO: Thumbnail support.
|
|||
|
|
((map image) event-local)
|
|||
|
|
(then (apply-partially #'ement-room--m.image-callback event ement-room))
|
|||
|
|
(else (lambda (plz-error)
|
|||
|
|
"Handle PLZ-ERROR for a failed request to download an image."
|
|||
|
|
(pcase-let* (((cl-struct plz-error response
|
|||
|
|
(message plz-message)
|
|||
|
|
(curl-error `(,curl-exit-code . ,curl-message)))
|
|||
|
|
plz-error)
|
|||
|
|
(status (when (plz-response-p response)
|
|||
|
|
(plz-response-status response)))
|
|||
|
|
(body (when (plz-response-p response)
|
|||
|
|
(plz-response-body response)))
|
|||
|
|
(json-object (when body
|
|||
|
|
(ignore-errors
|
|||
|
|
(json-read-from-string body))))
|
|||
|
|
(errcode (alist-get 'errcode json-object))
|
|||
|
|
(error-message (format "%S: %s"
|
|||
|
|
(or curl-exit-code status)
|
|||
|
|
(or (when json-object
|
|||
|
|
(alist-get 'error json-object))
|
|||
|
|
curl-message
|
|||
|
|
plz-message))))
|
|||
|
|
(pcase errcode
|
|||
|
|
("M_UNRECOGNIZED"
|
|||
|
|
;; Resend unauthenticated media request for older servers.
|
|||
|
|
;; FIXME: Test the "/versions" endpoint to see what's supported. See
|
|||
|
|
;; <https://matrix.org/blog/2024/06/20/matrix-v1.11-release/>.
|
|||
|
|
(ement-room--image-download event session :authenticatedp nil
|
|||
|
|
:then then))
|
|||
|
|
(_ (signal 'ement-api-error (list error-message))))))))
|
|||
|
|
(if (and ement-room-images image)
|
|||
|
|
;; Images enabled and image downloaded: create image and
|
|||
|
|
;; return it in a string.
|
|||
|
|
(condition-case err
|
|||
|
|
(let ((image (create-image image nil 'data-p :ascent 'center))
|
|||
|
|
(buffer-window (when buffer
|
|||
|
|
(get-buffer-window buffer)))
|
|||
|
|
max-height max-width)
|
|||
|
|
;; Calculate max image display size.
|
|||
|
|
(cond (ement-room-image-initial-height
|
|||
|
|
;; Use configured value.
|
|||
|
|
(setf max-height (max ement-room-image-thumbnail-height-min
|
|||
|
|
;; Emacs doesn't like floats as the max-height.
|
|||
|
|
(truncate
|
|||
|
|
(* (window-body-height buffer-window t)
|
|||
|
|
ement-room-image-initial-height)))
|
|||
|
|
max-width (window-body-width buffer-window t)))
|
|||
|
|
(buffer-window
|
|||
|
|
;; Buffer displayed: use window size.
|
|||
|
|
(setf max-height (window-body-height buffer-window t)
|
|||
|
|
max-width (window-body-width buffer-window t)))
|
|||
|
|
(t
|
|||
|
|
;; Buffer not displayed: use frame size.
|
|||
|
|
(setf max-height (frame-pixel-height)
|
|||
|
|
max-width (frame-pixel-width))))
|
|||
|
|
(when (fboundp 'imagemagick-types)
|
|||
|
|
;; Only do this when ImageMagick is supported.
|
|||
|
|
;; FIXME: When requiring Emacs 27+, remove this (I guess?).
|
|||
|
|
(setf (image-property image :type) 'imagemagick))
|
|||
|
|
(setf (image-property image :max-width) max-width
|
|||
|
|
(image-property image :max-height) max-height
|
|||
|
|
(image-property image :relief) ement-room-image-relief
|
|||
|
|
(image-property image :margin) ement-room-image-margin
|
|||
|
|
(image-property image :pointer) 'hand)
|
|||
|
|
(concat "\n"
|
|||
|
|
(ement-room-wrap-prefix " "
|
|||
|
|
'display image
|
|||
|
|
'keymap ement-room-image-keymap)))
|
|||
|
|
(error (format "\n [error inserting image: %s]" (error-message-string err))))
|
|||
|
|
;; Image not downloaded: insert URL as button, and download if enabled.
|
|||
|
|
(prog1
|
|||
|
|
(ement-room-wrap-prefix "[image]"
|
|||
|
|
'action (apply-partially #'apply #'ement-room--image-download)
|
|||
|
|
'button t
|
|||
|
|
'button-data (list event session
|
|||
|
|
:then (lambda (&rest args)
|
|||
|
|
;; Bind non-nil to force the image to be displayed.
|
|||
|
|
(let ((ement-room-images t))
|
|||
|
|
(apply then args)))
|
|||
|
|
:else else)
|
|||
|
|
'category t
|
|||
|
|
'face 'button
|
|||
|
|
'follow-link t
|
|||
|
|
'help-echo "Show image"
|
|||
|
|
'keymap button-map
|
|||
|
|
'mouse-face 'highlight)
|
|||
|
|
(when ement-room-images
|
|||
|
|
;; Images enabled: download it.
|
|||
|
|
(ement-room--image-download event session
|
|||
|
|
:then then :else else))))))
|
|||
|
|
|
|||
|
|
(defun ement-room--m.image-callback (event room data)
|
|||
|
|
"Add downloaded image from DATA to EVENT in ROOM.
|
|||
|
|
Then invalidate EVENT's node to show the image."
|
|||
|
|
(pcase-let* (((cl-struct ement-room (local (map buffer))) room))
|
|||
|
|
(setf (map-elt (ement-event-local event) 'image) data)
|
|||
|
|
(when (buffer-live-p buffer)
|
|||
|
|
(with-current-buffer buffer
|
|||
|
|
(if-let (node (ement-room--ewoc-last-matching ement-ewoc
|
|||
|
|
(lambda (node-data)
|
|||
|
|
(eq node-data event))))
|
|||
|
|
(ewoc-invalidate ement-ewoc node)
|
|||
|
|
;; This shouldn't happen, but very rarely, it can. I haven't figured out why
|
|||
|
|
;; yet, so checking whether a node is found rather than blindly calling
|
|||
|
|
;; `ewoc-invalidate' prevents an error from aborting event processing.
|
|||
|
|
(display-warning 'ement-room--m.image-callback
|
|||
|
|
(format "Event %S not found in room %S (a very rare, as-yet unexplained bug, which can be safely ignored; you may disconnect and reconnect if you wish, but it isn't strictly necessary)"
|
|||
|
|
(ement-event-id event)
|
|||
|
|
(ement-room-display-name room))))))))
|
|||
|
|
|
|||
|
|
(defun ement-room--format-m.file (event)
|
|||
|
|
"Return \"m.file\" EVENT formatted as a string."
|
|||
|
|
;; TODO: Insert thumbnail images when enabled.
|
|||
|
|
(pcase-let* (((cl-struct ement-event
|
|||
|
|
(content (map filename
|
|||
|
|
('info (map mimetype size))
|
|||
|
|
('url mxc-url))))
|
|||
|
|
event)
|
|||
|
|
(human-size (when size
|
|||
|
|
(file-size-human-readable size)))
|
|||
|
|
(string (format "[file: %s (%s) (%s)]" filename mimetype human-size)))
|
|||
|
|
(concat (propertize string
|
|||
|
|
'action #'call-interactively
|
|||
|
|
'button t
|
|||
|
|
'button-data #'ement-room-download-file
|
|||
|
|
'category t
|
|||
|
|
'face 'button
|
|||
|
|
'follow-link t
|
|||
|
|
'help-echo mxc-url
|
|||
|
|
'keymap button-map
|
|||
|
|
'mouse-face 'highlight)
|
|||
|
|
(propertize " "
|
|||
|
|
'display '(space :relative-height 1.5)))))
|
|||
|
|
|
|||
|
|
(defun ement-room--format-m.video (event)
|
|||
|
|
"Return \"m.video\" EVENT formatted as a string."
|
|||
|
|
;; TODO: Insert thumbnail images when enabled.
|
|||
|
|
(pcase-let* (((cl-struct ement-event
|
|||
|
|
(content (map body
|
|||
|
|
('info (map mimetype size w h))
|
|||
|
|
('url mxc-url))))
|
|||
|
|
event)
|
|||
|
|
(human-size (file-size-human-readable size))
|
|||
|
|
(string (format "[video: %s (%s) (%sx%s) (%s)]" body mimetype w h human-size)))
|
|||
|
|
(concat (propertize string
|
|||
|
|
'action #'call-interactively
|
|||
|
|
'button t
|
|||
|
|
'button-data #'ement-room-download-file
|
|||
|
|
'category t
|
|||
|
|
'face 'button
|
|||
|
|
'follow-link t
|
|||
|
|
'help-echo mxc-url
|
|||
|
|
'keymap button-map
|
|||
|
|
'mouse-face 'highlight)
|
|||
|
|
(propertize " "
|
|||
|
|
'display '(space :relative-height 1.5)))))
|
|||
|
|
|
|||
|
|
(defun ement-room--format-m.audio (event)
|
|||
|
|
"Return \"m.audio\" EVENT formatted as a string."
|
|||
|
|
(pcase-let* (((cl-struct ement-event
|
|||
|
|
(content (map body
|
|||
|
|
('info (map mimetype duration size))
|
|||
|
|
('url mxc-url))))
|
|||
|
|
event)
|
|||
|
|
(human-size (file-size-human-readable size))
|
|||
|
|
(human-duration (format-seconds "%m:%s" (/ duration 1000)))
|
|||
|
|
(string (format "[audio: %s (%s) (%s) (%s)]" body mimetype human-duration human-size)))
|
|||
|
|
(concat (propertize string
|
|||
|
|
'action #'ement-room-download-file
|
|||
|
|
'button t
|
|||
|
|
'button-data event
|
|||
|
|
'category t
|
|||
|
|
'face 'button
|
|||
|
|
'follow-link t
|
|||
|
|
'help-echo mxc-url
|
|||
|
|
'keymap button-map
|
|||
|
|
'mouse-face 'highlight)
|
|||
|
|
(propertize " "
|
|||
|
|
'display '(space :relative-height 1.5)))))
|
|||
|
|
|
|||
|
|
;;;;; Org format sending
|
|||
|
|
|
|||
|
|
;; Some of these declarations may need updating as Org changes.
|
|||
|
|
|
|||
|
|
(defvar org-export-with-toc)
|
|||
|
|
(defvar org-export-with-broken-links)
|
|||
|
|
(defvar org-export-with-section-numbers)
|
|||
|
|
(defvar org-export-with-sub-superscripts)
|
|||
|
|
(defvar org-html-inline-images)
|
|||
|
|
|
|||
|
|
(declare-function org-element-property "org-element")
|
|||
|
|
(declare-function org-export-data "ox")
|
|||
|
|
(declare-function org-export-get-caption "ox")
|
|||
|
|
(declare-function org-export-get-ordinal "ox")
|
|||
|
|
(declare-function org-export-get-reference "ox")
|
|||
|
|
(declare-function org-export-read-attribute "ox")
|
|||
|
|
(declare-function org-html--has-caption-p "ox-html")
|
|||
|
|
(declare-function org-html--textarea-block "ox-html")
|
|||
|
|
(declare-function org-html--translate "ox-html")
|
|||
|
|
(declare-function org-html-export-as-html "ox-html")
|
|||
|
|
(declare-function org-html-format-code "ox-html")
|
|||
|
|
|
|||
|
|
(defun ement-room-compose-org ()
|
|||
|
|
"Activate `org-mode' in current compose buffer.
|
|||
|
|
Configures the buffer appropriately so that saving it will export
|
|||
|
|
the Org buffer's contents."
|
|||
|
|
(interactive)
|
|||
|
|
(unless ement-room-compose-buffer
|
|||
|
|
(user-error "This command should be run in a compose buffer. Use `ement-room-compose-message' first"))
|
|||
|
|
;; Calling `org-mode' seems to wipe out local variables.
|
|||
|
|
(let ((room ement-room)
|
|||
|
|
(session ement-session))
|
|||
|
|
(org-mode)
|
|||
|
|
(ement-room-init-compose-buffer room session))
|
|||
|
|
(setq-local ement-room-send-message-filter #'ement-room-send-org-filter))
|
|||
|
|
|
|||
|
|
(defun ement-room-send-org-filter (content room)
|
|||
|
|
"Return event CONTENT for ROOM having processed its Org content.
|
|||
|
|
The CONTENT's body is exported with
|
|||
|
|
`org-html-export-as-html' (with some adjustments for
|
|||
|
|
compatibility), and the result is added to the CONTENT as
|
|||
|
|
\"formatted_body\"."
|
|||
|
|
(require 'ox-html)
|
|||
|
|
;; The CONTENT alist has string keys before being sent.
|
|||
|
|
(pcase-let* ((body (alist-get "body" content nil nil #'equal))
|
|||
|
|
(formatted-body
|
|||
|
|
(save-window-excursion
|
|||
|
|
(with-temp-buffer
|
|||
|
|
(insert (ement--format-body-mentions body room
|
|||
|
|
:template "[[https://matrix.to/#/%s][%s]]"))
|
|||
|
|
(cl-letf (((symbol-function 'org-html-src-block)
|
|||
|
|
(symbol-function 'ement-room--org-html-src-block)))
|
|||
|
|
(let ((org-export-with-toc nil)
|
|||
|
|
(org-export-with-broken-links t)
|
|||
|
|
(org-export-with-section-numbers nil)
|
|||
|
|
(org-export-with-sub-superscripts nil)
|
|||
|
|
(org-html-inline-images nil)
|
|||
|
|
(display-buffer-alist (cons '("^\\*Org HTML Export\\*$"
|
|||
|
|
. (display-buffer-no-window nil))
|
|||
|
|
display-buffer-alist)))
|
|||
|
|
(org-html-export-as-html nil nil nil 'body-only)))
|
|||
|
|
(with-current-buffer "*Org HTML Export*"
|
|||
|
|
(prog1 (string-trim (buffer-string))
|
|||
|
|
(kill-buffer)))))))
|
|||
|
|
(setf (alist-get "formatted_body" content nil nil #'equal) formatted-body
|
|||
|
|
(alist-get "format" content nil nil #'equal) "org.matrix.custom.html")
|
|||
|
|
content))
|
|||
|
|
|
|||
|
|
(defun ement-room--org-html-src-block (src-block _contents info)
|
|||
|
|
"Transcode a SRC-BLOCK element from Org to HTML.
|
|||
|
|
CONTENTS holds the contents of the item. INFO is a plist holding
|
|||
|
|
contextual information.
|
|||
|
|
|
|||
|
|
This is a copy of `org-html-src-block' that uses Riot
|
|||
|
|
Web-compatible HTML output, using HTML like:
|
|||
|
|
|
|||
|
|
<pre><code class=\"language-python\">..."
|
|||
|
|
(if (org-export-read-attribute :attr_html src-block :textarea)
|
|||
|
|
(org-html--textarea-block src-block)
|
|||
|
|
(let ((lang (pcase (org-element-property :language src-block)
|
|||
|
|
;; Riot's syntax coloring doesn't support "elisp", but "lisp" works.
|
|||
|
|
("elisp" "lisp")
|
|||
|
|
(else else)))
|
|||
|
|
(code (org-html-format-code src-block info))
|
|||
|
|
(label (let ((lbl (and (org-element-property :name src-block)
|
|||
|
|
(org-export-get-reference src-block info))))
|
|||
|
|
(if lbl (format " id=\"%s\"" lbl) ""))))
|
|||
|
|
(if (not lang) (format "<pre class=\"example\"%s>\n%s</pre>" label code)
|
|||
|
|
(format "<div class=\"org-src-container\">\n%s%s\n</div>"
|
|||
|
|
;; Build caption.
|
|||
|
|
(let ((caption (org-export-get-caption src-block)))
|
|||
|
|
(if (not caption) ""
|
|||
|
|
(let ((listing-number
|
|||
|
|
(format
|
|||
|
|
"<span class=\"listing-number\">%s </span>"
|
|||
|
|
(format
|
|||
|
|
(org-html--translate "Listing %d:" info)
|
|||
|
|
(org-export-get-ordinal
|
|||
|
|
src-block info nil #'org-html--has-caption-p)))))
|
|||
|
|
(format "<label class=\"org-src-name\">%s%s</label>"
|
|||
|
|
listing-number
|
|||
|
|
(string-trim (org-export-data caption info))))))
|
|||
|
|
;; Contents.
|
|||
|
|
(format "<pre><code class=\"src language-%s\"%s>%s</code></pre>"
|
|||
|
|
lang label code))))))
|
|||
|
|
|
|||
|
|
;;;;; Completion
|
|||
|
|
|
|||
|
|
;; Completing member and room names.
|
|||
|
|
|
|||
|
|
(defun ement-room--complete-members-at-point ()
|
|||
|
|
"Complete member names and IDs at point.
|
|||
|
|
Uses members in the current buffer's room. For use in
|
|||
|
|
`completion-at-point-functions'."
|
|||
|
|
(let ((beg (save-excursion
|
|||
|
|
(when (re-search-backward (rx (or bol bos blank)) nil t)
|
|||
|
|
(skip-syntax-forward "-")
|
|||
|
|
(point))))
|
|||
|
|
(end (point))
|
|||
|
|
(collection-fn (completion-table-dynamic
|
|||
|
|
;; The manual seems to show the FUN ignoring any
|
|||
|
|
;; arguments, but the `completion-table-dynamic' docstring
|
|||
|
|
;; seems to say that it should use the argument.
|
|||
|
|
(lambda (_ignore)
|
|||
|
|
(ement-room--member-names-and-ids)))))
|
|||
|
|
(when beg
|
|||
|
|
(list beg end collection-fn :exclusive 'no))))
|
|||
|
|
|
|||
|
|
(defun ement-room--complete-rooms-at-point ()
|
|||
|
|
"Complete room aliases and IDs at point.
|
|||
|
|
For use in `completion-at-point-functions'."
|
|||
|
|
(let ((beg (save-excursion
|
|||
|
|
(when (re-search-backward (rx (or bol bos blank) (or "!" "#")) nil t)
|
|||
|
|
(skip-syntax-forward "-")
|
|||
|
|
(point))))
|
|||
|
|
(end (point))
|
|||
|
|
(collection-fn (completion-table-dynamic
|
|||
|
|
;; The manual seems to show the FUN ignoring any
|
|||
|
|
;; arguments, but the `completion-table-dynamic' docstring
|
|||
|
|
;; seems to say that it should use the argument.
|
|||
|
|
(lambda (_ignore)
|
|||
|
|
(ement-room--room-aliases-and-ids)))))
|
|||
|
|
(when beg
|
|||
|
|
(list beg end collection-fn :exclusive 'no))))
|
|||
|
|
|
|||
|
|
;; TODO: Use `cl-pushnew' in these two functions instead of `delete-dups'.
|
|||
|
|
|
|||
|
|
(defun ement-room--member-names-and-ids ()
|
|||
|
|
"Return a list of member names and IDs seen in current room.
|
|||
|
|
If room's `members' table is filled, use it; otherwise, fetch
|
|||
|
|
members list and return already-seen members instead. For use in
|
|||
|
|
`completion-at-point-functions'."
|
|||
|
|
;; For now, we just collect a list of members from events we've seen.
|
|||
|
|
;; TODO: In the future, we may maintain a per-room table of members, which
|
|||
|
|
;; would be more suitable for completing names according to the spec.
|
|||
|
|
(pcase-let* ((room (if (minibufferp)
|
|||
|
|
(buffer-local-value
|
|||
|
|
'ement-room (window-buffer (minibuffer-selected-window)))
|
|||
|
|
ement-room))
|
|||
|
|
(session (if (minibufferp)
|
|||
|
|
(buffer-local-value
|
|||
|
|
'ement-session (window-buffer (minibuffer-selected-window)))
|
|||
|
|
ement-session))
|
|||
|
|
((cl-struct ement-room members) room)
|
|||
|
|
(members (if (alist-get 'fetched-members-p (ement-room-local room))
|
|||
|
|
(hash-table-values members)
|
|||
|
|
;; HACK: Members table empty: update list and use known events
|
|||
|
|
;; for now.
|
|||
|
|
(ement-singly (alist-get 'getting-members-p (ement-room-local room))
|
|||
|
|
(ement--get-joined-members room session
|
|||
|
|
:then (lambda (_) (setf (alist-get 'getting-members-p (ement-room-local room)) nil))
|
|||
|
|
:else (lambda (_) (setf (alist-get 'getting-members-p (ement-room-local room)) nil))))
|
|||
|
|
(mapcar #'ement-event-sender
|
|||
|
|
(ement-room-timeline ement-room)))))
|
|||
|
|
(delete-dups
|
|||
|
|
(cl-loop for member in members
|
|||
|
|
collect (ement-user-id member)
|
|||
|
|
collect (ement--user-displayname-in room member)))))
|
|||
|
|
|
|||
|
|
(defun ement-room--room-aliases-and-ids ()
|
|||
|
|
"Return a list of room names and aliases seen in current session.
|
|||
|
|
For use in `completion-at-point-functions'."
|
|||
|
|
(let* ((session (if (minibufferp)
|
|||
|
|
(buffer-local-value
|
|||
|
|
'ement-session (window-buffer (minibuffer-selected-window)))
|
|||
|
|
ement-session)))
|
|||
|
|
(delete-dups
|
|||
|
|
(delq nil (cl-loop for room in (ement-session-rooms session)
|
|||
|
|
collect (ement-room-id room)
|
|||
|
|
collect (ement-room-canonical-alias room))))))
|
|||
|
|
|
|||
|
|
;;;;; Transient
|
|||
|
|
|
|||
|
|
(require 'transient)
|
|||
|
|
|
|||
|
|
(transient-define-prefix ement-room-transient ()
|
|||
|
|
"Transient for Ement Room buffers."
|
|||
|
|
[:pad-keys t
|
|||
|
|
["Movement"
|
|||
|
|
("TAB" "Next event" ement-room-goto-next)
|
|||
|
|
("<backtab>" "Previous event" ement-room-goto-prev)
|
|||
|
|
("SPC" "Scroll up and mark read" ement-room-scroll-up-mark-read)
|
|||
|
|
("S-SPC" "Scroll down" ement-room-scroll-down-command)
|
|||
|
|
("M-SPC" "Jump to fully-read marker" ement-room-goto-fully-read-marker)
|
|||
|
|
("m" "Move read markers to point" ement-room-mark-read)]
|
|||
|
|
["Switching"
|
|||
|
|
("M-g M-l" "List rooms" ement-room-list)
|
|||
|
|
("M-g M-r" "Switch to other room" ement-view-room)
|
|||
|
|
("M-g M-m" "Switch to mentions buffer" ement-notify-switch-to-mentions-buffer)
|
|||
|
|
("M-g M-n" "Switch to notifications buffer" ement-notify-switch-to-notifications-buffer)
|
|||
|
|
("q" "Quit window" quit-window)]]
|
|||
|
|
[:pad-keys t
|
|||
|
|
["Messages"
|
|||
|
|
("c" "Composition format" ement-room-set-composition-format
|
|||
|
|
:description (lambda ()
|
|||
|
|
(concat "Composition format: "
|
|||
|
|
(propertize (car (cl-rassoc ement-room-send-message-filter
|
|||
|
|
(list (cons "Plain-text" nil)
|
|||
|
|
(cons "Org-mode" 'ement-room-send-org-filter))
|
|||
|
|
:test #'equal))
|
|||
|
|
'face 'transient-value))))
|
|||
|
|
("RET" "Write message" ement-room-dispatch-new-message)
|
|||
|
|
("M-RET" "Write message (alternative)" ement-room-dispatch-new-message-alt)
|
|||
|
|
("S-<return>" "Write reply" ement-room-dispatch-reply-to-message)
|
|||
|
|
("<insert>" "Edit message" ement-room-dispatch-edit-message)
|
|||
|
|
("C-k" "Delete message" ement-room-delete-message)
|
|||
|
|
("s r" "Send reaction" ement-room-send-reaction)
|
|||
|
|
("s e" "Send emote" ement-room-send-emote)
|
|||
|
|
("s f" "Send file" ement-room-send-file)
|
|||
|
|
("s i" "Send image" ement-room-send-image)
|
|||
|
|
("D" "Download event media" ement-room-download-file)]
|
|||
|
|
["Users"
|
|||
|
|
("u RET" "Send direct message" ement-send-direct-message)
|
|||
|
|
("u i" "Invite user" ement-invite-user)
|
|||
|
|
("u I" "Ignore user" ement-ignore-user)]]
|
|||
|
|
[:pad-keys t
|
|||
|
|
["Room"
|
|||
|
|
("M-s o" "Occur search in room" ement-room-occur)
|
|||
|
|
("r d" "Describe room" ement-describe-room)
|
|||
|
|
("r m" "List members" ement-list-members)
|
|||
|
|
("r t" "Set topic" ement-room-set-topic)
|
|||
|
|
("r f" "Set message format" ement-room-set-message-format)
|
|||
|
|
("r N" "Override name" ement-room-override-name
|
|||
|
|
:description (lambda ()
|
|||
|
|
(format "Name override: %s"
|
|||
|
|
(if-let* ((event (alist-get "org.matrix.msc3015.m.room.name.override"
|
|||
|
|
(ement-room-account-data ement-room) nil nil #'equal))
|
|||
|
|
(name (map-nested-elt event '(content name))))
|
|||
|
|
(propertize name 'face 'transient-value)
|
|||
|
|
(propertize "none" 'face 'transient-inactive-value)))))
|
|||
|
|
("r n" "Set notification state" ement-room-set-notification-state
|
|||
|
|
:description (lambda ()
|
|||
|
|
(let ((state (ement-room-notification-state ement-room ement-session)))
|
|||
|
|
(format "Notifications (%s|%s|%s|%s|%s)"
|
|||
|
|
(propertize "default"
|
|||
|
|
'face (pcase state
|
|||
|
|
(`nil 'transient-value)
|
|||
|
|
(_ 'transient-inactive-value)))
|
|||
|
|
(propertize "all-loud"
|
|||
|
|
'face (pcase state
|
|||
|
|
('all-loud 'transient-value)
|
|||
|
|
(_ 'transient-inactive-value)))
|
|||
|
|
(propertize "all"
|
|||
|
|
'face (pcase state
|
|||
|
|
('all 'transient-value)
|
|||
|
|
(_ 'transient-inactive-value)))
|
|||
|
|
(propertize "mentions"
|
|||
|
|
'face (pcase state
|
|||
|
|
('mentions-and-keywords 'transient-value)
|
|||
|
|
(_ 'transient-inactive-value)))
|
|||
|
|
(propertize "none"
|
|||
|
|
'face (pcase state
|
|||
|
|
('none 'transient-value)
|
|||
|
|
(_ 'transient-inactive-value)))))))
|
|||
|
|
("r T" "Tag/untag room" ement-tag-room
|
|||
|
|
:description (lambda ()
|
|||
|
|
(format "Tag/untag room (%s|%s)"
|
|||
|
|
(propertize "Fav"
|
|||
|
|
'face (if (ement--room-tagged-p "m.favourite" ement-room)
|
|||
|
|
'transient-value 'transient-inactive-value))
|
|||
|
|
(propertize "Low-prio"
|
|||
|
|
'face (if (ement--room-tagged-p "m.lowpriority" ement-room)
|
|||
|
|
'transient-value 'transient-inactive-value)))))]
|
|||
|
|
["Room membership"
|
|||
|
|
("R c" "Create room" ement-create-room)
|
|||
|
|
("R j" "Join room" ement-join-room)
|
|||
|
|
("R l" "Leave room" ement-leave-room)
|
|||
|
|
("R F" "Forget room" ement-forget-room)
|
|||
|
|
("R n" "Set nick" ement-room-set-display-name
|
|||
|
|
:description (lambda ()
|
|||
|
|
(format "Set nick (%s)"
|
|||
|
|
(propertize (ement--user-displayname-in
|
|||
|
|
ement-room (gethash (ement-user-id (ement-session-user ement-session))
|
|||
|
|
ement-users))
|
|||
|
|
'face 'transient-value))))
|
|||
|
|
("R s" "Toggle spaces" ement-room-toggle-space
|
|||
|
|
:description (lambda ()
|
|||
|
|
(format "Toggle spaces (%s)"
|
|||
|
|
(if-let ((spaces (ement--room-spaces ement-room ement-session)))
|
|||
|
|
(string-join
|
|||
|
|
(mapcar (lambda (space)
|
|||
|
|
(propertize (ement-room-display-name space)
|
|||
|
|
'face 'transient-value))
|
|||
|
|
spaces)
|
|||
|
|
", ")
|
|||
|
|
(propertize "none" 'face 'transient-inactive-value)))))]]
|
|||
|
|
["Other"
|
|||
|
|
("v" "View event" ement-room-view-event)
|
|||
|
|
("g" "Sync new messages" ement-room-sync
|
|||
|
|
:if (lambda ()
|
|||
|
|
(interactive)
|
|||
|
|
(or (not ement-auto-sync)
|
|||
|
|
(not (map-elt ement-syncs ement-session)))))])
|
|||
|
|
|
|||
|
|
;;;; Browsing URLs, EWW
|
|||
|
|
|
|||
|
|
(defun ement-room-browse-mxc (mxc)
|
|||
|
|
;; TODO: If prefix arg, prompt for destination and download to file.
|
|||
|
|
"Browse MXC URL on current `ement-session'."
|
|||
|
|
;; For authenticated media, we have to provide our own version of `eww-retrieve'.
|
|||
|
|
(let ((session ement-session))
|
|||
|
|
(cl-letf (((symbol-function 'eww-retrieve)
|
|||
|
|
(lambda (mxc callback cbargs)
|
|||
|
|
(ement--media-request mxc session
|
|||
|
|
:as (lambda ()
|
|||
|
|
;; EWW wants to parse the headers itself, so widen and decode them.
|
|||
|
|
(widen)
|
|||
|
|
(decode-coding-region (point-min) (point) 'utf-8)
|
|||
|
|
;; HACK: This STATUS argument to `eww-render' is bogus.
|
|||
|
|
(apply callback 'status cbargs))))))
|
|||
|
|
(eww-browse-url mxc))))
|
|||
|
|
|
|||
|
|
;;;; Downloading media/files
|
|||
|
|
|
|||
|
|
;; We load `eww' to define this variable on-demand.
|
|||
|
|
(defvar eww-download-directory)
|
|||
|
|
|
|||
|
|
(defun ement-room-download-file (event destination)
|
|||
|
|
"Download EVENT's file to DESTINATION.
|
|||
|
|
If DESTINATION is a directory, use the file's default name;
|
|||
|
|
otherwise, download to the filename. Interactively, download to
|
|||
|
|
`eww-download-directory'; with prefix, prompt for destination."
|
|||
|
|
(interactive (progn
|
|||
|
|
(require 'eww)
|
|||
|
|
(list (ement-room--event-at (point))
|
|||
|
|
(if current-prefix-arg
|
|||
|
|
(expand-file-name
|
|||
|
|
(read-file-name
|
|||
|
|
"Download to: "
|
|||
|
|
(cl-typecase eww-download-directory
|
|||
|
|
(string eww-download-directory)
|
|||
|
|
(function (funcall eww-download-directory)))))
|
|||
|
|
(expand-file-name
|
|||
|
|
(cl-typecase eww-download-directory
|
|||
|
|
(string eww-download-directory)
|
|||
|
|
(function (funcall eww-download-directory))))))))
|
|||
|
|
(pcase-let* (((cl-struct ement-event
|
|||
|
|
(content (map ('filename event-filename) ('url mxc-url)
|
|||
|
|
body)))
|
|||
|
|
event)
|
|||
|
|
(started-at (current-time))
|
|||
|
|
(filename (if (not event-filename)
|
|||
|
|
body
|
|||
|
|
(if (equal body event-filename)
|
|||
|
|
body
|
|||
|
|
event-filename))))
|
|||
|
|
(when (file-directory-p destination)
|
|||
|
|
(unless (file-exists-p destination)
|
|||
|
|
(make-directory destination 'parents))
|
|||
|
|
(setf destination (file-name-concat destination filename)))
|
|||
|
|
(unless (file-writable-p destination)
|
|||
|
|
;; FIXME: Pressing "C-u" before clicking a download link doesn't work.
|
|||
|
|
(user-error "Destination path not writable: %S (Call with prefix to prompt for filename)"
|
|||
|
|
destination))
|
|||
|
|
(when (file-exists-p destination)
|
|||
|
|
(user-error "File already exists: %S (Call with prefix to prompt for filename)" destination))
|
|||
|
|
;; TODO: For bonus points, provide a way to cancel a download (otherwise the user
|
|||
|
|
;; would have to use `list-processes' and find the right one to delete), and to see
|
|||
|
|
;; progress (perhaps borrowing some of the relevant code in hyperdrive.el).
|
|||
|
|
(ement--media-request mxc-url ement-session :authenticatedp t
|
|||
|
|
:as `(file ,destination)
|
|||
|
|
:then (lambda (&rest _)
|
|||
|
|
(let* ((file-size (file-attribute-size
|
|||
|
|
(file-attributes destination)))
|
|||
|
|
(duration (float-time (time-subtract (current-time) started-at)))
|
|||
|
|
(speed (file-size-human-readable (/ file-size duration))))
|
|||
|
|
(message "File downloaded: %S (%s in %s at %s/sec) "
|
|||
|
|
destination (file-size-human-readable file-size)
|
|||
|
|
(format-seconds "%h:%m:%s%z seconds" duration)
|
|||
|
|
speed))))
|
|||
|
|
(message "Downloading to %S..." destination)))
|
|||
|
|
|
|||
|
|
;;;; Footer
|
|||
|
|
|
|||
|
|
(provide 'ement-room)
|
|||
|
|
|
|||
|
|
;;; ement-room.el ends here
|