1 files changed, 223 insertions, 1 deletions

@@ -25,8 +25,230 @@ This does the same as `jabber-activity-show-p', but for the
   (when (funcall +jabber-tracking-show-p group)
     (tracking-add-buffer buffer 'jabber-activity-face)))
 
-;;; TODO: Hiding presence messages:
+;;; 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))))))))))))
+
 (provide '+jabber)
 ;;; +jabber.el ends here