about summary refs log tree commit diff stats
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/+jabber.el224
1 files changed, 223 insertions, 1 deletions
diff --git a/lisp/+jabber.el b/lisp/+jabber.el index a0fdea7..2382102 100644 --- a/lisp/+jabber.el +++ b/lisp/+jabber.el
@@ -25,8 +25,230 @@ This does the same as `jabber-activity-show-p', but for the
25 (when (funcall +jabber-tracking-show-p group) 25 (when (funcall +jabber-tracking-show-p group)
26 (tracking-add-buffer buffer 'jabber-activity-face))) 26 (tracking-add-buffer buffer 'jabber-activity-face)))
27 27
28;;; TODO: Hiding presence messages: 28;;; Hiding presence messages:
29;; https://paste.sr.ht/~hdasch/f0ad09fbcd08e940a4fda71c2f40abc1c4efd45f 29;; https://paste.sr.ht/~hdasch/f0ad09fbcd08e940a4fda71c2f40abc1c4efd45f
30 30
31;; Tame MUC presence notifications.
32
33;; This patch hides or applies a face to MUC presence notifications in
34;; the MUC chat buffer. To control its behavior, customize
35;; ’jabber-muc-decorate-presence-patterns’. By default it does nothing.
36
37;; ’jabber-muc-decorate-presence-patterns’ is a list of pairs consisting
38;; of a regular expression and a either a face or ‘nil’. If a the
39;; regular expression matches a presence notification, then either:
40
41;; - the specified face is applied to the notification message
42;; - or if the second value of the pair is nil, the notification is
43;; discarded
44
45;; If no regular expression in the list of pairs matches the notification
46;; message, the message is displayed unchanged.
47
48;; For example, the customization:
49
50;; '(jabber-muc-decorate-presence-patterns
51;; '(("\\( enters the room ([^)]+)\\| has left the chatroom\\)$")
52;; ("." . jabber-muc-presence-dim)))
53
54;; hides participant enter/leave notifications. It also diminishes other
55;; presence notification messages to make it easier to distinguish
56;; between conversation and notifications.
57
58(defface jabber-muc-presence-dim
59 '((t (:foreground "dark grey" :weight light :slant italic)))
60 "face for diminished presence notifications.")
61
62(defcustom jabber-muc-decorate-presence-patterns nil
63 "List of regular expressions and face pairs.
64When a presence notification matches a pattern, display it with
65associated face. Ignore notification if face is ‘nil’."
66 :type '(repeat
67 :tag "Patterns"
68 (cons :format "%v"
69 (regexp :tag "Regexp")
70 (choice
71 (const :tag "Ignore" nil)
72 (face :tag "Face" :value jabber-muc-presence-dim))))
73 :group 'jabber-alerts)
74
75(defun jabber-muc-maybe-decorate-presence (node)
76 "Filter presence notifications."
77 (cl-destructuring-bind (key msg &key time) node
78 (let* ((match (cl-find-if
79 (lambda (pair)
80 (string-match (car pair) msg))
81 jabber-muc-decorate-presence-patterns))
82 (face (cdr-safe match)))
83 (if match
84 (when face
85 (jabber-maybe-print-rare-time
86 (ewoc-enter-last
87 jabber-chat-ewoc
88 (list key
89 (propertize msg 'face face)
90 :time time))))
91 (jabber-maybe-print-rare-time
92 (ewoc-enter-last jabber-chat-ewoc node))))))
93
94(defun jabber-muc-process-presence (jc presence)
95 (let* ((from (jabber-xml-get-attribute presence 'from))
96 (type (jabber-xml-get-attribute presence 'type))
97 (x-muc (cl-find-if
98 (lambda (x) (equal (jabber-xml-get-attribute x 'xmlns)
99 "http://jabber.org/protocol/muc#user"))
100 (jabber-xml-get-children presence 'x)))
101 (group (jabber-jid-user from))
102 (nickname (jabber-jid-resource from))
103 (symbol (jabber-jid-symbol from))
104 (our-nickname (gethash symbol jabber-pending-groupchats))
105 (item (car (jabber-xml-get-children x-muc 'item)))
106 (actor (jabber-xml-get-attribute (car (jabber-xml-get-children item 'actor)) 'jid))
107 (reason (car (jabber-xml-node-children (car (jabber-xml-get-children item 'reason)))))
108 (error-node (car (jabber-xml-get-children presence 'error)))
109 (status-codes (if error-node
110 (list (jabber-xml-get-attribute error-node 'code))
111 (mapcar
112 (lambda (status-element)
113 (jabber-xml-get-attribute status-element 'code))
114 (jabber-xml-get-children x-muc 'status)))))
115 ;; handle leaving a room
116 (cond
117 ((or (string= type "unavailable") (string= type "error"))
118 ;; error from room itself? or are we leaving?
119 (if (or (null nickname)
120 (member "110" status-codes)
121 (string= nickname our-nickname))
122 ;; Assume that an error means that we were thrown out of the
123 ;; room...
124 (let* ((leavingp t)
125 (message (cond
126 ((string= type "error")
127 (cond
128 ;; ...except for certain cases.
129 ((or (member "406" status-codes)
130 (member "409" status-codes))
131 (setq leavingp nil)
132 (concat "Nickname change not allowed"
133 (when error-node
134 (concat ": " (jabber-parse-error error-node)))))
135 (t
136 (concat "Error entering room"
137 (when error-node
138 (concat ": " (jabber-parse-error error-node)))))))
139 ((member "301" status-codes)
140 (concat "You have been banned"
141 (when actor (concat " by " actor))
142 (when reason (concat " - '" reason "'"))))
143 ((member "307" status-codes)
144 (concat "You have been kicked"
145 (when actor (concat " by " actor))
146 (when reason (concat " - '" reason "'"))))
147 (t
148 "You have left the chatroom"))))
149 (when leavingp
150 (jabber-muc-remove-groupchat group))
151 ;; If there is no buffer for this groupchat, don't bother
152 ;; creating one just to tell that user left the room.
153 (let ((buffer (get-buffer (jabber-muc-get-buffer group))))
154 (if buffer
155 (with-current-buffer buffer
156 (jabber-muc-maybe-decorate-presence
157 (list (if (string= type "error")
158 :muc-error
159 :muc-notice)
160 message
161 :time (current-time)))))
162 (message "%s: %s" (jabber-jid-displayname group) message))))
163 ;; or someone else?
164 (let* ((plist (jabber-muc-participant-plist group nickname))
165 (jid (plist-get plist 'jid))
166 (name (concat nickname
167 (when jid
168 (concat " <"
169 (jabber-jid-user jid)
170 ">")))))
171 (jabber-muc-remove-participant group nickname)
172 (with-current-buffer (jabber-muc-create-buffer jc group)
173 (jabber-muc-maybe-decorate-presence
174 (list :muc-notice
175 (cond
176 ((member "301" status-codes)
177 (concat name " has been banned"
178 (when actor (concat " by " actor))
179 (when reason (concat " - '" reason "'"))))
180 ((member "307" status-codes)
181 (concat name " has been kicked"
182 (when actor (concat " by " actor))
183 (when reason (concat " - '" reason "'"))))
184 ((member "303" status-codes)
185 (concat name " changes nickname to "
186 (jabber-xml-get-attribute item 'nick)))
187 (t
188 (concat name " has left the chatroom")))
189 :time (current-time))))))
190 (t
191 ;; someone is entering
192
193 (when (or (member "110" status-codes) (string= nickname our-nickname))
194 ;; This is us. We just succeeded in entering the room.
195 ;;
196 ;; The MUC server is supposed to send a 110 code whenever this
197 ;; is our presence ("self-presence"), but at least one
198 ;; (ejabberd's mod_irc) doesn't, so check the nickname as well.
199 ;;
200 ;; This check might give incorrect results if the server
201 ;; changed our nickname to avoid collision with an existing
202 ;; participant, but even in this case the window where we have
203 ;; incorrect information should be very small, as we should be
204 ;; getting our own 110+210 presence shortly.
205 (let ((whichgroup (assoc group *jabber-active-groupchats*)))
206 (if whichgroup
207 (setcdr whichgroup nickname)
208 (add-to-list '*jabber-active-groupchats* (cons group nickname))))
209 ;; The server may have changed our nick. Record the new one.
210 (puthash symbol nickname jabber-pending-groupchats))
211
212 ;; Whoever enters, we create a buffer (if it didn't already
213 ;; exist), and print a notice. This is where autojoined MUC
214 ;; rooms have buffers created for them. We also remember some
215 ;; metadata.
216 (let ((old-plist (jabber-muc-participant-plist group nickname))
217 (new-plist (jabber-muc-parse-affiliation x-muc)))
218 (jabber-muc-modify-participant group nickname new-plist)
219 (let ((report (jabber-muc-report-delta nickname old-plist new-plist
220 reason actor)))
221 (when report
222 (with-current-buffer (jabber-muc-create-buffer jc group)
223 (jabber-muc-maybe-decorate-presence
224 (list :muc-notice report
225 :time (current-time)))
226 ;; Did the server change our nick?
227 (when (member "210" status-codes)
228 (ewoc-enter-last
229 jabber-chat-ewoc
230 (list :muc-notice
231 (concat "Your nick was changed to " nickname " by the server")
232 :time (current-time))))
233 ;; Was this room just created? If so, it's a locked
234 ;; room. Notify the user.
235 (when (member "201" status-codes)
236 (ewoc-enter-last
237 jabber-chat-ewoc
238 (list :muc-notice
239 (with-temp-buffer
240 (insert "This room was just created, and is locked to other participants.\n"
241 "To unlock it, ")
242 (insert-text-button
243 "configure the room"
244 'action (apply-partially 'call-interactively 'jabber-muc-get-config))
245 (insert " or ")
246 (insert-text-button
247 "accept the default configuration"
248 'action (apply-partially 'call-interactively 'jabber-muc-instant-config))
249 (insert ".")
250 (buffer-string))
251 :time (current-time))))))))))))
252
31(provide '+jabber) 253(provide '+jabber)
32;;; +jabber.el ends here 254;;; +jabber.el ends here