;;; ement-room.el --- Ement room buffers -*- lexical-binding: t; -*- ;; Copyright (C) 2022-2023 Free Software Foundation, Inc. ;; Author: Adam Porter ;; Maintainer: Adam Porter ;; 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 . ;;; 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 "") #'forward-button) (define-key map (kbd "") #'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-") #'ement-room-dispatch-reply-to-message) (define-key map (kbd "") #'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 . "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 ;; ), 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-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: (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 ." (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 ;; . (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 ;; 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. . (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 ;; and ;; . (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 . (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 ;; . (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: 
..."
  (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 "
\n%s
" label code)
	(format "
\n%s%s\n
"
		;; Build caption.
		(let ((caption (org-export-get-caption src-block)))
		  (if (not caption) ""
		    (let ((listing-number
			   (format
			    "%s "
			    (format
			     (org-html--translate "Listing %d:" info)
			     (org-export-get-ordinal
			      src-block info nil #'org-html--has-caption-p)))))
		      (format ""
			      listing-number
			      (string-trim (org-export-data caption info))))))
		;; Contents.
		(format "
%s
"
			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)
              ("" "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-" "Write reply" ement-room-dispatch-reply-to-message)
              ("" "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