djavu-asus/emacs/elpa/jabber-20230715.456/jabber-core.el

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