From c5ed4acda48fb5e5a75b24c55596d444e7a30465 Mon Sep 17 00:00:00 2001 From: defanor Date: Sat, 11 Sep 2021 13:13:42 +0300 Subject: Add initial xmpp.el faces Additional presence information and /me actions are handled too now. --- emacs/xmpp.el | 215 +++++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 159 insertions(+), 56 deletions(-) diff --git a/emacs/xmpp.el b/emacs/xmpp.el index a0ee75b..5102cbd 100644 --- a/emacs/xmpp.el +++ b/emacs/xmpp.el @@ -38,6 +38,44 @@ (require 'seq) (require 'tracking) +(defgroup xmpp nil + "An Emacs interface to rexmpp." + :prefix "xmpp-" + :group 'applications) + +(defface xmpp-timestamp + '((((type graphic) (class color) (background dark)) :foreground "SteelBlue") + (((type graphic) (class color) (background light)) :foreground "SteelBlue")) + "Timestamp face." + :group 'xmpp) + +(defface xmpp-my-nick + '((((type graphic) (class color) (background dark)) :foreground "LightSkyBlue") + (((type graphic) (class color) (background light)) :foreground "Blue") + (t :weight bold)) + "Own nick face." + :group 'xmpp) + +(defface xmpp-other-nick + '((((type graphic) (class color) (background dark)) :foreground "PaleGreen") + (((type graphic) (class color) (background light)) :foreground "DarkGreen") + (t :weight bold)) + "Others' nick face." + :group 'xmpp) + +(defface xmpp-presence + '((((type graphic) (class color) (background dark)) :foreground "wheat1") + (((type graphic) (class color) (background light)) :foreground "wheat4")) + "Presence notification face." + :group 'xmpp) + +(defface xmpp-action + '((((type graphic) (class color) (background dark)) :foreground "thistle1") + (((type graphic) (class color) (background light)) :foreground "thistle4")) + "Action (/me) face." + :group 'xmpp) + + (defvar xmpp-command "rexmpp_xml_interface" "A command to run an XMPP client subprocess.") @@ -82,6 +120,11 @@ "The buffer size at which to truncate an XMPP-related buffer by approximately halving it.") +(defun xmpp-timestamp-string () + (let ((str (format-time-string xmpp-timestamp-format))) + (add-face-text-property 0 (length str) 'xmpp-timestamp nil str) + str)) + (defun xmpp-activity-notify () (tracking-add-buffer (current-buffer))) @@ -134,6 +177,18 @@ proc) (funcall func message-body)))) +(defun xmpp-message-string (str) + (if (string-prefix-p "/me " str) + (let ((action (substring str 3))) + (add-face-text-property + 0 + (length action) + 'xmpp-action + nil + action) + action) + (concat ": " str))) + (defun xmpp-process-input (proc xml) (with-current-buffer (process-buffer proc) (with-current-buffer xmpp-xml-buffer @@ -141,45 +196,87 @@ (xmpp-insert-xml (list xml)) (xmpp-insert "\n")) (when (eq (xml-node-name xml) 'presence) - (let* ((presence-from (xml-get-attribute-or-nil xml 'from)) - (presence-type (or (xml-get-attribute-or-nil xml 'type) "available")) - (bare-jid (xmpp-jid-to-bare presence-from)) - (resourcepart (xmpp-jid-resource presence-from))) - (when (assoc bare-jid xmpp-query-buffers) - (with-current-buffer (cdr (assoc bare-jid xmpp-query-buffers)) - (xmpp-insert - (concat (format-time-string xmpp-timestamp-format) ", " - presence-from " is " presence-type "\n")))) - (when (assoc bare-jid xmpp-muc-buffers) - (with-current-buffer (cdr (assoc bare-jid xmpp-muc-buffers)) - (xmpp-insert - (concat (format-time-string xmpp-timestamp-format) ", " - resourcepart " is " presence-type "\n"))))))) + (let* ((presence-from (xml-get-attribute-or-nil xml 'from)) + (presence-type (or (xml-get-attribute-or-nil xml 'type) "available")) + (presence-show (car (xml-node-children (xmpp-xml-child xml 'show)))) + (presence-status (car (xml-node-children (xmpp-xml-child xml 'status)))) + (bare-jid (xmpp-jid-to-bare presence-from)) + (resourcepart (xmpp-jid-resource presence-from))) + (when (assoc bare-jid xmpp-query-buffers) + (with-current-buffer (cdr (assoc bare-jid xmpp-query-buffers)) + (let ((presence-string + (concat + presence-from " is " + presence-type + (when presence-show + (concat " (" presence-show ")")) + (when presence-status + (concat ": " presence-status))))) + (add-face-text-property + 0 + (length presence-string) + 'xmpp-presence + nil + presence-string) + (xmpp-insert (concat + (xmpp-timestamp-string) ", " + presence-string "\n"))))) + (when (assoc bare-jid xmpp-muc-buffers) + (with-current-buffer (cdr (assoc bare-jid xmpp-muc-buffers)) + (let ((presence-string (concat resourcepart " is " presence-type))) + (add-face-text-property + 0 + (length presence-string) + 'xmpp-presence + nil + presence-string) + (xmpp-insert + (concat (xmpp-timestamp-string) ", " + presence-string "\n")))))))) (when (eq (xml-node-name xml) 'message) (xmpp-with-message-body proc xml (lambda (message-body) - (let ((message-from (xml-get-attribute-or-nil xml 'from))) - (xmpp-with-name - message-from - (lambda (message-from-name) - (pcase (xml-get-attribute-or-nil xml 'type) - ("chat" - (when message-body + (when message-body + (let ((message-from (xml-get-attribute-or-nil xml 'from)) + (message-str + (xmpp-message-string (car (xml-node-children message-body))))) + (xmpp-with-name + message-from + (lambda (message-from-name) + (pcase (xml-get-attribute-or-nil xml 'type) + ("chat" (with-current-buffer (xmpp-query message-from proc) + (add-face-text-property + 0 + (length message-from-name) + (if (equal (with-current-buffer (process-buffer xmpp-proc) xmpp-jid) + (xmpp-jid-to-bare message-from)) + 'xmpp-my-nick + 'xmpp-other-nick) + nil + message-from-name) (xmpp-insert - (concat (format-time-string xmpp-timestamp-format) ", " - message-from-name ": " - (car (xml-node-children message-body)) "\n")) - (xmpp-activity-notify)))) - ("groupchat" - (when message-body + (concat (xmpp-timestamp-string) ", " + message-from-name + message-str "\n")) + (xmpp-activity-notify))) + ("groupchat" (with-current-buffer (xmpp-muc-buffer message-from proc) - (xmpp-insert - (concat (format-time-string xmpp-timestamp-format) ", " - (xmpp-jid-resource message-from) ": " - (car (xml-node-children message-body)) "\n")) - (xmpp-activity-notify)))))))))))) + (let ((from-nick (xmpp-jid-resource message-from))) + (add-face-text-property + 0 + (length from-nick) + (if (equal xmpp-muc-my-nick from-nick) + 'xmpp-my-nick + 'xmpp-other-nick) + nil + from-nick) + (xmpp-insert + (concat (xmpp-timestamp-string) ", " + from-nick + message-str "\n")) + (xmpp-activity-notify))))))))))))) (defun xmpp-set-from (proc xml) (let* ((name (xml-node-name xml)) @@ -205,18 +302,24 @@ ;; The "from" attribute is needed for validation. proc (xmpp-set-from proc xml) (lambda (message-body) - (let ((message-to (xml-get-attribute-or-nil xml 'to))) - (pcase (xml-get-attribute-or-nil xml 'type) - ("chat" - (when message-body - (let ((buf (xmpp-query message-to proc))) - (when buf - (with-current-buffer buf - (xmpp-insert - (concat - (format-time-string xmpp-timestamp-format) - ", me: " (car (xml-node-children message-body)) "\n"))))))) - ("groupchat" nil))))))) + (xmpp-with-name + xmpp-jid + (lambda (my-name) + (add-face-text-property 0 (length my-name) 'xmpp-my-nick nil my-name) + (let ((message-to (xml-get-attribute-or-nil xml 'to))) + (pcase (xml-get-attribute-or-nil xml 'type) + ("chat" + (when message-body + (let ((buf (xmpp-query message-to proc))) + (when buf + (with-current-buffer buf + (xmpp-insert + (concat + (xmpp-timestamp-string) ", " + my-name + (xmpp-message-string (car (xml-node-children message-body))) + "\n"))))))) + ("groupchat" nil))))))))) (defun xmpp-process (proc xml) (let* ((buf (process-buffer proc)) @@ -434,18 +537,18 @@ (defun xmpp-muc-join (jid &optional nick proc) (interactive "sConference JID: ") - (let* ((process (or proc xmpp-proc)) - (bare-jid (xmpp-jid-to-bare jid)) - (my-nick (or nick (xmpp-jid-localpart xmpp-jid))) - (full-jid (concat bare-jid "/" my-nick))) - (xmpp-send `(presence ((xmlns . "jabber:client") - (id . ,(xmpp-gen-id)) - (to . ,full-jid)) - (x ((xmlns . "http://jabber.org/protocol/muc"))))) - (let ((buf (xmpp-muc-buffer jid proc))) - (with-current-buffer buf - (setq-local xmpp-muc-my-nick my-nick)) - buf))) + (with-current-buffer (process-buffer (or proc xmpp-proc)) + (let* ((bare-jid (xmpp-jid-to-bare jid)) + (my-nick (or nick (xmpp-jid-localpart xmpp-jid))) + (full-jid (concat bare-jid "/" my-nick))) + (xmpp-send `(presence ((xmlns . "jabber:client") + (id . ,(xmpp-gen-id)) + (to . ,full-jid)) + (x ((xmlns . "http://jabber.org/protocol/muc"))))) + (let ((buf (xmpp-muc-buffer jid proc))) + (with-current-buffer buf + (setq-local xmpp-muc-my-nick my-nick)) + buf)))) (defun xmpp-muc-leave (jid &optional proc) (interactive "sConference JID: ") -- cgit v1.2.3