diff options
| author | Arto Jantunen <viiru@debian.org> | 2023-09-15 06:58:27 +0300 |
|---|---|---|
| committer | Arto Jantunen <viiru@debian.org> | 2023-09-15 06:58:27 +0300 |
| commit | 5f1aa8cced4634bce06e68dbf6de9ed1fb43dc3a (patch) | |
| tree | 48cff02b1fc8cb396e1e1626de0dc8956bc9673a | |
| parent | 0966788b65e45b418b4f69dc046af17cea876bf8 (diff) | |
| parent | a4fc3d1ab6df424bc1296b8ca480a8c55c542dc2 (diff) | |
Merge tag 'v0.12'
Release: v0.12
| -rw-r--r-- | .github/ISSUE_TEMPLATE/bug_report.yml | 71 | ||||
| -rw-r--r-- | .github/ISSUE_TEMPLATE/config.yml | 1 | ||||
| -rw-r--r-- | README.org | 29 | ||||
| -rw-r--r-- | ement-api.el | 2 | ||||
| -rw-r--r-- | ement-directory.el | 42 | ||||
| -rw-r--r-- | ement-lib.el | 487 | ||||
| -rw-r--r-- | ement-macros.el | 2 | ||||
| -rw-r--r-- | ement-notifications.el | 272 | ||||
| -rw-r--r-- | ement-notify.el | 100 | ||||
| -rw-r--r-- | ement-room-list.el | 138 | ||||
| -rw-r--r-- | ement-room.el | 539 | ||||
| -rw-r--r-- | ement-structs.el | 2 | ||||
| -rw-r--r-- | ement-tabulated-room-list.el | 2 | ||||
| -rw-r--r-- | ement.el | 328 |
14 files changed, 1220 insertions, 795 deletions
diff --git a/.github/ISSUE_TEMPLATE/bug_report.yml b/.github/ISSUE_TEMPLATE/bug_report.yml new file mode 100644 index 0000000..f9d9462 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/bug_report.yml @@ -0,0 +1,71 @@ +name: Bug Report +description: File a bug report +labels: ["bug"] +assignees: + - alphapapa +body: + - type: markdown + attributes: + value: | + Thanks for taking the time to fill out this bug report! + - type: input + id: os-platform + attributes: + label: OS/platform + description: What operating system or platform are you running Emacs on? + validations: + required: true + - type: textarea + id: emacs-provenance + attributes: + label: Emacs version and provenance + description: What version of Emacs are you using, where did you acquire it, and how did you install it? + validations: + required: true + - type: input + id: emacs-command + attributes: + label: Emacs command + description: By what method did you run Emacs? (i.e. what command did you run?) + validations: + required: true + - type: input + id: emacs-frame + attributes: + label: Emacs frame type + description: Did the problem happen on a GUI or tty Emacs frame? + validations: + required: true + - type: textarea + id: actions + attributes: + label: Actions taken + description: What actions did you take, step-by-step, in order, before the problem was noticed? + validations: + required: true + - type: textarea + id: results + attributes: + label: Results + description: What behavior did you observe that seemed wrong? + validations: + required: true + - type: textarea + id: expected + attributes: + label: Expected results + description: What behavior did you expect to observe? + validations: + required: true + - type: textarea + id: backtrace + attributes: + label: Backtrace + description: If an error was signaled, please use `M-x toggle-debug-on-error RET` and cause the error to happen again, then paste the contents of the `*Backtrace*` buffer here. + render: elisp + - type: textarea + id: etc + attributes: + label: Etc. + description: Any other information that seems relevant + diff --git a/.github/ISSUE_TEMPLATE/config.yml b/.github/ISSUE_TEMPLATE/config.yml new file mode 100644 index 0000000..0086358 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/config.yml @@ -0,0 +1 @@ +blank_issues_enabled: true @@ -168,11 +168,11 @@ These bindings are common to all of the following buffer types: *Movement* -+ Next event: ~TAB~ -+ Previous event: ~<backtab>~ ++ Next event: ~n~ ++ Previous event: ~p~ + Scroll up and mark read: ~SPC~ + Scroll down: ~S-SPC~ -+ Jump to fully-read marker: ~M-SPC~ ++ Jump to fully-read marker: ~M-g M-p~ + Move read markers to point: ~m~ + Load older messages: at top of buffer, scroll contents up (i.e. ~S-SPC~, ~M-v~ or ~mwheel-scroll~) @@ -292,6 +292,29 @@ Ement.el doesn't support encrypted rooms natively, but it can be used transparen :TOC: :depth 0 :END: +** 0.12 + +*Additions* + ++ Command ~ement-notifications~ shows recent notifications, similar to the pane in the Element client. (This new command fetches recent notifications from the server and allows scrolling up to retrieve older ones. Newly received notifications, as configured in the ~ement-notify~ options, are displayed in the same buffer. This functionality will be consolidated in the future.) ++ Face ~ement-room-quote~, applied to quoted parts of replies. + +*Changes* ++ Commands ~ement-room-goto-next~ and ~ement-room-goto-prev~ work more usefully at the end of a room buffer. (Now pressing ~n~ on the last event moves point to the end of the buffer so it will scroll automatically for new messages, and then pressing ~p~ skips over any read marker to the last event.) ++ Room buffer bindings: + + ~ement-room-goto-next~ and ~ement-room-goto-prev~ are bound to ~n~ and ~p~, respectively. + + ~ement-room-goto-fully-read-marker~ is bound to ~M-g M-p~ (the mnemonic being "go to previously read"). ++ The quoted part of a reply now omits the face applied to the rest of the message, helping to distinguish them. ++ Commands that read a string from the minibuffer in ~ement-room~ buffers and ~ement-connect~ user ID prompts use separate history list variables. ++ Use Emacs's Jansson-based JSON-parsing functions when available. (This results in a 3-5x speed improvement for parsing JSON responses, which can be significant for large initial sync responses. Thanks to [[https://github.com/rrix/][Ryan Rix]] for discovering this!) + +*Fixes* + ++ File event formatter assumed that file size metadata would be present (a malformed, e.g. spam, event might not have it). ++ Send correct file size when sending files/images. ++ Underscores are no longer interpreted as denoting subscripts when sending messages in Org format. (Thanks to [[https://github.com/phil-s][Phil Sainty]].) ++ Add workaround for ~savehist-mode~'s serializing of the ~command-history~ variable's arguments. (For ~ement-~ commands, that may include large data structures, like ~ement-session~ structs, which should never be serialized or reused, and ~savehist~'s doing so could cause noticeable delays for users who enabled it). (See [[https://github.com/alphapapa/ement.el/issues/216][#216]]. Thanks to [[https://github.com/phil-s][Phil Sainty]] and other users who helped to discover this problem.) + ** 0.11 *Additions* diff --git a/ement-api.el b/ement-api.el index db2f66f..ff8054c 100644 --- a/ement-api.el +++ b/ement-api.el @@ -1,6 +1,6 @@ ;;; ement-api.el --- Matrix API library -*- lexical-binding: t; -*- -;; Copyright (C) 2022 Free Software Foundation, Inc. +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. ;; Author: Adam Porter <adam@alphapapa.net> ;; Maintainer: Adam Porter <adam@alphapapa.net> diff --git a/ement-directory.el b/ement-directory.el index 197ae49..5a7b596 100644 --- a/ement-directory.el +++ b/ement-directory.el @@ -1,6 +1,6 @@ ;;; ement-directory.el --- Public room directory support -*- lexical-binding: t; -*- -;; Copyright (C) 2022 Free Software Foundation, Inc. +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. ;; Author: Adam Porter <adam@alphapapa.net> ;; Maintainer: Adam Porter <adam@alphapapa.net> @@ -296,31 +296,31 @@ APPEND-P, add ROOMS to buffer rather than replacing existing contents. To be called by `ement-directory-search'." (declare (indent defun)) (let (column-sizes window-start) - (cl-labels ((format-item - ;; NOTE: We use the buffer-local variable `ement-directory-etc' rather - ;; than a closure variable because the taxy-magit-section struct's format - ;; table is not stored in it, and we can't reuse closures' variables. - ;; (It would be good to store the format table in the taxy-magit-section - ;; in the future, to make this cleaner.) - (item) (gethash item (alist-get 'format-table ement-directory-etc))) + (cl-labels ((format-item (item) + ;; NOTE: We use the buffer-local variable `ement-directory-etc' rather + ;; than a closure variable because the taxy-magit-section struct's format + ;; table is not stored in it, and we can't reuse closures' variables. + ;; (It would be good to store the format table in the taxy-magit-section + ;; in the future, to make this cleaner.) + (gethash item (alist-get 'format-table ement-directory-etc))) ;; NOTE: Since these functions take an "item" (which is a [room session] ;; vector), they're prefixed "item-" rather than "room-". - (size - (item) (pcase-let (((map ('num_joined_members size)) item)) - size)) + (size (item) + (pcase-let (((map ('num_joined_members size)) item)) + size)) (t<nil (a b) (and a (not b))) (t>nil (a b) (and (not a) b)) (make-fn (&rest args) - (apply #'make-taxy-magit-section - :make #'make-fn - :format-fn #'format-item - ;; FIXME: Should we reuse `ement-room-list-level-indent' here? - :level-indent ement-room-list-level-indent - ;; :visibility-fn #'visible-p - ;; :heading-indent 2 - :item-indent 2 - ;; :heading-face-fn #'heading-face - args))) + (apply #'make-taxy-magit-section + :make #'make-fn + :format-fn #'format-item + ;; FIXME: Should we reuse `ement-room-list-level-indent' here? + :level-indent ement-room-list-level-indent + ;; :visibility-fn #'visible-p + ;; :heading-indent 2 + :item-indent 2 + ;; :heading-face-fn #'heading-face + args))) (with-current-buffer (get-buffer-create buffer-name) (unless (eq 'ement-directory-mode major-mode) ;; Don't obliterate buffer-local variables. diff --git a/ement-lib.el b/ement-lib.el index ad75bf7..bf9d7b7 100644 --- a/ement-lib.el +++ b/ement-lib.el @@ -1,6 +1,6 @@ ;;; ement-lib.el --- Library of Ement functions -*- lexical-binding: t; -*- -;; Copyright (C) 2022 Free Software Foundation, Inc. +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. ;; Author: Adam Porter <adam@alphapapa.net> ;; Maintainer: Adam Porter <adam@alphapapa.net> @@ -92,6 +92,23 @@ that stray such forms don't remain if the function is removed." ;; These workarounds should be removed when they aren't needed. +(defalias 'ement--json-parse-buffer + ;; For non-libjansson builds (those that do have libjansson will see a 4-5x improvement + ;; in the time needed to parse JSON responses). + + ;; TODO: Suggest mentioning in manual and docstrings that `json-read', et al do not use + ;; libjansson, while `json-parse-buffer', et al do. + (if (fboundp 'json-parse-buffer) + (lambda () + (condition-case err + (json-parse-buffer :object-type 'alist :null-object nil :false-object :json-false) + (json-parse-error + (ement-message "`json-parse-buffer' signaled `json-parse-error'; falling back to `json-read'... (%S)" + (error-message-string err)) + (goto-char (point-min)) + (json-read)))) + 'json-read)) + ;;;;; Emacs 28 color features. ;; Copied from Emacs 28. See <https://github.com/alphapapa/ement.el/issues/99>. @@ -155,8 +172,7 @@ include with the request (see Matrix spec)." :alias (read-string "New room alias (e.g. \"foo\" for \"#foo:matrix.org\"): ") :topic (read-string "New room topic: ") :visibility (completing-read "New room visibility: " '(private public)))) - (cl-labels ((given-p - (var) (and var (not (string-empty-p var))))) + (cl-labels ((given-p (var) (and var (not (string-empty-p var))))) (pcase-let* ((endpoint "createRoom") (data (ement-aprog1 (ement-alist "visibility" visibility) @@ -402,14 +418,14 @@ new one automatically if necessary." (ement-with-room-and-session (let* ((prompt (format "Toggle tag (%s): " (ement--format-room ement-room))) (default-tags - (ement-alist (propertize "Favourite" - 'face (when (ement--room-tagged-p "m.favourite" ement-room) - 'transient-value)) - "m.favourite" - (propertize "Low-priority" - 'face (when (ement--room-tagged-p "m.lowpriority" ement-room) - 'transient-value)) - "m.lowpriority")) + (ement-alist (propertize "Favourite" + 'face (when (ement--room-tagged-p "m.favourite" ement-room) + 'transient-value)) + "m.favourite" + (propertize "Low-priority" + 'face (when (ement--room-tagged-p "m.lowpriority" ement-room) + 'transient-value)) + "m.lowpriority")) (input (completing-read prompt default-tags)) (tag (alist-get input default-tags (concat "u." input) nil #'string=))) (list tag ement-room ement-session)))) @@ -493,11 +509,11 @@ Interactively, with prefix, prompt for room and session, otherwise use current room." (interactive (ement-with-room-and-session (list ement-room ement-session))) (cl-labels ((heading (string) - (propertize (or string "") 'face 'font-lock-builtin-face)) + (propertize (or string "") 'face 'font-lock-builtin-face)) (id (string) - (propertize (or string "") 'face 'font-lock-constant-face)) + (propertize (or string "") 'face 'font-lock-constant-face)) (member< - (a b) (string-collate-lessp (car a) (car b) nil t))) + (a b) (string-collate-lessp (car a) (car b) nil t))) (pcase-let* (((cl-struct ement-room (id room-id) avatar display-name canonical-alias members timeline status topic (local (map fetched-members-p))) room) @@ -584,31 +600,31 @@ Returns one of nil (meaning default rules are used), `all-loud', (let ((push-rules (cl-find-if (lambda (alist) (equal "m.push_rules" (alist-get 'type alist))) (ement-session-account-data session)))) - (cl-labels ((override-mute-rule-for-room-p - ;; Following findOverrideMuteRule() in RoomNotifs.ts. - (room) (when-let ((overrides (map-nested-elt push-rules '(content global override)))) - (cl-loop for rule in overrides - when (and (alist-get 'enabled rule) - (rule-for-room-p rule room)) - return rule))) - (rule-for-room-p - ;; Following isRuleForRoom() in RoomNotifs.ts. - (rule room) (and (/= 1 (length (alist-get 'conditions rule))) - (pcase-let* ((condition (elt (alist-get 'conditions rule) 0)) - ((map kind key pattern) condition)) - (and (equal "event_match" kind) - (equal "room_id" key) - (equal (ement-room-id room) pattern))))) - (mute-rule-p - (rule) (when-let ((actions (alist-get 'actions rule))) - (seq-contains-p actions "dont_notify"))) - ;; NOTE: Although v1.7 of the spec says that "dont_notify" is - ;; obsolete, the latest revision of matrix-react-sdk (released last week - ;; as v3.77.1) still works as modeled here. - (tweak-rule-p - (type rule) (when-let ((actions (alist-get 'actions rule))) - (and (seq-contains-p actions "notify") - (seq-contains-p actions `(set_tweak . ,type) 'seq-contains-p))))) + (cl-labels ((override-mute-rule-for-room-p (room) + ;; Following findOverrideMuteRule() in RoomNotifs.ts. + (when-let ((overrides (map-nested-elt push-rules '(content global override)))) + (cl-loop for rule in overrides + when (and (alist-get 'enabled rule) + (rule-for-room-p rule room)) + return rule))) + (rule-for-room-p (rule room) + ;; Following isRuleForRoom() in RoomNotifs.ts. + (and (/= 1 (length (alist-get 'conditions rule))) + (pcase-let* ((condition (elt (alist-get 'conditions rule) 0)) + ((map kind key pattern) condition)) + (and (equal "event_match" kind) + (equal "room_id" key) + (equal (ement-room-id room) pattern))))) + (mute-rule-p (rule) + (when-let ((actions (alist-get 'actions rule))) + (seq-contains-p actions "dont_notify"))) + ;; NOTE: Although v1.7 of the spec says that "dont_notify" is + ;; obsolete, the latest revision of matrix-react-sdk (released last week + ;; as v3.77.1) still works as modeled here. + (tweak-rule-p (type rule) + (when-let ((actions (alist-get 'actions rule))) + (and (seq-contains-p actions "notify") + (seq-contains-p actions `(set_tweak . ,type) 'seq-contains-p))))) ;; If none of these match, nil is returned, meaning that the default rule is used ;; for the room. (if (override-mute-rule-for-room-p room) @@ -658,34 +674,34 @@ default, `all', `mentions-and-keywords', or `none'." (state (alist-get selected-rule available-states nil nil #'equal))) (list state ement-room ement-session)))) (cl-labels ((set-rule (kind rule queue message-fn) - (pcase-let* (((cl-struct ement-room (id room-id)) room) - (rule-id (url-hexify-string room-id)) - (endpoint (format "pushrules/global/%s/%s" kind rule-id)) - (method (if rule 'put 'delete)) - (then (if rule - ;; Setting rules requires PUTting the rules, then making a second - ;; request to enable them. - (lambda (_data) - (ement-api session (concat endpoint "/enabled") :queue queue :version "r0" - :method 'put :data (json-encode (ement-alist 'enabled t)) - :then message-fn)) - message-fn))) - (ement-api session endpoint :queue queue :method method :version "r0" - :data (json-encode rule) - :then then - :else (lambda (plz-error) - (pcase-let* (((cl-struct plz-error response) plz-error) - ((cl-struct plz-response status) response)) - (pcase status - (404 (pcase rule - (`nil - ;; Room already had no rules, so none being found is not an - ;; error. - nil) - (_ ;; Unexpected error: re-signal. - (ement-api-error plz-error)))) - (_ ;; Unexpected error: re-signal. - (ement-api-error plz-error))))))))) + (pcase-let* (((cl-struct ement-room (id room-id)) room) + (rule-id (url-hexify-string room-id)) + (endpoint (format "pushrules/global/%s/%s" kind rule-id)) + (method (if rule 'put 'delete)) + (then (if rule + ;; Setting rules requires PUTting the rules, then making a second + ;; request to enable them. + (lambda (_data) + (ement-api session (concat endpoint "/enabled") :queue queue :version "r0" + :method 'put :data (json-encode (ement-alist 'enabled t)) + :then message-fn)) + message-fn))) + (ement-api session endpoint :queue queue :method method :version "r0" + :data (json-encode rule) + :then then + :else (lambda (plz-error) + (pcase-let* (((cl-struct plz-error response) plz-error) + ((cl-struct plz-response status) response)) + (pcase status + (404 (pcase rule + (`nil + ;; Room already had no rules, so none being found is not an + ;; error. + nil) + (_ ;; Unexpected error: re-signal. + (ement-api-error plz-error)))) + (_ ;; Unexpected error: re-signal. + (ement-api-error plz-error))))))))) (pcase-let* ((available-states (ement-alist nil (ement-alist @@ -772,13 +788,13 @@ Selects from seen users on all sessions. If point is on an event, suggests the event's sender as initial input. Allows unseen user IDs to be input as well." (cl-labels ((format-user (user) - ;; FIXME: Per-room displaynames are now stored in room structs - ;; rather than user structs, so to be complete, this needs to - ;; iterate over all known rooms, looking for the user's - ;; displayname in that room. - (format "%s <%s>" - (ement-user-displayname user) - (ement-user-id user)))) + ;; FIXME: Per-room displaynames are now stored in room structs + ;; rather than user structs, so to be complete, this needs to + ;; iterate over all known rooms, looking for the user's + ;; displayname in that room. + (format "%s <%s>" + (ement-user-displayname user) + (ement-user-id user)))) (let* ((display-to-id (cl-loop for key being the hash-keys of ement-users using (hash-values value) @@ -904,31 +920,30 @@ avatars, etc." ;; string as argument.) ;; TODO: Try using HSV somehow so we could avoid having so many strings return a ;; nearly-black color. - (cl-labels ((relative-luminance - ;; Copy of `modus-themes-wcag-formula', an elegant - ;; implementation by Protesilaos Stavrou. Also see - ;; <https://en.wikipedia.org/wiki/Relative_luminance> and - ;; <https://www.w3.org/TR/WCAG20/#relativeluminancedef>. - (rgb) (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 - ;; Copy of `modus-themes-contrast'; see above. - (a b) (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))))) + (cl-labels ((relative-luminance (rgb) + ;; Copy of `modus-themes-wcag-formula', an elegant + ;; implementation by Protesilaos Stavrou. Also see + ;; <https://en.wikipedia.org/wiki/Relative_luminance> and + ;; <https://www.w3.org/TR/WCAG20/#relativeluminancedef>. + (cl-loop for k in '(0.2126 0.7152 0.0722) + for x in rgb + sum (* k (if (<= x 0.03928) + (/ x 12.92) + (expt (/ (+ x 0.055) 1.055) 2.4))))) + (contrast-ratio (a b) + ;; Copy of `modus-themes-contrast'; see above. + (let ((ct (/ (+ (relative-luminance a) 0.05) + (+ (relative-luminance b) 0.05)))) + (max ct (/ ct)))) + (increase-contrast (color against target toward) + (let ((gradient (cdr (color-gradient color toward 20))) + new-color) + (cl-loop do (setf new-color (pop gradient)) + while new-color + until (>= (contrast-ratio new-color against) target) + ;; Avoid infinite loop in case of weirdness + ;; by returning color as a fallback. + finally return (or new-color color))))) (let* ((id string) (id-hash (float (+ (abs (sxhash id)) ement-room-prism-color-adjustment))) ;; TODO: Wrap-around the value to get the color I want. @@ -1007,12 +1022,12 @@ period, anywhere in the body." ;; "@foo and @bar:matrix.org: hi" ;; "foo: how about you and @bar ..." (declare (indent defun)) - (cl-labels ((members-having-displayname - ;; Iterating over the hash table values isn't as efficient as a hash - ;; lookup, but in most rooms it shouldn't be a problem. - (name members) (cl-loop for user being the hash-values of members - when (equal name (ement--user-displayname-in room user)) - collect user))) + (cl-labels ((members-having-displayname (name members) + ;; Iterating over the hash table values isn't as efficient as a hash + ;; lookup, but in most rooms it shouldn't be a problem. + (cl-loop for user being the hash-values of members + when (equal name (ement--user-displayname-in room user)) + collect user))) (pcase-let* (((cl-struct ement-room members) room) (regexp (rx (or bos bow (1+ blank)) (or (seq (group @@ -1199,35 +1214,34 @@ DATA is an unsent message event's data alist." (defun ement--direct-room-for-user (user session) "Return last-modified direct room with USER on SESSION, if one exists." ;; Loosely modeled on the Element function findDMForUser in createRoom.ts. - (cl-labels ((membership-event-for-p - (event user) (and (equal "m.room.member" (ement-event-type event)) - (equal (ement-user-id user) (ement-event-state-key event)))) - (latest-membership-for - (user room) - (when-let ((latest-membership-event - (car - (cl-sort - ;; I guess we need to check both state and timeline events. - (append (cl-remove-if-not (lambda (event) - (membership-event-for-p event user)) - (ement-room-state room)) - (cl-remove-if-not (lambda (event) - (membership-event-for-p event user)) - (ement-room-timeline room))) - (lambda (a b) - ;; Sort latest first so we can use the car. - (> (ement-event-origin-server-ts a) - (ement-event-origin-server-ts b))))))) - (alist-get 'membership (ement-event-content latest-membership-event)))) - (latest-event-in - (room) (car - (cl-sort - (append (ement-room-state room) - (ement-room-timeline room)) - (lambda (a b) - ;; Sort latest first so we can use the car. - (> (ement-event-origin-server-ts a) - (ement-event-origin-server-ts b))))))) + (cl-labels ((membership-event-for-p (event user) + (and (equal "m.room.member" (ement-event-type event)) + (equal (ement-user-id user) (ement-event-state-key event)))) + (latest-membership-for (user room) + (when-let ((latest-membership-event + (car + (cl-sort + ;; I guess we need to check both state and timeline events. + (append (cl-remove-if-not (lambda (event) + (membership-event-for-p event user)) + (ement-room-state room)) + (cl-remove-if-not (lambda (event) + (membership-event-for-p event user)) + (ement-room-timeline room))) + (lambda (a b) + ;; Sort latest first so we can use the car. + (> (ement-event-origin-server-ts a) + (ement-event-origin-server-ts b))))))) + (alist-get 'membership (ement-event-content latest-membership-event)))) + (latest-event-in (room) + (car + (cl-sort + (append (ement-room-state room) + (ement-room-timeline room)) + (lambda (a b) + ;; Sort latest first so we can use the car. + (> (ement-event-origin-server-ts a) + (ement-event-origin-server-ts b))))))) (let* ((direct-rooms (cl-remove-if-not (lambda (room) (ement--room-direct-p room session)) @@ -1350,6 +1364,24 @@ can cause undesirable underlining." while next-face-change-pos do (setf pos next-face-change-pos)))) +(cl-defun ement--text-property-search-forward (property predicate string &key (start 0)) + "Return the position at which PROPERTY in STRING matches PREDICATE. +Return nil if not found. Searches forward from START." + (declare (indent defun)) + (cl-loop for pos = start then (next-single-property-change pos property string) + while pos + when (funcall predicate (get-text-property pos property string)) + return pos)) + +(cl-defun ement--text-property-search-backward (property predicate string &key (start 0)) + "Return the position at which PROPERTY in STRING matches PREDICATE. +Return nil if not found. Searches backward from START." + (declare (indent defun)) + (cl-loop for pos = start then (previous-single-property-change pos property string) + while (and pos (> pos 1)) + when (funcall predicate (get-text-property (1- pos) property string)) + return pos)) + (defun ement--resize-image (image max-width max-height) "Return a copy of IMAGE set to MAX-WIDTH and MAX-HEIGHT. IMAGE should be one as created by, e.g. `create-image'." @@ -1395,10 +1427,10 @@ Works in major-modes `ement-room-mode', (defun ement--room-direct-p (room session) "Return non-nil if ROOM on SESSION is a direct chat." - (cl-labels ((content-contains-room-id - (content room-id) (cl-loop for (_user-id . room-ids) in content - ;; NOTE: room-ids is a vector. - thereis (seq-contains-p room-ids room-id)))) + (cl-labels ((content-contains-room-id (content room-id) + (cl-loop for (_user-id . room-ids) in content + ;; NOTE: room-ids is a vector. + thereis (seq-contains-p room-ids room-id)))) (pcase-let* (((cl-struct ement-session account-data) session) ((cl-struct ement-room id) room)) (or (cl-loop for event in account-data @@ -1417,63 +1449,62 @@ Works in major-modes `ement-room-mode', ;; or when to use "m.room.member" events for rooms without heroes (e.g. invited rooms). ;; TODO: Add SESSION argument and use it to remove local user from names. (cl-labels ((latest-event (type content-field) - (or (cl-loop for event in (ement-room-timeline room) - when (and (equal type (ement-event-type event)) - (not (string-empty-p (alist-get content-field (ement-event-content event))))) - return (alist-get content-field (ement-event-content event))) - (cl-loop for event in (ement-room-state room) - when (and (equal type (ement-event-type event)) - (not (string-empty-p (alist-get content-field (ement-event-content event))))) - return (alist-get content-field (ement-event-content event))))) - (member-events-name - () (when-let ((member-events (cl-loop for accessor in '(ement-room-timeline ement-room-state ement-room-invite-state) - append (cl-remove-if-not (apply-partially #'equal "m.room.member") - (funcall accessor room) - :key #'ement-event-type)))) - (string-join (delete-dups - (mapcar (lambda (event) - (ement--user-displayname-in room (ement-event-sender event))) - member-events)) - ", "))) - (heroes-name - () (pcase-let* (((cl-struct ement-room summary) room) - ((map ('m.heroes hero-ids) ('m.joined_member_count joined-count) - ('m.invited_member_count invited-count)) - summary)) - ;; TODO: Disambiguate hero display names. - (when hero-ids - (cond ((<= (+ joined-count invited-count) 1) - ;; Empty room. - (empty-room hero-ids joined-count)) - ((>= (length hero-ids) (1- (+ joined-count invited-count))) - ;; Members == heroes. - (hero-names hero-ids)) - ((and (< (length hero-ids) (1- (+ joined-count invited-count))) - (> (+ joined-count invited-count) 1)) - ;; More members than heroes. - (heroes-and-others hero-ids joined-count)))))) - (hero-names - (heroes) (string-join (mapcar #'hero-name heroes) ", ")) - (hero-name - (id) (if-let ((user (gethash id ement-users))) - (ement--user-displayname-in room user) - id)) - (heroes-and-others - (heroes joined) - (format "%s, and %s others" (hero-names heroes) - (- joined (length heroes)))) - (name-override - () (when-let ((event (alist-get "org.matrix.msc3015.m.room.name.override" - (ement-room-account-data room) - nil nil #'equal))) - (map-nested-elt event '(content name)))) - (empty-room - (heroes joined) (cl-etypecase (length heroes) - ((satisfies zerop) "Empty room") - ((number 1 5) (format "Empty room (was %s)" - (hero-names heroes))) - (t (format "Empty room (was %s)" - (heroes-and-others heroes joined)))))) + (or (cl-loop for event in (ement-room-timeline room) + when (and (equal type (ement-event-type event)) + (not (string-empty-p (alist-get content-field (ement-event-content event))))) + return (alist-get content-field (ement-event-content event))) + (cl-loop for event in (ement-room-state room) + when (and (equal type (ement-event-type event)) + (not (string-empty-p (alist-get content-field (ement-event-content event))))) + return (alist-get content-field (ement-event-content event))))) + (member-events-name () + (when-let ((member-events (cl-loop for accessor in '(ement-room-timeline ement-room-state ement-room-invite-state) + append (cl-remove-if-not (apply-partially #'equal "m.room.member") + (funcall accessor room) + :key #'ement-event-type)))) + (string-join (delete-dups + (mapcar (lambda (event) + (ement--user-displayname-in room (ement-event-sender event))) + member-events)) + ", "))) + (heroes-name () + (pcase-let* (((cl-struct ement-room summary) room) + ((map ('m.heroes hero-ids) ('m.joined_member_count joined-count) + ('m.invited_member_count invited-count)) + summary)) + ;; TODO: Disambiguate hero display names. + (when hero-ids + (cond ((<= (+ joined-count invited-count) 1) + ;; Empty room. + (empty-room hero-ids joined-count)) + ((>= (length hero-ids) (1- (+ joined-count invited-count))) + ;; Members == heroes. + (hero-names hero-ids)) + ((and (< (length hero-ids) (1- (+ joined-count invited-count))) + (> (+ joined-count invited-count) 1)) + ;; More members than heroes. + (heroes-and-others hero-ids joined-count)))))) + (hero-names (heroes) + (string-join (mapcar #'hero-name heroes) ", ")) + (hero-name (id) + (if-let ((user (gethash id ement-users))) + (ement--user-displayname-in room user) + id)) + (heroes-and-others (heroes joined) + (format "%s, and %s others" (hero-names heroes) + (- joined (length heroes)))) + (name-override () + (when-let ((event (alist-get "org.matrix.msc3015.m.room.name.override" + (ement-room-account-data room) + nil nil #'equal))) + (map-nested-elt event '(content name)))) + (empty-room (heroes joined) + (cl-etypecase (length heroes) + ((satisfies zerop) "Empty room") + ((number 1 5) (format "Empty room (was %s)" + (hero-names heroes))) + (t (format "Empty room (was %s)" + (heroes-and-others heroes joined)))))) (or (name-override) (latest-event "m.room.name" 'name) (latest-event "m.room.canonical_alias" 'alias) @@ -1529,19 +1560,19 @@ is not at the latest known message event." ;; A room should rarely, if ever, have a nil timeline, but in case it does ;; (which apparently can happen, given user reports), it should not be ;; considered unread. - (cl-labels ((event-counts-toward-unread-p - ;; NOTE: We only consider message events, so membership, reaction, - ;; etc. events will not mark a room as unread. Ideally, I think - ;; that join/leave events should, at least optionally, mark a room - ;; as unread (e.g. in a 1:1 room with a friend, if the other user - ;; left, one would probably want to know, and marking the room - ;; unread would help the user notice), but since membership events - ;; have to be processed to understand their meaning, it's not - ;; straightforward to know whether one should mark a room unread. - - ;; FIXME: Use code from `ement-room--format-member-event' to - ;; distinguish ones that should count. - (event) (equal "m.room.message" (ement-event-type event)))) + (cl-labels ((event-counts-toward-unread-p (event) + ;; NOTE: We only consider message events, so membership, reaction, + ;; etc. events will not mark a room as unread. Ideally, I think + ;; that join/leave events should, at least optionally, mark a room + ;; as unread (e.g. in a 1:1 room with a friend, if the other user + ;; left, one would probably want to know, and marking the room + ;; unread would help the user notice), but since membership events + ;; have to be processed to understand their meaning, it's not + ;; straightforward to know whether one should mark a room unread. + + ;; FIXME: Use code from `ement-room--format-member-event' to + ;; distinguish ones that should count. + (equal "m.room.message" (ement-event-type event)))) (let ((our-read-receipt-event-id (car (gethash our-id receipts))) (first-counting-event (cl-find-if #'event-counts-toward-unread-p timeline))) (cond ((equal fully-read-event-id (ement-event-id (car timeline))) @@ -1595,11 +1626,11 @@ problems." (if-let ((cached-name (gethash user (ement-room-displaynames room)))) cached-name ;; Put timeline events before state events, because IIUC they should be more recent. - (cl-labels ((join-displayname-event-p - (event) (and (eq user (ement-event-sender event)) - (equal "m.room.member" (ement-event-type event)) - (equal "join" (alist-get 'membership (ement-event-content event))) - (alist-get 'displayname (ement-event-content event))))) + (cl-labels ((join-displayname-event-p (event) + (and (eq user (ement-event-sender event)) + (equal "m.room.member" (ement-event-type event)) + (equal "join" (alist-get 'membership (ement-event-content event))) + (alist-get 'displayname (ement-event-content event))))) ;; FIXME: Should probably sort the relevant events to get the latest one. (if-let* ((displayname (or (cl-loop for event in (ement-room-timeline room) when (join-displayname-event-p event) @@ -1698,19 +1729,19 @@ seconds, etc." (if (< seconds 1) (if abbreviate "0s" "0 seconds") (cl-macrolet ((format> (place) - ;; When PLACE is greater than 0, return formatted string using its symbol name. - `(when (> ,place 0) - (format "%d%s%s" ,place - (if abbreviate "" " ") - (if abbreviate - ,(substring (symbol-name place) 0 1) - ,(symbol-name place))))) + ;; When PLACE is greater than 0, return formatted string using its symbol name. + `(when (> ,place 0) + (format "%d%s%s" ,place + (if abbreviate "" " ") + (if abbreviate + ,(substring (symbol-name place) 0 1) + ,(symbol-name place))))) (join-places (&rest places) - ;; Return string joining the names and values of PLACES. - `(string-join (delq nil - (list ,@(cl-loop for place in places - collect `(format> ,place)))) - (if abbreviate "" ", ")))) + ;; Return string joining the names and values of PLACES. + `(string-join (delq nil + (list ,@(cl-loop for place in places + collect `(format> ,place)))) + (if abbreviate "" ", ")))) (pcase-let ((`(,years ,days ,hours ,minutes ,seconds) (ement--human-duration seconds))) (join-places years days hours minutes seconds))))) @@ -1721,9 +1752,9 @@ a simple calculation that does not account for leap years, leap seconds, etc." ;; Copied from `ts-human-format-duration' (same author). (cl-macrolet ((dividef (place divisor) - ;; Divide PLACE by DIVISOR, set PLACE to the remainder, and return the quotient. - `(prog1 (/ ,place ,divisor) - (setf ,place (% ,place ,divisor))))) + ;; Divide PLACE by DIVISOR, set PLACE to the remainder, and return the quotient. + `(prog1 (/ ,place ,divisor) + (setf ,place (% ,place ,divisor))))) (let* ((seconds (floor seconds)) (years (dividef seconds 31536000)) (days (dividef seconds 86400)) diff --git a/ement-macros.el b/ement-macros.el index 88e9a44..9a46077 100644 --- a/ement-macros.el +++ b/ement-macros.el @@ -1,6 +1,6 @@ ;;; ement-macros.el --- Ement macros -*- lexical-binding: t; -*- -;; Copyright (C) 2022 Free Software Foundation, Inc. +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. ;; Author: Adam Porter <adam@alphapapa.net> ;; Maintainer: Adam Porter <adam@alphapapa.net> diff --git a/ement-notifications.el b/ement-notifications.el new file mode 100644 index 0000000..40cf7e5 --- /dev/null +++ b/ement-notifications.el @@ -0,0 +1,272 @@ +;;; ement-notifications.el --- Notifications support -*- lexical-binding: t; -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Adam Porter <adam@alphapapa.net> +;; Maintainer: Adam Porter <adam@alphapapa.net> + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library implements support for Matrix notifications. It differs from +;; `ement-notify', which implements a kind of bespoke notification system for events +;; received via sync requests rather than Matrix's own notifications endpoint. These two +;; libraries currently integrate somewhat, as newly arriving events are handled and +;; notified about by `ement-notify', and old notifications are fetched and listed by +;; `ement-notifications' in the same "*Ement Notifications*" buffer. + +;; In the future, these libraries will likely be consolidated and enhanced to more closely +;; follow the Matrix API's and Element client's examples. + +;;; Code: + +;;;; Requirements + +(require 'cl-lib) +(require 'map) + +(require 'ement-lib) +(require 'ement-room) +(require 'ement-notify) + +;;;; Structs + +(cl-defstruct ement-notification + "Represents a Matrix notification." + room-id event readp) + +(defun ement-notifications--make (notification) + "Return an `ement-notification' struct for NOTIFICATION. +NOTIFICATION is an alist representing a notification returned +from the \"/notifications\" endpoint. The notification's event +is passed through `ement--make-event'." + (declare (function ement--make-event "ement")) + (pcase-let (((map room_id _actions _ts event read) notification)) + (make-ement-notification :room-id room_id :readp read + :event (ement--make-event event)))) + +;;;; Variables + +(declare-function ement-room-list "ement-room-list") +(defvar ement-notifications-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "S-<return>") #'ement-notify-reply) + (define-key map (kbd "M-g M-l") #'ement-room-list) + (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 [remap scroll-down-command] #'ement-notifications-scroll-down-command) + (define-key map [remap mwheel-scroll] #'ement-notifications-mwheel-scroll) + (make-composed-keymap (list map button-buffer-map) 'view-mode-map)) + "Map for Ement notification buffers.") + +(defvar ement-notifications-hook '(ement-notifications-log-to-buffer) + "Functions called for `ement-notifications' notifications. +Each function is called with two arguments, the session and the +`ement-notification' struct.") + +(defvar-local ement-notifications-retro-loading nil + "Non-nil when earlier messages are being loaded. +Used to avoid overlapping requests.") + +(defvar-local ement-notifications-metadata nil + "Metadata for `ement-notifications' buffers.") + +;; Variables from other files. +(defvar ement-ewoc) +(defvar ement-session) +(defvar ement-notify-prism-background) +(defvar ement-room-message-format-spec) +(defvar ement-room-sender-in-left-margin) + +;;;; Commands + +;;;###autoload +(cl-defun ement-notifications + (session &key from limit only + (then (apply-partially #'ement-notifications-callback session)) else) + "Show the notifications buffer for SESSION. +FROM may be a \"next_token\" token from a previous request. +LIMIT may be a maximum number of events to return. ONLY may be +the string \"highlight\" to only return notifications that have +the highlight tweak set. THEN and ELSE may be callbacks passed +to `ement-api', which see." + (interactive (list (ement-complete-session) + :only (when current-prefix-arg + "highlight"))) + (if-let ((buffer (get-buffer "*Ement Notifications*"))) + (switch-to-buffer buffer) + (let ((endpoint "notifications") + (params (remq nil + (list (when from + (list "from" from)) + (when limit + (list "limit" (number-to-string limit))) + (when only + (list "only" only)))))) + (ement-api session endpoint :params params :then then :else else) + (ement-message "Fetching notifications for <%s>..." (ement-user-id (ement-session-user session)))))) + +(cl-defun ement-notifications-callback (session data &key (buffer (ement-notifications--log-buffer))) + "Callback for `ement-notifications' on SESSION which receives DATA." + (pcase-let (((map notifications next_token) data)) + (with-current-buffer buffer + (setf (map-elt ement-notifications-metadata :next-token) next_token) + (cl-loop for notification across notifications + do (run-hook-with-args 'ement-notifications-hook + session (ement-notifications--make notification))) + ;; TODO: Pass start/end nodes to `ement-room--insert-ts-headers' if possible. + (ement-room--insert-ts-headers) + (switch-to-buffer (current-buffer))))) + +(defun ement-notifications-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-notifications-retro)))) + +(defun ement-notifications-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-notifications-retro)))) + +(cl-defun ement-notifications-retro (session number) + ;; FIXME: Naming things is hard. + "Retrieve NUMBER older notifications on SESSION." + ;; FIXME: Support multiple sessions. + (interactive (list (ement-complete-session) + (cl-typecase current-prefix-arg + (null 100) + (list (read-number "Number of messages: ")) + (number current-prefix-arg)))) + (cl-assert (eq 'ement-notifications-mode major-mode)) + (cl-assert (map-elt ement-notifications-metadata :next-token) nil + "No more notifications for %s" (ement-user-id (ement-session-user ement-session))) + (let ((buffer (current-buffer))) + (unless ement-notifications-retro-loading + (ement-notifications + session :limit number + :from (map-elt ement-notifications-metadata :next-token) + ;; TODO: Use a :finally for resetting `ement-notifications-retro-loading'? + :then (lambda (data) + (unwind-protect + (ement-notifications-callback session data :buffer buffer) + (setf (buffer-local-value 'ement-notifications-retro-loading buffer) nil))) + :else (lambda (plz-error) + (setf (buffer-local-value 'ement-notifications-retro-loading buffer) nil) + (ement-api-error plz-error))) + (ement-message "Loading %s earlier messages..." number) + (setf ement-notifications-retro-loading t)))) + +;;;; Functions + +(cl-defun ement-notifications-log-to-buffer (session notification &key (buffer-name "*Ement Notifications*")) + "Log EVENT in ROOM on SESSION to \"*Ement NOTIFICATIONS*\" buffer." + (with-demoted-errors "ement-notifications-log-to-buffer: %S" + (with-current-buffer (ement-notifications--log-buffer :name buffer-name) + (save-window-excursion + (when-let ((buffer-window (get-buffer-window (current-buffer)))) + ;; Select the buffer's window to avoid EWOC bug. (See #191.) + (select-window buffer-window)) + ;; TODO: Use the :readp slot to mark unread events. + (save-mark-and-excursion + (pcase-let* (((cl-struct ement-notification room-id event) notification) + (ement-session session) + (ement-room (or (cl-find room-id (ement-session-rooms session) + :key #'ement-room-id :test #'equal) + (error "ement-notifications-log-to-buffer: Can't find room <%s>; discarding notification" room-id))) + (ement-room-sender-in-left-margin nil) + (ement-room-message-format-spec "%o%O »%W %S> %B%R%t") + (new-node (ement-room--insert-event event)) + (inhibit-read-only t) + (start) (end)) + (ewoc-goto-node ement-ewoc new-node) + (setf start (point)) + (if-let (next-node (ewoc-next ement-ewoc new-node)) + (ewoc-goto-node ement-ewoc next-node) + (goto-char (point-max))) + (setf end (- (point) 2)) + (add-text-properties start end + (list 'button '(t) + 'category 'default-button + 'action #'ement-notify-button-action + 'session session + 'room ement-room + 'event event)) + ;; Remove button face property. + (alter-text-property start end 'face + (lambda (face) + (pcase face + ('button nil) + ((pred listp) (remq 'button face)) + (_ face)))) + (when ement-notify-prism-background + (add-face-text-property start end (list :background (ement-notifications--room-background-color ement-room) + :extend t))))))))) + +(defun ement-notifications--room-background-color (room) + "Return a background color on which to display ROOM's messages." + (or (alist-get 'notify-background-color (ement-room-local room)) + (setf (alist-get 'notify-background-color (ement-room-local room)) + (let ((color (color-desaturate-name + (ement--prism-color (ement-room-id room) :contrast-with (face-foreground 'default)) + 50))) + (if (ement--color-dark-p (color-name-to-rgb (face-background 'default))) + (color-darken-name color 25) + (color-lighten-name color 25)))))) + +(cl-defun ement-notifications--log-buffer (&key (name "*Ement Notifications*")) + "Return an Ement notifications buffer named NAME." + (or (get-buffer name) + (with-current-buffer (get-buffer-create name) + (ement-notifications-mode) + (current-buffer)))) + +;;;; Mode + +(define-derived-mode ement-notifications-mode ement-room-mode "Ement Notifications" + (setf ement-room-sender-in-left-margin nil + left-margin-width 0 + right-margin-width 8) + (setq-local ement-room-message-format-spec "[%o%O] %S> %B%R%t" + bookmark-make-record-function #'ement-notifications-bookmark-make-record)) + +;;;; Bookmark support + +(require 'bookmark) + +(defun ement-notifications-bookmark-make-record () + "Return a bookmark record for the current `ement-notifications' buffer." + (list (buffer-name) + ;; It seems silly to have to record the buffer name twice, but the + ;; `bookmark-make-record' function seems to override the bookmark name sometimes, + ;; which makes the result useless unless we save the buffer name separately. + (cons 'buffer-name (buffer-name)) + (cons 'handler #'ement-notifications-bookmark-handler))) + +(defun ement-notifications-bookmark-handler (bookmark) + "Show `ement-notifications' buffer for BOOKMARK." + (pcase-let ((`(,_bookmark-name . ,(map buffer-name)) bookmark)) + (switch-to-buffer (ement-notifications--log-buffer :name buffer-name)))) + +;;; Footer + +(provide 'ement-notifications) + +;;; ement-notifications.el ends here diff --git a/ement-notify.el b/ement-notify.el index 1efd147..c341678 100644 --- a/ement-notify.el +++ b/ement-notify.el @@ -1,6 +1,6 @@ ;;; ement-notify.el --- Notifications for Ement events -*- lexical-binding: t; -*- -;; Copyright (C) 2022 Free Software Foundation, Inc. +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. ;; Author: Adam Porter <adam@alphapapa.net> ;; Maintainer: Adam Porter <adam@alphapapa.net> @@ -169,13 +169,21 @@ margins in Emacs. But it's useful, anyway." (defun ement-notify-switch-to-notifications-buffer () "Switch to \"*Ement Notifications*\" buffer." + (declare (function ement-notifications "ement-notifications")) (interactive) - (switch-to-buffer (ement-notify--log-buffer "*Ement Notifications*"))) + (call-interactively #'ement-notifications)) +(defvar ement-notifications-mode-map) (defun ement-notify-switch-to-mentions-buffer () "Switch to \"*Ement Mentions*\" buffer." + (declare (function ement-notifications--log-buffer "ement-notifications")) (interactive) - (switch-to-buffer (ement-notify--log-buffer "*Ement Mentions*"))) + (switch-to-buffer (ement-notifications--log-buffer :name "*Ement Mentions*")) + ;; HACK: Undo remapping of scroll commands which don't apply in this buffer. + (let ((map (copy-keymap ement-notifications-mode-map))) + (define-key map [remap scroll-down-command] nil) + (define-key map [remap mwheel-scroll] nil) + (use-local-map map))) ;;;; Functions @@ -206,13 +214,13 @@ If ROOM has no existing buffer, do nothing." (function dbus-get-unique-name "dbusbind.c") (function x-change-window-property "xfns.c") (function x-window-property "xfns.c")) - (cl-labels ((mark-frame-urgent - (frame) (let* ((prop "WM_HINTS") - (hints (cl-coerce - (x-window-property prop frame prop nil nil t) - 'list))) - (setf (car hints) (logior (car hints) 256)) - (x-change-window-property prop hints nil prop 32 t)))) + (cl-labels ((mark-frame-urgent (frame) + (let* ((prop "WM_HINTS") + (hints (cl-coerce + (x-window-property prop frame prop nil nil t) + 'list))) + (setf (car hints) (logior (car hints) 256)) + (x-change-window-property prop hints nil prop 32 t)))) (when-let* ((buffer (alist-get 'buffer (ement-room-local room))) (frames (cl-loop for frame in (frame-list) when (eq 'x (framep frame)) @@ -272,73 +280,13 @@ If ROOM has no existing buffer, do nothing." (delete-file filename))) filename)) -(define-derived-mode ement-notify-mode ement-room-mode "Ement Notify" - (setf ement-room-sender-in-left-margin nil - left-margin-width 0 - right-margin-width 8) - (setq-local ement-room-message-format-spec "[%o%O] %S> %B%R%t" - bookmark-make-record-function #'ement-notify-bookmark-make-record)) - (cl-defun ement-notify--log-to-buffer (event room session &key (buffer-name "*Ement Notifications*")) "Log EVENT in ROOM on SESSION to \"*Ement Notifications*\" buffer." - (with-demoted-errors "ement-notify--log-to-buffer: %S" - ;; HACK: We only log "m.room.message" events for now. This shouldn't be necessary - ;; since we have `ement-notify--event-message-p' in `ement-notify-predicates', but - ;; just to be safe... - (when (equal "m.room.message" (ement-event-type event)) - (with-current-buffer (ement-notify--log-buffer buffer-name) - (save-window-excursion - (when-let ((buffer-window (get-buffer-window (current-buffer)))) - ;; Select the buffer's window to avoid EWOC bug. (See #191.) - (select-window buffer-window)) - (let* ((ement-session session) - (ement-room room) - (ement-room-sender-in-left-margin nil) - (ement-room-message-format-spec "%o%O »%W %S> %B%R%t") - (new-node (ement-room--insert-event event)) - (inhibit-read-only t) - start end) - (ewoc-goto-node ement-ewoc new-node) - (setf start (point)) - (if-let (next-node (ewoc-next ement-ewoc new-node)) - (ewoc-goto-node ement-ewoc next-node) - (goto-char (point-max))) - (setf end (- (point) 2)) - (add-text-properties start end - (list 'button '(t) - 'category 'default-button - 'action #'ement-notify-button-action - 'session session - 'room room - 'event event)) - ;; Remove button face property. - (alter-text-property start end 'face - (lambda (face) - (pcase face - ('button nil) - ((pred listp) (remq 'button face)) - (_ face)))) - (when ement-notify-prism-background - (add-face-text-property start end (list :background (ement-notify--room-background-color room) - :extend t))))))))) - -(defun ement-notify--log-buffer (name) - "Return an Ement notifications buffer named NAME." - (or (get-buffer name) - (with-current-buffer (get-buffer-create name) - (ement-notify-mode) - (current-buffer)))) - -(defun ement-notify--room-background-color (room) - "Return a background color on which to display ROOM's messages." - (or (alist-get 'notify-background-color (ement-room-local room)) - (setf (alist-get 'notify-background-color (ement-room-local room)) - (let ((color (color-desaturate-name - (ement--prism-color (ement-room-id room) :contrast-with (face-foreground 'default)) - 50))) - (if (ement--color-dark-p (color-name-to-rgb (face-background 'default))) - (color-darken-name color 25) - (color-lighten-name color 25)))))) + (declare (function ement-notifications-log-to-buffer "ement-notifications") + (function make-ement-notification "ement-notifications")) + (pcase-let* (((cl-struct ement-room (id room-id)) room) + (notification (make-ement-notification :room-id room-id :event event))) + (ement-notifications-log-to-buffer session notification :buffer-name buffer-name))) ;;;;; Predicates @@ -395,7 +343,7 @@ According to the room's notification configuration on the server." (defun ement-notify-bookmark-handler (bookmark) "Show Ement notifications buffer for BOOKMARK." (pcase-let ((`(,_bookmark-name . ,(map buffer-name)) bookmark)) - (switch-to-buffer (ement-notify--log-buffer buffer-name)))) + (switch-to-buffer (ement-notifications--log-buffer :name buffer-name)))) ;;;; Footer diff --git a/ement-room-list.el b/ement-room-list.el index 117e009..232ef6d 100644 --- a/ement-room-list.el +++ b/ement-room-list.el @@ -1,6 +1,6 @@ ;;; ement-room-list.el --- List Ement rooms -*- lexical-binding: t; -*- -;; Copyright (C) 2022 Free Software Foundation, Inc. +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. ;; Author: Adam Porter <adam@alphapapa.net> ;; Maintainer: Adam Porter <adam@alphapapa.net> @@ -165,10 +165,10 @@ from recent to non-recent for rooms updated in the past hour.") (ement-room-list-define-key membership (&key name status) ;; FIXME: Docstring: status should be a symbol of either `invite', `join', `leave'. (cl-labels ((format-membership (membership) - (pcase membership - ('join "Joined") - ('invite "Invited") - ('leave "[Left]")))) + (pcase membership + ('join "Joined") + ('invite "Invited") + ('leave "[Left]")))) (pcase-let ((`[,(cl-struct ement-room (status membership)) ,_session] item)) (if status (when (equal status membership) @@ -200,12 +200,12 @@ from recent to non-recent for rooms updated in the past hour.") (pcase-let* ((`[,room ,session] item) ((cl-struct ement-session rooms) session) ((cl-struct ement-room type (local (map parents))) room)) - (cl-labels ((format-space - (id) (let* ((parent-room (cl-find id rooms :key #'ement-room-id :test #'equal)) - (space-name (if parent-room - (ement-room-display-name parent-room) - id))) - (concat "Space: " space-name)))) + (cl-labels ((format-space (id) + (let* ((parent-room (cl-find id rooms :key #'ement-room-id :test #'equal)) + (space-name (if parent-room + (ement-room-display-name parent-room) + id))) + (concat "Space: " space-name)))) (when-let ((key (if id ;; ID specified. (cond ((or (member id parents) @@ -553,64 +553,64 @@ DISPLAY-BUFFER-ACTION is nil, the buffer is not displayed." (format-item (item) (gethash item format-table)) ;; NOTE: Since these functions take an "item" (which is a [room session] ;; vector), they're prefixed "item-" rather than "room-". - (item-latest-ts - (item) (or (ement-room-latest-ts (elt item 0)) - ;; Room has no latest timestamp. FIXME: This shouldn't - ;; happen, but it can, maybe due to oversights elsewhere. - 0)) - (item-unread-p - (item) (pcase-let ((`[,room ,session] item)) - (ement--room-unread-p room session))) - (item-left-p - (item) (pcase-let ((`[,(cl-struct ement-room status) ,_session] item)) - (equal 'leave status))) - (item-buffer-p - (item) (pcase-let ((`[,(cl-struct ement-room (local (map buffer))) ,_session] item)) - (buffer-live-p buffer))) - (taxy-unread-p - (taxy) (or (cl-some #'item-unread-p (taxy-items taxy)) - (cl-some #'taxy-unread-p (taxy-taxys taxy)))) - (item-space-p - (item) (pcase-let ((`[,(cl-struct ement-room type) ,_session] item)) - (equal "m.space" type))) - (item-favourite-p - (item) (pcase-let ((`[,room ,_session] item)) - (ement--room-favourite-p room))) - (item-low-priority-p - (item) (pcase-let ((`[,room ,_session] item)) - (ement--room-low-priority-p room))) - (visible-p - ;; This is very confusing and doesn't currently work. - (section) (let ((value (oref section value))) - (if (cl-typecase value - (taxy-magit-section (item-unread-p value)) - (ement-room nil)) - 'show - 'hide))) - (item-invited-p - (item) (pcase-let ((`[,(cl-struct ement-room status) ,_session] item)) - (equal 'invite status))) - (taxy-latest-ts - (taxy) (apply #'max most-negative-fixnum - (delq nil - (list - (when (taxy-items taxy) - (item-latest-ts (car (taxy-items taxy)))) - (when (taxy-taxys taxy) - (cl-loop for sub-taxy in (taxy-taxys taxy) - maximizing (taxy-latest-ts sub-taxy))))))) + (item-latest-ts (item) + (or (ement-room-latest-ts (elt item 0)) + ;; Room has no latest timestamp. FIXME: This shouldn't + ;; happen, but it can, maybe due to oversights elsewhere. + 0)) + (item-unread-p (item) + (pcase-let ((`[,room ,session] item)) + (ement--room-unread-p room session))) + (item-left-p (item) + (pcase-let ((`[,(cl-struct ement-room status) ,_session] item)) + (equal 'leave status))) + (item-buffer-p (item) + (pcase-let ((`[,(cl-struct ement-room (local (map buffer))) ,_session] item)) + (buffer-live-p buffer))) + (taxy-unread-p (taxy) + (or (cl-some #'item-unread-p (taxy-items taxy)) + (cl-some #'taxy-unread-p (taxy-taxys taxy)))) + (item-space-p (item) + (pcase-let ((`[,(cl-struct ement-room type) ,_session] item)) + (equal "m.space" type))) + (item-favourite-p (item) + (pcase-let ((`[,room ,_session] item)) + (ement--room-favourite-p room))) + (item-low-priority-p (item) + (pcase-let ((`[,room ,_session] item)) + (ement--room-low-priority-p room))) + (visible-p (section) + ;; This is very confusing and doesn't currently work. + (let ((value (oref section value))) + (if (cl-typecase value + (taxy-magit-section (item-unread-p value)) + (ement-room nil)) + 'show + 'hide))) + (item-invited-p (item) + (pcase-let ((`[,(cl-struct ement-room status) ,_session] item)) + (equal 'invite status))) + (taxy-latest-ts (taxy) + (apply #'max most-negative-fixnum + (delq nil + (list + (when (taxy-items taxy) + (item-latest-ts (car (taxy-items taxy)))) + (when (taxy-taxys taxy) + (cl-loop for sub-taxy in (taxy-taxys taxy) + maximizing (taxy-latest-ts sub-taxy))))))) (t<nil (a b) (and a (not b))) (t>nil (a b) (and (not a) b)) (make-fn (&rest args) - (apply #'make-taxy-magit-section - :make #'make-fn - :format-fn #'format-item - :level-indent ement-room-list-level-indent - ;; :visibility-fn #'visible-p - ;; :heading-indent 2 - :item-indent 2 - ;; :heading-face-fn #'heading-face - args))) + (apply #'make-taxy-magit-section + :make #'make-fn + :format-fn #'format-item + :level-indent ement-room-list-level-indent + ;; :visibility-fn #'visible-p + ;; :heading-indent 2 + :item-indent 2 + ;; :heading-face-fn #'heading-face + args))) ;; (when (get-buffer buffer-name) ;; (kill-buffer buffer-name)) (unless ement-sessions @@ -626,9 +626,9 @@ DISPLAY-BUFFER-ACTION is nil, the buffer is not displayed." append (cl-loop for room in (ement-session-rooms session) collect (vector room session)))) (taxy (cl-macrolet ((first-item - (pred) `(lambda (taxy) - (when (taxy-items taxy) - (,pred (car (taxy-items taxy)))))) + (pred) `(lambda (taxy) + (when (taxy-items taxy) + (,pred (car (taxy-items taxy)))))) (name= (name) `(lambda (taxy) (equal ,name (taxy-name taxy))))) (thread-last diff --git a/ement-room.el b/ement-room.el index a7eb288..1dbf8bf 100644 --- a/ement-room.el +++ b/ement-room.el @@ -1,6 +1,6 @@ ;;; ement-room.el --- Ement room buffers -*- lexical-binding: t; -*- -;; Copyright (C) 2022 Free Software Foundation, Inc. +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. ;; Author: Adam Porter <adam@alphapapa.net> ;; Maintainer: Adam Porter <adam@alphapapa.net> @@ -122,11 +122,11 @@ Used to, e.g. call `ement-room-compose-org'.") (define-key map (kbd "?") #'ement-room-transient) ;; Movement - (define-key map (kbd "TAB") #'ement-room-goto-next) - (define-key map (kbd "<backtab>") #'ement-room-goto-prev) + (define-key map (kbd "n") #'ement-room-goto-next) + (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-SPC") #'ement-room-goto-fully-read-marker) + (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) @@ -206,6 +206,13 @@ In that case, sender names are aligned to the margin edge.") (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) @@ -277,6 +284,11 @@ normal text.") '((t (:inherit italic))) "Emote message bodies.") +(defface ement-room-quote + '((t (:height 0.9 :inherit font-lock-comment-face))) + "Quoted parts of messages. +Anything wrapped by HTML BLOCKQUOTE tag.") + (defface ement-room-redacted '((t (:strike-through t))) "Redacted messages.") @@ -293,6 +305,7 @@ this one automatically.") "Timestamp headers.") (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)))) @@ -398,12 +411,12 @@ 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)))))) + ;; 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)) @@ -779,7 +792,8 @@ room, and the session. See macro 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)) + (declare (indent defun) + (debug (characterp stringp def-body))) `(setf (alist-get ,char ement-room-event-formatters nil nil #'equal) (lambda (event room session) ,docstring @@ -805,23 +819,55 @@ spec) without requiring all events to use the same margin width." (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 :formatted-p nil))) - (face (ement-room--event-body-face event room session))) - (add-face-text-property 0 (length body) face 'append body) + (let* ((body (save-match-data + (ement-room--format-message-body event :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))) - (face (ement-room--event-body-face event room session))) - (add-face-text-property 0 (length body) face 'append body) + (let* ((body (save-match-data + (ement-room--format-message-body event))) + (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)) @@ -970,11 +1016,10 @@ Note that, if ROOM has no buffer, STRING is returned unchanged." (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-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 @@ -1125,15 +1170,14 @@ are passed to `browse-url'." (defun ement-room-find-event (event-id) "Go to EVENT-ID in current buffer." (interactive) - (cl-labels ((goto-event - (event-id) (progn - (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)))))))))) + (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) @@ -1217,8 +1261,9 @@ otherwise use current room." (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) nil nil 'inherit-input-method))) + (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. @@ -1228,7 +1273,7 @@ otherwise use current room." (extension (or (file-name-extension file) "")) (mime-type (mailcap-extension-to-mime extension)) (data `(file ,file)) - (size (length data))) + (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) @@ -1257,8 +1302,9 @@ otherwise use current room." (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) nil nil 'inherit-input-method))) + (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")) @@ -1333,7 +1379,7 @@ buffer). It receives two arguments, the room and the session." (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 (ewoc-locate ement-ewoc)) + (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))) @@ -1345,7 +1391,11 @@ see." (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) - (user-error "End of events"))) + (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." @@ -1513,16 +1563,16 @@ sync requests. Also, update any room list buffers." 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)))) + (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]") @@ -1554,8 +1604,8 @@ the content (e.g. see `ement-room-send-org-filter')." (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 nil nil - 'inherit-input-method)))) + (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 @@ -1586,8 +1636,8 @@ the content (e.g. see `ement-room-send-org-filter')." (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 nil nil - 'inherit-input-method)))) + (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) @@ -1660,8 +1710,8 @@ The message must be one sent by the local user." (ement-room-with-typing (let* ((prompt (format "Edit message (%s): " (ement-room-display-name ement-room))) - (body (ement-room-read-string prompt body nil nil - 'inherit-input-method))) + (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)) @@ -1709,7 +1759,8 @@ The message must be one sent by the local user." (lambda () (setq-local ement-room-replying-to-event event))) (body (ement-room-with-typing - (ement-room-read-string prompt nil nil nil 'inherit-input-method)))) + (ement-room-read-string prompt nil 'ement-room-message-history + nil 'inherit-input-method)))) (ement-room-send-message room session :body body :replying-to-event event)))) (defun ement-room-send-reaction (key position) @@ -1743,28 +1794,27 @@ reaction string, e.g. \"👍\"." "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))))))) + ((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)) @@ -2748,22 +2798,22 @@ 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))) - (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))))))) + (let* ((old-node (symbol-value symbol)) + (new-event-id (cl-etypecase to-event + (ement-event (ement-event-id to-event)) + (string to-event))) + (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 @@ -2882,15 +2932,15 @@ the first and last nodes in the buffer, respectively." (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)))))) + (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)))) @@ -2921,14 +2971,14 @@ the first and last nodes in the buffer, respectively." "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 ((read-marker-p - (data) (member data '(ement-room-fully-read-marker - ement-room-read-receipt-marker))) - (message-event-p - (data) (and (ement-event-p data) - (equal "m.room.message" (ement-event-type data)))) - (insert-sender-before - (node) (ewoc-enter-before ewoc node (ement-event-sender (ewoc-data node))))) + (cl-labels ((read-marker-p (data) + (member data '(ement-room-fully-read-marker + ement-room-read-receipt-marker))) + (message-event-p (data) + (and (ement-event-p data) + (equal "m.room.message" (ement-event-type data)))) + (insert-sender-before (node) + (ewoc-enter-before ewoc node (ement-event-sender (ewoc-data node))))) (let* ((event-node (if (ement-event-p (ewoc-data start-node)) start-node (ement-room--ewoc-next-matching ewoc start-node @@ -2982,10 +3032,10 @@ the first and last nodes in the buffer, respectively." (defun ement-room--coalesce-nodes (a b ewoc) "Try to coalesce events in nodes A and B in EWOC. Return absorbing node if 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))))) + (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)))) @@ -3004,40 +3054,39 @@ Return absorbing node if coalesced." (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. + (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)) + (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))) + (pcase data + ((pred ement-event-p) t) + ((pred ement-room-membership-events-p) t) + (`(ts . ,_) t))) (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)))) + (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)))) + "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)) @@ -3120,11 +3169,11 @@ Search from FROM (either `first' or `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))) + (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)) @@ -3267,38 +3316,38 @@ Formats according to `ement-room-message-format-spec', which see." "Return formatted reactions to EVENT." ;; TODO: Like other events, pop to a buffer showing the raw reaction events when a key is pressed. (if-let ((reactions (map-elt (ement-event-local event) 'reactions))) - (cl-labels ((format-reaction - (ks) (pcase-let* ((`(,key . ,senders) ks) - (key (propertize key 'face 'ement-room-reactions-key)) - (count (propertize (format " (%s)" (length senders)) - '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 ", ")))) + (cl-labels ((format-reaction (ks) + (pcase-let* ((`(,key . ,senders) ks) + (key (propertize key 'face 'ement-room-reactions-key)) + (count (propertize (format " (%s)" (length senders)) + '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 ", ")))) (cl-loop with keys-senders for reaction in reactions for key = (map-nested-elt (ement-event-content reaction) '(m.relates_to key)) @@ -3471,8 +3520,10 @@ HTML is rendered to Emacs text using `shr-insert-document'." (let ((beg (point-marker))) (funcall old-fn dom) (add-text-properties beg (point-max) - '(wrap-prefix " " - line-prefix " ")))))) + '( 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))))) @@ -3488,8 +3539,8 @@ HTML is rendered to Emacs text using `shr-insert-document'." ;; 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)))) + (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))))))) @@ -3528,31 +3579,30 @@ HTML is rendered to Emacs text using `shr-insert-document'." (defun ement-room--user-color (user) "Return a color in which to display USER's messages." - (cl-labels ((relative-luminance - ;; Copy of `modus-themes-wcag-formula', an elegant - ;; implementation by Protesilaos Stavrou. Also see - ;; <https://en.wikipedia.org/wiki/Relative_luminance> and - ;; <https://www.w3.org/TR/WCAG20/#relativeluminancedef>. - (rgb) (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 - ;; Copy of `modus-themes-contrast'; see above. - (a b) (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))))) + (cl-labels ((relative-luminance (rgb) + ;; Copy of `modus-themes-wcag-formula', an elegant + ;; implementation by Protesilaos Stavrou. Also see + ;; <https://en.wikipedia.org/wiki/Relative_luminance> and + ;; <https://www.w3.org/TR/WCAG20/#relativeluminancedef>. + (cl-loop for k in '(0.2126 0.7152 0.0722) + for x in rgb + sum (* k (if (<= x 0.03928) + (/ x 12.92) + (expt (/ (+ x 0.055) 1.055) 2.4))))) + (contrast-ratio (a b) + ;; Copy of `modus-themes-contrast'; see above. + (let ((ct (/ (+ (relative-luminance a) 0.05) + (+ (relative-luminance b) 0.05)))) + (max ct (/ ct)))) + (increase-contrast (color against target toward) + (let ((gradient (cdr (color-gradient color toward 20))) + new-color) + (cl-loop do (setf new-color (pop gradient)) + while new-color + until (>= (contrast-ratio new-color against) target) + ;; Avoid infinite loop in case of weirdness + ;; by returning color as a fallback. + finally return (or new-color color))))) (let* ((id (ement-user-id user)) (id-hash (float (+ (abs (sxhash id)) ement-room-prism-color-adjustment))) ;; TODO: Wrap-around the value to get the color I want. @@ -3677,8 +3727,10 @@ To be called from an `ement-room-compose' buffer." (eq data replying-to-event)))))) (body (if replying-to-event (ement-room-with-highlighted-event-at pos - (ement-room-read-string prompt (car kill-ring) nil nil 'inherit-input-method)) - (ement-room-read-string prompt (car kill-ring) nil nil 'inherit-input-method)) )) + (ement-room-read-string prompt (car kill-ring) 'ement-room-message-history + nil 'inherit-input-method)) + (ement-room-read-string prompt (car kill-ring) 'ement-room-message-history + nil 'inherit-input-method)) )) (ement-room-send-message ement-room ement-session :body body :replying-to-event replying-to-event)))) (defun ement-room-init-compose-buffer (room session) @@ -3731,24 +3783,24 @@ a copy of the local keymap, and sets `header-line-format'." 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)))) + ;; 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 @@ -3845,14 +3897,16 @@ a copy of the local keymap, and sets `header-line-format'." (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)))) + (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")) @@ -4165,7 +4219,8 @@ Then invalidate EVENT's node to show the image." event) (url (when mxc-url (ement--mxc-to-url mxc-url ement-session))) - (human-size (file-size-human-readable size)) + (human-size (when size + (file-size-human-readable size))) (string (format "[file: %s (%s) (%s)]" filename mimetype human-size))) (concat (propertize string 'action #'browse-url @@ -4212,6 +4267,7 @@ Then invalidate EVENT's node to show the image." (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") @@ -4259,6 +4315,7 @@ compatibility), and the result is added to the CONTENT as (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)) (org-html-export-as-html nil nil nil 'body-only))) (with-current-buffer "*Org HTML Export*" diff --git a/ement-structs.el b/ement-structs.el index d80a7bf..f6e9462 100644 --- a/ement-structs.el +++ b/ement-structs.el @@ -1,6 +1,6 @@ ;;; ement-structs.el --- Ement structs -*- lexical-binding: t; -*- -;; Copyright (C) 2022 Free Software Foundation, Inc. +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. ;; Author: Adam Porter <adam@alphapapa.net> ;; Maintainer: Adam Porter <adam@alphapapa.net> diff --git a/ement-tabulated-room-list.el b/ement-tabulated-room-list.el index 047852b..c020eee 100644 --- a/ement-tabulated-room-list.el +++ b/ement-tabulated-room-list.el @@ -1,6 +1,6 @@ ;;; ement-tabulated-room-list.el --- Ement tabulated room list buffer -*- lexical-binding: t; -*- -;; Copyright (C) 2022 Free Software Foundation, Inc. +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. ;; Author: Adam Porter <adam@alphapapa.net> ;; Maintainer: Adam Porter <adam@alphapapa.net> @@ -1,11 +1,11 @@ ;;; ement.el --- Matrix client -*- lexical-binding: t; -*- -;; Copyright (C) 2022 Free Software Foundation, Inc. +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. ;; Author: Adam Porter <adam@alphapapa.net> ;; Maintainer: Adam Porter <adam@alphapapa.net> ;; URL: https://github.com/alphapapa/ement.el -;; Version: 0.11 +;; Version: 0.12 ;; Package-Requires: ((emacs "27.1") (map "2.1") (persist "0.5") (plz "0.6") (taxy "0.10") (taxy-magit-section "0.12.1") (svg-lib "0.2.5") (transient "0.3.7")) ;; Keywords: comm @@ -60,6 +60,7 @@ ;; This package. (require 'ement-lib) (require 'ement-room) +(require 'ement-notifications) (require 'ement-notify) ;;;; Variables @@ -106,6 +107,9 @@ by users; ones who do so should know what they're doing.") (defvar ement-read-receipt-idle-timer nil "Idle timer used to update read receipts.") +(defvar ement-connect-user-id-history nil + "History list of user IDs entered into `ement-connect'.") + ;; From other files. (defvar ement-room-avatar-max-width) (defvar ement-room-avatar-max-height) @@ -210,7 +214,7 @@ the port, e.g. \"http://localhost:8080\"" (interactive (if current-prefix-arg ;; Force new session. - (list :user-id (read-string "User ID: ")) + (list :user-id (read-string "User ID: " nil 'ement-connect-user-id-history)) ;; Use known session. (unless ement-sessions ;; Read sessions from disk. @@ -219,110 +223,109 @@ the port, e.g. (error (display-warning 'ement (format "Unable to read session data from disk (%s). Prompting to log in again." (error-message-string err)))))) (cl-case (length ement-sessions) - (0 (list :user-id (read-string "User ID: "))) + (0 (list :user-id (read-string "User ID: " nil 'ement-connect-user-id-history))) (1 (list :session (cdar ement-sessions))) (otherwise (list :session (ement-complete-session)))))) (let (sso-server-process) - (cl-labels ((new-session - () (unless (string-match (rx bos "@" (group (1+ (not (any ":")))) ; Username - ":" (group (optional (1+ (not (any blank)))))) ; Server name - user-id) - (user-error "Invalid user ID format: use @USERNAME:SERVER")) - (let* ((username (match-string 1 user-id)) - (server-name (match-string 2 user-id)) - (uri-prefix (or uri-prefix (ement--hostname-uri server-name))) - (user (make-ement-user :id user-id :username username)) - (server (make-ement-server :name server-name :uri-prefix uri-prefix)) - (transaction-id (ement--initial-transaction-id)) - (initial-device-display-name (format "Ement.el: %s@%s" - ;; Just to be extra careful: - (or user-login-name "[unknown user-login-name]") - (or (system-name) "[unknown system-name]"))) - (device-id (secure-hash 'sha256 initial-device-display-name))) - (make-ement-session :user user :server server :transaction-id transaction-id - :device-id device-id :initial-device-display-name initial-device-display-name - :events (make-hash-table :test #'equal)))) - (password-login - () (pcase-let* (((cl-struct ement-session user device-id initial-device-display-name) session) - ((cl-struct ement-user id) user) - (data (ement-alist "type" "m.login.password" - "identifier" - (ement-alist "type" "m.id.user" - "user" id) - "password" (or password - (read-passwd (format "Password for %s: " id))) - "device_id" device-id - "initial_device_display_name" initial-device-display-name))) - ;; TODO: Clear password in callback (if we decide to hold on to it for retrying login timeouts). - (ement-api session "login" :method 'post :data (json-encode data) - :then (apply-partially #'ement--login-callback session)) - (ement-message "Logging in with password..."))) - (sso-filter - (process string) - ;; NOTE: This is technically wrong, because it's not guaranteed that the - ;; string will be a complete request--it could just be a chunk. But in - ;; practice, if this works, it's much simpler than setting up process log - ;; functions and per-client buffers for this throwaway, pretend HTTP server. - (when (string-match (rx "GET /?loginToken=" (group (0+ nonl)) " " (0+ nonl)) string) - (unwind-protect - (pcase-let* ((token (match-string 1 string)) - ((cl-struct ement-session user device-id initial-device-display-name) - session) - ((cl-struct ement-user id) user) - (data (ement-alist - "type" "m.login.token" - "identifier" (ement-alist "type" "m.id.user" - "user" id) - "token" token - "device_id" device-id - "initial_device_display_name" initial-device-display-name))) - (ement-api session "login" :method 'post - :data (json-encode data) - :then (apply-partially #'ement--login-callback session)) - (process-send-string process "HTTP/1.0 202 Accepted + (cl-labels ((new-session () + (unless (string-match (rx bos "@" (group (1+ (not (any ":")))) ; Username + ":" (group (optional (1+ (not (any blank)))))) ; Server name + user-id) + (user-error "Invalid user ID format: use @USERNAME:SERVER")) + (let* ((username (match-string 1 user-id)) + (server-name (match-string 2 user-id)) + (uri-prefix (or uri-prefix (ement--hostname-uri server-name))) + (user (make-ement-user :id user-id :username username)) + (server (make-ement-server :name server-name :uri-prefix uri-prefix)) + (transaction-id (ement--initial-transaction-id)) + (initial-device-display-name (format "Ement.el: %s@%s" + ;; Just to be extra careful: + (or user-login-name "[unknown user-login-name]") + (or (system-name) "[unknown system-name]"))) + (device-id (secure-hash 'sha256 initial-device-display-name))) + (make-ement-session :user user :server server :transaction-id transaction-id + :device-id device-id :initial-device-display-name initial-device-display-name + :events (make-hash-table :test #'equal)))) + (password-login () + (pcase-let* (((cl-struct ement-session user device-id initial-device-display-name) session) + ((cl-struct ement-user id) user) + (data (ement-alist "type" "m.login.password" + "identifier" + (ement-alist "type" "m.id.user" + "user" id) + "password" (or password + (read-passwd (format "Password for %s: " id))) + "device_id" device-id + "initial_device_display_name" initial-device-display-name))) + ;; TODO: Clear password in callback (if we decide to hold on to it for retrying login timeouts). + (ement-api session "login" :method 'post :data (json-encode data) + :then (apply-partially #'ement--login-callback session)) + (ement-message "Logging in with password..."))) + (sso-filter (process string) + ;; NOTE: This is technically wrong, because it's not guaranteed that the + ;; string will be a complete request--it could just be a chunk. But in + ;; practice, if this works, it's much simpler than setting up process log + ;; functions and per-client buffers for this throwaway, pretend HTTP server. + (when (string-match (rx "GET /?loginToken=" (group (0+ nonl)) " " (0+ nonl)) string) + (unwind-protect + (pcase-let* ((token (match-string 1 string)) + ((cl-struct ement-session user device-id initial-device-display-name) + session) + ((cl-struct ement-user id) user) + (data (ement-alist + "type" "m.login.token" + "identifier" (ement-alist "type" "m.id.user" + "user" id) + "token" token + "device_id" device-id + "initial_device_display_name" initial-device-display-name))) + (ement-api session "login" :method 'post + :data (json-encode data) + :then (apply-partially #'ement--login-callback session)) + (process-send-string process "HTTP/1.0 202 Accepted Content-Type: text/plain; charset=utf-8 Ement: SSO login accepted; session token received. Connecting to Matrix server. (You may close this page.)") - (process-send-eof process)) - (delete-process sso-server-process) - (delete-process process)))) + (process-send-eof process)) + (delete-process sso-server-process) + (delete-process process)))) (sso-login () - (setf sso-server-process - (make-network-process - :name "ement-sso" :family 'ipv4 :host 'local :service ement-sso-server-port - :filter #'sso-filter :server t :noquery t)) - ;; Kill server after 2 minutes in case of problems. - (run-at-time 120 nil (lambda () - (when (process-live-p sso-server-process) - (delete-process sso-server-process)))) - (let ((url (concat (ement-server-uri-prefix (ement-session-server session)) - "/_matrix/client/r0/login/sso/redirect?redirectUrl=http://localhost:" - (number-to-string ement-sso-server-port)))) - (funcall browse-url-secondary-browser-function url) - (message "Browsing to single sign-on page <%s>..." url))) - (flows-callback - (data) (let ((flows (cl-loop for flow across (map-elt data 'flows) - for type = (map-elt flow 'type) - when (member type '("m.login.password" "m.login.sso")) - collect type))) - (pcase (length flows) - (0 (error "Ement: No supported login flows: Server:%S Supported flows:%S" - (ement-server-uri-prefix (ement-session-server session)) - (map-elt data 'flows))) - (1 (pcase (car flows) - ("m.login.password" (password-login)) - ("m.login.sso" (sso-login)) - (_ (error "Ement: Unsupported login flow: %s Server:%S Supported flows:%S" - (car flows) (ement-server-uri-prefix (ement-session-server session)) - (map-elt data 'flows))))) - (_ (pcase (completing-read "Select authentication method: " - (cl-loop for flow in flows - collect (string-trim-left flow (rx "m.login.")))) - ("password" (password-login)) - ("sso" (sso-login)) - (else (error "Ement: Unsupported login flow:%S Server:%S Supported flows:%S" - else (ement-server-uri-prefix (ement-session-server session)) - (map-elt data 'flows))))))))) + (setf sso-server-process + (make-network-process + :name "ement-sso" :family 'ipv4 :host 'local :service ement-sso-server-port + :filter #'sso-filter :server t :noquery t)) + ;; Kill server after 2 minutes in case of problems. + (run-at-time 120 nil (lambda () + (when (process-live-p sso-server-process) + (delete-process sso-server-process)))) + (let ((url (concat (ement-server-uri-prefix (ement-session-server session)) + "/_matrix/client/r0/login/sso/redirect?redirectUrl=http://localhost:" + (number-to-string ement-sso-server-port)))) + (funcall browse-url-secondary-browser-function url) + (message "Browsing to single sign-on page <%s>..." url))) + (flows-callback (data) + (let ((flows (cl-loop for flow across (map-elt data 'flows) + for type = (map-elt flow 'type) + when (member type '("m.login.password" "m.login.sso")) + collect type))) + (pcase (length flows) + (0 (error "Ement: No supported login flows: Server:%S Supported flows:%S" + (ement-server-uri-prefix (ement-session-server session)) + (map-elt data 'flows))) + (1 (pcase (car flows) + ("m.login.password" (password-login)) + ("m.login.sso" (sso-login)) + (_ (error "Ement: Unsupported login flow: %s Server:%S Supported flows:%S" + (car flows) (ement-server-uri-prefix (ement-session-server session)) + (map-elt data 'flows))))) + (_ (pcase (completing-read "Select authentication method: " + (cl-loop for flow in flows + collect (string-trim-left flow (rx "m.login.")))) + ("password" (password-login)) + ("sso" (sso-login)) + (else (error "Ement: Unsupported login flow:%S Server:%S Supported flows:%S" + else (ement-server-uri-prefix (ement-session-server session)) + (map-elt data 'flows))))))))) (if session ;; Start syncing given session. (let ((user-id (ement-user-id (ement-session-user session)))) @@ -332,7 +335,7 @@ Ement: SSO login accepted; session token received. Connecting to Matrix server. ;; Start password login flow. Prompt for user ID and password ;; if not given (i.e. if not called interactively.) (unless user-id - (setf user-id (read-string "User ID: "))) + (setf user-id (read-string "User ID: " nil 'ement-connect-user-id-history))) (setf session (new-session)) (when (ement-api session "login" :then #'flows-callback) (message "Ement: Checking server's login flows...")))))) @@ -452,20 +455,20 @@ To be called from `ement-disconnect-hook'." If no URI is found, prompt the user for the hostname." ;; FIXME: When fail-prompting, a URI should be returned, not just a hostname. ;; SPEC: <https://matrix.org/docs/spec/client_server/r0.6.1#id178> ("4.1 Well-known URI") - (cl-labels ((fail-prompt - () (let ((input (read-string "Auto-discovery of server's well-known URI failed. Input server hostname, or leave blank to use server name: "))) - (pcase input - ("" hostname) - (_ input)))) + (cl-labels ((fail-prompt () + (let ((input (read-string "Auto-discovery of server's well-known URI failed. Input server hostname, or leave blank to use server name: "))) + (pcase input + ("" hostname) + (_ input)))) (parse (string) - (if-let* ((object (ignore-errors (json-read-from-string string))) - (url (map-nested-elt object '(m.homeserver base_url))) - ((string-match-p - (rx bos "http" (optional "s") "://" (1+ nonl)) - url))) - url - ;; Parsing error: FAIL_PROMPT. - (fail-prompt)))) + (if-let* ((object (ignore-errors (json-read-from-string string))) + (url (map-nested-elt object '(m.homeserver base_url))) + ((string-match-p + (rx bos "http" (optional "s") "://" (1+ nonl)) + url))) + url + ;; Parsing error: FAIL_PROMPT. + (fail-prompt)))) (condition-case err (let ((response (plz 'get (concat "https://" hostname "/.well-known/matrix/client") :as 'response :then 'sync))) @@ -548,13 +551,13 @@ a filter ID). When unspecified, the value of plz-error))) (_ (signal 'ement-api-error (list "Ement: Unrecognized network error" plz-error))))))) :json-read-fn (lambda () - "Print a message, then call `json-read'." + "Print a message, then call `ement--json-parse-buffer'." (when (ement--sync-messages-p session) (message "Ement: Response arrived after %.2f seconds. Reading %s JSON response..." (- (time-to-seconds) sync-start-time) (file-size-human-readable (buffer-size)))) (let ((start-time (time-to-seconds))) - (prog1 (json-read) + (prog1 (ement--json-parse-buffer) (when (ement--sync-messages-p session) (message "Ement: Reading JSON took %.2f seconds" (- (time-to-seconds) start-time))))))))) @@ -720,23 +723,22 @@ Also used for left rooms, in which case STATUS should be set to (alist-get 'new-account-data-events (ement-room-local room))) ;; Save state and timeline events. - (cl-macrolet ((push-events - (type accessor) - ;; Push new events of TYPE to room's slot of ACCESSOR, and return the latest timestamp pushed. - `(let ((ts 0)) - ;; NOTE: We replace each event in the vector with the - ;; struct, which is used when calling hooks later. - (cl-loop for event across-ref (alist-get 'events ,type) - do (setf event (ement--make-event event)) - do (push event (,accessor room)) - (when (ement--sync-messages-p session) - (ement-progress-update)) - (when (> (ement-event-origin-server-ts event) ts) - (setf ts (ement-event-origin-server-ts event)))) - ;; One would think that one should use `maximizing' here, but, completely - ;; inexplicably, it sometimes returns nil, even when every single value it's comparing - ;; is a number. It's absolutely bizarre, but I have to do the equivalent manually. - ts))) + (cl-macrolet ((push-events (type accessor) + ;; Push new events of TYPE to room's slot of ACCESSOR, and return the latest timestamp pushed. + `(let ((ts 0)) + ;; NOTE: We replace each event in the vector with the + ;; struct, which is used when calling hooks later. + (cl-loop for event across-ref (alist-get 'events ,type) + do (setf event (ement--make-event event)) + do (push event (,accessor room)) + (when (ement--sync-messages-p session) + (ement-progress-update)) + (when (> (ement-event-origin-server-ts event) ts) + (setf ts (ement-event-origin-server-ts event)))) + ;; One would think that one should use `maximizing' here, but, completely + ;; inexplicably, it sometimes returns nil, even when every single value it's comparing + ;; is a number. It's absolutely bizarre, but I have to do the equivalent manually. + ts))) ;; FIXME: This is a bit convoluted and hacky now. Refactor it. (setf latest-timestamp (max (push-events state ement-room-state) @@ -823,16 +825,16 @@ Adds sender to `ement-users' when necessary." (defun ement--read-sessions () "Return saved sessions alist read from disk. Returns nil if unable to read `ement-sessions-file'." - (cl-labels ((plist-to-session - (plist) (pcase-let* (((map (:user user-data) (:server server-data) - (:token token) (:transaction-id transaction-id)) - plist) - (user (apply #'make-ement-user user-data)) - (server (apply #'make-ement-server server-data)) - (session (make-ement-session :user user :server server - :token token :transaction-id transaction-id))) - (setf (ement-session-events session) (make-hash-table :test #'equal)) - session))) + (cl-labels ((plist-to-session (plist) + (pcase-let* (((map (:user user-data) (:server server-data) + (:token token) (:transaction-id transaction-id)) + plist) + (user (apply #'make-ement-user user-data)) + (server (apply #'make-ement-server server-data)) + (session (make-ement-session :user user :server server + :token token :transaction-id transaction-id))) + (setf (ement-session-events session) (make-hash-table :test #'equal)) + session))) (when (file-exists-p ement-sessions-file) (pcase-let* ((read-circle t) (sessions (with-temp-buffer @@ -854,16 +856,16 @@ Returns nil if unable to read `ement-sessions-file'." ;; NOTE: This writes all current sessions, even if there are multiple active ones and only one ;; is being disconnected. That's probably okay, but it might be something to keep in mind. - (cl-labels ((session-plist - (session) (pcase-let* (((cl-struct ement-session user server token transaction-id) session) - ((cl-struct ement-user (id user-id) username) user) - ((cl-struct ement-server (name server-name) uri-prefix) server)) - (list :user (list :id user-id - :username username) - :server (list :name server-name - :uri-prefix uri-prefix) - :token token - :transaction-id transaction-id)))) + (cl-labels ((session-plist (session) + (pcase-let* (((cl-struct ement-session user server token transaction-id) session) + ((cl-struct ement-user (id user-id) username) user) + ((cl-struct ement-server (name server-name) uri-prefix) server)) + (list :user (list :id user-id + :username username) + :server (list :name server-name + :uri-prefix uri-prefix) + :token token + :transaction-id transaction-id)))) (message "Ement: Writing sessions...") (with-temp-file ement-sessions-file (pcase-let* ((print-level nil) @@ -1059,6 +1061,26 @@ To be called after initial sync." (when-let ((child-room (cl-find child-id rooms :key #'ement-room-id :test #'equal))) (cl-pushnew parent-id (alist-get 'parents (ement-room-local child-room)) :test #'equal)))))))) +;;;;; Savehist compatibility + +;; See <https://github.com/alphapapa/ement.el/issues/216>. + +(defvar savehist-save-hook) + +(with-eval-after-load 'savehist + ;; TODO: Consider using a symbol property on our commands and checking that rather than + ;; symbol names; would avoid consing. + (defun ement--savehist-save-hook () + "Remove all `ement-' commands from `command-history'. +Because when `savehist' saves `command-history', it includes the +interactive arguments passed to the command, which in our case +includes large data structures that should never be persisted!" + (setf command-history + (cl-remove-if (pcase-lambda (`(,command . ,_)) + (string-match-p (rx bos "ement-") (symbol-name command))) + command-history))) + (cl-pushnew 'ement--savehist-save-hook savehist-save-hook)) + ;;;; Footer (provide 'ement) |