branch: elpa/jabber
commit a7b87cc870a6667a81462190350218096dd8316e
Author: Thanos Apollo <[email protected]>
Commit: Thanos Apollo <[email protected]>
reactions: Add message reactions support
---
Makefile | 1 +
doap.xml | 7 +
lisp/jabber-chat.el | 39 ++++-
lisp/jabber-chatbuffer.el | 26 +++-
lisp/jabber-muc.el | 38 ++---
lisp/jabber-reactions.el | 338 +++++++++++++++++++++++++++++++++++++++++
lisp/jabber-sm.el | 14 +-
lisp/jabber.el | 1 +
tests/jabber-test-reactions.el | 212 ++++++++++++++++++++++++++
tests/jabber-test-sm.el | 24 +++
10 files changed, 666 insertions(+), 34 deletions(-)
diff --git a/Makefile b/Makefile
index 5c52407ccd..3a1b048e2f 100644
--- a/Makefile
+++ b/Makefile
@@ -44,6 +44,7 @@ TESTS ?= tests/jabber-test-activity.el \
tests/jabber-test-openpgp-legacy.el \
tests/jabber-test-presence.el \
tests/jabber-test-pubsub.el \
+ tests/jabber-test-reactions.el \
tests/jabber-test-receipts.el \
tests/jabber-test-roster.el \
tests/jabber-test-sm.el \
diff --git a/doap.xml b/doap.xml
index 90123bbe63..4a2468d02b 100644
--- a/doap.xml
+++ b/doap.xml
@@ -537,6 +537,13 @@
<xmpp:since>0.10.0</xmpp:since>
</xmpp:SupportedXep>
</implements>
+ <implements>
+ <xmpp:SupportedXep>
+ <xmpp:xep rdf:resource="https://xmpp.org/extensions/xep-0444.html"/>
+ <xmpp:status>partial</xmpp:status>
+ <xmpp:note>Message Reactions display is in-memory only, with no
persistence, no restriction discovery, and provisional MUC actor
identity.</xmpp:note>
+ </xmpp:SupportedXep>
+ </implements>
<implements>
<xmpp:SupportedXep>
<xmpp:xep rdf:resource="https://xmpp.org/extensions/xep-0454.html"/>
diff --git a/lisp/jabber-chat.el b/lisp/jabber-chat.el
index 7ac2823ab8..db95e0fe19 100644
--- a/lisp/jabber-chat.el
+++ b/lisp/jabber-chat.el
@@ -29,8 +29,10 @@
(require 'jabber-core)
(require 'jabber-alert)
(require 'jabber-chatbuffer)
+(require 'jabber-reactions)
(require 'ewoc)
(require 'goto-addr)
+(require 'subr-x)
(require 'url-parse)
(require 'url-queue)
(require 'hex-util)
@@ -368,10 +370,7 @@ JC is the Jabber connection."
;; Catch up missed 1:1 messages from MAM.
(jabber-mam-chat-opened jc (jabber-jid-user chat-with))
- (when-let* ((win (get-buffer-window (current-buffer))))
- (with-selected-window win
- (goto-char jabber-point-insert)
- (recenter -1))))
+ (jabber-chat-buffer-recenter-input))
;; Make sure the connection variable is up to date.
(setq jabber-buffer-connection jc)
@@ -880,6 +879,30 @@ or X for undelivered."
(when indicator
(insert indicator)))))
+(defun jabber-chat--reaction-sender ()
+ "Return the local sender key for reaction display."
+ (jabber-reactions--local-sender))
+
+(defun jabber-chat--reaction-entry-string (entry)
+ "Return propertized reaction summary text for ENTRY."
+ (propertize (format "%d%s"
+ (plist-get entry :count)
+ (plist-get entry :reaction))
+ 'face (if (plist-get entry :chosen)
+ 'jabber-reaction-chosen
+ 'jabber-reaction)))
+
+(defun jabber-chat--insert-reactions (msg)
+ "Insert compact reaction summaries for MSG."
+ (unless (plist-get msg :retracted)
+ (when-let* ((entries (jabber-reactions--display-entries
+ (plist-get msg :reactions)
+ (jabber-chat--reaction-sender))))
+ (insert "\n"
+ (string-join
+ (mapcar #'jabber-chat--reaction-entry-string entries)
+ " ")))))
+
(defun jabber-chat-pp--local (data)
"Render a locally sent message from DATA."
(let* ((msg (cadr data))
@@ -892,6 +915,7 @@ or X for undelivered."
(when (plist-get msg :edited)
(insert (propertize " (edited)" 'face 'shadow)))
(jabber-chat--insert-status-indicator msg)
+ (jabber-chat--insert-reactions msg)
(insert "\n")))
(defun jabber-chat-pp--foreign (data)
@@ -905,6 +929,7 @@ or X for undelivered."
(run-hook-with-args 'jabber-chat-printers msg :foreign :insert))
(when (plist-get msg :edited)
(insert (propertize " (edited)" 'face 'shadow)))
+ (jabber-chat--insert-reactions msg)
(insert "\n")))
(defun jabber-chat--insert-tombstone (msg)
@@ -933,7 +958,8 @@ or X for undelivered."
(append jabber-muc-printers jabber-chat-printers)))
(when (plist-get msg :edited)
(insert (propertize " (edited)" 'face 'shadow)))
- (jabber-chat--insert-status-indicator msg))
+ (jabber-chat--insert-status-indicator msg)
+ (jabber-chat--insert-reactions msg))
(insert "\n")))
(defun jabber-chat-pp--muc-foreign (data)
@@ -948,7 +974,8 @@ or X for undelivered."
(mapc (lambda (f) (funcall f msg :muc-foreign :insert))
(append jabber-muc-printers jabber-chat-printers)))
(when (plist-get msg :edited)
- (insert (propertize " (edited)" 'face 'shadow))))
+ (insert (propertize " (edited)" 'face 'shadow)))
+ (jabber-chat--insert-reactions msg))
(insert "\n")))
(defun jabber-chat-pp--error (data)
diff --git a/lisp/jabber-chatbuffer.el b/lisp/jabber-chatbuffer.el
index e49323ec65..e722d93c05 100644
--- a/lisp/jabber-chatbuffer.el
+++ b/lisp/jabber-chatbuffer.el
@@ -34,6 +34,23 @@
(defvar jabber-point-insert nil
"Position where the message being composed starts.")
+(defun jabber-chat-buffer--recenter-input-p (window)
+ "Return non-nil when WINDOW should recenter to the input area."
+ (and (window-live-p window)
+ (with-current-buffer (window-buffer window)
+ (and (markerp jabber-point-insert)
+ (eq (marker-buffer jabber-point-insert)
+ (window-buffer window))
+ (>= (window-point window) jabber-point-insert)))))
+
+(defun jabber-chat-buffer-recenter-input ()
+ "Recenter the visible current buffer window to the input area."
+ (when-let* ((window (get-buffer-window (current-buffer))))
+ (when (jabber-chat-buffer--recenter-input-p window)
+ (with-selected-window window
+ (goto-char jabber-point-insert)
+ (recenter -1)))))
+
(defvar jabber-send-function nil
"Function for sending a message from a chat buffer.")
@@ -83,6 +100,7 @@ previous sequence detect the mismatch and stop.")
(declare-function jabber-chat-reply "jabber-message-reply" ())
(declare-function jabber-correct-last-message "jabber-message-correct" ())
(declare-function jabber-chat-cancel-reply "jabber-message-reply" ())
+(declare-function jabber-reactions-react-at-point-or-insert "jabber-reactions"
())
;;
@@ -415,7 +433,8 @@ MAM sync in this buffer. Set via the operations menu.")
"C-c C-e" #'jabber-chat-encryption-menu
"C-c C-m" #'jabber-muc-menu
"C-c C-r" #'jabber-chat-reply
- "C-c C-k" #'jabber-chat-cancel-reply)
+ "C-c C-k" #'jabber-chat-cancel-reply
+ "!" #'jabber-reactions-react-at-point-or-insert)
(define-derived-mode jabber-chat-mode fundamental-mode "jabber-chat"
"Major mode for Jabber chat buffers.
@@ -622,10 +641,7 @@ at the bottom of the window."
(setq jabber-chat-encryption saved))
(jabber-chat-encryption--update-header)
(force-mode-line-update)
- (when-let* ((win (get-buffer-window buffer)))
- (with-selected-window win
- (goto-char jabber-point-insert)
- (recenter -1)))))
+ (jabber-chat-buffer-recenter-input)))
(seq-filter
(lambda (buffer)
(with-current-buffer buffer
diff --git a/lisp/jabber-muc.el b/lisp/jabber-muc.el
index 915b6821d0..005ce86cc0 100644
--- a/lisp/jabber-muc.el
+++ b/lisp/jabber-muc.el
@@ -331,6 +331,8 @@ The format is that of `mode-line-format' and
`header-line-format'."
(xml-data))
(declare-function jabber-message-correct--apply "jabber-message-correct"
(replace-id new-body new-from muc-p buffer))
+(declare-function jabber-reactions--reaction-only-p "jabber-reactions"
+ (xml-data))
(defvar jabber-silent-mode) ; jabber.el
(defvar jabber-alert-muc-function) ; jabber-alert.el
(defvar jabber-body-printers) ; jabber-chat.el
@@ -408,10 +410,7 @@ JC is the Jabber connection."
#'jabber-chat-display-buffer-images
jabber-chat--backlog-generation))))
- (when-let* ((win (get-buffer-window (current-buffer))))
- (with-selected-window win
- (goto-char jabber-point-insert)
- (recenter -1))))
+ (jabber-chat-buffer-recenter-input))
;; Make sure the connection variable is up to date.
(setq jabber-buffer-connection jc)
@@ -1725,21 +1724,22 @@ messages."
JC is the Jabber connection."
(when (jabber-muc-message-p xml-data)
- (let* ((xml-data (jabber-chat--decrypt-if-needed jc xml-data))
- (from (jabber-xml-get-attribute xml-data 'from))
- (group (jabber-jid-user from))
- (nick (jabber-jid-resource from))
- (type (jabber-muc--classify-message jc group nick xml-data))
- (msg-plist (jabber-chat--msg-plist-from-stanza xml-data))
- (replace-id (jabber-message-correct--replace-id xml-data)))
- (if (and replace-id (not (jabber-muc--history-message-p xml-data)))
- (jabber-message-correct--apply
- replace-id
- (plist-get msg-plist :body)
- from
- t
- (jabber-muc-find-buffer group))
- (jabber-muc--display-message jc xml-data group nick type msg-plist)))))
+ (let ((xml-data (jabber-chat--decrypt-if-needed jc xml-data)))
+ (unless (jabber-reactions--reaction-only-p xml-data)
+ (let* ((from (jabber-xml-get-attribute xml-data 'from))
+ (group (jabber-jid-user from))
+ (nick (jabber-jid-resource from))
+ (type (jabber-muc--classify-message jc group nick xml-data))
+ (msg-plist (jabber-chat--msg-plist-from-stanza xml-data))
+ (replace-id (jabber-message-correct--replace-id xml-data)))
+ (if (and replace-id (not (jabber-muc--history-message-p xml-data)))
+ (jabber-message-correct--apply
+ replace-id
+ (plist-get msg-plist :body)
+ from
+ t
+ (jabber-muc-find-buffer group))
+ (jabber-muc--display-message jc xml-data group nick type
msg-plist)))))))
(defun jabber-muc--format-actor-reason (actor reason)
"Format optional \" by ACTOR\" / \" - \\='REASON\\='\" suffix."
diff --git a/lisp/jabber-reactions.el b/lisp/jabber-reactions.el
new file mode 100644
index 0000000000..efc3e7bbf6
--- /dev/null
+++ b/lisp/jabber-reactions.el
@@ -0,0 +1,338 @@
+;;; jabber-reactions.el --- XEP-0444 Message Reactions -*- lexical-binding:
t; -*-
+
+;; Copyright (C) 2026 Thanos Apollo
+
+;; Maintainer: Thanos Apollo <[email protected]>
+
+;; This file is a part of jabber.el.
+
+;; 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 2 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, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+;;; Commentary:
+
+;; XEP-0444 Message Reactions data helpers and outgoing stanza support.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'ewoc)
+(require 'subr-x)
+(require 'jabber-disco)
+(require 'jabber-util)
+
+(defconst jabber-reactions-xmlns "urn:xmpp:reactions:0"
+ "XEP-0444 Message Reactions namespace.")
+
+(defconst jabber-reactions-hints-xmlns "urn:xmpp:hints"
+ "XEP-0334 Message Processing Hints namespace.")
+
+(defcustom jabber-reactions-default-choices
+ '("👍" "❤️" "😂" "🎉" "😮" "😢" "🙏")
+ "Reaction strings offered by the outgoing reaction picker.
+This list is only a default set of picker choices. Incoming reactions
+are not filtered against it."
+ :type '(repeat string)
+ :group 'jabber)
+
+(defface jabber-reaction
+ '((t :inherit shadow))
+ "Face for message reaction summaries."
+ :group 'jabber)
+
+(defface jabber-reaction-chosen
+ '((t :inherit success))
+ "Face for message reactions selected by the local user."
+ :group 'jabber)
+
+(defvar jabber-buffer-connection)
+(defvar jabber-chat-ewoc)
+(defvar jabber-chatting-with)
+(defvar jabber-group)
+(defvar jabber-point-insert)
+
+(declare-function jabber-chat--unwrap-carbon "jabber-chat" (jc xml-data))
+(declare-function jabber-chat-ewoc-find-by-id "jabber-chatbuffer" (stanza-id))
+(declare-function jabber-chat-ewoc-invalidate "jabber-chatbuffer" (node))
+(declare-function jabber-chat-find-buffer "jabber-chat" (chat-with))
+(declare-function jabber-muc-find-buffer "jabber-muc" (group))
+(declare-function jabber-muc-nickname "jabber-muc" (group &optional jc))
+
+;;; Pure helpers
+
+(defun jabber-reactions--deduplicate (reactions)
+ "Return REACTIONS without duplicates, nils, or empty strings.
+The first occurrence of each non-empty string is kept."
+ (let ((seen nil)
+ (result nil))
+ (dolist (reaction reactions (nreverse result))
+ (when (and (stringp reaction)
+ (not (string-empty-p reaction))
+ (not (member reaction seen)))
+ (push reaction seen)
+ (push reaction result)))))
+
+(defun jabber-reactions--target-id (msg muc-p)
+ "Return the XEP-0444 target message ID from MSG.
+Use :server-id for MUC messages when MUC-P is non-nil, and :id for
+1:1 chat messages. Return nil when the needed ID is unavailable."
+ (plist-get msg (if muc-p :server-id :id)))
+
+(defun jabber-reactions--message-attributes (to type outgoing-id)
+ "Return message attributes for reaction stanza TO TYPE OUTGOING-ID."
+ (append `((to . ,to) (type . ,type))
+ (and outgoing-id `((id . ,outgoing-id)))))
+
+(defun jabber-reactions--build-stanza (to type target-id reactions outgoing-id)
+ "Build an outgoing XEP-0444 reaction stanza.
+TO is the destination JID. TYPE is the message type string. TARGET-ID
+is the stanza ID of the message being reacted to. REACTIONS is a list
+of selected reaction strings. OUTGOING-ID is the ID for the outgoing
+message stanza, or nil to omit it."
+ `(message ,(jabber-reactions--message-attributes to type outgoing-id)
+ (reactions ((xmlns . ,jabber-reactions-xmlns)
+ (id . ,target-id))
+ ,@(mapcar (lambda (reaction)
+ `(reaction () ,reaction))
+ (jabber-reactions--deduplicate reactions)))
+ (store ((xmlns . ,jabber-reactions-hints-xmlns)))))
+
+(defun jabber-reactions--display-entry (reaction senders chosen-sender)
+ "Build a display entry for REACTION by SENDERS.
+Non-nil CHOSEN-SENDER marks entries selected by that sender."
+ (list :reaction reaction
+ :count (length senders)
+ :chosen (and chosen-sender (member chosen-sender senders) t)
+ :senders senders))
+
+(defun jabber-reactions--display-entries (sender-state &optional chosen-sender)
+ "Aggregate SENDER-STATE into reaction display entries.
+SENDER-STATE is an alist of (SENDER . REACTIONS), where REACTIONS is a
+list of reaction strings currently selected by SENDER. CHOSEN-SENDER is
+used to mark locally selected reactions. Return a list of plists with
+:reaction, :count, :chosen, and :senders keys, preserving the first-seen
+reaction order."
+ (let ((order nil)
+ (senders-by-reaction nil))
+ (dolist (entry sender-state)
+ (let ((sender (car entry)))
+ (dolist (reaction (jabber-reactions--deduplicate (cdr entry)))
+ (unless (assoc reaction senders-by-reaction)
+ (push reaction order))
+ (cl-pushnew sender (alist-get reaction senders-by-reaction nil nil
#'equal)
+ :test #'equal))))
+ (mapcar (lambda (reaction)
+ (jabber-reactions--display-entry
+ reaction
+ (nreverse (alist-get reaction senders-by-reaction nil nil
#'equal))
+ chosen-sender))
+ (nreverse order))))
+
+(defun jabber-reactions--sender-reactions (sender msg)
+ "Return SENDER's current reactions from MSG."
+ (copy-sequence (alist-get sender (plist-get msg :reactions) nil nil
#'equal)))
+
+(defun jabber-reactions--toggle-reaction (reaction reactions)
+ "Return REACTIONS with REACTION toggled.
+Existing REACTION is removed. Missing REACTION is appended after the
+current deduplicated reaction list."
+ (let ((deduplicated (jabber-reactions--deduplicate reactions)))
+ (if (member reaction deduplicated)
+ (remove reaction deduplicated)
+ (append deduplicated (list reaction)))))
+
+(defun jabber-reactions--replace-sender-reactions (sender sender-reactions
reactions)
+ "Return REACTIONS with SENDER replaced by SENDER-REACTIONS.
+When SENDER-REACTIONS is nil, remove SENDER from REACTIONS."
+ (let ((without-sender (cl-remove sender reactions :key #'car :test #'equal))
+ (deduplicated (jabber-reactions--deduplicate sender-reactions)))
+ (if deduplicated
+ (cons (cons sender deduplicated) without-sender)
+ without-sender)))
+
+(defun jabber-reactions--parse-element (reactions)
+ "Return (TARGET-ID REACTIONS) parsed from REACTIONS element.
+REACTIONS is a XEP-0444 `<reactions>' XML node. Empty strings and
+repeated reaction strings are ignored. The reaction list may be nil for
+an empty update."
+ (when-let* ((target-id (jabber-xml-get-attribute reactions 'id)))
+ (list target-id
+ (jabber-reactions--deduplicate
+ (mapcar (lambda (reaction)
+ (car (jabber-xml-node-children reaction)))
+ (jabber-xml-get-children reactions 'reaction))))))
+
+(defun jabber-reactions--reaction-only-p (xml-data)
+ "Return non-nil when XML-DATA is only a reaction update stanza.
+A reaction-only stanza has a XEP-0444 `<reactions>' payload and no
+`<body>', `<subject>', or `<error>' child."
+ (and (jabber-xml-child-with-xmlns xml-data jabber-reactions-xmlns)
+ (not (jabber-xml-get-children xml-data 'body))
+ (not (jabber-xml-get-children xml-data 'subject))
+ (not (jabber-xml-get-children xml-data 'error))))
+
+(defun jabber-reactions--incoming-sender (from type)
+ "Return the reaction sender key for incoming FROM and message TYPE."
+ (when from
+ (if (string= type "groupchat")
+ from
+ (jabber-jid-user from))))
+
+(defun jabber-reactions--buffer-for-stanza (from type)
+ "Return the displayed chat buffer for incoming FROM and message TYPE."
+ (when from
+ (if (string= type "groupchat")
+ (jabber-muc-find-buffer (jabber-jid-user from))
+ (jabber-chat-find-buffer (jabber-jid-user from)))))
+
+(defun jabber-reactions--unwrap-stanza (jc xml-data)
+ "Return (MESSAGE . BUFFER) for reaction-bearing XML-DATA on JC."
+ (if (or (string= (or (jabber-xml-get-attribute xml-data 'type) "")
"groupchat")
+ (not (fboundp 'jabber-chat--unwrap-carbon)))
+ (cons xml-data nil)
+ (jabber-chat--unwrap-carbon jc xml-data)))
+
+(defun jabber-reactions--update-message (msg sender sender-reactions)
+ "Return MSG with SENDER's reactions replaced by SENDER-REACTIONS."
+ (plist-put (copy-sequence msg)
+ :reactions
+ (jabber-reactions--replace-sender-reactions
+ sender sender-reactions (plist-get msg :reactions))))
+
+(defun jabber-reactions--local-sender ()
+ "Return the local sender key for reaction state in the current buffer."
+ (when jabber-buffer-connection
+ (if (bound-and-true-p jabber-group)
+ (when-let* ((nick (jabber-muc-nickname jabber-group
jabber-buffer-connection)))
+ (concat jabber-group "/" nick))
+ (jabber-connection-bare-jid jabber-buffer-connection))))
+
+;;; Command support
+
+(defun jabber-reactions--composition-point-p ()
+ "Return non-nil when point is in the chat composition area."
+ (and (boundp 'jabber-point-insert)
+ (markerp jabber-point-insert)
+ (>= (point) jabber-point-insert)))
+
+(defun jabber-reactions--message-id ()
+ "Return a generated message ID for outgoing reaction stanzas."
+ (format "emacs-reaction-%.6f" (float-time)))
+
+(defun jabber-reactions--reactable-node-at-point ()
+ "Return reaction context for the EWOC node at point, or nil.
+The returned list has the form (NODE MSG TARGET-ID)."
+ (unless (jabber-reactions--composition-point-p)
+ (when-let* ((node (and (bound-and-true-p jabber-chat-ewoc)
+ (ewoc-locate jabber-chat-ewoc (point))))
+ (data (ewoc-data node))
+ ((listp data))
+ (msg (cadr data))
+ ((listp msg))
+ (target-id (jabber-reactions--target-id
+ msg (bound-and-true-p jabber-group))))
+ (list node msg target-id))))
+
+(defun jabber-reactions--insert-literal-bang ()
+ "Insert a literal exclamation mark in the composition area."
+ (when (and (boundp 'jabber-point-insert)
+ (markerp jabber-point-insert)
+ (< (point) jabber-point-insert))
+ (goto-char jabber-point-insert))
+ (insert "!"))
+
+(defun jabber-reactions--chat-target ()
+ "Return reaction stanza target information for the current buffer.
+The returned list has the form (TO TYPE), or nil outside chat and MUC
+buffers with a known destination."
+ (cond
+ ((bound-and-true-p jabber-group)
+ (list jabber-group "groupchat"))
+ ((bound-and-true-p jabber-chatting-with)
+ (list jabber-chatting-with "chat"))))
+
+(defun jabber-reactions--optimistic-update (node msg sender sender-reactions)
+ "Update NODE's MSG reaction state for SENDER to SENDER-REACTIONS."
+ (let* ((reactions (plist-get msg :reactions))
+ (updated-msg (plist-put
+ (copy-sequence msg)
+ :reactions
+ (jabber-reactions--replace-sender-reactions
+ sender sender-reactions reactions))))
+ (setcar (cdr (ewoc-data node)) updated-msg)
+ (jabber-chat-ewoc-invalidate node)))
+
+;;;###autoload
+(defun jabber-reactions-react-at-point-or-insert ()
+ "React to the message at point, or insert a literal exclamation mark."
+ (interactive)
+ (pcase-let ((`(,node ,msg ,target-id)
+ (jabber-reactions--reactable-node-at-point))
+ (`(,to ,type) (jabber-reactions--chat-target))
+ (sender (jabber-reactions--local-sender)))
+ (if (and node msg target-id to type sender)
+ (let ((reaction (completing-read
+ "Reaction: "
+ jabber-reactions-default-choices
+ nil nil)))
+ (when (string-empty-p reaction)
+ (user-error "Reaction cannot be empty"))
+ (let ((sender-reactions (jabber-reactions--toggle-reaction
+ reaction
+ (jabber-reactions--sender-reactions sender
msg))))
+ (jabber-send-sexp
+ jabber-buffer-connection
+ (jabber-reactions--build-stanza to type target-id
+ sender-reactions
+ (jabber-reactions--message-id)))
+ (unless (bound-and-true-p jabber-group)
+ (jabber-reactions--optimistic-update node msg sender
sender-reactions))))
+ (jabber-reactions--insert-literal-bang))))
+
+;;; Incoming updates
+
+(defun jabber-reactions--apply-incoming-update (node sender sender-reactions)
+ "Apply SENDER's SENDER-REACTIONS to the message stored in NODE."
+ (when-let* ((data (ewoc-data node))
+ ((listp data))
+ (msg (cadr data))
+ ((listp msg)))
+ (setcar (cdr data)
+ (jabber-reactions--update-message msg sender sender-reactions))
+ (jabber-chat-ewoc-invalidate node)))
+
+(defun jabber-reactions--handle-message (jc xml-data)
+ "Handle incoming XEP-0444 reaction updates in XML-DATA on JC."
+ (pcase-let* ((`(,message . ,carbon-buffer)
+ (jabber-reactions--unwrap-stanza jc xml-data)))
+ (when-let* ((reactions (jabber-xml-child-with-xmlns
+ message jabber-reactions-xmlns))
+ (parsed (jabber-reactions--parse-element reactions))
+ (from (jabber-xml-get-attribute message 'from))
+ (type (jabber-xml-get-attribute message 'type))
+ (sender (jabber-reactions--incoming-sender from type))
+ (buffer (or carbon-buffer
+ (jabber-reactions--buffer-for-stanza from type))))
+ (with-current-buffer buffer
+ (when-let* ((node (jabber-chat-ewoc-find-by-id (car parsed))))
+ (jabber-reactions--apply-incoming-update node sender (cadr
parsed)))))))
+
+(jabber-chain-add 'jabber-message-chain #'jabber-reactions--handle-message -5)
+
+;;; Disco
+
+(jabber-disco-advertise-feature jabber-reactions-xmlns)
+
+(provide 'jabber-reactions)
+;;; jabber-reactions.el ends here
diff --git a/lisp/jabber-sm.el b/lisp/jabber-sm.el
index 5958d59763..cbc1e2b28a 100644
--- a/lisp/jabber-sm.el
+++ b/lisp/jabber-sm.el
@@ -319,14 +319,20 @@ Return updated STATE-DATA."
(last-acked (plist-get state-data :sm-last-acked))
(queue (plist-get state-data :sm-outbound-queue))
(pruned (jabber-sm--prune-queue queue h)))
- (when (not (jabber-sm--counter-<= h sent))
+ (cond
+ ((jabber-sm--counter-<= h last-acked)
+ state-data)
+ ((not (jabber-sm--counter-<= h sent))
(message "SM warning: server acked more stanzas than sent (h=%d,
sent=%d)"
- h sent))
- (when (not (jabber-sm--counter-<= h last-acked))
+ h sent)
+ (setq state-data (plist-put state-data :sm-outbound-count h))
(setq state-data (plist-put state-data :sm-last-acked h))
(setq state-data (plist-put state-data :sm-outbound-queue pruned))
(plist-put state-data :sm-stall-since nil))
- state-data))
+ (t
+ (setq state-data (plist-put state-data :sm-last-acked h))
+ (setq state-data (plist-put state-data :sm-outbound-queue pruned))
+ (plist-put state-data :sm-stall-since nil)))))
;;; Enable/resume XML generation
diff --git a/lisp/jabber.el b/lisp/jabber.el
index f19f231ee9..b888ec4f11 100644
--- a/lisp/jabber.el
+++ b/lisp/jabber.el
@@ -172,6 +172,7 @@ One disabled account with a non-standard port:
(require 'jabber-moderation)
(require 'jabber-message-correct)
(require 'jabber-message-reply)
+(require 'jabber-reactions)
(require 'jabber-styling)
(require 'jabber-browse)
(require 'jabber-compose)
diff --git a/tests/jabber-test-reactions.el b/tests/jabber-test-reactions.el
new file mode 100644
index 0000000000..ee9c7765bf
--- /dev/null
+++ b/tests/jabber-test-reactions.el
@@ -0,0 +1,212 @@
+;;; jabber-test-reactions.el --- Tests for jabber-reactions -*-
lexical-binding: t; -*-
+
+;;; Commentary:
+
+;; XEP-0444 Message Reactions helper tests.
+
+;;; Code:
+
+(require 'ert)
+(require 'jabber-reactions)
+
+;;; Group 1: Pure reaction state helpers
+
+(ert-deftest jabber-test-reactions-deduplicate-filters-empty-and-duplicates ()
+ "Deduplication keeps first non-empty string occurrences only."
+ (should (equal (jabber-reactions--deduplicate
+ '(nil "" "👍" "" "🎉" "👍" nil "🎉" "❤️"))
+ '("👍" "🎉" "❤️"))))
+
+(ert-deftest jabber-test-reactions-target-id-selects-chat-id ()
+ "Direct chat reactions target the message :id."
+ (should (equal (jabber-reactions--target-id '(:id "client-1"
+ :server-id "server-1")
+ nil)
+ "client-1")))
+
+(ert-deftest jabber-test-reactions-target-id-selects-muc-server-id ()
+ "MUC reactions target the message :server-id."
+ (should (equal (jabber-reactions--target-id '(:id "client-1"
+ :server-id "server-1")
+ t)
+ "server-1")))
+
+(ert-deftest jabber-test-reactions-display-entries-aggregate-counts-and-chosen
()
+ "Display entries aggregate reactions and mark the chosen sender."
+ (let ((entries (jabber-reactions--display-entries
+ '(("[email protected]" . ("👍" "🎉" "👍"))
+ ("[email protected]" . ("👍" "❤️"))
+ ("[email protected]" . ("🎉")))
+ "[email protected]")))
+ (should (equal (mapcar (lambda (entry) (plist-get entry :reaction))
entries)
+ '("👍" "🎉" "❤️")))
+ (let ((thumbs (cl-find "👍" entries
+ :key (lambda (entry) (plist-get entry :reaction))
+ :test #'equal))
+ (party (cl-find "🎉" entries
+ :key (lambda (entry) (plist-get entry :reaction))
+ :test #'equal))
+ (heart (cl-find "❤️" entries
+ :key (lambda (entry) (plist-get entry :reaction))
+ :test #'equal)))
+ (should (= (plist-get thumbs :count) 2))
+ (should (plist-get thumbs :chosen))
+ (should (= (plist-get party :count) 2))
+ (should (plist-get party :chosen))
+ (should (= (plist-get heart :count) 1))
+ (should-not (plist-get heart :chosen)))))
+
+(ert-deftest
jabber-test-reactions-toggle-reaction-adds-and-removes-from-full-list ()
+ "Toggling updates the complete local reaction list."
+ (should (equal (jabber-reactions--toggle-reaction "❤️" '("👍" "👍" "🎉"))
+ '("👍" "🎉" "❤️")))
+ (should (equal (jabber-reactions--toggle-reaction "👍" '("👍" "🎉" "👍"))
+ '("🎉"))))
+
+(ert-deftest jabber-test-reactions-update-message-replaces-sender-reactions ()
+ "Incoming updates replace only the sender's full reaction list."
+ (let* ((msg '(:id "m1" :reactions (("alice" . ("👍"))
+ ("bob" . ("🎉")))))
+ (updated (jabber-reactions--update-message msg "alice" '("❤️" "❤️"
""))))
+ (should (equal (alist-get "alice" (plist-get updated :reactions) nil nil
#'equal)
+ '("❤️")))
+ (should (equal (alist-get "bob" (plist-get updated :reactions) nil nil
#'equal)
+ '("🎉")))))
+
+(ert-deftest
jabber-test-reactions-update-message-removes-sender-on-empty-update ()
+ "Incoming empty updates remove that sender from reaction state."
+ (let* ((msg '(:id "m1" :reactions (("alice" . ("👍"))
+ ("bob" . ("🎉")))))
+ (updated (jabber-reactions--update-message msg "alice" nil)))
+ (should-not (assoc "alice" (plist-get updated :reactions)))
+ (should (equal (alist-get "bob" (plist-get updated :reactions) nil nil
#'equal)
+ '("🎉")))))
+
+;;; Group 2: Outgoing stanza helpers
+
+(ert-deftest jabber-test-reactions-build-stanza-includes-store-hint ()
+ "Outgoing reaction stanzas include the XEP-0334 store hint."
+ (let* ((stanza (jabber-reactions--build-stanza
+ "[email protected]" "chat" "target-1" '("👍" "👍" "🎉")
+ "reaction-1"))
+ (store (assq 'store (cddr stanza))))
+ (should (equal (cdr (assq 'xmlns (cadr store)))
+ jabber-reactions-hints-xmlns))))
+
+(ert-deftest jabber-test-reactions-build-stanza-keeps-empty-reactions-element
()
+ "An empty full local reaction list sends an empty reactions element."
+ (let* ((stanza (jabber-reactions--build-stanza
+ "[email protected]" "groupchat" "target-1" nil "reaction-1"))
+ (reactions (assq 'reactions (cddr stanza))))
+ (should reactions)
+ (should (equal (cadr reactions)
+ `((xmlns . ,jabber-reactions-xmlns) (id . "target-1"))))
+ (should-not (cddr reactions))))
+
+;;; Group 3: Incoming stanza classification
+
+(ert-deftest jabber-test-reactions-reaction-only-p-accepts-bodyless-update ()
+ "A bodyless stanza with only reactions is reaction-only."
+ (should (jabber-reactions--reaction-only-p
+ `(message ((from . "[email protected]") (type . "chat"))
+ (reactions ((xmlns . ,jabber-reactions-xmlns)
+ (id . "target-1"))
+ (reaction nil "👍"))))))
+
+(ert-deftest
jabber-test-reactions-reaction-only-p-rejects-body-subject-or-error ()
+ "Reaction stanzas with body, subject, or error are not reaction-only."
+ (dolist (extra '((body nil "hello")
+ (subject nil "topic")
+ (error ((type . "cancel")))))
+ (should-not
+ (jabber-reactions--reaction-only-p
+ `(message ((from . "[email protected]") (type . "chat"))
+ (reactions ((xmlns . ,jabber-reactions-xmlns)
+ (id . "target-1"))
+ (reaction nil "👍"))
+ ,extra)))))
+
+(ert-deftest jabber-test-reactions-react-allows-custom-picker-input ()
+ "Outgoing reaction picker accepts custom reactions outside defaults."
+ (let ((sent nil)
+ (require-match :unset))
+ (cl-letf (((symbol-function 'jabber-reactions--reactable-node-at-point)
+ (lambda () (list 'node '(:id "target-1") "target-1")))
+ ((symbol-function 'jabber-reactions--chat-target)
+ (lambda () (list "[email protected]" "chat")))
+ ((symbol-function 'jabber-reactions--local-sender)
+ (lambda () "[email protected]"))
+ ((symbol-function 'completing-read)
+ (lambda (_prompt _collection _predicate require &rest _args)
+ (setq require-match require)
+ "🔥"))
+ ((symbol-function 'jabber-send-sexp)
+ (lambda (_jc stanza) (setq sent stanza)))
+ ((symbol-function 'jabber-reactions--optimistic-update)
#'ignore))
+ (with-temp-buffer
+ (setq-local jabber-buffer-connection 'fake-jc)
+ (jabber-reactions-react-at-point-or-insert)
+ (should-not require-match)
+ (should (equal (cadr (assq 'reaction (cddr (assq 'reactions (cddr
sent)))))
+ nil))
+ (should (equal (car (last (assq 'reaction
+ (cddr (assq 'reactions (cddr sent))))))
+ "🔥"))))))
+
+(ert-deftest jabber-test-reactions-handle-carbon-wrapped-update ()
+ "Incoming carbon-wrapped reaction updates the targeted message node."
+ (with-temp-buffer
+ (let* ((jabber-chat-ewoc (ewoc-create #'ignore))
+ (msg '(:id "target-1" :body "hello"))
+ (node (ewoc-enter-last jabber-chat-ewoc (list :foreign msg)))
+ (inner `(message ((from . "[email protected]/laptop")
+ (to . "[email protected]")
+ (type . "chat"))
+ (reactions ((xmlns . ,jabber-reactions-xmlns)
+ (id . "target-1"))
+ (reaction nil "👍"))))
+ (outer `(message ((from . "[email protected]") (type . "chat"))
+ (received ((xmlns . "urn:xmpp:carbons:2"))
+ (forwarded ((xmlns .
"urn:xmpp:forward:0"))
+ ,inner)))))
+ (cl-letf (((symbol-function 'jabber-chat--unwrap-carbon)
+ (lambda (_jc _xml-data) (cons inner nil)))
+ ((symbol-function 'jabber-chat-find-buffer)
+ (lambda (_chat-with) (current-buffer)))
+ ((symbol-function 'jabber-chat-ewoc-find-by-id)
+ (lambda (_stanza-id) node))
+ ((symbol-function 'jabber-chat-ewoc-invalidate) #'ignore))
+ (jabber-reactions--handle-message 'fake-jc outer)
+ (should (equal (plist-get (cadr (ewoc-data node)) :reactions)
+ '(("[email protected]" . ("👍")))))))))
+
+(ert-deftest jabber-test-reactions-handle-sent-carbon-uses-carbon-buffer ()
+ "Sent carbon reaction updates the buffer returned by carbon unwrapping."
+ (with-temp-buffer
+ (let* ((carbon-buffer (current-buffer))
+ (jabber-chat-ewoc (ewoc-create #'ignore))
+ (msg '(:id "target-1" :body "hello"))
+ (node (ewoc-enter-last jabber-chat-ewoc (list :local msg)))
+ (inner `(message ((from . "[email protected]/phone")
+ (to . "[email protected]")
+ (type . "chat"))
+ (reactions ((xmlns . ,jabber-reactions-xmlns)
+ (id . "target-1"))
+ (reaction nil "🔥"))))
+ (outer `(message ((from . "[email protected]") (type . "chat"))
+ (sent ((xmlns . "urn:xmpp:carbons:2"))
+ (forwarded ((xmlns . "urn:xmpp:forward:0"))
+ ,inner)))))
+ (cl-letf (((symbol-function 'jabber-chat--unwrap-carbon)
+ (lambda (_jc _xml-data) (cons inner carbon-buffer)))
+ ((symbol-function 'jabber-chat-find-buffer)
+ (lambda (_chat-with) nil))
+ ((symbol-function 'jabber-chat-ewoc-find-by-id)
+ (lambda (_stanza-id) node))
+ ((symbol-function 'jabber-chat-ewoc-invalidate) #'ignore))
+ (jabber-reactions--handle-message 'fake-jc outer)
+ (should (equal (plist-get (cadr (ewoc-data node)) :reactions)
+ '(("[email protected]" . ("🔥")))))))))
+
+(provide 'jabber-test-reactions)
+;;; jabber-test-reactions.el ends here
diff --git a/tests/jabber-test-sm.el b/tests/jabber-test-sm.el
index 3ac1d733bb..155a784f90 100644
--- a/tests/jabber-test-sm.el
+++ b/tests/jabber-test-sm.el
@@ -201,6 +201,30 @@
(should (= (length (plist-get result :sm-outbound-queue)) 1))
(should (= (caar (plist-get result :sm-outbound-queue)) 3))))
+(ert-deftest jabber-test-sm-process-ack-ahead-recovers ()
+ "Ack-ahead recovery keeps outbound counters consistent."
+ (let* ((sd (list :sm-enabled t
+ :sm-outbound-count 11501
+ :sm-outbound-queue (list (cons 11501 'a))
+ :sm-last-acked 11501
+ :sm-stall-since 1.0))
+ (ack '(a ((xmlns . "urn:xmpp:sm:3") (h . "11502"))))
+ (result (jabber-sm--process-ack sd ack)))
+ (should (= (plist-get result :sm-outbound-count) 11502))
+ (should (= (plist-get result :sm-last-acked) 11502))
+ (should (= (jabber-sm--in-flight-count result) 0))
+ (should-not (plist-get result :sm-stall-since)))
+ (dolist (h '("11502" "11501"))
+ (let* ((sd (list :sm-enabled t
+ :sm-outbound-count 11502
+ :sm-outbound-queue (list (cons 11502 'a))
+ :sm-last-acked 11502
+ :sm-stall-since 1.0))
+ (before (copy-tree sd))
+ (ack `(a ((xmlns . "urn:xmpp:sm:3") (h . ,h))))
+ (result (jabber-sm--process-ack sd ack)))
+ (should (equal result before)))))
+
;;; FSM routing helper
(ert-deftest jabber-test-sm-maybe-enable-with-sm ()
