jabber-presence.el

   1 ;; jabber-presence.el - roster and presence bookkeeping
   2
   3 ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
   4 ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
   5
   6 ;; This file is a part of jabber.el.
   7
   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.
  12
  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.
  17
  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
  21
  22 (require 'jabber-core)
  23 (require 'jabber-iq)
  24 (require 'jabber-alert)
  25 (require 'jabber-util)
  26 (require 'jabber-menu)
  27 (require 'jabber-muc)
  28 (require 'jabber-autoloads)
  29
  30 (require 'assoc)
  31
  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/>
  36 stanza.")
  37
  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\")"
  57                  from
  58                  username server username server resource)
  59
  60       (dolist (item (jabber-xml-get-children (car (jabber-xml-get-children xml-data 'query)) 'item))
  61         (let (roster-item
  62               (jid (jabber-jid-symbol (jabber-xml-get-attribute item 'jid))))
  63
  64           ;; If subscripton="remove", contact is to be removed from roster
  65           (if (string= (jabber-xml-get-attribute item 'subscription) "remove")
  66               (progn
  67                 (message "%s removed from roster" jid)
  68                 (push jid deleted-items))
  69
  70             ;; Find contact if already in roster
  71             (setq roster-item (car (memq jid roster)))
  72
  73             (if roster-item
  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))
  79
  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
  85             ;; between accounts.
  86             (when (eq closure-data 'initial)
  87               (setplist roster-item nil))
  88
  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))
  93
  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
  97             ;; compatibility.
  98             (put roster-item 'xml item)
  99
 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)
 106
 107     (if (and id (string= type "set"))
 108         (jabber-send-iq jc nil "result" nil
 109                         nil nil nil nil id)))
 110
 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)))
 116
 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))))
 131                                         "0"))))
 132     (cond
 133      ((string= type "subscribe")
 134       (run-with-idle-timer 0.01 nil #'jabber-process-subscription-request jc from presence-status))
 135
 136      ((jabber-muc-presence-p xml-data)
 137       (jabber-muc-process-presence jc xml-data))
 138
 139      (t
 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))))
 147                    newstatus)
 148               (cond
 149                ((and (string= resource "") (member type '("unavailable" "error")))
 150                 ;; 'unavailable' or 'error' from bare JID means that all resources
 151                 ;; are offline.
 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)
 156                                      presence-status)))
 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)))
 162
 163                ((string= type "unavailable")
 164                 (setq resource-plist
 165                       (plist-put resource-plist 'connected nil))
 166                 (setq resource-plist
 167                       (plist-put resource-plist 'show nil))
 168                 (setq resource-plist
 169                       (plist-put resource-plist 'status
 170                                  presence-status)))
 171
 172                ((string= type "error")
 173                 (setq newstatus "error")
 174                 (setq resource-plist
 175                       (plist-put resource-plist 'connected nil))
 176                 (setq resource-plist
 177                       (plist-put resource-plist 'show "error"))
 178                 (setq resource-plist
 179                       (plist-put resource-plist 'status
 180                                  (if error
 181                                      (jabber-parse-error error)
 182                                    presence-status))))
 183                ((or
 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))
 190                (t
 191                 (setq resource-plist
 192                       (plist-put resource-plist 'connected t))
 193                 (setq resource-plist
 194                       (plist-put resource-plist 'show (or presence-show "")))
 195                 (setq resource-plist
 196                       (plist-put resource-plist 'status
 197                                  presence-status))
 198                 (setq resource-plist
 199                       (plist-put resource-plist 'priority priority))
 200                 (setq newstatus (or presence-show ""))))
 201
 202               (when resource-plist
 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))
 208
 209               (fsm-send jc (cons :roster-update buddy))
 210
 211               (dolist (hook '(jabber-presence-hooks jabber-alert-presence-hooks))
 212                 (run-hook-with-args hook
 213                                     buddy
 214                                     oldstatus
 215                                     newstatus
 216                                     (plist-get resource-plist 'status)
 217                                     (funcall jabber-alert-presence-message-function
 218                                              buddy
 219                                              oldstatus
 220                                              newstatus
 221                                              (plist-get resource-plist 'status)))))))))))
 222
 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)))
 227
 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)))))
 230
 231 (defun jabber-subscription-accept-mutual (&rest ignored)
 232   (message "Subscription accepted; reciprocal subscription request sent")
 233   (jabber-subscription-reply "subscribed" "subscribe"))
 234
 235 (defun jabber-subscription-accept-one-way (&rest ignored)
 236   (message "Subscription accepted")
 237   (jabber-subscription-reply "subscribed"))
 238
 239 (defun jabber-subscription-decline (&rest ignored)
 240   (message "Subscription declined")
 241   (jabber-subscription-reply "unsubscribed"))
 242
 243 (defun jabber-subscription-reply (&rest types)
 244   (let ((to (jabber-jid-user jabber-chatting-with)))
 245     (dolist (type types)
 246       (jabber-send-sexp jabber-buffer-connection `(presence ((to . ,to) (type . ,type)))))))
 247
 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)
 262                               (and 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)))
 270
 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)))))))
 278           resource-alist)))
 279
 280 (defun jabber-count-connected-resources (buddy)
 281   "Return the number of connected resources for BUDDY."
 282   (let ((resource-alist (get buddy 'resources))
 283         (count 0))
 284     (dolist (resource resource-alist)
 285       (if (plist-get (cdr resource) 'connected)
 286           (setq count (1+ count))))
 287     count))
 288
 289 ;;;###autoload
 290 (defun jabber-send-presence (show status priority)
 291   "Set presence for all accounts."
 292   (interactive (list (completing-read "show:"
 293                                       '(("" . nil)
 294                                         ("away" . nil)
 295                                         ("xa" . nil)
 296                                         ("dnd" . nil)
 297                                         ("chat" . nil))
 298                                       nil t)
 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.
 313
 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))))
 322              (jc (when buffer
 323                    (buffer-local-value 'jabber-buffer-connection buffer)))
 324              (subelements (cdr (assq jc subelements-map))))
 325         (when jc
 326           (jabber-send-sexp-if-connected jc `(presence ((to . ,(car groupchat))) ,@subelements))))))
 327   (jabber-display-roster))
 328
 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)
 338                                (funcall f jc))
 339                              jabber-presence-element-functions))))
 340
 341 (defun jabber-send-directed-presence (jc jid type)
 342   "Send a directed presence stanza to JID.
 343 TYPE is one of:
 344 \"online\", \"away\", \"xa\", \"dnd\", \"chatty\":
 345   Appear as present with the given status.
 346 \"unavailable\":
 347   Appear as offline.
 348 \"probe\":
 349   Ask the contact's server for updated presence.
 350 \"subscribe\":
 351   Ask for subscription to contact's presence.
 352   (see also `jabber-send-subscription-request')
 353 \"unsubscribe\":
 354   Cancel your subscription to contact's presence.
 355 \"subscribed\":
 356   Accept contact's request for presence subscription.
 357   (this is usually done within a chat buffer)
 358 \"unsubscribed\":
 359   Cancel contact's subscription to your presence."
 360   (interactive
 361    (list (jabber-read-account)
 362          (jabber-read-jid-completing "Send directed presence to: ")
 363          (completing-read "Type (default is online): "
 364                           '(("online")
 365                             ("away")
 366                             ("xa")
 367                             ("dnd")
 368                             ("chatty")
 369                             ("probe")
 370                             ("unavailable")
 371                             ("subscribe")
 372                             ("unsubscribe")
 373                             ("subscribed")
 374                             ("unsubscribed"))
 375                           nil t nil nil "online")))
 376   (cond
 377    ((member type '("probe" "unavailable"
 378                    "subscribe" "unsubscribe"
 379                    "subscribed" "unsubscribed"))
 380     (jabber-send-sexp jc `(presence ((to . ,jid)
 381                                      (type . ,type)))))
 382
 383    (t
 384     (let ((*jabber-current-show*
 385            (if (string= type "online")
 386                ""
 387              type))
 388           (*jabber-current-status* nil))
 389       (jabber-send-sexp jc `(presence ((to . ,jid))
 390                                       ,@(jabber-presence-children jc)))))))
 391
 392 (defun jabber-send-away-presence (&optional status)
 393   "Set status to away.
 394 With prefix argument, ask for status message."
 395   (interactive (list
 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*))
 399
 400 (defun jabber-send-xa-presence (&optional status)
 401   "Send extended away presence.
 402 With prefix argument, ask for status message."
 403   (interactive (list
 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*))
 407
 408 ;;;###autoload
 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'."
 413   (interactive)
 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))
 417
 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')."
 422   (interactive)
 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)))
 428
 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: ")))
 436   (jabber-send-sexp jc
 437                     `(presence
 438                       ((to . ,to)
 439                        (type . "subscribe"))
 440                       ,@(when (and request (> (length request) 0))
 441                           (list `(status () ,request))))))
 442
 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"))
 459                         (list 'item (append
 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))
 464                                       groups)))
 465                   #'jabber-report-success "Roster item change"
 466                   #'jabber-report-success "Roster item change"))
 467
 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"))
 475                           (item ((jid . ,jid)
 476                                  (subscription . "remove"))))
 477                   #'jabber-report-success "Roster item removal"
 478                   #'jabber-report-success "Roster item removal"))
 479
 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."
 483   (interactive)
 484   (let ((jid-at-point (get-text-property (point)
 485                                          'jabber-jid))
 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"))))
 491
 492 (provide 'jabber-presence)
 493
 494 ;;; arch-tag: b8616d4c-dde8-423e-86c7-da7b4928afc3