branch: elpa/jabber
commit 798f2aa6b51db74b5a7174afed8b7383512983c4
Author: Thanos Apollo <[email protected]>
Commit: Thanos Apollo <[email protected]>
stanza: Separate shared state and transport
---
lisp/jabber-sm-runtime.el | 2 +-
lisp/jabber-stanza.el | 138 ++++++++++++++++++++++++++++++++++++
lisp/jabber-state.el | 72 +++++++++++++++++++
lisp/jabber-util.el | 175 +---------------------------------------------
4 files changed, 213 insertions(+), 174 deletions(-)
diff --git a/lisp/jabber-sm-runtime.el b/lisp/jabber-sm-runtime.el
index bc0e2cc56b..a08c67c3ba 100644
--- a/lisp/jabber-sm-runtime.el
+++ b/lisp/jabber-sm-runtime.el
@@ -20,7 +20,7 @@
(require 'fsm)
(require 'jabber-sm)
-(require 'jabber-util)
+(require 'jabber-stanza)
(defun jabber-sm--count-inbound (jc state-data stanza)
"Record inbound STANZA and send a periodic acknowledgement when due.
diff --git a/lisp/jabber-stanza.el b/lisp/jabber-stanza.el
new file mode 100644
index 0000000000..d36f1f0654
--- /dev/null
+++ b/lisp/jabber-stanza.el
@@ -0,0 +1,138 @@
+;;; jabber-stanza.el --- Jabber stanza transport -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2026 Thanos Apollo
+
+;; Maintainer: Thanos Apollo <[email protected]>
+
+;; 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.
+
+;;; Commentary:
+
+;; Serialize, transmit, and dispatch XMPP stanzas. Stream Management state
+;; transformations remain in `jabber-sm'; this module applies them at the
+;; network boundary.
+
+;;; Code:
+
+(require 'fsm)
+(require 'jabber-sm)
+(require 'jabber-state)
+(require 'jabber-xml)
+
+(defconst jabber-bind-xmlns "urn:ietf:params:xml:ns:xmpp-bind"
+ "RFC 6120 resource binding namespace.")
+
+(defconst jabber-session-xmlns "urn:ietf:params:xml:ns:xmpp-session"
+ "RFC 6120 session establishment namespace.")
+
+(defconst jabber-streams-xmlns "http://etherx.jabber.org/streams";
+ "RFC 6120 XMPP streams namespace.")
+
+(defvar jabber-debug-log-xml) ; jabber-console.el
+(declare-function jabber-process-console "jabber-console" (jc direction
xml-data))
+
+(defun jabber-log-xml (jc direction data)
+ "Log DATA for JC in DIRECTION when XML debugging is enabled."
+ (when jabber-debug-log-xml
+ (jabber-process-console jc direction data)))
+
+(defun jabber-stanza--connection-jid (state-data)
+ "Return the full JID represented by STATE-DATA."
+ (concat (plist-get state-data :username) "@"
+ (plist-get state-data :server) "/"
+ (plist-get state-data :resource)))
+
+(defun jabber-send-string (jc string)
+ "Send STRING through 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-stanza--connection-jid state-data)))
+ (funcall send-function connection string)))
+
+(defun jabber-send-sexp--raw (jc sexp)
+ "Send SEXP to JC without updating Stream Management state."
+ (condition-case err
+ (jabber-log-xml jc "sending" sexp)
+ (error
+ (ding)
+ (message "Couldn't write XML log: %s" (error-message-string err))
+ (sit-for 2)))
+ (let* ((xml (jabber-sexp2xml sexp))
+ (state-data (fsm-get-state-data jc))
+ (sm-countable (and (plist-get state-data :sm-enabled)
+ (jabber-sm--stanza-p sexp))))
+ (jabber-send-string
+ jc
+ (if sm-countable
+ (concat xml (jabber-sm--make-request-xml))
+ xml))))
+
+(defun jabber-send-sexp--immediate (jc sexp)
+ "Send SEXP to JC immediately and update Stream Management state."
+ (jabber-send-sexp--raw jc sexp)
+ (jabber-sm--count-outbound (fsm-get-state-data jc) sexp))
+
+(defun jabber-send-sexp (jc sexp)
+ "Send SEXP to JC, respecting Stream Management back-pressure."
+ (let ((state-data (fsm-get-state-data jc)))
+ (if (jabber-sm--should-queue-p state-data sexp)
+ (progn
+ (jabber-sm--enqueue-pending state-data sexp)
+ (when (eq (jabber-xml-node-name sexp) 'message)
+ (message "SM: message queued (waiting for server ack, %d pending)"
+ (length (plist-get state-data :sm-pending-queue)))))
+ (jabber-send-sexp--immediate jc sexp))))
+
+(defun jabber-send-sexp-if-connected (jc sexp)
+ "Send SEXP through JC only after its session is established."
+ (fsm-send-sync jc (cons :send-if-connected sexp)))
+
+(defvar jabber-use-sasl) ; jabber-core.el
+
+(defsubst jabber-have-sasl-p ()
+ "Return non-nil when the SASL library is available."
+ (featurep 'sasl))
+
+(defun jabber-send-stream-header (jc)
+ "Send the opening XML stream header to JC."
+ (let* ((state-data (fsm-get-state-data jc))
+ (header
+ (concat "<?xml version='1.0'?><stream:stream to='"
+ (plist-get state-data :server)
+ "' xmlns='jabber:client'
xmlns:stream='http://etherx.jabber.org/streams'"
+ (if (and (jabber-have-sasl-p) jabber-use-sasl)
+ " version='1.0'"
+ "")
+ ">\n")))
+ (jabber-log-xml jc "sending" header)
+ (jabber-send-string jc header)))
+
+(defvar jabber-xml-data) ; jabber.el
+
+(defun jabber-process-input (jc xml-data)
+ "Dispatch XML-DATA received on JC through its stanza handler chain."
+ (let* ((jabber-xml-data xml-data)
+ (tag (jabber-xml-node-name xml-data))
+ (handlers (pcase tag
+ ('iq jabber-iq-chain)
+ ('presence jabber-presence-chain)
+ ('message jabber-message-chain))))
+ (dolist (entry handlers)
+ (let ((handler (if (consp entry) (cdr entry) entry)))
+ (condition-case err
+ (funcall handler jc xml-data)
+ ((debug error)
+ (fsm-debug-output "Error %S while processing %S with function %s"
+ err xml-data handler)))))))
+
+(provide 'jabber-stanza)
+
+;;; jabber-stanza.el ends here
diff --git a/lisp/jabber-state.el b/lisp/jabber-state.el
new file mode 100644
index 0000000000..2720c8f12b
--- /dev/null
+++ b/lisp/jabber-state.el
@@ -0,0 +1,72 @@
+;;; jabber-state.el --- Shared Jabber state -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2026 Thanos Apollo
+
+;; Maintainer: Thanos Apollo <[email protected]>
+
+;; 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.
+
+;;; Commentary:
+
+;; State shared by the connection FSM and protocol handlers lives here. This
+;; module has no network, database, or user-interface effects.
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defvar jabber-connections nil
+ "List of Jabber connection FSMs.")
+
+(define-obsolete-variable-alias '*jabber-roster*
+ 'jabber-roster-list "0.11.0")
+(defvar jabber-roster-list nil
+ "The roster list.")
+
+(defvar jabber-jid-obarray (make-vector 127 0)
+ "Obarray for interned JIDs.")
+
+(define-obsolete-variable-alias '*jabber-disconnecting*
+ 'jabber-disconnecting "0.11.0")
+(defvar jabber-disconnecting nil
+ "Non-nil while voluntarily disconnecting.")
+
+(defvar jabber-message-chain nil
+ "Ordered handlers for incoming message stanzas.")
+
+(defvar jabber-iq-chain nil
+ "Ordered handlers for incoming IQ stanzas.")
+
+(defvar jabber-presence-chain nil
+ "Ordered handlers for incoming presence stanzas.")
+
+;;;###autoload
+(defun jabber-chain-add (chain-var handler &optional depth)
+ "Add HANDLER to CHAIN-VAR at numeric priority DEPTH.
+Lower depths run first. Bare function entries from older versions are
+accepted when checking for an existing handler."
+ (let ((entry (cons (or depth 0) handler))
+ (entry-depth (lambda (item) (if (consp item) (car item) 0)))
+ (entry-function (lambda (item) (if (consp item) (cdr item) item))))
+ (unless (cl-find handler (symbol-value chain-var) :key entry-function)
+ (set chain-var
+ (sort (cons entry (symbol-value chain-var))
+ (lambda (a b)
+ (< (funcall entry-depth a)
+ (funcall entry-depth b))))))))
+
+(defun jabber-clear-roster ()
+ "Clear all interned roster state."
+ (mapatoms (lambda (jid)
+ (unintern jid jabber-jid-obarray))
+ jabber-jid-obarray)
+ (setq jabber-roster-list nil))
+
+(provide 'jabber-state)
+
+;;; jabber-state.el ends here
diff --git a/lisp/jabber-util.el b/lisp/jabber-util.el
index b5619f9220..78d6eb4929 100644
--- a/lisp/jabber-util.el
+++ b/lisp/jabber-util.el
@@ -30,8 +30,9 @@
;;; Code:
(require 'cl-lib)
+(require 'jabber-state)
+(require 'jabber-stanza)
(require 'jabber-xml)
-(require 'jabber-sm)
(require 'fsm)
(require 'password-cache)
@@ -895,177 +896,5 @@ Matches the \"[LABEL: could not decrypt]\" bodies
produced by
message text with a placeholder."
(and body (string-match-p "\\`\\[.*: could not decrypt\\]\\'" body)))
-;;; Connection state primitives
-
-(defconst jabber-bind-xmlns "urn:ietf:params:xml:ns:xmpp-bind"
- "RFC 6120 resource binding namespace.")
-
-(defconst jabber-session-xmlns "urn:ietf:params:xml:ns:xmpp-session"
- "RFC 6120 session establishment namespace.")
-
-(defconst jabber-streams-xmlns "http://etherx.jabber.org/streams";
- "RFC 6120 XMPP streams namespace.")
-
-(defvar jabber-connections nil
- "List of jabber-connection FSMs.")
-
-(define-obsolete-variable-alias '*jabber-roster*
- 'jabber-roster-list "0.11.0")
-(defvar jabber-roster-list nil
- "The roster list.")
-
-(defvar jabber-jid-obarray (make-vector 127 0)
- "Obarray for keeping JIDs.")
-
-(define-obsolete-variable-alias '*jabber-disconnecting*
- 'jabber-disconnecting "0.11.0")
-(defvar jabber-disconnecting nil
- "Non-nil if are we in the process of voluntary disconnection.")
-
-(defvar jabber-message-chain nil
- "Incoming messages are sent to these functions, in order.
-Each entry is a cons (DEPTH . HANDLER). Lower depth runs first.")
-
-(defvar jabber-iq-chain nil
- "Incoming infoqueries are sent to these functions, in order.
-Each entry is a cons (DEPTH . HANDLER). Lower depth runs first.")
-
-(defvar jabber-presence-chain nil
- "Incoming presence notifications are sent to these functions, in order.
-Each entry is a cons (DEPTH . HANDLER). Lower depth runs first.")
-
-;;;###autoload
-(defun jabber-chain-add (chain-var handler &optional depth)
- "Add HANDLER to stanza processing chain CHAIN-VAR.
-DEPTH is numeric priority (default 0). Lower runs first.
-Tolerates bare function entries from old-style registrations."
- (let ((entry (cons (or depth 0) handler))
- (entry-depth (lambda (e) (if (consp e) (car e) 0)))
- (entry-fn (lambda (e) (if (consp e) (cdr e) e))))
- (unless (cl-find handler (symbol-value chain-var) :key entry-fn)
- (set chain-var
- (sort (cons entry (symbol-value chain-var))
- (lambda (a b)
- (< (funcall entry-depth a)
- (funcall entry-depth b))))))))
-
-;;; Stanza transmission
-
-(defvar jabber-debug-log-xml) ; jabber-console.el
-(declare-function jabber-process-console "jabber-console" (jc direction
xml-data))
-
-(defun jabber-log-xml (fsm direction data)
- "Print DATA to XML console.
-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-send-sexp--raw (jc sexp)
- "Send SEXP to JC without updating Stream Management state.
-Log the XML and append an <r/> request when SM is enabled for a
-countable stanza."
- (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)))
- (let* ((xml (jabber-sexp2xml sexp))
- (state-data (fsm-get-state-data jc))
- (sm-countable (and (plist-get state-data :sm-enabled)
- (jabber-sm--stanza-p sexp))))
- (if sm-countable
- (jabber-send-string jc (concat xml (jabber-sm--make-request-xml)))
- (jabber-send-string jc xml))))
-
-(defun jabber-send-sexp--immediate (jc sexp)
- "Send SEXP to JC immediately, bypassing the back-pressure gate.
-Update Stream Management state after transmitting the stanza."
- (jabber-send-sexp--raw jc sexp)
- (jabber-sm--count-outbound (fsm-get-state-data jc) sexp))
-
-(defun jabber-send-sexp (jc sexp)
- "Send the xml corresponding to SEXP to connection JC.
-When SM back-pressure is active and the in-flight limit is reached,
-queue the stanza for later delivery instead of sending immediately."
- (let ((state-data (fsm-get-state-data jc)))
- (if (jabber-sm--should-queue-p state-data sexp)
- (progn
- (jabber-sm--enqueue-pending state-data sexp)
- (when (eq (jabber-xml-node-name sexp) 'message)
- (message "SM: message queued (waiting for server ack, %d pending)"
- (length (plist-get state-data :sm-pending-queue)))))
- (jabber-send-sexp--immediate jc 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-string (jc string)
- "Send STRING through 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)))
-
-(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)))
-
-;;; Stanza dispatch
-
-(defvar jabber-xml-data) ; jabber.el
-
-(defun jabber-process-input (jc xml-data)
- "Process an incoming parsed tag.
-
-JC is the Jabber connection.
-XML-DATA is the parsed tree data from the stream (stanzas)
-obtained from `xml-parse-region'."
- (let* ((jabber-xml-data xml-data)
- (tag (jabber-xml-node-name xml-data))
- (functions (pcase tag
- ('iq jabber-iq-chain)
- ('presence jabber-presence-chain)
- ('message jabber-message-chain))))
- (dolist (entry functions)
- (let ((f (if (consp entry) (cdr entry) entry)))
- (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-clear-roster ()
- "Clean up the roster."
- (mapatoms (lambda (x)
- (unintern x jabber-jid-obarray))
- jabber-jid-obarray)
- (setq jabber-roster-list nil))
-
-;;; SASL check
-
-(defvar jabber-use-sasl) ; jabber-core.el
-
-(defsubst jabber-have-sasl-p ()
- "Return non-nil if SASL library is available."
- (featurep 'sasl))
-
(provide 'jabber-util)
;;; jabber-util.el ends here
