jabber-core.el

   1 ;; jabber-core.el - core 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 ;; SSL-Connection Parts:
   7 ;; Copyright (C) 2005 - Georg Lehner - jorge@magma.com.ni
   8
   9 ;; This file is a part of jabber.el.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program; if not, write to the Free Software
  23 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  24
  25 (require 'cl)
  26
  27 (require 'jabber-util)
  28 (require 'jabber-logon)
  29 (require 'jabber-conn)
  30 (require 'fsm)
  31
  32 (require 'jabber-sasl)
  33 (require 'jabber-console)
  34
  35 (defvar jabber-connections nil
  36   "List of jabber-connection FSMs.")
  37
  38 (defvar *jabber-roster* nil
  39   "the roster list")
  40
  41 (defvar jabber-jid-obarray (make-vector 127 0)
  42   "obarray for keeping JIDs")
  43
  44 (defvar *jabber-connected* nil
  45   "boolean - are we connected")
  46
  47 (defvar *jabber-authenticated* nil
  48   "boolean - are we authenticated")
  49
  50 (defvar *jabber-disconnecting* nil
  51   "boolean - are we in the process of disconnecting by free will")
  52
  53 (defvar jabber-message-chain nil
  54   "Incoming messages are sent to these functions, in order.")
  55
  56 (defvar jabber-iq-chain nil
  57   "Incoming infoqueries are sent to these functions, in order.")
  58
  59 (defvar jabber-presence-chain nil
  60   "Incoming presence notifications are sent to these functions, in order.")
  61
  62 (defvar jabber-choked-count 0
  63   "Number of successive times that the process buffer has been nonempty.")
  64
  65 (defvar jabber-choked-timer nil)
  66
  67 (defgroup jabber-core nil "customize core functionality"
  68   :group 'jabber)
  69
  70 (defcustom jabber-post-connect-hooks '(jabber-send-current-presence
  71                                        jabber-muc-autojoin
  72                                        jabber-whitespace-ping-start
  73                                        jabber-vcard-avatars-find-current)
  74   "*Hooks run after successful connection and authentication.
  75 The functions should accept one argument, the connection object."
  76   :type 'hook
  77   :options '(jabber-send-current-presence
  78              jabber-muc-autojoin
  79              jabber-whitespace-ping-start
  80              jabber-keepalive-start
  81              jabber-vcard-avatars-find-current
  82              jabber-autoaway-start)
  83   :group 'jabber-core)
  84
  85 (defcustom jabber-pre-disconnect-hook nil
  86   "*Hooks run just before voluntary disconnection
  87 This might be due to failed authentication.  Check `*jabber-authenticated*'."
  88   :type 'hook
  89   :group 'jabber-core)
  90
  91 (defcustom jabber-lost-connection-hooks nil
  92   "*Hooks run after involuntary disconnection.
  93 The functions are called with one argument: the connection object."
  94   :type 'hook
  95   :group 'jabber-core)
  96
  97 (defcustom jabber-post-disconnect-hook nil
  98   "*Hooks run after disconnection"
  99   :type 'hook
 100   :group 'jabber-core)
 101
 102 (defcustom jabber-auto-reconnect nil
 103   "Reconnect automatically after losing connection?
 104 This will be of limited use unless you have the password library
 105 installed, and have configured it to cache your password
 106 indefinitely.  See `password-cache' and `password-cache-expiry'."
 107   :type 'boolean
 108   :group 'jabber-core)
 109
 110 (defcustom jabber-reconnect-delay 5
 111   "Seconds to wait before reconnecting"
 112   :type 'integer
 113   :group 'jabber-core)
 114
 115 (defcustom jabber-roster-buffer "*-jabber-roster-*"
 116   "The name of the roster buffer"
 117   :type 'string
 118   :group 'jabber-core)
 119
 120 (defvar jabber-process-buffer " *-jabber-process-*"
 121   "The name of the process buffer")
 122
 123 (defcustom jabber-use-sasl t
 124   "If non-nil, use SASL if possible.
 125 SASL will still not be used if the library for it is missing or
 126 if the server doesn't support it.
 127
 128 Disabling this shouldn't be necessary, but it may solve certain
 129 problems."
 130   :type 'boolean
 131   :group 'jabber-core)
 132
 133 (defsubst jabber-have-sasl-p ()
 134   "Return non-nil if SASL functions are available."
 135   (featurep 'sasl))
 136
 137 (defvar jabber-account-history ()
 138   "Keeps track of previously used jabber accounts")
 139
 140 (defvar jabber-connection-type-history ()
 141   "Keeps track of previously used connection types")
 142
 143 ;; jabber-connect and jabber-connect-all should load jabber.el, not
 144 ;; just jabber-core.el, when autoloaded.
 145
 146 ;;;###autoload (autoload 'jabber-connect-all "jabber" "Connect to all configured Jabber accounts.\nSee `jabber-account-list'.\nIf no accounts are configured (or ARG supplied), call `jabber-connect' interactively." t)
 147 (defun jabber-connect-all (&optional arg)
 148   "Connect to all configured Jabber accounts.
 149 See `jabber-account-list'.
 150 If no accounts are configured (or with prefix argument), call `jabber-connect' interactively.
 151 With many prefix arguments, one less is passed to `jabber-connect'."
 152   (interactive "P")
 153   (let ((accounts
 154          (remove-if (lambda (account)
 155                       (cdr (assq :disabled (cdr account))))
 156                     jabber-account-list)))
 157     (if (or (null accounts) arg)
 158         (let ((current-prefix-arg
 159                (cond
 160                 ;; A number of C-u's; remove one, so to speak.
 161                 ((consp arg)
 162                  (if (> (car arg) 4)
 163                      (list (/ (car arg) 4))
 164                    nil))
 165                 ;; Otherwise, we just don't care.
 166                 (t
 167                  arg))))
 168           (call-interactively 'jabber-connect))
 169       ;; Only connect those accounts that are not yet connected.
 170       (let ((already-connected (mapcar #'jabber-connection-bare-jid jabber-connections))
 171             (connected-one nil))
 172         (dolist (account accounts)
 173           (unless (member (jabber-jid-user (car account)) already-connected)
 174             (let* ((jid (car account))
 175                    (alist (cdr account))
 176                    (password (cdr (assq :password alist)))
 177                    (network-server (cdr (assq :network-server alist)))
 178                    (port (cdr (assq :port alist)))
 179                    (connection-type (cdr (assq :connection-type alist))))
 180               (jabber-connect
 181                (jabber-jid-username jid)
 182                (jabber-jid-server jid)
 183                (jabber-jid-resource jid)
 184                nil password network-server
 185                port connection-type))))))))
 186
 187 ;;;###autoload (autoload 'jabber-connect "jabber" "Connect to the Jabber server and start a Jabber XML stream.\nWith prefix argument, register a new account.\nWith double prefix argument, specify more connection details." t)
 188 (defun jabber-connect (username server resource &optional
 189                                 registerp password network-server
 190                                 port connection-type)
 191   "Connect to the Jabber server and start a Jabber XML stream.
 192 With prefix argument, register a new account.
 193 With double prefix argument, specify more connection details."
 194   (interactive
 195    (let* ((jid (completing-read "Enter your JID: " jabber-account-list nil nil nil 'jabber-account-history))
 196           (entry (assoc jid jabber-account-list))
 197           (alist (cdr entry))
 198           password network-server port connection-type registerp)
 199      (flet ((nonempty
 200              (s)
 201              (unless (zerop (length s)) s)))
 202        (when entry
 203          ;; If the user entered the JID of one of the preconfigured
 204          ;; accounts, use that data.
 205          (setq password (cdr (assq :password alist)))
 206          (setq network-server (cdr (assq :network-server alist)))
 207          (setq port (cdr (assq :port alist)))
 208          (setq connection-type (cdr (assq :connection-type alist))))
 209        (when (equal current-prefix-arg '(16))
 210          ;; Double prefix arg: ask about everything.
 211          ;; (except password, which is asked about later anyway)
 212          (setq password nil)
 213          (setq network-server
 214                (read-string (format "Network server: (default `%s') " network-server)
 215                             nil nil network-server))
 216          (when (zerop (length network-server))
 217            (setq network-server nil))
 218          (setq port
 219                (car
 220                 (read-from-string
 221                  (read-string (format "Port: (default `%s') " port)
 222                               nil nil (if port (number-to-string port) "nil")))))
 223          (setq connection-type
 224                (car
 225                 (read-from-string
 226                  (let ((default (symbol-name (or connection-type jabber-default-connection-type))))
 227                    (completing-read
 228                     (format "Connection type: (default `%s') " default)
 229                     (mapcar (lambda (type)
 230                               (cons (symbol-name (car type)) nil))
 231                             jabber-connect-methods)
 232                     nil t nil 'jabber-connection-type-history default)))))
 233          (setq registerp (or jabber-silent-mode (yes-or-no-p "Register new account? "))))
 234        (when (equal current-prefix-arg '(4))
 235          (setq registerp t))
 236
 237        (list (jabber-jid-username jid)
 238              (jabber-jid-server jid)
 239              (jabber-jid-resource jid)
 240              registerp password network-server port connection-type))))
 241
 242   (require 'jabber)
 243
 244   (if (member (list username
 245                     server)
 246               (mapcar
 247                (lambda (c)
 248                  (let ((data (fsm-get-state-data c)))
 249                    (list (plist-get data :username)
 250                          (plist-get data :server))))
 251                jabber-connections))
 252       (message "Already connected to %s@%s"
 253                username server)
 254     (setq *jabber-authenticated* nil)
 255     ;;(jabber-clear-roster)
 256     (jabber-reset-choked)
 257
 258     (push (start-jabber-connection username server resource
 259                                    registerp password
 260                                    network-server port connection-type)
 261           jabber-connections)))
 262
 263 (define-state-machine jabber-connection
 264   :start ((username server resource registerp password network-server port connection-type)
 265           "Start a Jabber connection."
 266           (let* ((connection-type
 267                   (or connection-type jabber-default-connection-type))
 268                  (send-function
 269                   (jabber-get-send-function connection-type)))
 270
 271             (list :connecting
 272                   (list :send-function send-function
 273                         :username username
 274                         :server server
 275                         :resource resource
 276                         :password password
 277                         :registerp registerp
 278                         :connection-type connection-type
 279                         :encrypted (eq connection-type 'ssl)
 280                         :network-server network-server
 281                         :port port)))))
 282
 283 (define-enter-state jabber-connection nil
 284   (fsm state-data)
 285   ;; `nil' is the error state.
 286
 287   ;; Close the network connection.
 288   (let ((connection (plist-get state-data :connection)))
 289     (when (processp connection)
 290       (let ((process-buffer (process-buffer connection)))
 291         (delete-process connection)
 292         (when (and (bufferp process-buffer)
 293                    (not jabber-debug-keep-process-buffers))
 294           (kill-buffer process-buffer)))))
 295   (setq state-data (plist-put state-data :connection nil))
 296   ;; Remove lost connections from the roster buffer.
 297   (jabber-display-roster)
 298   (let ((expected (plist-get state-data :disconnection-expected))
 299         (reason (plist-get state-data :disconnection-reason))
 300         (ever-session-established (plist-get state-data :ever-session-established)))
 301     (unless expected
 302       (run-hook-with-args 'jabber-lost-connection-hooks fsm)
 303       (message "%s@%s/%s: connection lost: `%s'"
 304                (plist-get state-data :username)
 305                (plist-get state-data :server)
 306                (plist-get state-data :resource)
 307                reason))
 308
 309     (if (and jabber-auto-reconnect (not expected) ever-session-established)
 310         ;; Reconnect after a short delay?
 311         (list state-data jabber-reconnect-delay)
 312       ;; Else the connection is really dead.  Remove it from the list
 313       ;; of connections.
 314       (setq jabber-connections
 315             (delq fsm jabber-connections))
 316       (when jabber-mode-line-mode
 317         (jabber-mode-line-presence-update))
 318       (jabber-display-roster)
 319       ;; And let the FSM sleep...
 320       (list state-data nil))))
 321
 322 (define-state jabber-connection nil
 323   (fsm state-data event callback)
 324   ;; In the `nil' state, the connection is dead.  We wait for a
 325   ;; :timeout message, meaning to reconnect, or :do-disconnect,
 326   ;; meaning to cancel reconnection.
 327   (case event
 328     (:timeout
 329      (list :connecting state-data))
 330     (:do-disconnect
 331      (setq jabber-connections
 332             (delq fsm jabber-connections))
 333      (list nil state-data nil))))
 334
 335 (define-enter-state jabber-connection :connecting
 336   (fsm state-data)
 337   (let* ((connection-type (plist-get state-data :connection-type))
 338          (connect-function (jabber-get-connect-function connection-type))
 339          (server (plist-get state-data :server))
 340          (network-server (plist-get state-data :network-server))
 341          (port (plist-get state-data :port)))
 342     (funcall connect-function fsm server network-server port))
 343   (list state-data nil))
 344
 345 (define-state jabber-connection :connecting
 346   (fsm state-data event callback)
 347   (case (or (car-safe event) event)
 348     (:connected
 349      (let ((connection (cadr event))
 350            (registerp (plist-get state-data :registerp)))
 351
 352        (setq state-data (plist-put state-data :connection connection))
 353
 354        (when (processp connection)
 355          ;; TLS connections leave data in the process buffer, which
 356          ;; the XML parser will choke on.
 357          (with-current-buffer (process-buffer connection)
 358            (erase-buffer))
 359
 360          (set-process-filter connection (fsm-make-filter fsm))
 361          (set-process-sentinel connection (fsm-make-sentinel fsm)))
 362
 363        (list :connected state-data)))
 364
 365     (:connection-failed
 366      (message "Jabber connection failed")
 367      (list nil state-data))
 368
 369     (:do-disconnect
 370      ;; We don't have the connection object, so defer the disconnection.
 371      :defer)))
 372
 373 (defsubst jabber-fsm-handle-sentinel (state-data event)
 374   "Handle sentinel event for jabber fsm."
 375   ;; We do the same thing for every state, so avoid code duplication.
 376   (let* ((string (car (cddr event)))
 377          (new-state-data
 378           ;; If we already know the reason (e.g. a stream error), don't
 379           ;; overwrite it.
 380           (if (plist-get state-data :disconnection-reason)
 381               state-data
 382             (plist-put state-data :disconnection-reason string))))
 383     (list nil new-state-data)))
 384
 385 (define-enter-state jabber-connection :connected
 386   (fsm state-data)
 387
 388   (jabber-send-stream-header fsm)
 389
 390   ;; XXX: Update to multiaccount?  Remove?
 391   ;; (setq jabber-choked-timer
 392   ;;    (run-with-timer 5 5 #'jabber-check-choked))
 393
 394   ;;XXX: why is this here?  I'll try commenting it out...
 395   ;;(accept-process-output *jabber-connection*)
 396
 397   ;; Next thing happening is the server sending its own <stream:stream> start tag.
 398
 399   (setq *jabber-connected* t)
 400   (list state-data nil))
 401
 402 (define-state jabber-connection :connected
 403   (fsm state-data event callback)
 404   (case (or (car-safe event) event)
 405     (:filter
 406      (let ((process (cadr event))
 407            (string (car (cddr event))))
 408        (jabber-pre-filter process string fsm)
 409        (list :connected state-data)))
 410
 411     (:sentinel
 412      (jabber-fsm-handle-sentinel state-data event))
 413
 414     (:stream-start
 415      (let ((session-id (cadr event))
 416            (stream-version (car (cddr event))))
 417        (setq state-data
 418              (plist-put state-data :session-id session-id))
 419        ;; the stream feature is only sent if the initiating entity has
 420        ;; sent 1.0 in the stream header. if sasl is not supported then
 421        ;; we don't send 1.0 in the header and therefore we shouldn't wait
 422        ;; even if 1.0 is present in the receiving stream.
 423        (cond
 424         ;; Wait for stream features?
 425         ((and stream-version
 426               (>= (string-to-number stream-version) 1.0)
 427               jabber-use-sasl
 428               (jabber-have-sasl-p))
 429          ;; Stay in same state...
 430          (list :connected state-data))
 431         ;; Register account?
 432         ((plist-get state-data :registerp)
 433          ;; XXX: require encryption for registration?
 434          (list :register-account state-data))
 435         ;; Legacy authentication?
 436         (t
 437          (list :legacy-auth state-data)))))
 438
 439     (:stanza
 440      (let ((stanza (cadr event)))
 441        (cond
 442         ;; At this stage, we only expect a stream:features stanza.
 443         ((not (eq (jabber-xml-node-name stanza) 'stream:features))
 444          (list nil (plist-put state-data
 445                               :disconnection-reason
 446                               (format "Unexpected stanza %s" stanza))))
 447         ((and (jabber-xml-get-children stanza 'starttls)
 448               (eq (plist-get state-data :connection-type) 'starttls))
 449          (list :starttls state-data))
 450         ;; XXX: require encryption for registration?
 451         ((plist-get state-data :registerp)
 452          ;; We could check for the <register/> element in stream
 453          ;; features, but as a client we would only lose by doing
 454          ;; that.
 455          (list :register-account state-data))
 456         (t
 457          (list :sasl-auth (plist-put state-data :stream-features stanza))))))
 458
 459     (:do-disconnect
 460      (jabber-send-string fsm "</stream:stream>")
 461      (list nil (plist-put state-data
 462                           :disconnection-expected t)))))
 463
 464 (define-enter-state jabber-connection :starttls
 465   (fsm state-data)
 466   (jabber-starttls-initiate fsm)
 467   (list state-data nil))
 468
 469 (define-state jabber-connection :starttls
 470   (fsm state-data event callback)
 471   (case (or (car-safe event) event)
 472     (:filter
 473      (let ((process (cadr event))
 474            (string (car (cddr event))))
 475        (jabber-pre-filter process string fsm)
 476        (list :starttls state-data)))
 477
 478     (:sentinel
 479      (jabber-fsm-handle-sentinel state-data event))
 480
 481     (:stanza
 482      (if (jabber-starttls-process-input fsm (cadr event))
 483          ;; Connection is encrypted.  Send a stream tag again.
 484          (list :connected (plist-put state-data :encrypted t))
 485        (message "STARTTLS negotiation failed")
 486        (list nil state-data)))
 487
 488     (:do-disconnect
 489      (jabber-send-string fsm "</stream:stream>")
 490      (list nil (plist-put state-data
 491                           :disconnection-expected t)))))
 492
 493 (define-enter-state jabber-connection :register-account
 494   (fsm state-data)
 495   (jabber-get-register fsm nil)
 496   (list state-data nil))
 497
 498 (define-state jabber-connection :register-account
 499   (fsm state-data event callback)
 500   ;; The connection will be closed in jabber-register
 501   (case (or (car-safe event) event)
 502     (:filter
 503      (let ((process (cadr event))
 504            (string (car (cddr event))))
 505        (jabber-pre-filter process string fsm)
 506        (list :register-account state-data)))
 507
 508     (:sentinel
 509      (jabber-fsm-handle-sentinel state-data event))
 510
 511     (:stanza
 512      (or
 513       (jabber-process-stream-error (cadr event) state-data)
 514       (progn
 515         (jabber-process-input fsm (cadr event))
 516         (list :register-account state-data))))
 517
 518     (:do-disconnect
 519      (jabber-send-string fsm "</stream:stream>")
 520      (list nil (plist-put state-data
 521                           :disconnection-expected t)))))
 522
 523 (define-enter-state jabber-connection :legacy-auth
 524   (fsm state-data)
 525   (jabber-get-auth fsm (plist-get state-data :server)
 526                    (plist-get state-data :session-id))
 527   (list state-data nil))
 528
 529 (define-state jabber-connection :legacy-auth
 530   (fsm state-data event callback)
 531   (case (or (car-safe event) event)
 532     (:filter
 533      (let ((process (cadr event))
 534            (string (car (cddr event))))
 535        (jabber-pre-filter process string fsm)
 536        (list :legacy-auth state-data)))
 537
 538     (:sentinel
 539      (jabber-fsm-handle-sentinel state-data event))
 540
 541     (:stanza
 542      (or
 543       (jabber-process-stream-error (cadr event) state-data)
 544       (progn
 545         (jabber-process-input fsm (cadr event))
 546         (list :legacy-auth state-data))))
 547
 548     (:authentication-success
 549      (jabber-cache-password (jabber-connection-bare-jid fsm) (cdr event))
 550      (list :session-established state-data))
 551
 552     (:authentication-failure
 553      (jabber-uncache-password (jabber-connection-bare-jid fsm))
 554      ;; jabber-logon has already displayed a message
 555      (list nil (plist-put state-data
 556                           :disconnection-expected t)))
 557
 558     (:do-disconnect
 559      (jabber-send-string fsm "</stream:stream>")
 560      (list nil (plist-put state-data
 561                           :disconnection-expected t)))))
 562
 563 (define-enter-state jabber-connection :sasl-auth
 564   (fsm state-data)
 565   (let ((new-state-data
 566          (plist-put state-data
 567                     :sasl-data
 568                     (jabber-sasl-start-auth
 569                      fsm
 570                      (plist-get state-data
 571                                 :stream-features)))))
 572     (list new-state-data nil)))
 573
 574 (define-state jabber-connection :sasl-auth
 575   (fsm state-data event callback)
 576   (case (or (car-safe event) event)
 577     (:filter
 578      (let ((process (cadr event))
 579            (string (car (cddr event))))
 580        (jabber-pre-filter process string fsm)
 581        (list :sasl-auth state-data)))
 582
 583     (:sentinel
 584      (jabber-fsm-handle-sentinel state-data event))
 585
 586     (:stanza
 587      (let ((new-sasl-data
 588             (jabber-sasl-process-input
 589              fsm (cadr event)
 590              (plist-get state-data :sasl-data))))
 591        (list :sasl-auth (plist-put state-data :sasl-data new-sasl-data))))
 592
 593     (:use-legacy-auth-instead
 594      (list :legacy-auth (plist-put state-data :sasl-data nil)))
 595
 596     (:authentication-success
 597      (jabber-cache-password (jabber-connection-bare-jid fsm) (cdr event))
 598      (list :bind (plist-put state-data :sasl-data nil)))
 599
 600     (:authentication-failure
 601      (jabber-uncache-password (jabber-connection-bare-jid fsm))
 602      ;; jabber-sasl has already displayed a message
 603      (list nil (plist-put state-data
 604                           :disconnection-expected t)))
 605
 606     (:do-disconnect
 607      (jabber-send-string fsm "</stream:stream>")
 608      (list nil (plist-put state-data
 609                           :disconnection-expected t)))))
 610
 611 (define-enter-state jabber-connection :bind
 612   (fsm state-data)
 613   (jabber-send-stream-header fsm)
 614   (list state-data nil))
 615
 616 (define-state jabber-connection :bind
 617   (fsm state-data event callback)
 618   (case (or (car-safe event) event)
 619     (:filter
 620      (let ((process (cadr event))
 621            (string (car (cddr event))))
 622        (jabber-pre-filter process string fsm)
 623        (list :bind state-data)))
 624
 625     (:sentinel
 626      (jabber-fsm-handle-sentinel state-data event))
 627
 628     (:stream-start
 629      ;; we wait for stream features...
 630      (list :bind state-data))
 631
 632     (:stanza
 633      (let ((stanza (cadr event)))
 634        (cond
 635         ((eq (jabber-xml-node-name stanza) 'stream:features)
 636          (if (and (jabber-xml-get-children stanza 'bind)
 637                   (jabber-xml-get-children stanza 'session))
 638              (labels
 639                  ((handle-bind
 640                    (jc xml-data success)
 641                    (fsm-send jc (list
 642                                  (if success :bind-success :bind-failure)
 643                                  xml-data))))
 644                ;; So let's bind a resource.  We can either pick a resource ourselves,
 645                ;; or have the server pick one for us.
 646                (let ((resource (plist-get state-data :resource)))
 647                  (jabber-send-iq fsm nil "set"
 648                                  `(bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind"))
 649                                         ,@(when resource
 650                                             `((resource () ,resource))))
 651                                  #'handle-bind t
 652                                  #'handle-bind nil))
 653                (list :bind state-data))
 654            (message "Server doesn't permit resource binding and session establishing")
 655            (list nil state-data)))
 656         (t
 657          (or
 658           (jabber-process-stream-error (cadr event) state-data)
 659           (progn
 660             (jabber-process-input fsm (cadr event))
 661             (list :bind state-data)))))))
 662
 663     (:bind-success
 664      (let ((jid (jabber-xml-path (cadr event) '(bind jid ""))))
 665        ;; Maybe this isn't the JID we asked for.
 666        (plist-put state-data :username (jabber-jid-username jid))
 667        (plist-put state-data :server (jabber-jid-server jid))
 668        (plist-put state-data :resource (jabber-jid-resource jid)))
 669
 670      ;; Been there, done that.  Time to establish a session.
 671      (labels
 672          ((handle-session
 673            (jc xml-data success)
 674            (fsm-send jc (list
 675                          (if success :session-success :session-failure)
 676                          xml-data))))
 677        (jabber-send-iq fsm nil "set"
 678                        '(session ((xmlns . "urn:ietf:params:xml:ns:xmpp-session")))
 679                        #'handle-session t
 680                        #'handle-session nil)
 681        (list :bind state-data)))
 682
 683     (:session-success
 684      ;; We have a session
 685      (list :session-established state-data))
 686
 687     (:bind-failure
 688      (message "Resource binding failed: %s"
 689               (jabber-parse-error
 690                (jabber-iq-error (cadr event))))
 691      (list nil state-data))
 692
 693     (:session-failure
 694      (message "Session establishing failed: %s"
 695               (jabber-parse-error
 696                (jabber-iq-error (cadr event))))
 697      (list nil state-data))
 698
 699     (:do-disconnect
 700      (jabber-send-string fsm "</stream:stream>")
 701      (list nil (plist-put state-data
 702                           :disconnection-expected t)))))
 703
 704 (define-enter-state jabber-connection :session-established
 705   (fsm state-data)
 706   (jabber-send-iq fsm nil
 707                   "get"
 708                   '(query ((xmlns . "jabber:iq:roster")))
 709                   #'jabber-process-roster 'initial
 710                   #'jabber-report-success "Roster retrieval")
 711   (list (plist-put state-data :ever-session-established t) nil))
 712
 713 (defvar jabber-pending-presence-timeout 0.5
 714   "Wait this long before doing presence packet batch processing.")
 715
 716 (define-state jabber-connection :session-established
 717   (fsm state-data event callback)
 718   (case (or (car-safe event) event)
 719     (:filter
 720      (let ((process (cadr event))
 721            (string (car (cddr event))))
 722        (jabber-pre-filter process string fsm)
 723        (list :session-established state-data :keep)))
 724
 725     (:sentinel
 726      (jabber-fsm-handle-sentinel state-data event))
 727
 728     (:stanza
 729      (or
 730       (jabber-process-stream-error (cadr event) state-data)
 731       (progn
 732         (jabber-process-input fsm (cadr event))
 733         (list :session-established state-data :keep))))
 734
 735     (:roster-update
 736      ;; Batch up roster updates
 737      (let* ((jid-symbol-to-update (cdr event))
 738             (pending-updates (plist-get state-data :roster-pending-updates)))
 739        ;; If there are pending updates, there is a timer running
 740        ;; already; just add the new symbol and wait.
 741        (if pending-updates
 742            (progn
 743              (unless (memq jid-symbol-to-update pending-updates)
 744                (nconc pending-updates (list jid-symbol-to-update)))
 745              (list :session-established state-data :keep))
 746          ;; Otherwise, we need to create the list and start the timer.
 747          (setq state-data
 748                (plist-put state-data
 749                           :roster-pending-updates
 750                           (list jid-symbol-to-update)))
 751          (list :session-established state-data jabber-pending-presence-timeout))))
 752
 753     (:timeout
 754      ;; Update roster
 755      (let ((pending-updates (plist-get state-data :roster-pending-updates)))
 756        (setq state-data (plist-put state-data :roster-pending-updates nil))
 757        (jabber-roster-update fsm nil pending-updates nil)
 758        (list :session-established state-data)))
 759
 760     (:send-if-connected
 761      ;; This is the only state in which we respond to such messages.
 762      ;; This is to make sure we don't send anything inappropriate
 763      ;; during authentication etc.
 764      (jabber-send-sexp fsm (cdr event))
 765      (list :session-established state-data :keep))
 766
 767     (:do-disconnect
 768      (jabber-send-string fsm "</stream:stream>")
 769      (list nil (plist-put state-data
 770                           :disconnection-expected t)))))
 771
 772 (defun jabber-disconnect (&optional arg)
 773   "Disconnect from all Jabber servers. If ARG supplied, disconnect one account."
 774   (interactive "P")
 775   (if arg
 776       (jabber-disconnect-one (jabber-read-account))
 777     (unless *jabber-disconnecting*      ; avoid reentry
 778       (let ((*jabber-disconnecting* t))
 779         (run-hooks 'jabber-pre-disconnect-hook)
 780         (dolist (c jabber-connections)
 781           (jabber-disconnect-one c t))
 782         (setq jabber-connections nil)
 783
 784         (jabber-disconnected)
 785         (when (interactive-p)
 786           (message "Disconnected from Jabber server(s)"))))))
 787
 788 (defun jabber-disconnect-one (jc &optional dont-redisplay)
 789   "Disconnect from one Jabber server.
 790 If DONT-REDISPLAY is non-nil, don't update roster buffer."
 791   (interactive (list (jabber-read-account)))
 792   (fsm-send-sync jc :do-disconnect)
 793   (when (interactive-p)
 794     (message "Disconnected from %s"
 795              (jabber-connection-jid jc)))
 796   (unless dont-redisplay
 797     (jabber-display-roster)))
 798
 799 (defun jabber-disconnected ()
 800   "Re-initialise jabber package variables.
 801 Call this function after disconnection."
 802   (when jabber-choked-timer
 803     (jabber-cancel-timer jabber-choked-timer)
 804     (setq jabber-choked-timer nil))
 805
 806   (when (get-buffer jabber-roster-buffer)
 807     (with-current-buffer (get-buffer jabber-roster-buffer)
 808       (let ((inhibit-read-only t))
 809         (erase-buffer))))
 810
 811   (setq *jabber-connection* nil)
 812   (jabber-clear-roster)
 813   (setq *jabber-authenticated* nil)
 814   (setq *jabber-connected* nil)
 815   (setq *jabber-active-groupchats* nil)
 816   (run-hooks 'jabber-post-disconnect-hook))
 817
 818 (defun jabber-log-xml (fsm direction data)
 819   "Print DATA to XML console (and, optionally, in file).
 820 If `jabber-debug-log-xml' is nil, do nothing.
 821 FSM is the connection that is sending/receiving.
 822 DIRECTION is a string, either \"sending\" or \"receive\".
 823 DATA is any sexp."
 824   (when jabber-debug-log-xml
 825       (jabber-process-console fsm direction data)))
 826
 827 (defun jabber-pre-filter (process string fsm)
 828   (with-current-buffer (process-buffer process)
 829     ;; Append new data
 830     (goto-char (point-max))
 831     (insert string)
 832
 833     (unless (boundp 'jabber-filtering)
 834       (let (jabber-filtering)
 835         (jabber-filter process fsm)))))
 836
 837 (defun jabber-filter (process fsm)
 838   "the filter function for the jabber process"
 839   (with-current-buffer (process-buffer process)
 840     ;; Start from the beginning
 841     (goto-char (point-min))
 842     (let (xml-data)
 843       (loop
 844        do
 845        ;; Skip whitespace
 846        (unless (zerop (skip-chars-forward " \t\r\n"))
 847          (delete-region (point-min) (point)))
 848        ;; Skip processing directive
 849        (when (looking-at "<\\?xml[^?]*\\?>")
 850          (delete-region (match-beginning 0) (match-end 0)))
 851
 852        ;; Stream end?
 853        (when (looking-at "</stream:stream>")
 854          (return (fsm-send fsm :stream-end)))
 855
 856        ;; Stream header?
 857        (when (looking-at "<stream:stream[^>]*>")
 858          (let ((stream-header (match-string 0))
 859                (ending-at (match-end 0))
 860                session-id stream-version)
 861            ;; These regexps extract attribute values from the stream
 862            ;; header, taking into account that the quotes may be either
 863            ;; single or double quotes.
 864            (setq session-id
 865                  (and (or (string-match "id='\\([^']+\\)'" stream-header)
 866                           (string-match "id=\"\\([^\"]+\\)\"" stream-header))
 867                       (jabber-unescape-xml (match-string 1 stream-header))))
 868            (setq stream-version
 869                  (and (or
 870                        (string-match "version='\\([0-9.]+\\)'" stream-header)
 871                        (string-match "version=\"\\([0-9.]+\\)\"" stream-header))
 872                       (match-string 1 stream-header)))
 873            (jabber-log-xml fsm "receive" stream-header)
 874
 875            ;; If the server is XMPP compliant, i.e. there is a version attribute
 876            ;; and it's >= 1.0, there will be a stream:features tag shortly,
 877            ;; so just wait for that.
 878
 879            (fsm-send fsm (list :stream-start session-id stream-version))
 880
 881            (delete-region (point-min) ending-at)))
 882
 883        ;; Normal tag
 884
 885        ;; XXX: do these checks make sense?  If so, reinstate them.
 886        ;;(if (active-minibuffer-window)
 887        ;;    (run-with-idle-timer 0.01 nil #'jabber-filter process string)
 888
 889        ;; This check is needed for xml.el of Emacs 21, as it chokes on
 890        ;; empty attribute values.
 891        (save-excursion
 892          (while (search-forward-regexp " \\w+=''" nil t)
 893            (replace-match "")))
 894
 895        (setq xml-data (and (catch 'unfinished
 896                              (jabber-xml-skip-tag-forward)
 897                              (> (point) (point-min)))
 898                            (xml-parse-region (point-min) (point))))
 899        (if xml-data
 900            (jabber-reset-choked))
 901
 902        while xml-data
 903        do
 904        ;; If there's a problem with writing the XML log,
 905        ;; make sure the stanza is delivered, at least.
 906        (condition-case e
 907            (jabber-log-xml fsm "receive" (car xml-data))
 908          (error
 909           (ding)
 910           (message "Couldn't write XML log: %s" (error-message-string e))
 911           (sit-for 2)))
 912        (delete-region (point-min) (point))
 913
 914        (fsm-send fsm (list :stanza (jabber-xml-resolve-namespace-prefixes (car xml-data))))
 915        ;; XXX: move this logic elsewhere
 916        ;; We explicitly don't catch errors in jabber-process-input,
 917        ;; to facilitate debugging.
 918        ;; (jabber-process-input (car xml-data))
 919        ))))
 920
 921 (defun jabber-reset-choked ()
 922   (setq jabber-choked-count 0))
 923
 924 (defun jabber-check-choked ()
 925   ;; "Choked" means that data is sitting in the process buffer
 926   ;; without being parsed, despite several attempts.
 927   (if (zerop (buffer-size (process-buffer *jabber-connection*)))
 928       (jabber-reset-choked)
 929     (incf jabber-choked-count)
 930     (if (and (> jabber-choked-count 3)
 931              ;; Now we're definitely choked.  Take action.
 932              ;; But ask user first.
 933              (yes-or-no-p "jabber.el is severely confused.  Bail out? "))
 934         (run-with-idle-timer 0.1 nil 'jabber-choked-bail-out)
 935       (jabber-reset-choked))))
 936
 937 (defun jabber-choked-bail-out ()
 938   ;; So here we are.  Something in the process buffer prevents us
 939   ;; from continuing normally.  Let's die honorably by providing
 940   ;; bug report material.
 941   (with-current-buffer (generate-new-buffer "*jabber-bug*")
 942     (insert "jabber.el couldn't cope with the data received from the server.
 943 This should never happen, but apparently it did.
 944
 945 The information below will be helpful in tracking down and fixing
 946 the bug.  You may want to edit out any sensitive information.
 947
 948 Please go to
 949 http://sourceforge.net/tracker/?group_id=88346&atid=586350 and
 950 submit a bug report, including the information below.
 951
 952 ")
 953     (goto-address)
 954     (emacs-version t)
 955     (insert "\n\nThe following couldn't be parsed:\n")
 956     (insert-buffer-substring (process-buffer *jabber-connection*))
 957     (switch-to-buffer (current-buffer)))
 958   (jabber-disconnect))
 959
 960 (defun jabber-process-input (jc xml-data)
 961   "process an incoming parsed tag"
 962   (let* ((tag (jabber-xml-node-name xml-data))
 963          (functions (eval (cdr (assq tag '((iq . jabber-iq-chain)
 964                                            (presence . jabber-presence-chain)
 965                                            (message . jabber-message-chain)))))))
 966     (dolist (f functions)
 967       (condition-case e
 968           (funcall f jc xml-data)
 969         ((debug error)
 970          (fsm-debug-output "Error %S while processing %S with function %s" e xml-data f))))))
 971
 972 (defun jabber-process-stream-error (xml-data state-data)
 973   "Process an incoming stream error.
 974 Return nil if XML-DATA is not a stream:error stanza.
 975 Return an fsm result list if it is."
 976   (when (eq (jabber-xml-node-name xml-data) 'stream:error)
 977     (let ((condition (jabber-stream-error-condition xml-data))
 978           (text (jabber-parse-stream-error xml-data)))
 979       (setq state-data (plist-put state-data :disconnection-reason
 980                                   (format "Stream error: %s" text)))
 981       ;; Special case: when the error is `conflict', we have been
 982       ;; forcibly disconnected by the same user.  Don't reconnect
 983       ;; automatically.
 984       (when (eq condition 'conflict)
 985         (setq state-data (plist-put state-data :disconnection-expected t)))
 986       (list nil state-data))))
 987
 988 ;; XXX: This function should probably die.  The roster is stored
 989 ;; inside the connection plists, and the obarray shouldn't be so big
 990 ;; that we need to clean it.
 991 (defun jabber-clear-roster ()
 992   "Clean up the roster."
 993   ;; This is made complicated by the fact that the JIDs are symbols with properties.
 994   (mapatoms #'(lambda (x)
 995                 (unintern x jabber-jid-obarray))
 996             jabber-jid-obarray)
 997   (setq *jabber-roster* nil))
 998
 999 (defun jabber-send-sexp (jc sexp)
1000   "Send the xml corresponding to SEXP to connection JC."
1001   (condition-case e
1002       (jabber-log-xml jc "sending" sexp)
1003     (error
1004      (ding)
1005      (message "Couldn't write XML log: %s" (error-message-string e))
1006      (sit-for 2)))
1007   (jabber-send-string jc (jabber-sexp2xml sexp)))
1008
1009 (defun jabber-send-sexp-if-connected (jc sexp)
1010   "Send the stanza SEXP only if JC has established a session."
1011   (fsm-send-sync jc (cons :send-if-connected sexp)))
1012
1013 (defun jabber-send-stream-header (jc)
1014   "Send stream header to connection JC."
1015   (let ((stream-header
1016          (concat "<?xml version='1.0'?><stream:stream to='"
1017                  (plist-get (fsm-get-state-data jc) :server)
1018                  "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams'"
1019                  ;; Not supporting SASL is not XMPP compliant,
1020                  ;; so don't pretend we are.
1021                  (if (and (jabber-have-sasl-p) jabber-use-sasl)
1022                      " version='1.0'"
1023                    "")
1024                  ">
1025 ")))
1026     (jabber-log-xml jc "sending" stream-header)
1027     (jabber-send-string jc stream-header)))
1028
1029 (defun jabber-send-string (jc string)
1030   "Send STRING to the connection JC."
1031   (let* ((state-data (fsm-get-state-data jc))
1032          (connection (plist-get state-data :connection))
1033          (send-function (plist-get state-data :send-function)))
1034     (unless connection
1035       (error "%s has no connection" (jabber-connection-jid jc)))
1036     (funcall send-function connection string)))
1037
1038 (provide 'jabber-core)
1039
1040 ;;; arch-tag: 9d273ce6-c45a-447b-abf3-21d3ce73a51a