diff options
Diffstat (limited to 'jabber-core.el')
| -rw-r--r-- | jabber-core.el | 1006 |
1 files changed, 1006 insertions, 0 deletions
diff --git a/jabber-core.el b/jabber-core.el new file mode 100644 index 0000000..9258647 --- /dev/null +++ b/jabber-core.el @@ -0,0 +1,1006 @@ +;; jabber-core.el - core functions + +;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu +;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net + +;; SSL-Connection Parts: +;; Copyright (C) 2005 - Georg Lehner - jorge@magma.com.ni + +;; This file is a part of jabber.el. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(require 'cl) + +(require 'jabber-util) +(require 'jabber-logon) +(require 'jabber-conn) +(eval-and-compile + (or (ignore-errors (require 'fsm)) + (ignore-errors + (let ((load-path (cons (expand-file-name + "jabber-fallback-lib" + (file-name-directory (locate-library "jabber"))) + load-path))) + (require 'fsm))) + (error + "fsm not found in `load-path' or jabber-fallback-lib/ directory."))) + +(require 'jabber-sasl) +(require 'jabber-console) + +(defvar jabber-connections nil + "List of jabber-connection FSMs.") + +(defvar *jabber-roster* nil + "the roster list") + +(defvar jabber-jid-obarray (make-vector 127 0) + "obarray for keeping JIDs") + +(defvar *jabber-disconnecting* nil + "boolean - are we in the process of disconnecting by free will") + +(defvar jabber-message-chain nil + "Incoming messages are sent to these functions, in order.") + +(defvar jabber-iq-chain nil + "Incoming infoqueries are sent to these functions, in order.") + +(defvar jabber-presence-chain nil + "Incoming presence notifications are sent to these functions, in order.") + +(defvar jabber-namespace-prefixes nil + "XML namespace prefixes used for the current connection.") +(make-variable-buffer-local 'jabber-namespace-prefixes) + +(defgroup jabber-core nil "customize core functionality" + :group 'jabber) + +(defcustom jabber-post-connect-hooks '(jabber-send-current-presence + jabber-muc-autojoin + jabber-whitespace-ping-start + jabber-vcard-avatars-find-current) + "*Hooks run after successful connection and authentication. +The functions should accept one argument, the connection object." + :type 'hook + :options '(jabber-send-current-presence + jabber-muc-autojoin + jabber-whitespace-ping-start + jabber-keepalive-start + jabber-vcard-avatars-find-current + jabber-autoaway-start) + :group 'jabber-core) + +(defcustom jabber-pre-disconnect-hook nil + "*Hooks run just before voluntary disconnection +This might be due to failed authentication." + :type 'hook + :group 'jabber-core) + +(defcustom jabber-lost-connection-hooks nil + "*Hooks run after involuntary disconnection. +The functions are called with one argument: the connection object." + :type 'hook + :group 'jabber-core) + +(defcustom jabber-post-disconnect-hook nil + "*Hooks run after disconnection" + :type 'hook + :group 'jabber-core) + +(defcustom jabber-auto-reconnect nil + "Reconnect automatically after losing connection? +This will be of limited use unless you have the password library +installed, and have configured it to cache your password +indefinitely. See `password-cache' and `password-cache-expiry'." + :type 'boolean + :group 'jabber-core) + +(defcustom jabber-reconnect-delay 5 + "Seconds to wait before reconnecting" + :type 'integer + :group 'jabber-core) + +(defcustom jabber-roster-buffer "*-jabber-roster-*" + "The name of the roster buffer" + :type 'string + :group 'jabber-core) + +(defvar jabber-process-buffer " *-jabber-process-*" + "The name of the process buffer") + +(defcustom jabber-use-sasl t + "If non-nil, use SASL if possible. +SASL will still not be used if the library for it is missing or +if the server doesn't support it. + +Disabling this shouldn't be necessary, but it may solve certain +problems." + :type 'boolean + :group 'jabber-core) + +(defsubst jabber-have-sasl-p () + "Return non-nil if SASL functions are available." + (featurep 'sasl)) + +(defvar jabber-account-history () + "Keeps track of previously used jabber accounts") + +(defvar jabber-connection-type-history () + "Keeps track of previously used connection types") + +;; jabber-connect and jabber-connect-all should load jabber.el, not +;; just jabber-core.el, when autoloaded. + +;;;###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) +(defun jabber-connect-all (&optional arg) + "Connect to all configured Jabber accounts. +See `jabber-account-list'. +If no accounts are configured (or with prefix argument), call `jabber-connect' interactively. +With many prefix arguments, one less is passed to `jabber-connect'." + (interactive "P") + (let ((accounts + (remove-if (lambda (account) + (cdr (assq :disabled (cdr account)))) + jabber-account-list))) + (if (or (null accounts) arg) + (let ((current-prefix-arg + (cond + ;; A number of C-u's; remove one, so to speak. + ((consp arg) + (if (> (car arg) 4) + (list (/ (car arg) 4)) + nil)) + ;; Otherwise, we just don't care. + (t + arg)))) + (call-interactively 'jabber-connect)) + ;; Only connect those accounts that are not yet connected. + (let ((already-connected (mapcar #'jabber-connection-original-jid jabber-connections)) + (connected-one nil)) + (dolist (account accounts) + (unless (member (jabber-jid-user (car account)) already-connected) + (let* ((jid (car account)) + (alist (cdr account)) + (password (cdr (assq :password alist))) + (network-server (cdr (assq :network-server alist))) + (port (cdr (assq :port alist))) + (connection-type (cdr (assq :connection-type alist)))) + (jabber-connect + (jabber-jid-username jid) + (jabber-jid-server jid) + (jabber-jid-resource jid) + nil password network-server + port connection-type) + (setq connected-one t)))) + (unless connected-one + (message "All configured Jabber accounts are already connected")))))) + +;;;###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) +(defun jabber-connect (username server resource &optional + registerp password network-server + port connection-type) + "Connect to the Jabber server and start a Jabber XML stream. +With prefix argument, register a new account. +With double prefix argument, specify more connection details." + (interactive + (let* ((jid (completing-read "Enter your JID: " jabber-account-list nil nil nil 'jabber-account-history)) + (entry (assoc jid jabber-account-list)) + (alist (cdr entry)) + password network-server port connection-type registerp) + (when (zerop (length jid)) + (error "No JID specified")) + (unless (jabber-jid-username jid) + (error "Missing username part in JID")) + (when entry + ;; If the user entered the JID of one of the preconfigured + ;; accounts, use that data. + (setq password (cdr (assq :password alist))) + (setq network-server (cdr (assq :network-server alist))) + (setq port (cdr (assq :port alist))) + (setq connection-type (cdr (assq :connection-type alist)))) + (when (equal current-prefix-arg '(16)) + ;; Double prefix arg: ask about everything. + ;; (except password, which is asked about later anyway) + (setq password nil) + (setq network-server + (read-string (format "Network server: (default `%s') " network-server) + nil nil network-server)) + (when (zerop (length network-server)) + (setq network-server nil)) + (setq port + (car + (read-from-string + (read-string (format "Port: (default `%s') " port) + nil nil (if port (number-to-string port) "nil"))))) + (setq connection-type + (car + (read-from-string + (let ((default (symbol-name (or connection-type jabber-default-connection-type)))) + (completing-read + (format "Connection type: (default `%s') " default) + (mapcar (lambda (type) + (cons (symbol-name (car type)) nil)) + jabber-connect-methods) + nil t nil 'jabber-connection-type-history default))))) + (setq registerp (or jabber-silent-mode (yes-or-no-p "Register new account? ")))) + (when (equal current-prefix-arg '(4)) + (setq registerp t)) + + (list (jabber-jid-username jid) + (jabber-jid-server jid) + (jabber-jid-resource jid) + registerp password network-server port connection-type))) + + (require 'jabber) + + (if (member (list username + server) + (mapcar + (lambda (c) + (let ((data (fsm-get-state-data c))) + (list (plist-get data :username) + (plist-get data :server)))) + jabber-connections)) + (message "Already connected to %s@%s" + username server) + ;;(jabber-clear-roster) + + (push (start-jabber-connection username server resource + registerp password + network-server port connection-type) + jabber-connections))) + +(define-state-machine jabber-connection + :start ((username server resource registerp password network-server port connection-type) + "Start a Jabber connection." + (let* ((connection-type + (or connection-type jabber-default-connection-type)) + (send-function + (jabber-get-send-function connection-type))) + + (list :connecting + (list :send-function send-function + ;; Save the JID we originally connected with. + :original-jid (concat username "@" server) + :username username + :server server + :resource resource + :password password + :registerp registerp + :connection-type connection-type + :encrypted (eq connection-type 'ssl) + :network-server network-server + :port port))))) + +(define-enter-state jabber-connection nil + (fsm state-data) + ;; `nil' is the error state. + + ;; Close the network connection. + (let ((connection (plist-get state-data :connection))) + (when (processp connection) + (let ((process-buffer (process-buffer connection))) + (delete-process connection) + (when (and (bufferp process-buffer) + (not jabber-debug-keep-process-buffers)) + (kill-buffer process-buffer))))) + (setq state-data (plist-put state-data :connection nil)) + ;; Clear MUC data + (jabber-muc-connection-closed (jabber-connection-bare-jid fsm)) + ;; Remove lost connections from the roster buffer. + (jabber-display-roster) + (let ((expected (plist-get state-data :disconnection-expected)) + (reason (plist-get state-data :disconnection-reason)) + (ever-session-established (plist-get state-data :ever-session-established))) + (unless expected + (run-hook-with-args 'jabber-lost-connection-hooks fsm) + (message "%s@%s%s: connection lost: `%s'" + (plist-get state-data :username) + (plist-get state-data :server) + (if (plist-get state-data :resource) + (concat "/" (plist-get state-data :resource)) + "") + reason)) + + (if (and jabber-auto-reconnect (not expected) ever-session-established) + ;; Reconnect after a short delay? + (list state-data jabber-reconnect-delay) + ;; Else the connection is really dead. Remove it from the list + ;; of connections. + (setq jabber-connections + (delq fsm jabber-connections)) + (when jabber-mode-line-mode + (jabber-mode-line-presence-update)) + (jabber-display-roster) + ;; And let the FSM sleep... + (list state-data nil)))) + +(define-state jabber-connection nil + (fsm state-data event callback) + ;; In the `nil' state, the connection is dead. We wait for a + ;; :timeout message, meaning to reconnect, or :do-disconnect, + ;; meaning to cancel reconnection. + (case event + (:timeout + (list :connecting state-data)) + (:do-disconnect + (setq jabber-connections + (delq fsm jabber-connections)) + (list nil state-data nil)))) + +(define-enter-state jabber-connection :connecting + (fsm state-data) + (let* ((connection-type (plist-get state-data :connection-type)) + (connect-function (jabber-get-connect-function connection-type)) + (server (plist-get state-data :server)) + (network-server (plist-get state-data :network-server)) + (port (plist-get state-data :port))) + (funcall connect-function fsm server network-server port)) + (list state-data nil)) + +(define-state jabber-connection :connecting + (fsm state-data event callback) + (case (or (car-safe event) event) + (:connected + (let ((connection (cadr event)) + (registerp (plist-get state-data :registerp))) + + (setq state-data (plist-put state-data :connection connection)) + + (when (processp connection) + ;; TLS connections leave data in the process buffer, which + ;; the XML parser will choke on. + (with-current-buffer (process-buffer connection) + (erase-buffer)) + + (set-process-filter connection (fsm-make-filter fsm)) + (set-process-sentinel connection (fsm-make-sentinel fsm))) + + (list :connected state-data))) + + (:connection-failed + (message "Jabber connection failed") + (plist-put state-data :disconnection-reason + (mapconcat #'identity (cadr event) "; ")) + (list nil state-data)) + + (:do-disconnect + ;; We don't have the connection object, so defer the disconnection. + :defer))) + +(defsubst jabber-fsm-handle-sentinel (state-data event) + "Handle sentinel event for jabber fsm." + ;; We do the same thing for every state, so avoid code duplication. + (let* ((string (car (cddr event))) + ;; The event string sometimes (always?) has a trailing + ;; newline, that we don't care for. + (trimmed-string + (if (eq ?\n (aref string (1- (length string)))) + (substring string 0 -1) + string)) + (new-state-data + ;; If we already know the reason (e.g. a stream error), don't + ;; overwrite it. + (if (plist-get state-data :disconnection-reason) + state-data + (plist-put state-data :disconnection-reason trimmed-string)))) + (list nil new-state-data))) + +(define-enter-state jabber-connection :connected + (fsm state-data) + + (jabber-send-stream-header fsm) + + ;; Next thing happening is the server sending its own <stream:stream> start tag. + + (list state-data nil)) + +(define-state jabber-connection :connected + (fsm state-data event callback) + (case (or (car-safe event) event) + (:filter + (let ((process (cadr event)) + (string (car (cddr event)))) + (jabber-pre-filter process string fsm) + (list :connected state-data))) + + (:sentinel + (jabber-fsm-handle-sentinel state-data event)) + + (:stream-start + (let ((session-id (cadr event)) + (stream-version (car (cddr event)))) + (setq state-data + (plist-put state-data :session-id session-id)) + ;; the stream feature is only sent if the initiating entity has + ;; sent 1.0 in the stream header. if sasl is not supported then + ;; we don't send 1.0 in the header and therefore we shouldn't wait + ;; even if 1.0 is present in the receiving stream. + (cond + ;; Wait for stream features? + ((and stream-version + (>= (string-to-number stream-version) 1.0) + jabber-use-sasl + (jabber-have-sasl-p)) + ;; Stay in same state... + (list :connected state-data)) + ;; Register account? + ((plist-get state-data :registerp) + ;; XXX: require encryption for registration? + (list :register-account state-data)) + ;; Legacy authentication? + (t + (list :legacy-auth state-data))))) + + (:stanza + (let ((stanza (cadr event))) + (cond + ;; At this stage, we only expect a stream:features stanza. + ((not (eq (jabber-xml-node-name stanza) 'features)) + (list nil (plist-put state-data + :disconnection-reason + (format "Unexpected stanza %s" stanza)))) + ((and (jabber-xml-get-children stanza 'starttls) + (eq (plist-get state-data :connection-type) 'starttls)) + (list :starttls state-data)) + ;; XXX: require encryption for registration? + ((plist-get state-data :registerp) + ;; We could check for the <register/> element in stream + ;; features, but as a client we would only lose by doing + ;; that. + (list :register-account state-data)) + (t + (list :sasl-auth (plist-put state-data :stream-features stanza)))))) + + (:do-disconnect + (jabber-send-string fsm "</stream:stream>") + (list nil (plist-put state-data + :disconnection-expected t))))) + +(define-enter-state jabber-connection :starttls + (fsm state-data) + (jabber-starttls-initiate fsm) + (list state-data nil)) + +(define-state jabber-connection :starttls + (fsm state-data event callback) + (case (or (car-safe event) event) + (:filter + (let ((process (cadr event)) + (string (car (cddr event)))) + (jabber-pre-filter process string fsm) + (list :starttls state-data))) + + (:sentinel + (jabber-fsm-handle-sentinel state-data event)) + + (:stanza + (condition-case e + (progn + (jabber-starttls-process-input fsm (cadr event)) + ;; Connection is encrypted. Send a stream tag again. + (list :connected (plist-put state-data :encrypted t))) + (error + (let* ((msg (concat "STARTTLS negotiation failed: " + (error-message-string e))) + (new-state-data (plist-put state-data :disconnection-reason msg))) + (list nil new-state-data))))) + + (:do-disconnect + (jabber-send-string fsm "</stream:stream>") + (list nil (plist-put state-data + :disconnection-expected t))))) + +(define-enter-state jabber-connection :register-account + (fsm state-data) + (jabber-get-register fsm nil) + (list state-data nil)) + +(define-state jabber-connection :register-account + (fsm state-data event callback) + ;; The connection will be closed in jabber-register + (case (or (car-safe event) event) + (:filter + (let ((process (cadr event)) + (string (car (cddr event)))) + (jabber-pre-filter process string fsm) + (list :register-account state-data))) + + (:sentinel + (jabber-fsm-handle-sentinel state-data event)) + + (:stanza + (or + (jabber-process-stream-error (cadr event) state-data) + (progn + (jabber-process-input fsm (cadr event)) + (list :register-account state-data)))) + + (:do-disconnect + (jabber-send-string fsm "</stream:stream>") + (list nil (plist-put state-data + :disconnection-expected t))))) + +(define-enter-state jabber-connection :legacy-auth + (fsm state-data) + (jabber-get-auth fsm (plist-get state-data :server) + (plist-get state-data :session-id)) + (list state-data nil)) + +(define-state jabber-connection :legacy-auth + (fsm state-data event callback) + (case (or (car-safe event) event) + (:filter + (let ((process (cadr event)) + (string (car (cddr event)))) + (jabber-pre-filter process string fsm) + (list :legacy-auth state-data))) + + (:sentinel + (jabber-fsm-handle-sentinel state-data event)) + + (:stanza + (or + (jabber-process-stream-error (cadr event) state-data) + (progn + (jabber-process-input fsm (cadr event)) + (list :legacy-auth state-data)))) + + (:authentication-success + (jabber-cache-password (jabber-connection-bare-jid fsm) (cdr event)) + (list :session-established state-data)) + + (:authentication-failure + (jabber-uncache-password (jabber-connection-bare-jid fsm)) + ;; jabber-logon has already displayed a message + (list nil (plist-put state-data + :disconnection-expected t))) + + (:do-disconnect + (jabber-send-string fsm "</stream:stream>") + (list nil (plist-put state-data + :disconnection-expected t))))) + +(define-enter-state jabber-connection :sasl-auth + (fsm state-data) + (let ((new-state-data + (plist-put state-data + :sasl-data + (jabber-sasl-start-auth + fsm + (plist-get state-data + :stream-features))))) + (list new-state-data nil))) + +(define-state jabber-connection :sasl-auth + (fsm state-data event callback) + (case (or (car-safe event) event) + (:filter + (let ((process (cadr event)) + (string (car (cddr event)))) + (jabber-pre-filter process string fsm) + (list :sasl-auth state-data))) + + (:sentinel + (jabber-fsm-handle-sentinel state-data event)) + + (:stanza + (let ((new-sasl-data + (jabber-sasl-process-input + fsm (cadr event) + (plist-get state-data :sasl-data)))) + (list :sasl-auth (plist-put state-data :sasl-data new-sasl-data)))) + + (:use-legacy-auth-instead + (list :legacy-auth (plist-put state-data :sasl-data nil))) + + (:authentication-success + (jabber-cache-password (jabber-connection-bare-jid fsm) (cdr event)) + (list :bind (plist-put state-data :sasl-data nil))) + + (:authentication-failure + (jabber-uncache-password (jabber-connection-bare-jid fsm)) + ;; jabber-sasl has already displayed a message + (list nil (plist-put state-data + :disconnection-expected t))) + + (:do-disconnect + (jabber-send-string fsm "</stream:stream>") + (list nil (plist-put state-data + :disconnection-expected t))))) + +(define-enter-state jabber-connection :bind + (fsm state-data) + (jabber-send-stream-header fsm) + (list state-data nil)) + +(define-state jabber-connection :bind + (fsm state-data event callback) + (case (or (car-safe event) event) + (:filter + (let ((process (cadr event)) + (string (car (cddr event)))) + (jabber-pre-filter process string fsm) + (list :bind state-data))) + + (:sentinel + (jabber-fsm-handle-sentinel state-data event)) + + (:stream-start + ;; we wait for stream features... + (list :bind state-data)) + + (:stanza + (let ((stanza (cadr event))) + (cond + ((eq (jabber-xml-node-name stanza) 'features) + ;; Record stream features, discarding earlier data: + (setq state-data (plist-put state-data :stream-features stanza)) + (if (jabber-xml-get-children stanza 'bind) + (let ((handle-bind + (lambda (jc xml-data success) + (fsm-send jc (list + (if success :bind-success :bind-failure) + xml-data)))) + ;; So let's bind a resource. We can either pick a resource ourselves, + ;; or have the server pick one for us. + (resource (plist-get state-data :resource))) + (jabber-send-iq fsm nil "set" + `(bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind")) + ,@(when resource + `((resource () ,resource)))) + handle-bind t + handle-bind nil) + (list :bind state-data)) + (message "Server doesn't permit resource binding") + (list nil state-data))) + (t + (or + (jabber-process-stream-error (cadr event) state-data) + (progn + (jabber-process-input fsm (cadr event)) + (list :bind state-data))))))) + + (:bind-success + (let ((jid (jabber-xml-path (cadr event) '(bind jid "")))) + ;; Maybe this isn't the JID we asked for. + (plist-put state-data :username (jabber-jid-username jid)) + (plist-put state-data :server (jabber-jid-server jid)) + (plist-put state-data :resource (jabber-jid-resource jid))) + + ;; If the server follows the older RFCs 3920 and 3921, it may + ;; offer session initiation here. If it follows RFCs 6120 and + ;; 6121, it might not offer it, and we should just skip it. + (if (jabber-xml-get-children (plist-get state-data :stream-features) 'session) + (let ((handle-session + (lambda (jc xml-data success) + (fsm-send jc (list + (if success :session-success :session-failure) + xml-data))))) + (jabber-send-iq fsm nil "set" + '(session ((xmlns . "urn:ietf:params:xml:ns:xmpp-session"))) + handle-session t + handle-session nil) + (list :bind state-data)) + ;; Session establishment not offered - assume not necessary. + (list :session-established state-data))) + + (:session-success + ;; We have a session + (list :session-established state-data)) + + (:bind-failure + (message "Resource binding failed: %s" + (jabber-parse-error + (jabber-iq-error (cadr event)))) + (list nil state-data)) + + (:session-failure + (message "Session establishing failed: %s" + (jabber-parse-error + (jabber-iq-error (cadr event)))) + (list nil state-data)) + + (:do-disconnect + (jabber-send-string fsm "</stream:stream>") + (list nil (plist-put state-data + :disconnection-expected t))))) + +(define-enter-state jabber-connection :session-established + (fsm state-data) + (jabber-send-iq fsm nil + "get" + '(query ((xmlns . "jabber:iq:roster"))) + #'jabber-process-roster 'initial + #'jabber-initial-roster-failure nil) + (list (plist-put state-data :ever-session-established t) nil)) + +(defvar jabber-pending-presence-timeout 0.5 + "Wait this long before doing presence packet batch processing.") + +(define-state jabber-connection :session-established + (fsm state-data event callback) + (case (or (car-safe event) event) + (:filter + (let ((process (cadr event)) + (string (car (cddr event)))) + (jabber-pre-filter process string fsm) + (list :session-established state-data :keep))) + + (:sentinel + (jabber-fsm-handle-sentinel state-data event)) + + (:stanza + (or + (jabber-process-stream-error (cadr event) state-data) + (progn + (jabber-process-input fsm (cadr event)) + (list :session-established state-data :keep)))) + + (:roster-update + ;; Batch up roster updates + (let* ((jid-symbol-to-update (cdr event)) + (pending-updates (plist-get state-data :roster-pending-updates))) + ;; If there are pending updates, there is a timer running + ;; already; just add the new symbol and wait. + (if pending-updates + (progn + (unless (memq jid-symbol-to-update pending-updates) + (nconc pending-updates (list jid-symbol-to-update))) + (list :session-established state-data :keep)) + ;; Otherwise, we need to create the list and start the timer. + (setq state-data + (plist-put state-data + :roster-pending-updates + (list jid-symbol-to-update))) + (list :session-established state-data jabber-pending-presence-timeout)))) + + (:timeout + ;; Update roster + (let ((pending-updates (plist-get state-data :roster-pending-updates))) + (setq state-data (plist-put state-data :roster-pending-updates nil)) + (jabber-roster-update fsm nil pending-updates nil) + (list :session-established state-data))) + + (:send-if-connected + ;; This is the only state in which we respond to such messages. + ;; This is to make sure we don't send anything inappropriate + ;; during authentication etc. + (jabber-send-sexp fsm (cdr event)) + (list :session-established state-data :keep)) + + (:do-disconnect + (jabber-send-string fsm "</stream:stream>") + (list nil (plist-put state-data + :disconnection-expected t))))) + +(defun jabber-disconnect (&optional arg) + "Disconnect from all Jabber servers. If ARG supplied, disconnect one account." + (interactive "P") + (if arg + (jabber-disconnect-one (jabber-read-account)) + (unless *jabber-disconnecting* ; avoid reentry + (let ((*jabber-disconnecting* t)) + (if (null jabber-connections) + (message "Already disconnected") + (run-hooks 'jabber-pre-disconnect-hook) + (dolist (c jabber-connections) + (jabber-disconnect-one c t)) + (setq jabber-connections nil) + + (jabber-disconnected) + (when (interactive-p) + (message "Disconnected from Jabber server(s)"))))))) + +(defun jabber-disconnect-one (jc &optional dont-redisplay) + "Disconnect from one Jabber server. +If DONT-REDISPLAY is non-nil, don't update roster buffer." + (interactive (list (jabber-read-account))) + (fsm-send-sync jc :do-disconnect) + (when (interactive-p) + (message "Disconnected from %s" + (jabber-connection-jid jc))) + (unless dont-redisplay + (jabber-display-roster))) + +(defun jabber-disconnected () + "Re-initialise jabber package variables. +Call this function after disconnection." + (when (get-buffer jabber-roster-buffer) + (with-current-buffer (get-buffer jabber-roster-buffer) + (let ((inhibit-read-only t)) + (erase-buffer)))) + + (jabber-clear-roster) + (run-hooks 'jabber-post-disconnect-hook)) + +(defun jabber-log-xml (fsm direction data) + "Print DATA to XML console (and, optionally, in file). +If `jabber-debug-log-xml' is nil, do nothing. +FSM is the connection that is sending/receiving. +DIRECTION is a string, either \"sending\" or \"receive\". +DATA is any sexp." + (when jabber-debug-log-xml + (jabber-process-console fsm direction data))) + +(defun jabber-pre-filter (process string fsm) + (with-current-buffer (process-buffer process) + ;; Append new data + (goto-char (point-max)) + (insert string) + + (unless (boundp 'jabber-filtering) + (let (jabber-filtering) + (jabber-filter process fsm))))) + +(defun jabber-filter (process fsm) + "the filter function for the jabber process" + (with-current-buffer (process-buffer process) + ;; Start from the beginning + (goto-char (point-min)) + (let (xml-data) + (loop + do + ;; Skip whitespace + (unless (zerop (skip-chars-forward " \t\r\n")) + (delete-region (point-min) (point))) + ;; Skip processing directive + (when (looking-at "<\\?xml[^?]*\\?>") + (delete-region (match-beginning 0) (match-end 0))) + + ;; Stream end? + (when (looking-at "</stream:stream>") + (return (fsm-send fsm :stream-end))) + + ;; Stream header? + (when (looking-at "<stream:stream[^>]*\\(>\\)") + ;; Let's pretend that the stream header is a closed tag, + ;; and parse it as such. + (replace-match "/>" t t nil 1) + (let* ((ending-at (point)) + (stream-header (car (xml-parse-region (point-min) ending-at))) + (session-id (jabber-xml-get-attribute stream-header 'id)) + (stream-version (jabber-xml-get-attribute stream-header 'version))) + + ;; Need to keep any namespace attributes on the stream + ;; header, as they can affect any stanza in the + ;; stream... + (setq jabber-namespace-prefixes + (jabber-xml-merge-namespace-declarations + (jabber-xml-node-attributes stream-header) + nil)) + (jabber-log-xml fsm "receive" stream-header) + (fsm-send fsm (list :stream-start session-id stream-version)) + (delete-region (point-min) ending-at))) + + ;; Normal tag + + ;; XXX: do these checks make sense? If so, reinstate them. + ;;(if (active-minibuffer-window) + ;; (run-with-idle-timer 0.01 nil #'jabber-filter process string) + + ;; This check is needed for xml.el of Emacs 21, as it chokes on + ;; empty attribute values. + (save-excursion + (while (search-forward-regexp " \\w+=''" nil t) + (replace-match ""))) + + (setq xml-data (jabber-xml-parse-next-stanza)) + + while xml-data + do + ;; If there's a problem with writing the XML log, + ;; make sure the stanza is delivered, at least. + (condition-case e + (jabber-log-xml fsm "receive" (car xml-data)) + (error + (ding) + (message "Couldn't write XML log: %s" (error-message-string e)) + (sit-for 2))) + (delete-region (point-min) (point)) + + (fsm-send fsm (list :stanza + (jabber-xml-resolve-namespace-prefixes + (car xml-data) nil jabber-namespace-prefixes))) + ;; XXX: move this logic elsewhere + ;; We explicitly don't catch errors in jabber-process-input, + ;; to facilitate debugging. + ;; (jabber-process-input (car xml-data)) + )))) + +(defun jabber-process-input (jc xml-data) + "process an incoming parsed tag" + (let* ((tag (jabber-xml-node-name xml-data)) + (functions (eval (cdr (assq tag '((iq . jabber-iq-chain) + (presence . jabber-presence-chain) + (message . jabber-message-chain))))))) + (dolist (f functions) + (condition-case e + (funcall f jc xml-data) + ((debug error) + (fsm-debug-output "Error %S while processing %S with function %s" e xml-data f)))))) + +(defun jabber-process-stream-error (xml-data state-data) + "Process an incoming stream error. +Return nil if XML-DATA is not a stream:error stanza. +Return an fsm result list if it is." + (when (and (eq (jabber-xml-node-name xml-data) 'error) + (equal (jabber-xml-get-xmlns xml-data) "http://etherx.jabber.org/streams")) + (let ((condition (jabber-stream-error-condition xml-data)) + (text (jabber-parse-stream-error xml-data))) + (setq state-data (plist-put state-data :disconnection-reason + (format "Stream error: %s" text))) + ;; Special case: when the error is `conflict', we have been + ;; forcibly disconnected by the same user. Don't reconnect + ;; automatically. + (when (eq condition 'conflict) + (setq state-data (plist-put state-data :disconnection-expected t))) + (list nil state-data)))) + +;; XXX: This function should probably die. The roster is stored +;; inside the connection plists, and the obarray shouldn't be so big +;; that we need to clean it. +(defun jabber-clear-roster () + "Clean up the roster." + ;; This is made complicated by the fact that the JIDs are symbols with properties. + (mapatoms #'(lambda (x) + (unintern x jabber-jid-obarray)) + jabber-jid-obarray) + (setq *jabber-roster* nil)) + +(defun jabber-send-sexp (jc sexp) + "Send the xml corresponding to SEXP to connection JC." + (condition-case e + (jabber-log-xml jc "sending" sexp) + (error + (ding) + (message "Couldn't write XML log: %s" (error-message-string e)) + (sit-for 2))) + (jabber-send-string jc (jabber-sexp2xml sexp))) + +(defun jabber-send-sexp-if-connected (jc sexp) + "Send the stanza SEXP only if JC has established a session." + (fsm-send-sync jc (cons :send-if-connected sexp))) + +(defun jabber-send-stream-header (jc) + "Send stream header to connection JC." + (let ((stream-header + (concat "<?xml version='1.0'?><stream:stream to='" + (plist-get (fsm-get-state-data jc) :server) + "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams'" + ;; Not supporting SASL is not XMPP compliant, + ;; so don't pretend we are. + (if (and (jabber-have-sasl-p) jabber-use-sasl) + " version='1.0'" + "") + "> +"))) + (jabber-log-xml jc "sending" stream-header) + (jabber-send-string jc stream-header))) + +(defun jabber-send-string (jc string) + "Send STRING to the connection JC." + (let* ((state-data (fsm-get-state-data jc)) + (connection (plist-get state-data :connection)) + (send-function (plist-get state-data :send-function))) + (unless connection + (error "%s has no connection" (jabber-connection-jid jc))) + (funcall send-function connection string))) + +(provide 'jabber-core) + +;;; arch-tag: 9d273ce6-c45a-447b-abf3-21d3ce73a51a |