279 lines
12 KiB
EmacsLisp
279 lines
12 KiB
EmacsLisp
;;; +jabber.el --- Customizations for jabber.el -*- lexical-binding: t; -*-
|
||
|
||
;;; Commentary:
|
||
|
||
;; Most changes I want to PR and contribute, but a few don't make sense to
|
||
;; contribute upstream, at least not now.
|
||
|
||
;;; Code:
|
||
|
||
(require 'jabber)
|
||
(require 'tracking)
|
||
|
||
(defgroup +jabber nil
|
||
"Extra jabber.el customizations."
|
||
:group 'jabber)
|
||
|
||
(defcustom +jabber-ws-prefix 0
|
||
"Width to pad left side of chats."
|
||
:type 'string)
|
||
|
||
(defcustom +jabber-pre-prompt " \n"
|
||
"String to put before the prompt."
|
||
:type 'string)
|
||
|
||
(defvar +jabber-tracking-show-p #'jabber-activity-show-p-default
|
||
"Function that checks if the given JID should be shown in the mode line.
|
||
This does the same as `jabber-activity-show-p', but for the
|
||
`tracking-mode' mode-line.")
|
||
|
||
(defun +jabber-tracking-add (from buffer text proposed-alert)
|
||
"ADVICE to add jabber buffers to `tracking-buffers'."
|
||
(when (funcall +jabber-tracking-show-p from)
|
||
(tracking-add-buffer buffer 'jabber-activity-face)))
|
||
|
||
(defun +jabber-tracking-add-muc (nick group buffer text proposed-alert)
|
||
"ADVICE to add jabber MUC buffers to `tracking-buffers'."
|
||
(when (funcall +jabber-tracking-show-p group)
|
||
(tracking-add-buffer buffer 'jabber-activity-face)))
|
||
|
||
;;; Hiding presence messages:
|
||
;; https://paste.sr.ht/~hdasch/f0ad09fbcd08e940a4fda71c2f40abc1c4efd45f
|
||
|
||
;; Tame MUC presence notifications.
|
||
|
||
;; This patch hides or applies a face to MUC presence notifications in
|
||
;; the MUC chat buffer. To control its behavior, customize
|
||
;; ’jabber-muc-decorate-presence-patterns’. By default it does nothing.
|
||
|
||
;; ’jabber-muc-decorate-presence-patterns’ is a list of pairs consisting
|
||
;; of a regular expression and a either a face or ‘nil’. If a the
|
||
;; regular expression matches a presence notification, then either:
|
||
|
||
;; - the specified face is applied to the notification message
|
||
;; - or if the second value of the pair is nil, the notification is
|
||
;; discarded
|
||
|
||
;; If no regular expression in the list of pairs matches the notification
|
||
;; message, the message is displayed unchanged.
|
||
|
||
;; For example, the customization:
|
||
|
||
;; '(jabber-muc-decorate-presence-patterns
|
||
;; '(("\\( enters the room ([^)]+)\\| has left the chatroom\\)$")
|
||
;; ("." . jabber-muc-presence-dim)))
|
||
|
||
;; hides participant enter/leave notifications. It also diminishes other
|
||
;; presence notification messages to make it easier to distinguish
|
||
;; between conversation and notifications.
|
||
|
||
(defface jabber-muc-presence-dim
|
||
'((t (:foreground "dark grey" :weight light :slant italic)))
|
||
"face for diminished presence notifications.")
|
||
|
||
(defcustom jabber-muc-decorate-presence-patterns nil
|
||
"List of regular expressions and face pairs.
|
||
When a presence notification matches a pattern, display it with
|
||
associated face. Ignore notification if face is ‘nil’."
|
||
:type '(repeat
|
||
:tag "Patterns"
|
||
(cons :format "%v"
|
||
(regexp :tag "Regexp")
|
||
(choice
|
||
(const :tag "Ignore" nil)
|
||
(face :tag "Face" :value jabber-muc-presence-dim))))
|
||
:group 'jabber-alerts)
|
||
|
||
(defun jabber-muc-maybe-decorate-presence (node)
|
||
"Filter presence notifications."
|
||
(cl-destructuring-bind (key msg &key time) node
|
||
(let* ((match (cl-find-if
|
||
(lambda (pair)
|
||
(string-match (car pair) msg))
|
||
jabber-muc-decorate-presence-patterns))
|
||
(face (cdr-safe match)))
|
||
(if match
|
||
(when face
|
||
(jabber-maybe-print-rare-time
|
||
(ewoc-enter-last
|
||
jabber-chat-ewoc
|
||
(list key
|
||
(propertize msg 'face face)
|
||
:time time))))
|
||
(jabber-maybe-print-rare-time
|
||
(ewoc-enter-last jabber-chat-ewoc node))))))
|
||
|
||
(defun jabber-muc-process-presence (jc presence)
|
||
(let* ((from (jabber-xml-get-attribute presence 'from))
|
||
(type (jabber-xml-get-attribute presence 'type))
|
||
(x-muc (cl-find-if
|
||
(lambda (x) (equal (jabber-xml-get-attribute x 'xmlns)
|
||
"http://jabber.org/protocol/muc#user"))
|
||
(jabber-xml-get-children presence 'x)))
|
||
(group (jabber-jid-user from))
|
||
(nickname (jabber-jid-resource from))
|
||
(symbol (jabber-jid-symbol from))
|
||
(our-nickname (gethash symbol jabber-pending-groupchats))
|
||
(item (car (jabber-xml-get-children x-muc 'item)))
|
||
(actor (jabber-xml-get-attribute (car (jabber-xml-get-children item 'actor)) 'jid))
|
||
(reason (car (jabber-xml-node-children (car (jabber-xml-get-children item 'reason)))))
|
||
(error-node (car (jabber-xml-get-children presence 'error)))
|
||
(status-codes (if error-node
|
||
(list (jabber-xml-get-attribute error-node 'code))
|
||
(mapcar
|
||
(lambda (status-element)
|
||
(jabber-xml-get-attribute status-element 'code))
|
||
(jabber-xml-get-children x-muc 'status)))))
|
||
;; handle leaving a room
|
||
(cond
|
||
((or (string= type "unavailable") (string= type "error"))
|
||
;; error from room itself? or are we leaving?
|
||
(if (or (null nickname)
|
||
(member "110" status-codes)
|
||
(string= nickname our-nickname))
|
||
;; Assume that an error means that we were thrown out of the
|
||
;; room...
|
||
(let* ((leavingp t)
|
||
(message (cond
|
||
((string= type "error")
|
||
(cond
|
||
;; ...except for certain cases.
|
||
((or (member "406" status-codes)
|
||
(member "409" status-codes))
|
||
(setq leavingp nil)
|
||
(concat "Nickname change not allowed"
|
||
(when error-node
|
||
(concat ": " (jabber-parse-error error-node)))))
|
||
(t
|
||
(concat "Error entering room"
|
||
(when error-node
|
||
(concat ": " (jabber-parse-error error-node)))))))
|
||
((member "301" status-codes)
|
||
(concat "You have been banned"
|
||
(when actor (concat " by " actor))
|
||
(when reason (concat " - '" reason "'"))))
|
||
((member "307" status-codes)
|
||
(concat "You have been kicked"
|
||
(when actor (concat " by " actor))
|
||
(when reason (concat " - '" reason "'"))))
|
||
(t
|
||
"You have left the chatroom"))))
|
||
(when leavingp
|
||
(jabber-muc-remove-groupchat group))
|
||
;; If there is no buffer for this groupchat, don't bother
|
||
;; creating one just to tell that user left the room.
|
||
(let ((buffer (get-buffer (jabber-muc-get-buffer group))))
|
||
(if buffer
|
||
(with-current-buffer buffer
|
||
(jabber-muc-maybe-decorate-presence
|
||
(list (if (string= type "error")
|
||
:muc-error
|
||
:muc-notice)
|
||
message
|
||
:time (current-time)))))
|
||
(message "%s: %s" (jabber-jid-displayname group) message))))
|
||
;; or someone else?
|
||
(let* ((plist (jabber-muc-participant-plist group nickname))
|
||
(jid (plist-get plist 'jid))
|
||
(name (concat nickname
|
||
(when jid
|
||
(concat " <"
|
||
(jabber-jid-user jid)
|
||
">")))))
|
||
(jabber-muc-remove-participant group nickname)
|
||
(with-current-buffer (jabber-muc-create-buffer jc group)
|
||
(jabber-muc-maybe-decorate-presence
|
||
(list :muc-notice
|
||
(cond
|
||
((member "301" status-codes)
|
||
(concat name " has been banned"
|
||
(when actor (concat " by " actor))
|
||
(when reason (concat " - '" reason "'"))))
|
||
((member "307" status-codes)
|
||
(concat name " has been kicked"
|
||
(when actor (concat " by " actor))
|
||
(when reason (concat " - '" reason "'"))))
|
||
((member "303" status-codes)
|
||
(concat name " changes nickname to "
|
||
(jabber-xml-get-attribute item 'nick)))
|
||
(t
|
||
(concat name " has left the chatroom")))
|
||
:time (current-time))))))
|
||
(t
|
||
;; someone is entering
|
||
|
||
(when (or (member "110" status-codes) (string= nickname our-nickname))
|
||
;; This is us. We just succeeded in entering the room.
|
||
;;
|
||
;; The MUC server is supposed to send a 110 code whenever this
|
||
;; is our presence ("self-presence"), but at least one
|
||
;; (ejabberd's mod_irc) doesn't, so check the nickname as well.
|
||
;;
|
||
;; This check might give incorrect results if the server
|
||
;; changed our nickname to avoid collision with an existing
|
||
;; participant, but even in this case the window where we have
|
||
;; incorrect information should be very small, as we should be
|
||
;; getting our own 110+210 presence shortly.
|
||
(let ((whichgroup (assoc group *jabber-active-groupchats*)))
|
||
(if whichgroup
|
||
(setcdr whichgroup nickname)
|
||
(add-to-list '*jabber-active-groupchats* (cons group nickname))))
|
||
;; The server may have changed our nick. Record the new one.
|
||
(puthash symbol nickname jabber-pending-groupchats))
|
||
|
||
;; Whoever enters, we create a buffer (if it didn't already
|
||
;; exist), and print a notice. This is where autojoined MUC
|
||
;; rooms have buffers created for them. We also remember some
|
||
;; metadata.
|
||
(let ((old-plist (jabber-muc-participant-plist group nickname))
|
||
(new-plist (jabber-muc-parse-affiliation x-muc)))
|
||
(jabber-muc-modify-participant group nickname new-plist)
|
||
(let ((report (jabber-muc-report-delta nickname old-plist new-plist
|
||
reason actor)))
|
||
(when report
|
||
(with-current-buffer (jabber-muc-create-buffer jc group)
|
||
(jabber-muc-maybe-decorate-presence
|
||
(list :muc-notice report
|
||
:time (current-time)))
|
||
;; Did the server change our nick?
|
||
(when (member "210" status-codes)
|
||
(ewoc-enter-last
|
||
jabber-chat-ewoc
|
||
(list :muc-notice
|
||
(concat "Your nick was changed to " nickname " by the server")
|
||
:time (current-time))))
|
||
;; Was this room just created? If so, it's a locked
|
||
;; room. Notify the user.
|
||
(when (member "201" status-codes)
|
||
(ewoc-enter-last
|
||
jabber-chat-ewoc
|
||
(list :muc-notice
|
||
(with-temp-buffer
|
||
(insert "This room was just created, and is locked to other participants.\n"
|
||
"To unlock it, ")
|
||
(insert-text-button
|
||
"configure the room"
|
||
'action (apply-partially 'call-interactively 'jabber-muc-get-config))
|
||
(insert " or ")
|
||
(insert-text-button
|
||
"accept the default configuration"
|
||
'action (apply-partially 'call-interactively 'jabber-muc-instant-config))
|
||
(insert ".")
|
||
(buffer-string))
|
||
:time (current-time))))))))))))
|
||
|
||
(defun +jabber-colors-update (&optional buffer)
|
||
"Update jabber colors in BUFFER, defaulting to the current."
|
||
(with-current-buffer (or buffer (current-buffer))
|
||
(when jabber-buffer-connection
|
||
(setq jabber-muc-participant-colors nil)
|
||
(cond (jabber-chatting-with
|
||
(jabber-chat-create-buffer jabber-buffer-connection
|
||
jabber-chatting-with))
|
||
(jabber-group
|
||
(jabber-muc-create-buffer jabber-buffer-connection
|
||
jabber-group))))))
|
||
|
||
(provide '+jabber)
|
||
;;; +jabber.el ends here
|