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