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 (defvar jabber-namespace-prefixes nil
  68   "XML namespace prefixes used for the current connection.")
  69 (make-variable-buffer-local 'jabber-namespace-prefixes)
  70
  71 (defgroup jabber-core nil "customize core functionality"
  72   :group 'jabber)
  73
  74 (defcustom jabber-post-connect-hooks '(jabber-send-current-presence
  75                                        jabber-muc-autojoin
  76                                        jabber-whitespace-ping-start
  77                                        jabber-vcard-avatars-find-current)
  78   "*Hooks run after successful connection and authentication.
  79 The functions should accept one argument, the connection object."
  80   :type 'hook
  81   :options '(jabber-send-current-presence
  82              jabber-muc-autojoin
  83              jabber-whitespace-ping-start
  84              jabber-keepalive-start
  85              jabber-vcard-avatars-find-current
  86              jabber-autoaway-start)
  87   :group 'jabber-core)
  88
  89 (defcustom jabber-pre-disconnect-hook nil
  90   "*Hooks run just before voluntary disconnection
  91 This might be due to failed authentication.  Check `*jabber-authenticated*'."
  92   :type 'hook
  93   :group 'jabber-core)
  94
  95 (defcustom jabber-lost-connection-hooks nil
  96   "*Hooks run after involuntary disconnection.
  97 The functions are called with one argument: the connection object."
  98   :type 'hook
  99   :group 'jabber-core)
 100
 101 (defcustom jabber-post-disconnect-hook nil
 102   "*Hooks run after disconnection"
 103   :type 'hook
 104   :group 'jabber-core)
 105
 106 (defcustom jabber-auto-reconnect nil
 107   "Reconnect automatically after losing connection?
 108 This will be of limited use unless you have the password library
 109 installed, and have configured it to cache your password
 110 indefinitely.  See `password-cache' and `password-cache-expiry'."
 111   :type 'boolean
 112   :group 'jabber-core)
 113
 114 (defcustom jabber-reconnect-delay 5
 115   "Seconds to wait before reconnecting"
 116   :type 'integer
 117   :group 'jabber-core)
 118
 119 (defcustom jabber-roster-buffer "*-jabber-roster-*"
 120   "The name of the roster buffer"
 121   :type 'string
 122   :group 'jabber-core)
 123
 124 (defvar jabber-process-buffer " *-jabber-process-*"
 125   "The name of the process buffer")
 126
 127 (defcustom jabber-use-sasl t
 128   "If non-nil, use SASL if possible.
 129 SASL will still not be used if the library for it is missing or
 130 if the server doesn't support it.
 131
 132 Disabling this shouldn't be necessary, but it may solve certain
 133 problems."
 134   :type 'boolean
 135   :group 'jabber-core)
 136
 137 (defsubst jabber-have-sasl-p ()
 138   "Return non-nil if SASL functions are available."
 139   (featurep 'sasl))
 140
 141 (defvar jabber-account-history ()
 142   "Keeps track of previously used jabber accounts")
 143
 144 (defvar jabber-connection-type-history ()
 145   "Keeps track of previously used connection types")
 146
 147 ;; jabber-connect and jabber-connect-all should load jabber.el, not
 148 ;; just jabber-core.el, when autoloaded.
 149
 150 ;;;###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)
 151 (defun jabber-connect-all (&optional arg)
 152   "Connect to all configured Jabber accounts.
 153 See `jabber-account-list'.
 154 If no accounts are configured (or with prefix argument), call `jabber-connect' interactively.
 155 With many prefix arguments, one less is passed to `jabber-connect'."
 156   (interactive "P")
 157   (let ((accounts
 158          (remove-if (lambda (account)
 159                       (cdr (assq :disabled (cdr account))))
 160                     jabber-account-list)))
 161     (if (or (null accounts) arg)
 162         (let ((current-prefix-arg
 163                (cond
 164                 ;; A number of C-u's; remove one, so to speak.
 165                 ((consp arg)
 166                  (if (> (car arg) 4)
 167                      (list (/ (car arg) 4))
 168                    nil))
 169                 ;; Otherwise, we just don't care.
 170                 (t
 171                  arg))))
 172           (call-interactively 'jabber-connect))
 173       ;; Only connect those accounts that are not yet connected.
 174       (let ((already-connected (mapcar #'jabber-connection-bare-jid jabber-connections))
 175             (connected-one nil))
 176         (dolist (account accounts)
 177           (unless (member (jabber-jid-user (car account)) already-connected)
 178             (let* ((jid (car account))
 179                    (alist (cdr account))
 180                    (password (cdr (assq :password alist)))
 181                    (network-server (cdr (assq :network-server alist)))
 182                    (port (cdr (assq :port alist)))
 183                    (connection-type (cdr (assq :connection-type alist))))
 184               (jabber-connect
 185                (jabber-jid-username jid)
 186                (jabber-jid-server jid)
 187                (jabber-jid-resource jid)
 188                nil password network-server
 189                port connection-type))))))))
 190
 191 ;;;###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)
 192 (defun jabber-connect (username server resource &optional
 193                                 registerp password network-server
 194                                 port connection-type)
 195   "Connect to the Jabber server and start a Jabber XML stream.
 196 With prefix argument, register a new account.
 197 With double prefix argument, specify more connection details."
 198   (interactive
 199    (let* ((jid (completing-read "Enter your JID: " jabber-account-list nil nil nil 'jabber-account-history))
 200           (entry (assoc jid jabber-account-list))
 201           (alist (cdr entry))
 202           password network-server port connection-type registerp)
 203      (flet ((nonempty
 204              (s)
 205              (unless (zerop (length s)) s)))
 206        (when entry
 207          ;; If the user entered the JID of one of the preconfigured
 208          ;; accounts, use that data.
 209          (setq password (cdr (assq :password alist)))
 210          (setq network-server (cdr (assq :network-server alist)))
 211          (setq port (cdr (assq :port alist)))
 212          (setq connection-type (cdr (assq :connection-type alist))))
 213        (when (equal current-prefix-arg '(16))
 214          ;; Double prefix arg: ask about everything.
 215          ;; (except password, which is asked about later anyway)
 216          (setq password nil)
 217          (setq network-server
 218                (read-string (format "Network server: (default `%s') " network-server)
 219                             nil nil network-server))
 220          (when (zerop (length network-server))
 221            (setq network-server nil))
 222          (setq port
 223                (car
 224                 (read-from-string
 225                  (read-string (format "Port: (default `%s') " port)
 226                               nil nil (if port (number-to-string port) "nil")))))
 227          (setq connection-type
 228                (car
 229                 (read-from-string
 230                  (let ((default (symbol-name (or connection-type jabber-default-connection-type))))
 231                    (completing-read
 232                     (format "Connection type: (default `%s') " default)
 233                     (mapcar (lambda (type)
 234                               (cons (symbol-name (car type)) nil))
 235                             jabber-connect-methods)
 236                     nil t nil 'jabber-connection-type-history default)))))
 237          (setq registerp (or jabber-silent-mode (yes-or-no-p "Register new account? "))))
 238        (when (equal current-prefix-arg '(4))
 239          (setq registerp t))
 240
 241        (list (jabber-jid-username jid)
 242              (jabber-jid-server jid)
 243              (jabber-jid-resource jid)
 244              registerp password network-server port connection-type))))
 245
 246   (require 'jabber)
 247
 248   (if (member (list username
 249                     server)
 250               (mapcar
 251                (lambda (c)
 252                  (let ((data (fsm-get-state-data c)))
 253                    (list (plist-get data :username)
 254                          (plist-get data :server))))
 255                jabber-connections))
 256       (message "Already connected to %s@%s"
 257                username server)
 258     (setq *jabber-authenticated* nil)
 259     ;;(jabber-clear-roster)
 260     (jabber-reset-choked)
 261
 262     (push (start-jabber-connection username server resource
 263                                    registerp password
 264                                    network-server port connection-type)
 265           jabber-connections)))
 266
 267 (define-state-machine jabber-connection
 268   :start ((username server resource registerp password network-server port connection-type)
 269           "Start a Jabber connection."
 270           (let* ((connection-type
 271                   (or connection-type jabber-default-connection-type))
 272                  (send-function
 273                   (jabber-get-send-function connection-type)))
 274
 275             (list :connecting
 276                   (list :send-function send-function
 277                         :username username
 278                         :server server
 279                         :resource resource
 280                         :password password
 281                         :registerp registerp
 282                         :connection-type connection-type
 283                         :encrypted (eq connection-type 'ssl)
 284                         :network-server network-server
 285                         :port port)))))
 286
 287 (define-enter-state jabber-connection nil
 288   (fsm state-data)
 289   ;; `nil' is the error state.
 290
 291   ;; Close the network connection.
 292   (let ((connection (plist-get state-data :connection)))
 293     (when (processp connection)
 294       (let ((process-buffer (process-buffer connection)))
 295         (delete-process connection)
 296         (when (and (bufferp process-buffer)
 297                    (not jabber-debug-keep-process-buffers))
 298           (kill-buffer process-buffer)))))
 299   (setq state-data (plist-put state-data :connection nil))
 300   ;; Remove lost connections from the roster buffer.
 301   (jabber-display-roster)
 302   (let ((expected (plist-get state-data :disconnection-expected))
 303         (reason (plist-get state-data :disconnection-reason))
 304         (ever-session-established (plist-get state-data :ever-session-established)))
 305     (unless expected
 306       (run-hook-with-args 'jabber-lost-connection-hooks fsm)
 307       (message "%s@%s/%s: connection lost: `%s'"
 308                (plist-get state-data :username)
 309                (plist-get state-data :server)
 310                (plist-get state-data :resource)
 311                reason))
 312
 313     (if (and jabber-auto-reconnect (not expected) ever-session-established)
 314         ;; Reconnect after a short delay?
 315         (list state-data jabber-reconnect-delay)
 316       ;; Else the connection is really dead.  Remove it from the list
 317       ;; of connections.
 318       (setq jabber-connections
 319             (delq fsm jabber-connections))
 320       (when jabber-mode-line-mode
 321         (jabber-mode-line-presence-update))
 322       (jabber-display-roster)
 323       ;; And let the FSM sleep...
 324       (list state-data nil))))
 325
 326 (define-state jabber-connection nil
 327   (fsm state-data event callback)
 328   ;; In the `nil' state, the connection is dead.  We wait for a
 329   ;; :timeout message, meaning to reconnect, or :do-disconnect,
 330   ;; meaning to cancel reconnection.
 331   (case event
 332     (:timeout
 333      (list :connecting state-data))
 334     (:do-disconnect
 335      (setq jabber-connections
 336             (delq fsm jabber-connections))
 337      (list nil state-data nil))))
 338
 339 (define-enter-state jabber-connection :connecting
 340   (fsm state-data)
 341   (let* ((connection-type (plist-get state-data :connection-type))
 342          (connect-function (jabber-get-connect-function connection-type))
 343          (server (plist-get state-data :server))
 344          (network-server (plist-get state-data :network-server))
 345          (port (plist-get state-data :port)))
 346     (funcall connect-function fsm server network-server port))
 347   (list state-data nil))
 348
 349 (define-state jabber-connection :connecting
 350   (fsm state-data event callback)
 351   (case (or (car-safe event) event)
 352     (:connected
 353      (let ((connection (cadr event))
 354            (registerp (plist-get state-data :registerp)))
 355
 356        (setq state-data (plist-put state-data :connection connection))
 357
 358        (when (processp connection)
 359          ;; TLS connections leave data in the process buffer, which
 360          ;; the XML parser will choke on.
 361          (with-current-buffer (process-buffer connection)
 362            (erase-buffer))
 363
 364          (set-process-filter connection (fsm-make-filter fsm))
 365          (set-process-sentinel connection (fsm-make-sentinel fsm)))
 366
 367        (list :connected state-data)))
 368
 369     (:connection-failed
 370      (message "Jabber connection failed")
 371      (list nil state-data))
 372
 373     (:do-disconnect
 374      ;; We don't have the connection object, so defer the disconnection.
 375      :defer)))
 376
 377 (defsubst jabber-fsm-handle-sentinel (state-data event)
 378   "Handle sentinel event for jabber fsm."
 379   ;; We do the same thing for every state, so avoid code duplication.
 380   (let* ((string (car (cddr event)))
 381          (new-state-data
 382           ;; If we already know the reason (e.g. a stream error), don't
 383           ;; overwrite it.
 384           (if (plist-get state-data :disconnection-reason)
 385               state-data
 386             (plist-put state-data :disconnection-reason string))))
 387     (list nil new-state-data)))
 388
 389 (define-enter-state jabber-connection :connected
 390   (fsm state-data)
 391
 392   (jabber-send-stream-header fsm)
 393
 394   ;; XXX: Update to multiaccount?  Remove?
 395   ;; (setq jabber-choked-timer
 396   ;;    (run-with-timer 5 5 #'jabber-check-choked))
 397
 398   ;;XXX: why is this here?  I'll try commenting it out...
 399   ;;(accept-process-output *jabber-connection*)
 400
 401   ;; Next thing happening is the server sending its own <stream:stream> start tag.
 402
 403   (setq *jabber-connected* t)
 404   (list state-data nil))
 405
 406 (define-state jabber-connection :connected
 407   (fsm state-data event callback)
 408   (case (or (car-safe event) event)
 409     (:filter
 410      (let ((process (cadr event))
 411            (string (car (cddr event))))
 412        (jabber-pre-filter process string fsm)
 413        (list :connected state-data)))
 414
 415     (:sentinel
 416      (jabber-fsm-handle-sentinel state-data event))
 417
 418     (:stream-start
 419      (let ((session-id (cadr event))
 420            (stream-version (car (cddr event))))
 421        (setq state-data
 422              (plist-put state-data :session-id session-id))
 423        ;; the stream feature is only sent if the initiating entity has
 424        ;; sent 1.0 in the stream header. if sasl is not supported then
 425        ;; we don't send 1.0 in the header and therefore we shouldn't wait
 426        ;; even if 1.0 is present in the receiving stream.
 427        (cond
 428         ;; Wait for stream features?
 429         ((and stream-version
 430               (>= (string-to-number stream-version) 1.0)
 431               jabber-use-sasl
 432               (jabber-have-sasl-p))
 433          ;; Stay in same state...
 434          (list :connected state-data))
 435         ;; Register account?
 436         ((plist-get state-data :registerp)
 437          ;; XXX: require encryption for registration?
 438          (list :register-account state-data))
 439         ;; Legacy authentication?
 440         (t
 441          (list :legacy-auth state-data)))))
 442
 443     (:stanza
 444      (let ((stanza (cadr event)))
 445        (cond
 446         ;; At this stage, we only expect a stream:features stanza.
 447         ((not (eq (jabber-xml-node-name stanza) 'features))
 448          (list nil (plist-put state-data
 449                               :disconnection-reason
 450                               (format "Unexpected stanza %s" stanza))))
 451         ((and (jabber-xml-get-children stanza 'starttls)
 452               (eq (plist-get state-data :connection-type) 'starttls))
 453          (list :starttls state-data))
 454         ;; XXX: require encryption for registration?
 455         ((plist-get state-data :registerp)
 456          ;; We could check for the <register/> element in stream
 457          ;; features, but as a client we would only lose by doing
 458          ;; that.
 459          (list :register-account state-data))
 460         (t
 461          (list :sasl-auth (plist-put state-data :stream-features stanza))))))
 462
 463     (:do-disconnect
 464      (jabber-send-string fsm "</stream:stream>")
 465      (list nil (plist-put state-data
 466                           :disconnection-expected t)))))
 467
 468 (define-enter-state jabber-connection :starttls
 469   (fsm state-data)
 470   (jabber-starttls-initiate fsm)
 471   (list state-data nil))
 472
 473 (define-state jabber-connection :starttls
 474   (fsm state-data event callback)
 475   (case (or (car-safe event) event)
 476     (:filter
 477      (let ((process (cadr event))
 478            (string (car (cddr event))))
 479        (jabber-pre-filter process string fsm)
 480        (list :starttls state-data)))
 481
 482     (:sentinel
 483      (jabber-fsm-handle-sentinel state-data event))
 484
 485     (:stanza
 486      (if (jabber-starttls-process-input fsm (cadr event))
 487          ;; Connection is encrypted.  Send a stream tag again.
 488          (list :connected (plist-put state-data :encrypted t))
 489        (message "STARTTLS negotiation failed")
 490        (list nil state-data)))
 491
 492     (:do-disconnect
 493      (jabber-send-string fsm "</stream:stream>")
 494      (list nil (plist-put state-data
 495                           :disconnection-expected t)))))
 496
 497 (define-enter-state jabber-connection :register-account
 498   (fsm state-data)
 499   (jabber-get-register fsm nil)
 500   (list state-data nil))
 501
 502 (define-state jabber-connection :register-account
 503   (fsm state-data event callback)
 504   ;; The connection will be closed in jabber-register
 505   (case (or (car-safe event) event)
 506     (:filter
 507      (let ((process (cadr event))
 508            (string (car (cddr event))))
 509        (jabber-pre-filter process string fsm)
 510        (list :register-account state-data)))
 511
 512     (:sentinel
 513      (jabber-fsm-handle-sentinel state-data event))
 514
 515     (:stanza
 516      (or
 517       (jabber-process-stream-error (cadr event) state-data)
 518       (progn
 519         (jabber-process-input fsm (cadr event))
 520         (list :register-account state-data))))
 521
 522     (:do-disconnect
 523      (jabber-send-string fsm "</stream:stream>")
 524      (list nil (plist-put state-data
 525                           :disconnection-expected t)))))
 526
 527 (define-enter-state jabber-connection :legacy-auth
 528   (fsm state-data)
 529   (jabber-get-auth fsm (plist-get state-data :server)
 530                    (plist-get state-data :session-id))
 531   (list state-data nil))
 532
 533 (define-state jabber-connection :legacy-auth
 534   (fsm state-data event callback)
 535   (case (or (car-safe event) event)
 536     (:filter
 537      (let ((process (cadr event))
 538            (string (car (cddr event))))
 539        (jabber-pre-filter process string fsm)
 540        (list :legacy-auth state-data)))
 541
 542     (:sentinel
 543      (jabber-fsm-handle-sentinel state-data event))
 544
 545     (:stanza
 546      (or
 547       (jabber-process-stream-error (cadr event) state-data)
 548       (progn
 549         (jabber-process-input fsm (cadr event))
 550         (list :legacy-auth state-data))))
 551
 552     (:authentication-success
 553      (jabber-cache-password (jabber-connection-bare-jid fsm) (cdr event))
 554      (list :session-established state-data))
 555
 556     (:authentication-failure
 557      (jabber-uncache-password (jabber-connection-bare-jid fsm))
 558      ;; jabber-logon has already displayed a message
 559      (list nil (plist-put state-data
 560                           :disconnection-expected t)))
 561
 562     (:do-disconnect
 563      (jabber-send-string fsm "</stream:stream>")
 564      (list nil (plist-put state-data
 565                           :disconnection-expected t)))))
 566
 567 (define-enter-state jabber-connection :sasl-auth
 568   (fsm state-data)
 569   (let ((new-state-data
 570          (plist-put state-data
 571                     :sasl-data
 572                     (jabber-sasl-start-auth
 573                      fsm
 574                      (plist-get state-data
 575                                 :stream-features)))))
 576     (list new-state-data nil)))
 577
 578 (define-state jabber-connection :sasl-auth
 579   (fsm state-data event callback)
 580   (case (or (car-safe event) event)
 581     (:filter
 582      (let ((process (cadr event))
 583            (string (car (cddr event))))
 584        (jabber-pre-filter process string fsm)
 585        (list :sasl-auth state-data)))
 586
 587     (:sentinel
 588      (jabber-fsm-handle-sentinel state-data event))
 589
 590     (:stanza
 591      (let ((new-sasl-data
 592             (jabber-sasl-process-input
 593              fsm (cadr event)
 594              (plist-get state-data :sasl-data))))
 595        (list :sasl-auth (plist-put state-data :sasl-data new-sasl-data))))
 596
 597     (:use-legacy-auth-instead
 598      (list :legacy-auth (plist-put state-data :sasl-data nil)))
 599
 600     (:authentication-success
 601      (jabber-cache-password (jabber-connection-bare-jid fsm) (cdr event))
 602      (list :bind (plist-put state-data :sasl-data nil)))
 603
 604     (:authentication-failure
 605      (jabber-uncache-password (jabber-connection-bare-jid fsm))
 606      ;; jabber-sasl has already displayed a message
 607      (list nil (plist-put state-data
 608                           :disconnection-expected t)))
 609
 610     (:do-disconnect
 611      (jabber-send-string fsm "</stream:stream>")
 612      (list nil (plist-put state-data
 613                           :disconnection-expected t)))))
 614
 615 (define-enter-state jabber-connection :bind
 616   (fsm state-data)
 617   (jabber-send-stream-header fsm)
 618   (list state-data nil))
 619
 620 (define-state jabber-connection :bind
 621   (fsm state-data event callback)
 622   (case (or (car-safe event) event)
 623     (:filter
 624      (let ((process (cadr event))
 625            (string (car (cddr event))))
 626        (jabber-pre-filter process string fsm)
 627        (list :bind state-data)))
 628
 629     (:sentinel
 630      (jabber-fsm-handle-sentinel state-data event))
 631
 632     (:stream-start
 633      ;; we wait for stream features...
 634      (list :bind state-data))
 635
 636     (:stanza
 637      (let ((stanza (cadr event)))
 638        (cond
 639         ((eq (jabber-xml-node-name stanza) 'features)
 640          (if (and (jabber-xml-get-children stanza 'bind)
 641                   (jabber-xml-get-children stanza 'session))
 642              (labels
 643                  ((handle-bind
 644                    (jc xml-data success)
 645                    (fsm-send jc (list
 646                                  (if success :bind-success :bind-failure)
 647                                  xml-data))))
 648                ;; So let's bind a resource.  We can either pick a resource ourselves,
 649                ;; or have the server pick one for us.
 650                (let ((resource (plist-get state-data :resource)))
 651                  (jabber-send-iq fsm nil "set"
 652                                  `(bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind"))
 653                                         ,@(when resource
 654                                             `((resource () ,resource))))
 655                                  #'handle-bind t
 656                                  #'handle-bind nil))
 657                (list :bind state-data))
 658            (message "Server doesn't permit resource binding and session establishing")
 659            (list nil state-data)))
 660         (t
 661          (or
 662           (jabber-process-stream-error (cadr event) state-data)
 663           (progn
 664             (jabber-process-input fsm (cadr event))
 665             (list :bind state-data)))))))
 666
 667     (:bind-success
 668      (let ((jid (jabber-xml-path (cadr event) '(bind jid ""))))
 669        ;; Maybe this isn't the JID we asked for.
 670        (plist-put state-data :username (jabber-jid-username jid))
 671        (plist-put state-data :server (jabber-jid-server jid))
 672        (plist-put state-data :resource (jabber-jid-resource jid)))
 673
 674      ;; Been there, done that.  Time to establish a session.
 675      (labels
 676          ((handle-session
 677            (jc xml-data success)
 678            (fsm-send jc (list
 679                          (if success :session-success :session-failure)
 680                          xml-data))))
 681        (jabber-send-iq fsm nil "set"
 682                        '(session ((xmlns . "urn:ietf:params:xml:ns:xmpp-session")))
 683                        #'handle-session t
 684                        #'handle-session nil)
 685        (list :bind state-data)))
 686
 687     (:session-success
 688      ;; We have a session
 689      (list :session-established state-data))
 690
 691     (:bind-failure
 692      (message "Resource binding failed: %s"
 693               (jabber-parse-error
 694                (jabber-iq-error (cadr event))))
 695      (list nil state-data))
 696
 697     (:session-failure
 698      (message "Session establishing failed: %s"
 699               (jabber-parse-error
 700                (jabber-iq-error (cadr event))))
 701      (list nil state-data))
 702
 703     (:do-disconnect
 704      (jabber-send-string fsm "</stream:stream>")
 705      (list nil (plist-put state-data
 706                           :disconnection-expected t)))))
 707
 708 (define-enter-state jabber-connection :session-established
 709   (fsm state-data)
 710   (jabber-send-iq fsm nil
 711                   "get"
 712                   '(query ((xmlns . "jabber:iq:roster")))
 713                   #'jabber-process-roster 'initial
 714                   #'jabber-report-success "Roster retrieval")
 715   (list (plist-put state-data :ever-session-established t) nil))
 716
 717 (defvar jabber-pending-presence-timeout 0.5
 718   "Wait this long before doing presence packet batch processing.")
 719
 720 (define-state jabber-connection :session-established
 721   (fsm state-data event callback)
 722   (case (or (car-safe event) event)
 723     (:filter
 724      (let ((process (cadr event))
 725            (string (car (cddr event))))
 726        (jabber-pre-filter process string fsm)
 727        (list :session-established state-data :keep)))
 728
 729     (:sentinel
 730      (jabber-fsm-handle-sentinel state-data event))
 731
 732     (:stanza
 733      (or
 734       (jabber-process-stream-error (cadr event) state-data)
 735       (progn
 736         (jabber-process-input fsm (cadr event))
 737         (list :session-established state-data :keep))))
 738
 739     (:roster-update
 740      ;; Batch up roster updates
 741      (let* ((jid-symbol-to-update (cdr event))
 742             (pending-updates (plist-get state-data :roster-pending-updates)))
 743        ;; If there are pending updates, there is a timer running
 744        ;; already; just add the new symbol and wait.
 745        (if pending-updates
 746            (progn
 747              (unless (memq jid-symbol-to-update pending-updates)
 748                (nconc pending-updates (list jid-symbol-to-update)))
 749              (list :session-established state-data :keep))
 750          ;; Otherwise, we need to create the list and start the timer.
 751          (setq state-data
 752                (plist-put state-data
 753                           :roster-pending-updates
 754                           (list jid-symbol-to-update)))
 755          (list :session-established state-data jabber-pending-presence-timeout))))
 756
 757     (:timeout
 758      ;; Update roster
 759      (let ((pending-updates (plist-get state-data :roster-pending-updates)))
 760        (setq state-data (plist-put state-data :roster-pending-updates nil))
 761        (jabber-roster-update fsm nil pending-updates nil)
 762        (list :session-established state-data)))
 763
 764     (:send-if-connected
 765      ;; This is the only state in which we respond to such messages.
 766      ;; This is to make sure we don't send anything inappropriate
 767      ;; during authentication etc.
 768      (jabber-send-sexp fsm (cdr event))
 769      (list :session-established state-data :keep))
 770
 771     (:do-disconnect
 772      (jabber-send-string fsm "</stream:stream>")
 773      (list nil (plist-put state-data
 774                           :disconnection-expected t)))))
 775
 776 (defun jabber-disconnect (&optional arg)
 777   "Disconnect from all Jabber servers. If ARG supplied, disconnect one account."
 778   (interactive "P")
 779   (if arg
 780       (jabber-disconnect-one (jabber-read-account))
 781     (unless *jabber-disconnecting*      ; avoid reentry
 782       (let ((*jabber-disconnecting* t))
 783         (run-hooks 'jabber-pre-disconnect-hook)
 784         (dolist (c jabber-connections)
 785           (jabber-disconnect-one c t))
 786         (setq jabber-connections nil)
 787
 788         (jabber-disconnected)
 789         (when (interactive-p)
 790           (message "Disconnected from Jabber server(s)"))))))
 791
 792 (defun jabber-disconnect-one (jc &optional dont-redisplay)
 793   "Disconnect from one Jabber server.
 794 If DONT-REDISPLAY is non-nil, don't update roster buffer."
 795   (interactive (list (jabber-read-account)))
 796   (fsm-send-sync jc :do-disconnect)
 797   (when (interactive-p)
 798     (message "Disconnected from %s"
 799              (jabber-connection-jid jc)))
 800   (unless dont-redisplay
 801     (jabber-display-roster)))
 802
 803 (defun jabber-disconnected ()
 804   "Re-initialise jabber package variables.
 805 Call this function after disconnection."
 806   (when jabber-choked-timer
 807     (jabber-cancel-timer jabber-choked-timer)
 808     (setq jabber-choked-timer nil))
 809
 810   (when (get-buffer jabber-roster-buffer)
 811     (with-current-buffer (get-buffer jabber-roster-buffer)
 812       (let ((inhibit-read-only t))
 813         (erase-buffer))))
 814
 815   (setq *jabber-connection* nil)
 816   (jabber-clear-roster)
 817   (setq *jabber-authenticated* nil)
 818   (setq *jabber-connected* nil)
 819   (setq *jabber-active-groupchats* nil)
 820   (run-hooks 'jabber-post-disconnect-hook))
 821
 822 (defun jabber-log-xml (fsm direction data)
 823   "Print DATA to XML console (and, optionally, in file).
 824 If `jabber-debug-log-xml' is nil, do nothing.
 825 FSM is the connection that is sending/receiving.
 826 DIRECTION is a string, either \"sending\" or \"receive\".
 827 DATA is any sexp."
 828   (when jabber-debug-log-xml
 829       (jabber-process-console fsm direction data)))
 830
 831 (defun jabber-pre-filter (process string fsm)
 832   (with-current-buffer (process-buffer process)
 833     ;; Append new data
 834     (goto-char (point-max))
 835     (insert string)
 836
 837     (unless (boundp 'jabber-filtering)
 838       (let (jabber-filtering)
 839         (jabber-filter process fsm)))))
 840
 841 (defun jabber-filter (process fsm)
 842   "the filter function for the jabber process"
 843   (with-current-buffer (process-buffer process)
 844     ;; Start from the beginning
 845     (goto-char (point-min))
 846     (let (xml-data)
 847       (loop
 848        do
 849        ;; Skip whitespace
 850        (unless (zerop (skip-chars-forward " \t\r\n"))
 851          (delete-region (point-min) (point)))
 852        ;; Skip processing directive
 853        (when (looking-at "<\\?xml[^?]*\\?>")
 854          (delete-region (match-beginning 0) (match-end 0)))
 855
 856        ;; Stream end?
 857        (when (looking-at "</stream:stream>")
 858          (return (fsm-send fsm :stream-end)))
 859
 860        ;; Stream header?
 861        (when (looking-at "<stream:stream[^>]*\\(>\\)")
 862          ;; Let's pretend that the stream header is a closed tag,
 863          ;; and parse it as such.
 864          (replace-match "/>" t t nil 1)
 865          (let* ((ending-at (point))
 866                 (stream-header (car (xml-parse-region (point-min) ending-at)))
 867                 (session-id (jabber-xml-get-attribute stream-header 'id))
 868                 (stream-version (jabber-xml-get-attribute stream-header 'version)))
 869
 870            ;; Need to keep any namespace attributes on the stream
 871            ;; header, as they can affect any stanza in the
 872            ;; stream...
 873            (setq jabber-namespace-prefixes
 874                  (jabber-xml-merge-namespace-declarations
 875                   (jabber-xml-node-attributes stream-header)
 876                   nil))
 877            (jabber-log-xml fsm "receive" stream-header)
 878            (fsm-send fsm (list :stream-start session-id stream-version))
 879            (delete-region (point-min) ending-at)))
 880
 881        ;; Normal tag
 882
 883        ;; XXX: do these checks make sense?  If so, reinstate them.
 884        ;;(if (active-minibuffer-window)
 885        ;;    (run-with-idle-timer 0.01 nil #'jabber-filter process string)
 886
 887        ;; This check is needed for xml.el of Emacs 21, as it chokes on
 888        ;; empty attribute values.
 889        (save-excursion
 890          (while (search-forward-regexp " \\w+=''" nil t)
 891            (replace-match "")))
 892
 893        (setq xml-data (and (catch 'unfinished
 894                              (jabber-xml-skip-tag-forward)
 895                              (> (point) (point-min)))
 896                            (xml-parse-region (point-min) (point))))
 897        (if xml-data
 898            (jabber-reset-choked))
 899
 900        while xml-data
 901        do
 902        ;; If there's a problem with writing the XML log,
 903        ;; make sure the stanza is delivered, at least.
 904        (condition-case e
 905            (jabber-log-xml fsm "receive" (car xml-data))
 906          (error
 907           (ding)
 908           (message "Couldn't write XML log: %s" (error-message-string e))
 909           (sit-for 2)))
 910        (delete-region (point-min) (point))
 911
 912        (fsm-send fsm (list :stanza
 913                            (jabber-xml-resolve-namespace-prefixes
 914                             (car xml-data) nil jabber-namespace-prefixes)))
 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