jabber-muc.el

   1 ;; jabber-muc.el - advanced MUC functions
   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-chat)
  23 (require 'jabber-widget)
  24 (require 'jabber-newdisco)
  25 (require 'jabber-autoloads)
  26
  27 (require 'cl)
  28
  29 ;;;###autoload
  30 (defvar *jabber-active-groupchats* nil
  31   "alist of groupchats and nicknames
  32 Keys are strings, the bare JID of the room.
  33 Values are strings.")
  34
  35 (defvar jabber-pending-groupchats (make-hash-table)
  36   "Hash table of groupchats and nicknames.
  37 Keys are JID symbols; values are strings.
  38 This table records the last nickname used to join the particular
  39 chat room.  Items are thus never removed.")
  40
  41 (defvar jabber-muc-participants nil
  42   "alist of groupchats and participants
  43 Keys are strings, the bare JID of the room.
  44 Values are lists of nickname strings.")
  45
  46 (defvar jabber-group nil
  47   "the groupchat you are participating in")
  48
  49 (defvar jabber-muc-topic ""
  50   "The topic of the current MUC room.")
  51
  52 ;;;###autoload
  53 (defcustom jabber-muc-default-nicknames nil
  54   "Default nickname for specific MUC rooms."
  55   :group 'jabber-chat
  56   :type '(repeat
  57           (cons :format "%v"
  58                 (string :tag "JID of room")
  59                 (string :tag "Nickname"))))
  60
  61 ;;;###autoload
  62 (defcustom jabber-muc-autojoin nil
  63   "List of MUC rooms to automatically join on connection.
  64 This list is saved in your Emacs customizations.  You can also store
  65 such a list on the Jabber server, where it is available to every
  66 client; see `jabber-edit-bookmarks'."
  67   :group 'jabber-chat
  68   :type '(repeat (string :tag "JID of room")))
  69
  70 (defcustom jabber-muc-disable-disco-check nil
  71   "If non-nil, disable checking disco#info of rooms before joining them.
  72 Disco information can tell whether the room exists and whether it is
  73 password protected, but some servers do not support it.  If you want
  74 to join chat rooms on such servers, set this variable to t."
  75   :group 'jabber-chat
  76   :type 'boolean)
  77
  78 (defcustom jabber-groupchat-buffer-format "*-jabber-groupchat-%n-*"
  79   "The format specification for the name of groupchat buffers.
  80
  81 These fields are available (all are about the group you are chatting
  82 in):
  83
  84 %n   Roster name of group, or JID if no nickname set
  85 %j   Bare JID (without resource)"
  86   :type 'string
  87   :group 'jabber-chat)
  88
  89 (defcustom jabber-groupchat-prompt-format "[%t] %n> "
  90   "The format specification for lines in groupchat.
  91
  92 These fields are available:
  93
  94 %t   Time, formatted according to `jabber-chat-time-format'
  95 %n, %u, %r
  96      Nickname in groupchat
  97 %j   Full JID (room@server/nick)"
  98   :type 'string
  99   :group 'jabber-chat)
 100
 101 (defcustom jabber-muc-header-line-format
 102   '(" " (:eval (jabber-jid-displayname jabber-group))
 103     "\t" jabber-muc-topic)
 104   "The specification for the header line of MUC buffers.
 105
 106 The format is that of `mode-line-format' and `header-line-format'."
 107   :type 'sexp
 108   :group 'jabber-chat)
 109
 110 (defcustom jabber-muc-private-buffer-format "*-jabber-muc-priv-%g-%n-*"
 111   "The format specification for the buffer name for private MUC messages.
 112
 113 These fields are available:
 114
 115 %g   Roster name of group, or JID if no nickname set
 116 %n   Nickname of the group member you're chatting with"
 117   :type 'string
 118   :group 'jabber-chat)
 119
 120 (defcustom jabber-muc-private-foreign-prompt-format "[%t] %g/%n> "
 121   "The format specification for lines others type in a private MUC buffer.
 122
 123 These fields are available:
 124
 125 %t  Time, formatted according to `jabber-chat-time-format'
 126 %n  Nickname in room
 127 %g  Short room name (either roster name or username part of JID)"
 128   :type 'string
 129   :group 'jabber-chat)
 130
 131 (defcustom jabber-muc-private-header-line-format
 132   '(" " (:eval (jabber-jid-resource jabber-chatting-with))
 133     " in " (:eval (jabber-jid-displayname (jabber-jid-user jabber-chatting-with)))
 134     "\t" jabber-events-message
 135     "\t" jabber-chatstates-message)
 136   "The specification for the header line of private MUC chat buffers.
 137
 138 The format is that of `mode-line-format' and `header-line-format'."
 139   :type 'sexp
 140   :group 'jabber-chat)
 141
 142 ;;;###autoload
 143 (defvar jabber-muc-printers '()
 144   "List of functions that may be able to print part of a MUC message.
 145 This gets prepended to `jabber-chat-printers', which see.")
 146
 147 ;;;###autoload
 148 (defun jabber-muc-get-buffer (group)
 149   "Return the chat buffer for chatroom GROUP.
 150 Either a string or a buffer is returned, so use `get-buffer' or
 151 `get-buffer-create'."
 152   (format-spec jabber-groupchat-buffer-format
 153                (list
 154                 (cons ?n (jabber-jid-displayname group))
 155                 (cons ?j (jabber-jid-user group)))))
 156
 157 (defun jabber-muc-create-buffer (jc group)
 158   "Prepare a buffer for chatroom GROUP.
 159 This function is idempotent."
 160   (with-current-buffer (get-buffer-create (jabber-muc-get-buffer group))
 161     (unless (eq major-mode 'jabber-chat-mode)
 162       (jabber-chat-mode jc #'jabber-chat-pp))
 163     ;; Make sure the connection variable is up to date.
 164     (setq jabber-buffer-connection jc)
 165
 166     (set (make-local-variable 'jabber-group) group)
 167     (make-local-variable 'jabber-muc-topic)
 168     (setq jabber-send-function 'jabber-muc-send)
 169     (setq header-line-format jabber-muc-header-line-format)
 170     (current-buffer)))
 171
 172 ;;;###autoload
 173 (defun jabber-muc-private-get-buffer (group nickname)
 174   "Return the chat buffer for private chat with NICKNAME in GROUP.
 175 Either a string or a buffer is returned, so use `get-buffer' or
 176 `get-buffer-create'."
 177   (format-spec jabber-muc-private-buffer-format
 178                (list
 179                 (cons ?g (jabber-jid-displayname group))
 180                 (cons ?n nickname))))
 181
 182 (defun jabber-muc-private-create-buffer (jc group nickname)
 183   "Prepare a buffer for chatting with NICKNAME in GROUP.
 184 This function is idempotent."
 185   (with-current-buffer (get-buffer-create (jabber-muc-private-get-buffer group nickname))
 186     (unless (eq major-mode 'jabber-chat-mode)
 187       (jabber-chat-mode jc #'jabber-chat-pp))
 188
 189     (set (make-local-variable 'jabber-chatting-with) (concat group "/" nickname))
 190     (setq jabber-send-function 'jabber-chat-send)
 191     (setq header-line-format jabber-muc-private-header-line-format)
 192
 193     (current-buffer)))
 194
 195 (defun jabber-muc-send (jc body)
 196   "Send BODY to MUC room in current buffer."
 197   ;; There is no need to display the sent message in the buffer, as
 198   ;; we will get it back from the MUC server.
 199   (jabber-send-sexp jc
 200                     `(message
 201                       ((to . ,jabber-group)
 202                        (type . "groupchat"))
 203                       (body () ,body))))
 204
 205 (defun jabber-muc-add-groupchat (group nickname)
 206   "Remember participating in GROUP under NICKNAME."
 207   (let ((whichgroup (assoc group *jabber-active-groupchats*)))
 208     (if whichgroup
 209         (setcdr whichgroup nickname)
 210       (add-to-list '*jabber-active-groupchats* (cons group nickname)))))
 211
 212 (defun jabber-muc-remove-groupchat (group)
 213   "Remove GROUP from internal bookkeeping."
 214   (let ((whichgroup (assoc group *jabber-active-groupchats*))
 215         (whichparticipants (assoc group jabber-muc-participants)))
 216     (setq *jabber-active-groupchats*
 217           (delq whichgroup *jabber-active-groupchats*))
 218     (setq jabber-muc-participants
 219           (delq whichparticipants jabber-muc-participants))))
 220
 221 (defun jabber-muc-participant-plist (group nickname)
 222   "Return plist associated with NICKNAME in GROUP.
 223 Return nil if nothing known about that combination."
 224   (let ((whichparticipants (assoc group jabber-muc-participants)))
 225     (when whichparticipants
 226       (cdr (assoc nickname whichparticipants)))))
 227
 228 (defun jabber-muc-modify-participant (group nickname new-plist)
 229   "Assign properties in NEW-PLIST to NICKNAME in GROUP."
 230   (let ((participants (assoc group jabber-muc-participants)))
 231     ;; either we have a list of participants already...
 232     (if participants
 233         (let ((participant (assoc nickname participants)))
 234           ;; and maybe this participant is already in the list
 235           (if participant
 236               ;; if so, just update role, affiliation, etc.
 237               (setf (cdr participant) new-plist)
 238             (push (cons nickname new-plist) (cdr participants))))
 239       ;; or we don't
 240       (push (cons group (list (cons nickname new-plist))) jabber-muc-participants))))
 241
 242 (defun jabber-muc-report-delta (nickname old-plist new-plist reason actor)
 243   "Compare OLD-PLIST and NEW-PLIST, and return a string explaining the change.
 244 Return nil if nothing noteworthy has happened.
 245 NICKNAME is the user experiencing the change.  REASON and ACTOR, if non-nil,
 246 are the corresponding presence fields.
 247
 248 This function is only concerned with presence stanzas resulting
 249 in the user entering/staying in the room."
 250   ;; The keys in the plist are affiliation, role and jid.
 251   (when (plist-get new-plist 'jid)
 252     ;; nickname is only used for displaying, so we can modify it if we
 253     ;; want to.
 254     (setq nickname (concat nickname " <"
 255                            (jabber-jid-user (plist-get new-plist 'jid))
 256                            ">")))
 257   (cond
 258    ((null old-plist)
 259     ;; User enters the room
 260     (concat nickname " enters the room ("
 261             (plist-get new-plist 'role)
 262             (unless (string= (plist-get new-plist 'affiliation) "none")
 263               (concat ", " (plist-get new-plist 'affiliation)))
 264             ")"))
 265
 266    ;; If affiliation changes, the role change is usually the logical
 267    ;; one, so don't report it separately.
 268    ((not (string= (plist-get old-plist 'affiliation)
 269                   (plist-get new-plist 'affiliation)))
 270     (let ((actor-reason (concat (when actor
 271                                   (concat " by " actor))
 272                                 (when reason
 273                                   (concat ": " reason))))
 274           (from (plist-get old-plist 'affiliation))
 275           (to (plist-get new-plist 'affiliation)))
 276       ;; There are many ways to express these transitions in English.
 277       ;; This one favors eloquence over regularity and consistency.
 278       (cond
 279        ;; Higher affiliation
 280        ((or (and (member from '("outcast" "none" "member"))
 281                  (member to '("admin" "owner")))
 282             (and (string= from "admin") (string= to "owner")))
 283         (concat nickname " has been promoted to " to actor-reason))
 284        ;; Lower affiliation
 285        ((or (and (member from '("owner" "admin"))
 286                  (string= to "member"))
 287             (and (string= from "owner") (string= to "admin")))
 288         (concat nickname " has been demoted to " to actor-reason))
 289        ;; Become member
 290        ((string= to "member")
 291         (concat nickname " has been granted membership" actor-reason))
 292        ;; Lose membership
 293        ((string= to "none")
 294         (concat nickname " has been deprived of membership" actor-reason)))))
 295
 296    ;; Role changes
 297    ((not (string= (plist-get old-plist 'role)
 298                   (plist-get new-plist 'role)))
 299     (let ((actor-reason (concat (when actor
 300                                   (concat " by " actor))
 301                                 (when reason
 302                                   (concat ": " reason))))
 303           (from (plist-get old-plist 'role))
 304           (to (plist-get new-plist 'role)))
 305       ;; Possible roles are "none" (not in room, hence not of interest
 306       ;; in this function), "visitor" (no voice), "participant" (has
 307       ;; voice), and "moderator".
 308       (cond
 309        ((string= to "moderator")
 310         (concat nickname " has been granted moderator privileges" actor-reason))
 311        ((and (string= from "moderator")
 312              (string= to "participant"))
 313         (concat nickname " had moderator privileges revoked" actor-reason))
 314        ((string= to "participant")
 315         (concat nickname " has been granted voice" actor-reason))
 316        ((string= to "visitor")
 317         (concat nickname " has been denied voice" actor-reason)))))))
 318
 319 (defun jabber-muc-remove-participant (group nickname)
 320   "Forget everything about NICKNAME in GROUP."
 321   (let ((participants (assoc group jabber-muc-participants)))
 322     (when participants
 323       (let ((participant (assoc nickname (cdr participants))))
 324         (setf (cdr participants) (delq participant (cdr participants)))))))
 325
 326 (defmacro jabber-muc-argument-list (&optional args)
 327   "Prepend connection and group name to ARGS.
 328 If the current buffer is not an MUC buffer, signal an error.
 329 This macro is meant for use as an argument to `interactive'."
 330   `(if (null jabber-group)
 331        (error "Not in MUC buffer")
 332      (nconc (list jabber-buffer-connection jabber-group) ,args)))
 333
 334 (defun jabber-muc-read-completing (prompt &optional allow-not-joined)
 335   "Read the name of a joined chatroom, or use chatroom of current buffer, if any.
 336 If ALLOW-NOT-JOINED is provided and true, permit choosing any
 337 JID; only provide completion as a guide."
 338   (or jabber-group
 339       (jabber-read-jid-completing prompt
 340                                   (if (null *jabber-active-groupchats*)
 341                                       (error "You haven't joined any group")
 342                                     (mapcar (lambda (x) (jabber-jid-symbol (car x)))
 343                                             *jabber-active-groupchats*))
 344                                   (not allow-not-joined)
 345                                   jabber-group)))
 346
 347 (defun jabber-muc-read-nickname (group prompt)
 348   "Read the nickname of a participant in GROUP."
 349   (let ((nicknames (cdr (assoc group jabber-muc-participants))))
 350     (unless nicknames
 351       (error "Unknown group: %s" group))
 352     (completing-read prompt nicknames nil t)))
 353
 354 (add-to-list 'jabber-jid-muc-menu
 355    (cons "Configure groupchat" 'jabber-groupchat-get-config))
 356 (defun jabber-groupchat-get-config (jc group)
 357   "Ask for MUC configuration form"
 358   (interactive (jabber-muc-argument-list))
 359   (jabber-send-iq jc group
 360                   "get"
 361                   '(query ((xmlns . "http://jabber.org/protocol/muc#owner")))
 362                   #'jabber-process-data #'jabber-groupchat-render-config
 363                   #'jabber-process-data "MUC configuration request failed"))
 364
 365 (defun jabber-groupchat-render-config (jc xml-data)
 366   "Render MUC configuration form"
 367
 368   (let ((query (jabber-iq-query xml-data))
 369         xdata)
 370     (dolist (x (jabber-xml-get-children query 'x))
 371       (if (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data")
 372           (setq xdata x)))
 373     (if (not xdata)
 374         (insert "No configuration possible.\n")
 375
 376     (jabber-init-widget-buffer (jabber-xml-get-attribute xml-data 'from))
 377     (setq jabber-buffer-connection jc)
 378
 379     (jabber-render-xdata-form xdata)
 380
 381     (widget-create 'push-button :notify #'jabber-groupchat-submit-config "Submit")
 382     (widget-insert "\t")
 383     (widget-create 'push-button :notify #'jabber-groupchat-cancel-config "Cancel")
 384     (widget-insert "\n")
 385
 386     (widget-setup)
 387     (widget-minor-mode 1))))
 388
 389 (defun jabber-groupchat-submit-config (&rest ignore)
 390   "Submit MUC configuration form."
 391
 392   (jabber-send-iq jabber-buffer-connection jabber-submit-to
 393                   "set"
 394                   `(query ((xmlns . "http://jabber.org/protocol/muc#owner"))
 395                           ,(jabber-parse-xdata-form))
 396                   #'jabber-report-success "MUC configuration"
 397                   #'jabber-report-success "MUC configuration"))
 398
 399 (defun jabber-groupchat-cancel-config (&rest ignore)
 400   "Cancel MUC configuration form."
 401
 402   (jabber-send-iq jabber-buffer-connection jabber-submit-to
 403                   "set"
 404                   '(query ((xmlns . "http://jabber.org/protocol/muc#owner"))
 405                           (x ((xmlns . "jabber:x:data") (type . "cancel"))))
 406                   nil nil nil nil))
 407
 408 (add-to-list 'jabber-jid-muc-menu
 409              (cons "Join groupchat" 'jabber-groupchat-join))
 410
 411 (defun jabber-groupchat-join (jc group nickname &optional popup)
 412   "join a groupchat, or change nick.
 413 In interactive calls, or if POPUP is true, switch to the
 414 groupchat buffer."
 415   (interactive
 416    (let ((account (jabber-read-account))
 417          (group (jabber-read-jid-completing "group: ")))
 418      (list account group (jabber-muc-read-my-nickname account group) t)))
 419
 420   ;; If the user is already in the room, we don't need as many checks.
 421   (if (or (assoc group *jabber-active-groupchats*)
 422           ;; Or if the users asked us not to check disco info.
 423           jabber-muc-disable-disco-check)
 424       (jabber-groupchat-join-3 jc group nickname nil popup)
 425     ;; Else, send a disco request to find out what we are connecting
 426     ;; to.
 427     (jabber-disco-get-info jc group nil #'jabber-groupchat-join-2
 428                            (list group nickname popup))))
 429
 430 (defun jabber-groupchat-join-2 (jc closure result)
 431   (destructuring-bind (group nickname popup) closure
 432     (let ( ;; Either success...
 433           (identities (car result))
 434           (features (cadr result))
 435           ;; ...or error
 436           (condition (when (eq (car result) 'error) (jabber-error-condition result))))
 437       (cond
 438        ;; Maybe the room doesn't exist yet.
 439        ((eq condition 'item-not-found)
 440         (unless (y-or-n-p (format "%s doesn't exist.  Create it? " (jabber-jid-displayname group)))
 441           (error "Non-existent groupchat")))
 442
 443        ;; Maybe the room doesn't support disco.
 444        ((eq condition 'feature-not-implemented)
 445         t                               ;whatever...
 446         )
 447        ;; Maybe another error occurred.
 448        (condition
 449         (error "Couldn't query groupchat: %s" (jabber-parse-error result)))
 450
 451        ;; Maybe it isn't a chat room.
 452        ((not (find "conference" identities
 453                    :key (lambda (i) (aref i 1))
 454                    :test #'string=))
 455         (error "%s is not a groupchat" (jabber-jid-displayname group))))
 456
 457       (let ((password
 458              ;; Is the room password-protected?
 459              (when (member "muc_passwordprotected" features)
 460                (or
 461                 (jabber-get-conference-data jc group nil :password)
 462                 (read-passwd (format "Password for %s: " (jabber-jid-displayname group)))))))
 463
 464         (jabber-groupchat-join-3 jc group nickname password popup)))))
 465
 466 (defun jabber-groupchat-join-3 (jc group nickname password popup)
 467
 468   ;; Remember that this is a groupchat _before_ sending the stanza.
 469   ;; The response might come quicker than you think.
 470
 471   (puthash (jabber-jid-symbol group) nickname jabber-pending-groupchats)
 472
 473   (jabber-send-sexp jc
 474                     `(presence ((to . ,(format "%s/%s" group nickname)))
 475                                (x ((xmlns . "http://jabber.org/protocol/muc"))
 476                                   ,@(when password
 477                                       `((password () ,password))))
 478                                ,@(jabber-presence-children jc)))
 479
 480   ;; There, stanza sent.  Now we just wait for the MUC service to
 481   ;; mirror the stanza.  This is handled in
 482   ;; `jabber-muc-process-presence', where a buffer will be created for
 483   ;; the room.
 484
 485   ;; But if the user interactively asked to join, he/she probably
 486   ;; wants the buffer to pop up right now.
 487   (when popup
 488     (let ((buffer (jabber-muc-create-buffer jc group)))
 489       (switch-to-buffer buffer))))
 490
 491 (defun jabber-muc-read-my-nickname (jc group)
 492   "Read nickname for joining GROUP."
 493   (let ((default-nickname (or
 494                            (jabber-get-conference-data jc group nil :nick)
 495                            (cdr (assoc group jabber-muc-default-nicknames))
 496                            (plist-get (fsm-get-state-data jc) :username))))
 497     (jabber-read-with-input-method (format "Nickname: (default %s) "
 498                                            default-nickname)
 499                                    nil nil default-nickname)))
 500
 501 (add-to-list 'jabber-jid-muc-menu
 502              (cons "Change nickname" 'jabber-muc-nick))
 503
 504 (defalias 'jabber-muc-nick 'jabber-groupchat-join)
 505
 506 (add-to-list 'jabber-jid-muc-menu
 507              (cons "Leave groupchat" 'jabber-groupchat-leave))
 508
 509 (defun jabber-groupchat-leave (jc group)
 510   "leave a groupchat"
 511   (interactive (jabber-muc-argument-list))
 512   (let ((whichgroup (assoc group *jabber-active-groupchats*)))
 513     ;; send unavailable presence to our own nick in room
 514     (jabber-send-sexp jc
 515                       `(presence ((to . ,(format "%s/%s" group (cdr whichgroup)))
 516                                   (type . "unavailable"))))))
 517
 518 (add-to-list 'jabber-jid-muc-menu
 519              (cons "List participants" 'jabber-muc-names))
 520
 521 (defun jabber-muc-names ()
 522   "Print names, affiliations, and roles of participants in current buffer."
 523   (interactive)
 524   (ewoc-enter-last jabber-chat-ewoc (list :notice
 525                                           (jabber-muc-print-names
 526                                            (cdr (assoc jabber-group jabber-muc-participants)))
 527                                           :time (current-time))))
 528
 529 (defun jabber-muc-print-names (participants)
 530   "Format and return data in PARTICIPANTS."
 531   (apply 'concat "Participants:\n"
 532          (format "%-15s %-15s %-11s %s\n" "Nickname" "Role" "Affiliation" "JID")
 533          (mapcar (lambda (x)
 534                    (let ((plist (cdr x)))
 535                      (format "%-15s %-15s %-11s %s\n"
 536                              (car x)
 537                              (plist-get plist 'role)
 538                              (plist-get plist 'affiliation)
 539                              (or (plist-get plist 'jid) ""))))
 540                  participants)))
 541
 542 (add-to-list 'jabber-jid-muc-menu
 543              (cons "Set topic" 'jabber-muc-set-topic))
 544
 545 (defun jabber-muc-set-topic (jc group topic)
 546   "Set topic of GROUP to TOPIC."
 547   (interactive
 548    (jabber-muc-argument-list
 549     (list (jabber-read-with-input-method "New topic: " jabber-muc-topic))))
 550   (jabber-send-message jc group topic nil "groupchat"))
 551
 552 (defun jabber-muc-snarf-topic (xml-data)
 553   "Record subject (topic) of the given <message/>, if any."
 554   (let ((new-topic (jabber-xml-path xml-data '(subject ""))))
 555     (when new-topic
 556       (setq jabber-muc-topic new-topic))))
 557
 558 (add-to-list 'jabber-jid-muc-menu
 559              (cons "Set role (kick, voice, op)" 'jabber-muc-set-role))
 560
 561 (defun jabber-muc-set-role (jc group nickname role reason)
 562   "Set role of NICKNAME in GROUP to ROLE, specifying REASON."
 563   (interactive
 564    (jabber-muc-argument-list
 565     (let ((nickname (jabber-muc-read-nickname jabber-group "Nickname: ")))
 566       (list nickname
 567             (completing-read "New role: " '(("none") ("visitor") ("participant") ("moderator")) nil t)
 568             (read-string "Reason: ")))))
 569   (unless (or (zerop (length nickname)) (zerop (length role)))
 570     (jabber-send-iq jc group "set"
 571                     `(query ((xmlns . "http://jabber.org/protocol/muc#admin"))
 572                             (item ((nick . ,nickname)
 573                                    (role . ,role))
 574                                   ,(unless (zerop (length reason))
 575                                      `(reason () ,reason))))
 576                     'jabber-report-success "Role change"
 577                     'jabber-report-success "Role change")))
 578
 579 (add-to-list 'jabber-jid-muc-menu
 580              (cons "Set affiliation (ban, member, admin)" 'jabber-muc-set-affiliation))
 581
 582 (defun jabber-muc-set-affiliation (jc group nickname-or-jid nickname-p affiliation reason)
 583   "Set affiliation of NICKNAME-OR-JID in GROUP to AFFILIATION.
 584 If NICKNAME-P is non-nil, NICKNAME-OR-JID is a nickname in the
 585 group, else it is a JID."
 586   (interactive
 587    (jabber-muc-argument-list
 588     (let ((nickname-p (y-or-n-p "Specify user by room nickname? ")))
 589       (list
 590        (if nickname-p
 591            (jabber-muc-read-nickname jabber-group "Nickname: ")
 592          (jabber-read-jid-completing "User: "))
 593        nickname-p
 594        (completing-read "New affiliation: "
 595                         '(("none") ("outcast") ("member") ("admin") ("owner")) nil t)
 596        (read-string "Reason: ")))))
 597   (let ((jid
 598          (if nickname-p
 599              (let ((participants (cdr (assoc group jabber-muc-participants))))
 600                (unless participants
 601                  (error "Couldn't find group %s" group))
 602                (let ((participant (cdr (assoc nickname-or-jid participants))))
 603                  (unless participant
 604                    (error "Couldn't find %s in group %s" nickname-or-jid group))
 605                  (or (plist-get participant 'jid)
 606                      (error "JID of %s in group %s is unknown" nickname-or-jid group))))
 607            nickname-or-jid)))
 608     (jabber-send-iq jc group "set"
 609                     `(query ((xmlns . "http://jabber.org/protocol/muc#admin"))
 610                             (item ((jid . ,jid)
 611                                    (affiliation . ,affiliation))
 612                                   ,(unless (zerop (length reason))
 613                                      `(reason () ,reason))))
 614                     'jabber-report-success "Affiliation change"
 615                     'jabber-report-success "Affiliation change")))
 616
 617 (add-to-list 'jabber-jid-muc-menu
 618              (cons "Invite someone to chatroom" 'jabber-muc-invite))
 619
 620 (defun jabber-muc-invite (jc jid group reason)
 621   "Invite JID to GROUP, stating REASON."
 622   (interactive
 623    (list (jabber-read-account)
 624          (jabber-read-jid-completing "Invite whom: ")
 625          (jabber-muc-read-completing "To group: ")
 626          (jabber-read-with-input-method "Reason: ")))
 627   (jabber-send-sexp
 628    jc
 629    `(message ((to . ,group))
 630              (x ((xmlns . "http://jabber.org/protocol/muc#user"))
 631                 (invite ((to . ,jid))
 632                         ,(unless (zerop (length reason))
 633                            `(reason nil ,reason)))))))
 634
 635 (add-to-list 'jabber-body-printers 'jabber-muc-print-invite)
 636
 637 (defun jabber-muc-print-invite (xml-data who mode)
 638   "Print MUC invitation"
 639   (dolist (x (jabber-xml-get-children xml-data 'x))
 640     (when (string= (jabber-xml-get-attribute x 'xmlns) "http://jabber.org/protocol/muc#user")
 641       (let ((invitation (car (jabber-xml-get-children x 'invite))))
 642         (when invitation
 643           (when (eql mode :insert)
 644             (let ((group (jabber-xml-get-attribute xml-data 'from))
 645                   (inviter (jabber-xml-get-attribute invitation 'from))
 646                   (reason (car (jabber-xml-node-children (car (jabber-xml-get-children invitation 'reason))))))
 647               ;; XXX: password
 648               (insert "You have been invited to MUC room " (jabber-jid-displayname group))
 649               (when inviter
 650                 (insert " by " (jabber-jid-displayname inviter)))
 651               (insert ".")
 652               (when reason
 653                 (insert "  Reason: " reason))
 654               (insert "\n\n")
 655
 656               (let ((action
 657                      `(lambda (&rest ignore) (interactive)
 658                         (jabber-groupchat-join jabber-buffer-connection ,group
 659                                                (jabber-muc-read-my-nickname ,jabber-buffer-connection ,group)))))
 660                 (if (fboundp 'insert-button)
 661                     (insert-button "Accept"
 662                                    'action action)
 663                   ;; Simple button replacement
 664                   (let ((keymap (make-keymap)))
 665                     (define-key keymap "\r" action)
 666                     (insert (jabber-propertize "Accept"
 667                                                'keymap keymap
 668                                                'face 'highlight))))
 669
 670                 (insert "\t")
 671
 672                 (let ((action
 673                        `(lambda (&rest ignore) (interactive)
 674                           (let ((reason
 675                                  (jabber-read-with-input-method
 676                                   "Reason: ")))
 677                             (jabber-send-sexp
 678                              jabber-buffer-connection
 679                              (list 'message
 680                                    (list (cons 'to ,group))
 681                                    (list 'x
 682                                          (list (cons 'xmlns "http://jabber.org/protocol/muc#user"))
 683                                          (list 'decline
 684                                                (list (cons 'to ,inviter))
 685                                                (unless (zerop (length reason))
 686                                                  (list 'reason nil reason))))))))))
 687                   (if (fboundp 'insert-button)
 688                       (insert-button "Decline"
 689                                      'action action)
 690                     ;; Simple button replacement
 691                     (let ((keymap (make-keymap)))
 692                       (define-key keymap "\r" action)
 693                       (insert (jabber-propertize "Decline"
 694                                                  'keymap keymap
 695                                                  'face 'highlight))))))))
 696           (return t))))))
 697
 698 (defun jabber-muc-autojoin (jc)
 699   "Join rooms specified in account bookmarks and global `jabber-muc-autojoin'."
 700   (interactive (list (jabber-read-account)))
 701   (let ((nickname (plist-get (fsm-get-state-data jc) :username)))
 702     (when (bound-and-true-p jabber-muc-autojoin)
 703       (dolist (group jabber-muc-autojoin)
 704         (jabber-groupchat-join jc group (or
 705                                          (cdr (assoc group jabber-muc-default-nicknames))
 706                                          (plist-get (fsm-get-state-data jc) :username)))))
 707     (jabber-get-bookmarks
 708      jc
 709      (lambda (jc bookmarks)
 710        (dolist (bookmark bookmarks)
 711          (setq bookmark (jabber-parse-conference-bookmark bookmark))
 712          (when (and bookmark (plist-get bookmark :autojoin))
 713            (jabber-groupchat-join jc (plist-get bookmark :jid)
 714                                   (or (plist-get bookmark :nick)
 715                                       (plist-get (fsm-get-state-data jc) :username)))))))))
 716
 717 ;;;###autoload
 718 (defun jabber-muc-message-p (message)
 719   "Return non-nil if MESSAGE is a groupchat message.
 720 That does not include private messages in a groupchat, but does
 721 include groupchat invites."
 722   ;; Public groupchat messages have type "groupchat" and are from
 723   ;; room@server/nick.  Public groupchat errors have type "error" and
 724   ;; are from room@server.
 725   (let ((from (jabber-xml-get-attribute message 'from))
 726         (type (jabber-xml-get-attribute message 'type)))
 727     (or
 728      (string= type "groupchat")
 729      (and (string= type "error")
 730           (gethash (jabber-jid-symbol from) jabber-pending-groupchats))
 731      (jabber-xml-path message '(("http://jabber.org/protocol/muc#user" . "x") invite)))))
 732
 733 ;;;###autoload
 734 (defun jabber-muc-sender-p (jid)
 735   "Return non-nil if JID is a full JID of an MUC participant."
 736   (and (assoc (jabber-jid-user jid) *jabber-active-groupchats*)
 737        (jabber-jid-resource jid)))
 738
 739 ;;;###autoload
 740 (defun jabber-muc-private-message-p (message)
 741   "Return non-nil if MESSAGE is a private message in a groupchat."
 742   (let ((from (jabber-xml-get-attribute message 'from))
 743         (type (jabber-xml-get-attribute message 'type)))
 744     (and
 745      (not (string= type "groupchat"))
 746      (jabber-muc-sender-p from))))
 747
 748 (add-to-list 'jabber-jid-muc-menu
 749              (cons "Open private chat" 'jabber-muc-private))
 750
 751 (defun jabber-muc-private (jc group nickname)
 752   "Open private chat with NICKNAME in GROUP."
 753   (interactive
 754    (jabber-muc-argument-list
 755     (list (jabber-muc-read-nickname jabber-group "Nickname: "))))
 756   (switch-to-buffer (jabber-muc-private-create-buffer jabber-buffer-connection group nickname)))
 757
 758 (defun jabber-muc-presence-p (presence)
 759   "Return non-nil if PRESENCE is presence from groupchat."
 760   (let ((from (jabber-xml-get-attribute presence 'from))
 761         (type (jabber-xml-get-attribute presence 'type))
 762         (muc-marker (find-if
 763                      (lambda (x) (equal (jabber-xml-get-attribute x 'xmlns)
 764                                    "http://jabber.org/protocol/muc#user"))
 765                      (jabber-xml-get-children presence 'x))))
 766     ;; This is MUC presence if it has an MUC-namespaced tag...
 767     (or muc-marker
 768         ;; ...or if it is error presence from a room we tried to join.
 769         (and (string= type "error")
 770              (gethash (jabber-jid-symbol from) jabber-pending-groupchats)))))
 771
 772 (defun jabber-muc-parse-affiliation (x-muc)
 773   "Parse X-MUC in the muc#user namespace and return a plist.
 774 Return nil if X-MUC is nil."
 775   ;; XXX: parse <actor/> and <reason/> tags?  or maybe elsewhere?
 776   (apply 'nconc (mapcar (lambda (prop) (list (car prop) (cdr prop)))
 777                         (jabber-xml-node-attributes
 778                          (car (jabber-xml-get-children x-muc 'item))))))
 779
 780 (defun jabber-muc-print-prompt (xml-data &optional local dont-print-nick-p)
 781   "Print MUC prompt for message in XML-DATA."
 782   (let ((nick (jabber-jid-resource (jabber-xml-get-attribute xml-data 'from)))
 783         (timestamp (car (delq nil (mapcar 'jabber-x-delay (jabber-xml-get-children xml-data 'x))))))
 784     (if (stringp nick)
 785         (insert (jabber-propertize
 786                  (format-spec jabber-groupchat-prompt-format
 787                               (list
 788                                (cons ?t (format-time-string
 789                                          (if timestamp
 790                                              jabber-chat-delayed-time-format
 791                                            jabber-chat-time-format)
 792                                          timestamp))
 793                                (cons ?n (if dont-print-nick-p "" nick))
 794                                (cons ?u nick)
 795                                (cons ?r nick)
 796                                (cons ?j (concat jabber-group "/" nick))))
 797                  'face (if local 'jabber-chat-prompt-local
 798                          'jabber-chat-prompt-foreign)
 799                  'help-echo (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from " nick " in " jabber-group)))
 800       (jabber-muc-system-prompt))))
 801
 802 (defun jabber-muc-private-print-prompt (xml-data)
 803   "Print prompt for private MUC message in XML-DATA."
 804   (let ((nick (jabber-jid-resource (jabber-xml-get-attribute xml-data 'from)))
 805         (group (jabber-jid-user (jabber-xml-get-attribute xml-data 'from)))
 806         (timestamp (car (delq nil (mapcar 'jabber-x-delay (jabber-xml-get-children xml-data 'x))))))
 807     (insert (jabber-propertize
 808              (format-spec jabber-muc-private-foreign-prompt-format
 809                           (list
 810                            (cons ?t (format-time-string
 811                                      (if timestamp
 812                                          jabber-chat-delayed-time-format
 813                                        jabber-chat-time-format)
 814                                      timestamp))
 815                            (cons ?n nick)
 816                            (cons ?g (or (jabber-jid-rostername group)
 817                                         (jabber-jid-username group)))))
 818              'face 'jabber-chat-prompt-foreign
 819              'help-echo (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from " nick " in " jabber-group)))))
 820
 821 (defun jabber-muc-system-prompt (&rest ignore)
 822   "Print system prompt for MUC."
 823   (insert (jabber-propertize
 824            (format-spec jabber-groupchat-prompt-format
 825                         (list
 826                          (cons ?t (format-time-string jabber-chat-time-format))
 827                          (cons ?n "")
 828                          (cons ?u "")
 829                          (cons ?r "")
 830                          (cons ?j jabber-group)))
 831            'face 'jabber-chat-prompt-system
 832            'help-echo (format-time-string "System message on %Y-%m-%d %H:%M:%S"))))
 833
 834 (add-to-list 'jabber-message-chain 'jabber-muc-process-message)
 835
 836 (defun jabber-muc-process-message (jc xml-data)
 837   "If XML-DATA is a groupchat message, handle it as such."
 838   (when (jabber-muc-message-p xml-data)
 839     (let* ((from (jabber-xml-get-attribute xml-data 'from))
 840            (group (jabber-jid-user from))
 841            (nick (jabber-jid-resource from))
 842            (error-p (jabber-xml-get-children xml-data 'error))
 843            (type (cond
 844                   (error-p :muc-error)
 845                   ((string= nick (cdr (assoc group *jabber-active-groupchats*)))
 846                    :muc-local)
 847                   (t :muc-foreign)))
 848            (body-text (car (jabber-xml-node-children
 849                            (car (jabber-xml-get-children
 850                                  xml-data 'body)))))
 851
 852            (printers (append jabber-muc-printers jabber-chat-printers)))
 853
 854       (with-current-buffer (jabber-muc-create-buffer jc group)
 855         (jabber-muc-snarf-topic xml-data)
 856         ;; Call alert hooks only when something is output
 857         (when (or error-p
 858                   (run-hook-with-args-until-success 'printers xml-data type :printp))
 859           (jabber-maybe-print-rare-time
 860            (ewoc-enter-last jabber-chat-ewoc (list type xml-data :time (current-time))))
 861
 862           ;; ...except if the message is part of history, in which
 863           ;; case we don't want an alert.
 864           (let ((children-namespaces (mapcar (lambda (x) (when (listp x) (jabber-xml-get-attribute x 'xmlns)))
 865                                              (jabber-xml-node-children xml-data))))
 866             (unless (or (member "urn:xmpp:delay" children-namespaces)
 867                         (member "jabber:x:delay" children-namespaces))
 868               (dolist (hook '(jabber-muc-hooks jabber-alert-muc-hooks))
 869                 (run-hook-with-args hook
 870                                     nick group (current-buffer) body-text
 871                                     (funcall jabber-alert-muc-function
 872                                              nick group (current-buffer) body-text))))))))))
 873
 874 (defun jabber-muc-process-presence (jc presence)
 875   (let* ((from (jabber-xml-get-attribute presence 'from))
 876          (type (jabber-xml-get-attribute presence 'type))
 877          (x-muc (find-if
 878                  (lambda (x) (equal (jabber-xml-get-attribute x 'xmlns)
 879                                "http://jabber.org/protocol/muc#user"))
 880                  (jabber-xml-get-children presence 'x)))
 881          (group (jabber-jid-user from))
 882          (nickname (jabber-jid-resource from))
 883          (symbol (jabber-jid-symbol from))
 884          (item (car (jabber-xml-get-children x-muc 'item)))
 885          (actor (jabber-xml-get-attribute (car (jabber-xml-get-children item 'actor)) 'jid))
 886          (reason (car (jabber-xml-node-children (car (jabber-xml-get-children item 'reason)))))
 887          (error-node (car (jabber-xml-get-children presence 'error)))
 888          (status-code (if error-node
 889                           (jabber-xml-get-attribute error-node 'code)
 890                         (jabber-xml-get-attribute (car (jabber-xml-get-children x-muc 'status)) 'code))))
 891     ;; handle leaving a room
 892     (cond
 893      ((or (string= type "unavailable") (string= type "error"))
 894       ;; error from room itself? or are we leaving?
 895       (if (or (null nickname)
 896               (string= nickname (gethash (jabber-jid-symbol group) jabber-pending-groupchats)))
 897           ;; Assume that an error means that we were thrown out of the
 898           ;; room...
 899           (let* ((leavingp t)
 900                  (message (cond
 901                            ((string= type "error")
 902                             (cond
 903                              ;; ...except for certain cases.
 904                              ((or (equal status-code "406")
 905                                   (equal status-code "409"))
 906                               (setq leavingp nil)
 907                               (concat "Nickname change not allowed"
 908                                       (when error-node
 909                                         (concat ": " (jabber-parse-error error-node)))))
 910                              (t
 911                               (concat "Error entering room"
 912                                       (when error-node
 913                                         (concat ": " (jabber-parse-error error-node)))))))
 914                            ((equal status-code "301")
 915                             (concat "You have been banned"
 916                                     (when actor (concat " by " actor))
 917                                     (when reason (concat " - '" reason "'"))))
 918                            ((equal status-code "307")
 919                             (concat "You have been kicked"
 920                                     (when actor (concat " by " actor))
 921                                     (when reason (concat " - '" reason "'"))))
 922                            (t
 923                             "You have left the chatroom"))))
 924             (when leavingp
 925               (jabber-muc-remove-groupchat group))
 926             ;; If there is no buffer for this groupchat, don't bother
 927             ;; creating one just to tell that user left the room.
 928             (let ((buffer (get-buffer (jabber-muc-get-buffer group))))
 929               (if buffer
 930                   (with-current-buffer buffer
 931                     (jabber-maybe-print-rare-time
 932                      (ewoc-enter-last jabber-chat-ewoc
 933                                       (list (if (string= type "error")
 934                                                 :muc-error
 935                                               :muc-notice)
 936                                             message
 937                                             :time (current-time)))))
 938                 (message "%s: %s" (jabber-jid-displayname group) message))))
 939         ;; or someone else?
 940         (let* ((plist (jabber-muc-participant-plist group nickname))
 941                (jid (plist-get plist 'jid))
 942                (name (concat nickname
 943                              (when jid
 944                                (concat " <"
 945                                        (jabber-jid-user jid)
 946                                        ">")))))
 947           (jabber-muc-remove-participant group nickname)
 948           (with-current-buffer (jabber-muc-create-buffer jc group)
 949             (jabber-maybe-print-rare-time
 950              (ewoc-enter-last
 951               jabber-chat-ewoc
 952               (list :muc-notice
 953                     (cond
 954                      ((equal status-code "301")
 955                       (concat name " has been banned"
 956                               (when actor (concat " by " actor))
 957                               (when reason (concat " - '" reason "'"))))
 958                      ((equal status-code "307")
 959                       (concat name " has been kicked"
 960                               (when actor (concat " by " actor))
 961                               (when reason (concat " - '" reason "'"))))
 962                      ((equal status-code "303")
 963                       (concat name " changes nickname to "
 964                               (jabber-xml-get-attribute item 'nick)))
 965                      (t
 966                       (concat name " has left the chatroom")))
 967                     :time (current-time))))))))
 968      (t
 969       ;; someone is entering
 970
 971       (when (string= nickname (gethash (jabber-jid-symbol group) jabber-pending-groupchats))
 972         ;; Our own nick?  We just succeeded in entering the room.
 973         (let ((whichgroup (assoc group *jabber-active-groupchats*)))
 974           (if whichgroup
 975               (setcdr whichgroup nickname)
 976             (add-to-list '*jabber-active-groupchats* (cons group nickname)))))
 977
 978       ;; Whoever enters, we create a buffer (if it didn't already
 979       ;; exist), and print a notice.  This is where autojoined MUC
 980       ;; rooms have buffers created for them.  We also remember some
 981       ;; metadata.
 982       (let ((old-plist (jabber-muc-participant-plist group nickname))
 983             (new-plist (jabber-muc-parse-affiliation x-muc)))
 984         (jabber-muc-modify-participant group nickname new-plist)
 985         (let ((report (jabber-muc-report-delta nickname old-plist new-plist
 986                                                reason actor)))
 987           (when report
 988             (with-current-buffer (jabber-muc-create-buffer jc group)
 989               (jabber-maybe-print-rare-time
 990                (ewoc-enter-last
 991                 jabber-chat-ewoc
 992                 (list :muc-notice report
 993                       :time (current-time))))))))))))
 994
 995 (provide 'jabber-muc)
 996
 997 ;;; arch-tag: 1ff7ab35-1717-46ae-b803-6f5b3fb2cd7d