1 ;; jabber-presence.el - roster and presence bookkeeping
3 ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
4 ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
6 ;; This file is a part of jabber.el.
8 ;; This program is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2 of the License, or
11 ;; (at your option) any later version.
13 ;; This program is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with this program; if not, write to the Free Software
20 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
22 (require 'jabber-core
)
24 (require 'jabber-alert
)
25 (require 'jabber-util
)
26 (require 'jabber-menu
)
28 (require 'jabber-autoloads
)
32 (defvar jabber-presence-element-functions nil
33 "List of functions returning extra elements for <presence/> stanzas.
34 Each function takes one argument, the connection, and returns a
35 possibly empty list of extra child element of the <presence/>
38 (add-to-list 'jabber-iq-set-xmlns-alist
39 (cons "jabber:iq:roster" (function (lambda (jc x
) (jabber-process-roster jc x nil
)))))
40 (defun jabber-process-roster (jc xml-data closure-data
)
41 "process an incoming roster infoquery result
42 CLOSURE-DATA should be 'initial if initial roster push, nil otherwise."
43 (let ((roster (plist-get (fsm-get-state-data jc
) :roster
))
44 (from (jabber-xml-get-attribute xml-data
'from
))
45 (type (jabber-xml-get-attribute xml-data
'type
))
46 (id (jabber-xml-get-attribute xml-data
'id
))
47 (username (plist-get (fsm-get-state-data jc
) :username
))
48 (server (plist-get (fsm-get-state-data jc
) :server
))
49 (resource (plist-get (fsm-get-state-data jc
) :resource
))
50 new-items changed-items deleted-items
)
51 ;; Perform sanity check on "from" attribute: it should be either absent
52 ;; or match our own JID.
53 (if (not (or (null from
)
54 (string= from
(concat username
"@" server
))
55 (string= from
(concat username
"@" server
"/" resource
))))
56 (message "Roster push with invalid \"from\": \"%s\" (expected \"%s@%s\" or \"%s@%s/%s\")"
58 username server username server resource
)
60 (dolist (item (jabber-xml-get-children (car (jabber-xml-get-children xml-data
'query
)) 'item
))
62 (jid (jabber-jid-symbol (jabber-xml-get-attribute item
'jid
))))
64 ;; If subscripton="remove", contact is to be removed from roster
65 (if (string= (jabber-xml-get-attribute item
'subscription
) "remove")
67 (message "%s removed from roster" jid
)
68 (push jid deleted-items
))
70 ;; Find contact if already in roster
71 (setq roster-item
(car (memq jid roster
)))
74 (push roster-item changed-items
)
75 ;; If not found, create a new roster item.
76 (message "%s added to roster" jid
)
77 (setq roster-item jid
)
78 (push roster-item new-items
))
80 ;; If this is an initial push, we want to forget
81 ;; everything we knew about this contact before - e.g. if
82 ;; the contact was online when we disconnected and offline
83 ;; when we reconnect, we don't want to see stale presence
84 ;; information. This assumes that no contacts are shared
86 (when (eq closure-data
'initial
)
87 (setplist roster-item nil
))
89 ;; Now, get all data associated with the contact.
90 (put roster-item
'name
(jabber-xml-get-attribute item
'name
))
91 (put roster-item
'subscription
(jabber-xml-get-attribute item
'subscription
))
92 (put roster-item
'ask
(jabber-xml-get-attribute item
'ask
))
94 ;; Since roster items can't be changed incrementally, we
95 ;; save the original XML to be able to modify it, instead of
96 ;; having to reproduce it. This is for forwards
98 (put roster-item
'xml item
)
100 (put roster-item
'groups
101 (mapcar (lambda (foo) (nth 2 foo
))
102 (jabber-xml-get-children item
'group
)))))))
103 ;; This is the function that does the actual updating and
104 ;; redrawing of the roster.
105 (jabber-roster-update jc new-items changed-items deleted-items
)
107 (if (and id
(string= type
"set"))
108 (jabber-send-iq jc nil
"result" nil
109 nil nil nil nil id
)))
111 ;; After initial roster push, run jabber-post-connect-hooks. We do
112 ;; it here and not before since we want to have the entire roster
113 ;; before we receive any presence stanzas.
114 (when (eq closure-data
'initial
)
115 (run-hook-with-args 'jabber-post-connect-hooks jc
)))
117 (add-to-list 'jabber-presence-chain
'jabber-process-presence
)
118 (defun jabber-process-presence (jc xml-data
)
119 "process incoming presence tags"
120 ;; XXX: use JC argument
121 (let ((roster (plist-get (fsm-get-state-data jc
) :roster
))
122 (from (jabber-xml-get-attribute xml-data
'from
))
123 (to (jabber-xml-get-attribute xml-data
'to
))
124 (type (jabber-xml-get-attribute xml-data
'type
))
125 (presence-show (car (jabber-xml-node-children
126 (car (jabber-xml-get-children xml-data
'show
)))))
127 (presence-status (car (jabber-xml-node-children
128 (car (jabber-xml-get-children xml-data
'status
)))))
129 (error (car (jabber-xml-get-children xml-data
'error
)))
130 (priority (string-to-number (or (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data
'priority
))))
133 ((string= type
"subscribe")
134 (run-with-idle-timer 0.01 nil
#'jabber-process-subscription-request jc from presence-status
))
136 ((jabber-muc-presence-p xml-data
)
137 (jabber-muc-process-presence jc xml-data
))
140 ;; XXX: Think about what to do about out-of-roster presences.
141 (let ((buddy (jabber-jid-symbol from
)))
142 (if (memq buddy roster
)
143 (let* ((oldstatus (get buddy
'show
))
144 (resource (or (jabber-jid-resource from
) ""))
145 (resource-plist (cdr (assoc resource
146 (get buddy
'resources
))))
149 ((and (string= resource
"") (member type
'("unavailable" "error")))
150 ;; 'unavailable' or 'error' from bare JID means that all resources
152 (setq resource-plist nil
)
153 (setq newstatus
(if (string= type
"error") "error" nil
))
154 (let ((new-message (if error
155 (jabber-parse-error error
)
157 ;; erase any previous information
158 (put buddy
'resources nil
)
159 (put buddy
'connected nil
)
160 (put buddy
'show newstatus
)
161 (put buddy
'status new-message
)))
163 ((string= type
"unavailable")
165 (plist-put resource-plist
'connected nil
))
167 (plist-put resource-plist
'show nil
))
169 (plist-put resource-plist
'status
172 ((string= type
"error")
173 (setq newstatus
"error")
175 (plist-put resource-plist
'connected nil
))
177 (plist-put resource-plist
'show
"error"))
179 (plist-put resource-plist
'status
181 (jabber-parse-error error
)
184 (string= type
"unsubscribe")
185 (string= type
"subscribed")
186 (string= type
"unsubscribed"))
187 ;; Do nothing, except letting the user know. The Jabber protocol
188 ;; places all this complexity on the server.
189 (setq newstatus type
))
192 (plist-put resource-plist
'connected t
))
194 (plist-put resource-plist
'show
(or presence-show
"")))
196 (plist-put resource-plist
'status
199 (plist-put resource-plist
'priority priority
))
200 (setq newstatus
(or presence-show
""))))
203 ;; this is for `assoc-set!' in guile
204 (if (assoc resource
(get buddy
'resources
))
205 (setcdr (assoc resource
(get buddy
'resources
)) resource-plist
)
206 (put buddy
'resources
(cons (cons resource resource-plist
) (get buddy
'resources
))))
207 (jabber-prioritize-resources buddy
))
209 (fsm-send jc
(cons :roster-update buddy
))
211 (dolist (hook '(jabber-presence-hooks jabber-alert-presence-hooks
))
212 (run-hook-with-args hook
216 (plist-get resource-plist
'status
)
217 (funcall jabber-alert-presence-message-function
221 (plist-get resource-plist
'status
)))))))))))
223 (defun jabber-process-subscription-request (jc from presence-status
)
224 "process an incoming subscription request"
225 (with-current-buffer (jabber-chat-create-buffer jc from
)
226 (ewoc-enter-last jabber-chat-ewoc
(list :subscription-request presence-status
:time
(current-time)))
228 (dolist (hook '(jabber-presence-hooks jabber-alert-presence-hooks
))
229 (run-hook-with-args hook
(jabber-jid-symbol from
) nil
"subscribe" presence-status
(funcall jabber-alert-presence-message-function
(jabber-jid-symbol from
) nil
"subscribe" presence-status
)))))
231 (defun jabber-subscription-accept-mutual (&rest ignored
)
232 (message "Subscription accepted; reciprocal subscription request sent")
233 (jabber-subscription-reply "subscribed" "subscribe"))
235 (defun jabber-subscription-accept-one-way (&rest ignored
)
236 (message "Subscription accepted")
237 (jabber-subscription-reply "subscribed"))
239 (defun jabber-subscription-decline (&rest ignored
)
240 (message "Subscription declined")
241 (jabber-subscription-reply "unsubscribed"))
243 (defun jabber-subscription-reply (&rest types
)
244 (let ((to (jabber-jid-user jabber-chatting-with
)))
246 (jabber-send-sexp jabber-buffer-connection
`(presence ((to .
,to
) (type .
,type
)))))))
248 (defun jabber-prioritize-resources (buddy)
249 "Set connected, show and status properties for BUDDY from highest-priority resource."
250 (let ((resource-alist (get buddy
'resources
))
251 (highest-priority nil
))
252 ;; Reset to nil at first, for cases (a) resource-alist is nil
253 ;; and (b) all resources are disconnected.
254 (put buddy
'connected nil
)
255 (put buddy
'show nil
)
256 (put buddy
'status nil
)
257 (mapc #'(lambda (resource)
258 (let* ((resource-plist (cdr resource
))
259 (priority (plist-get resource-plist
'priority
)))
260 (if (plist-get resource-plist
'connected
)
261 (when (or (null highest-priority
)
263 (> priority highest-priority
)))
264 ;; if no priority specified, interpret as zero
265 (setq highest-priority
(or priority
0))
266 (put buddy
'connected
(plist-get resource-plist
'connected
))
267 (put buddy
'show
(plist-get resource-plist
'show
))
268 (put buddy
'status
(plist-get resource-plist
'status
))
269 (put buddy
'resource
(car resource
)))
271 ;; if we have not found a connected resource yet, but this
272 ;; disconnected resource has a status message, display it.
273 (when (not (get buddy
'connected
))
274 (if (plist-get resource-plist
'status
)
275 (put buddy
'status
(plist-get resource-plist
'status
)))
276 (if (plist-get resource-plist
'show
)
277 (put buddy
'show
(plist-get resource-plist
'show
)))))))
280 (defun jabber-count-connected-resources (buddy)
281 "Return the number of connected resources for BUDDY."
282 (let ((resource-alist (get buddy
'resources
))
284 (dolist (resource resource-alist
)
285 (if (plist-get (cdr resource
) 'connected
)
286 (setq count
(1+ count
))))
290 (defun jabber-send-presence (show status priority
)
291 "Set presence for all accounts."
292 (interactive (list (completing-read "show:"
299 (jabber-read-with-input-method "status message: " *jabber-current-status
* '*jabber-status-history
*)
300 (read-string "priority: " (progn
301 (unless *jabber-current-priority
*
302 (setq *jabber-current-priority
*
303 jabber-default-priority
))
304 (int-to-string *jabber-current-priority
*)))))
305 (if (numberp priority
)
306 (setq priority
(int-to-string priority
)))
307 (setq *jabber-current-status
* status
)
308 (setq *jabber-current-show
* show
)
309 (setq *jabber-current-priority
* (string-to-number priority
))
310 (let (subelements-map)
311 ;; For each connection, we use a different set of subelements. We
312 ;; cache them, to only generate them once.
314 ;; Ordinary presence, with no specified recipient
315 (dolist (jc jabber-connections
)
316 (let ((subelements (jabber-presence-children jc
)))
317 (aput 'subelements-map jc subelements
)
318 (jabber-send-sexp-if-connected jc
`(presence () ,@subelements
))))
319 ;; Then send presence to groupchats
320 (dolist (groupchat *jabber-active-groupchats
*)
321 (let* ((buffer (get-buffer (jabber-muc-get-buffer (car groupchat
))))
323 (buffer-local-value 'jabber-buffer-connection buffer
)))
324 (subelements (cdr (assq jc subelements-map
))))
326 (jabber-send-sexp-if-connected jc
`(presence ((to .
,(car groupchat
))) ,@subelements
))))))
327 (jabber-display-roster))
329 (defun jabber-presence-children (jc)
330 "Return the children for a <presence/> stanza."
331 `(,(when (> (length *jabber-current-status
*) 0)
332 `(status () ,*jabber-current-status
*))
333 ,(when (> (length *jabber-current-show
*) 0)
334 `(show () ,*jabber-current-show
*))
335 ,(when *jabber-current-priority
*
336 `(priority () ,(number-to-string *jabber-current-priority
*)))
337 ,@(apply 'append
(mapcar (lambda (f)
339 jabber-presence-element-functions
))))
341 (defun jabber-send-directed-presence (jc jid type
)
342 "Send a directed presence stanza to JID.
344 \"online\", \"away\", \"xa\", \"dnd\", \"chatty\":
345 Appear as present with the given status.
349 Ask the contact's server for updated presence.
351 Ask for subscription to contact's presence.
352 (see also `jabber-send-subscription-request')
354 Cancel your subscription to contact's presence.
356 Accept contact's request for presence subscription.
357 (this is usually done within a chat buffer)
359 Cancel contact's subscription to your presence."
361 (list (jabber-read-account)
362 (jabber-read-jid-completing "Send directed presence to: ")
363 (completing-read "Type (default is online): "
375 nil t nil nil
"online")))
377 ((member type
'("probe" "unavailable"
378 "subscribe" "unsubscribe"
379 "subscribed" "unsubscribed"))
380 (jabber-send-sexp jc
`(presence ((to .
,jid
)
384 (let ((*jabber-current-show
*
385 (if (string= type
"online")
388 (*jabber-current-status
* nil
))
389 (jabber-send-sexp jc
`(presence ((to .
,jid
))
390 ,@(jabber-presence-children jc
)))))))
392 (defun jabber-send-away-presence (&optional status
)
394 With prefix argument, ask for status message."
396 (when current-prefix-arg
397 (jabber-read-with-input-method "status message: " *jabber-current-status
* '*jabber-status-history
*))))
398 (jabber-send-presence "away" status
*jabber-current-priority
*))
400 (defun jabber-send-xa-presence (&optional status
)
401 "Send extended away presence.
402 With prefix argument, ask for status message."
404 (when current-prefix-arg
405 (jabber-read-with-input-method "status message: " *jabber-current-status
* '*jabber-status-history
*))))
406 (jabber-send-presence "xa" status
*jabber-current-priority
*))
409 (defun jabber-send-default-presence (&optional jc
)
410 "Send default presence.
411 Default presence is specified by `jabber-default-priority', `jabber-default-show',
412 and `jabber-default-status'."
414 ;; jc is ignored. It's only there so this function can be in
415 ;; jabber-post-connect-hooks.
416 (jabber-send-presence jabber-default-show jabber-default-status jabber-default-priority
))
418 (defun jabber-send-current-presence (&optional jc
)
419 "(Re-)send current presence.
420 That is, if presence has already been sent, use current settings,
421 else send defaults (see `jabber-send-default-presence')."
423 ;; jc is ignored. It's only there so this function can be in
424 ;; jabber-post-connect-hooks.
425 (if *jabber-current-show
*
426 (jabber-send-presence *jabber-current-show
* *jabber-current-status
* *jabber-current-priority
*)
427 (jabber-send-default-presence)))
429 (add-to-list 'jabber-jid-roster-menu
430 (cons "Send subscription request" 'jabber-send-subscription-request
))
431 (defun jabber-send-subscription-request (jc to
&optional request
)
432 "send a subscription request to jid, showing him your request text, if specified"
433 (interactive (list (jabber-read-account)
434 (jabber-read-jid-completing "to: ")
435 (jabber-read-with-input-method "request: ")))
439 (type .
"subscribe"))
440 ,@(when (and request
(> (length request
) 0))
441 (list `(status () ,request
))))))
443 (add-to-list 'jabber-jid-roster-menu
444 (cons "Add/modify roster entry" 'jabber-roster-change
))
445 (defun jabber-roster-change (jc jid name groups
)
446 "Add or change a roster item."
447 (interactive (let* ((jid (jabber-jid-symbol
448 (jabber-read-jid-completing "Add/change JID: ")))
449 (name (get jid
'name
))
450 (groups (get jid
'groups
)))
451 (list (jabber-read-account)
452 jid
(jabber-read-with-input-method (format "Name: (default `%s') " name
) nil nil name
)
453 (car (read-from-string (jabber-read-with-input-method (format "Groups: (default `%S') " groups
) nil nil
(format "%S" groups
)))))))
454 ;; If new fields are added to the roster XML structure in a future standard,
455 ;; they will be clobbered by this function.
456 ;; XXX: specify account
457 (jabber-send-iq jc nil
"set"
458 (list 'query
(list (cons 'xmlns
"jabber:iq:roster"))
460 (list (cons 'jid
(symbol-name jid
)))
461 (if (and name
(> (length name
) 0))
462 (list (cons 'name name
))))
463 (mapcar #'(lambda (x) `(group () ,x
))
465 #'jabber-report-success
"Roster item change"
466 #'jabber-report-success
"Roster item change"))
468 (add-to-list 'jabber-jid-roster-menu
469 (cons "Delete roster entry" 'jabber-roster-delete
))
470 (defun jabber-roster-delete (jc jid
)
471 (interactive (list (jabber-read-account)
472 (jabber-read-jid-completing "Delete from roster: ")))
473 (jabber-send-iq jc nil
"set"
474 `(query ((xmlns .
"jabber:iq:roster"))
476 (subscription .
"remove"))))
477 #'jabber-report-success
"Roster item removal"
478 #'jabber-report-success
"Roster item removal"))
480 (defun jabber-roster-delete-jid-at-point ()
481 "Delete JID at point from roster.
482 Signal an error if there is no JID at point."
484 (let ((jid-at-point (get-text-property (point)
486 (account (get-text-property (point) 'jabber-account
)))
487 (if (and jid-at-point account
488 (yes-or-no-p (format "Really delete %s from roster? " jid-at-point
)))
489 (jabber-roster-delete account jid-at-point
)
490 (error "No contact at point"))))
492 (provide 'jabber-presence
)
494 ;;; arch-tag: b8616d4c-dde8-423e-86c7-da7b4928afc3