path: root/lisp/+jabber.el

;;; +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