pax_global_header00006660000000000000000000000064151661011350014511gustar00rootroot0000000000000052 comment=2e7019fc32e26b0f05036bfa13d3a01c5a183c85 emacs-jabber/000077500000000000000000000000001516610113500133705ustar00rootroot00000000000000emacs-jabber/.dir-locals.el000066400000000000000000000000511516610113500160150ustar00rootroot00000000000000((org-mode . ((org-tags-column . -60)))) emacs-jabber/.elpaignore000066400000000000000000000001351516610113500155150ustar00rootroot00000000000000tests src/picomemo/.github src/picomemo/test src/picomemo/example src/picomemo/.clang-format emacs-jabber/.gitignore000066400000000000000000000001671516610113500153640ustar00rootroot00000000000000*.elc *~ \#* *.tar* *.zip jabber-autoloads.el /jabber-pkg.el jabber.info .worktrees/ .test-results/ src/*.so lisp/*.so emacs-jabber/.gitmodules000066400000000000000000000001421516610113500155420ustar00rootroot00000000000000[submodule "src/picomemo"] path = src/picomemo url = https://github.com/mierenhoop/picomemo.git emacs-jabber/CHANGELOG.org000066400000000000000000000354111516610113500153740ustar00rootroot00000000000000#+TITLE: Changelog * [0.10.5] #+date: 2026-04-10 ** Fixes - OMEMO JIT build prompt now discloses network fetch from github.com - OMEMO module no longer auto-fetches in batch mode (Emacs network policy) - OMEMO module init hardened: graceful degradation without module support, nil-safe path resolution, single prompt per session - Use gmake on BSD for OMEMO module build ** Improved - ELPA users guided to clone and build OMEMO module manually - README documents OMEMO build for ELPA and package-vc users ** Internal - Fixed native-comp warnings (declare-function for jabber-chain-add, jabber-process-ping, ewoc-data, encode-hex-string, auth-source-search) - Added make lint-native-comp target - Added ;;; Commentary: and ;;; Code: sections to 30 legacy files * [0.10.4] #+date: 2026-04-08 ** Fixes - OMEMO module install path autodetected for ELPA layout (build no longer fails when ~lisp/~ subdirectory is absent) ** Internal - Silenced native-comp warnings in jabber-message-reply and jabber-moderation * [0.10.3] #+date: 2026-04-06 ** Fixes - OMEMO JIT build finds source path in ELPA installs - Picomemo fallback clone for ELPA tarballs (submodule not populated) - History import no longer stores empty account string - Exclude picomemo test/example files from ELPA tarball ** Internal - MAM decoupled from display via hooks - Chat backlog loaded from local DB instead of MAM - Removed legacy SSL connection method * [0.10.2] #+date: 2026-04-04 ** Fixes - OMEMO module now optional: graceful degradation when native module is absent - D-Bus notifications guard for Windows: no longer kills alert chain - Roster refresh crash with multiple windows - OMEMO trust commands guard without native module * [0.10.1] #+date: 2026-04-03 ** New XEP implementations - XEP-0163 Personal Eventing Protocol - XEP-0368 SRV Records for XMPP over TLS (Direct TLS) ** Features - Idle time support for Windows - Deduplicated JID completion with annotated candidates ** Fixes - PubSub node handler duplicate registration on repeated loads - OpenPGP key refetch skipped when key already in local keyring ** Compliance - Achieves Advanced Core compliance (XEP-0479 Compliance Suites 2023) * [0.10.0] #+date: 2026-04-02 ** Breaking changes - Minimum Emacs version raised to 29.1 - Flat-file message history replaced with SQLite (~jabber-db.el~) - Many obsolete modules removed (see commit history for full list) ** New XEP implementations - XEP-0060 Publish-Subscribe - XEP-0184 Delivery Receipts and XEP-0333 Chat Markers - XEP-0191 Blocking Command - XEP-0198 Stream Management with resume - XEP-0249 Direct MUC Invitations - XEP-0280 Message Carbons - XEP-0308 Last Message Correction - XEP-0313 Message Archive Management - XEP-0352 Client State Indication - XEP-0373 OpenPGP for XMPP - XEP-0384 OMEMO 0.3 encryption (requires native module build) - XEP-0393 Message Styling - XEP-0402 PEP Native Bookmarks - XEP-0410 MUC Self-Ping - XEP-0424/0425 Message Retraction and Moderation - XEP-0454 OMEMO Media Sharing - XEP-0461 Message Replies ** Features - SQLite message storage with full-text search - Inline image display and encrypted media (aesgcm://) - Typing indicators, delivery receipts, and read markers in chat buffers - Encryption indicator in header line (OMEMO, OpenPGP, plaintext) - Message correction, reply, retraction - Stream Management with automatic resume on reconnect - Disco-prioritized MUC autojoin (smallest rooms first) - Room preservation and self-ping across reconnect - MUC notification filtering (~all~, ~mentions~, ~nil~) - OMEMO trust management UI and device management - Modernized roster display - Unified modeline with activity tracking - Auto-reconnect enabled by default ** Security - [[https://www.cvedetails.com/cve/CVE-2017-5589/][CVE-2017-5589]]: Message Carbons validates sender JID to prevent spoofed carbon copies - Receipt handling guards against MAM replay - OMEMO trust filtering at encrypt time * [0.9.0] :PROPERTIES: :CUSTOM_ID: v0.9.0 :END: ** Enable carbons by default :PROPERTIES: :CUSTOM_ID: enable-carbons-by-default :END: Enable support for XEP-0280 (message carbons) by default. ** Support for reading passwords from netrc/authinfo files :PROPERTIES: :CUSTOM_ID: support-reading-passwords-from-netrc-authinfo-files :END: Use "machine example.com login username password s3cret port xmpp". ** Provide MUC presence announcement formatting :PROPERTIES: :CUSTOM_ID: provide-muc-presence-announcement-formatting :END: Provide customization to limit, highlight, or deemphasize MUC presence announcements. See the manual for details (info "(jabber) Presence announcements"). ** Support for roster's groups roll state saving :PROPERTIES: :CUSTOM_ID: support-rosters-groups-roll-state-saving :END: ** Full support for XEP-0012 :PROPERTIES: :CUSTOM_ID: full-support-xep-001 :END: Response of idle time. ** Support for XEP-0202 :PROPERTIES: :CUSTOM_ID: support-xep-020 :END: Entity Time for request/response time as main method. ** Support for automatic MUC nicks colorization :PROPERTIES: :CUSTOM_ID: support-automatic-muc-nicks-colorization :END: See "Customizing the chat buffer" in the manual. ** XML Console :PROPERTIES: :CUSTOM_ID: xml-console :END: Log all received/sending XML stanzas into special buffer. Also can be used to send custom XML stanzas manually. ** Autoaway :PROPERTIES: :CUSTOM_ID: autoaway :END: Support for list of autoaway methods. Support for Xa. See section "Autoaway" in manual. ** MUC :PROPERTIES: :CUSTOM_ID: muc :END: MUC participants list format is now customizable: see jabber-muc-print-names-format in manual. Also, participants sorted by role. ** Treat XML namespace prefixes correctly :PROPERTIES: :CUSTOM_ID: treat-xml-namespace-prefixes-correctly :END: A change in the Google Talk server has brought to light the fact that jabber.el didn't handle XML namespace prefixes correctly. This should be fixed by the new jabber-xml-resolve-namespace-prefixes function. * [0.8] :PROPERTIES: :CUSTOM_ID: v0.8 :END: ** Added :PROPERTIES: :CUSTOM_ID: added :END: *** Support for multiple accounts :PROPERTIES: :CUSTOM_ID: support-multiple-accounts :END: Configuration variables have changed. See section "Account settings" in the manual. *** Activity mode improved :PROPERTIES: :CUSTOM_ID: activity-mode-improved :END: Customizable face for personal messages added, list of unwanted (banned) JIDs added *** Simple automatic answering machine :PROPERTIES: :CUSTOM_ID: simple-automatic-answering-machine :END: Realized as alert. Can match regexp and answer with predefined string *** OSD alerts (message, MUC, MUC-personal) :PROPERTIES: :CUSTOM_ID: osd-alerts-message,-muc,-muc-personal :END: *** Family of personal MUC alerts added :PROPERTIES: :CUSTOM_ID: family-personal-muc-alerts-added :END: See section "Standard alerts" in manual. *** MUC nicks completion :PROPERTIES: :CUSTOM_ID: muc-nicks-completion :END: See section "Groupchat" in manual. *** Automatic reconnection :PROPERTIES: :CUSTOM_ID: automatic-reconnection :END: Not enabled by default; See "Reconnecting" section in manual. *** Support for XEP-0085 :PROPERTIES: :CUSTOM_ID: support-xep-008 :END: This means "contact is typing" notifications when chatting with Gajim or Google Talk users, among others. See "Typing notifications" section in the manual. *** Option: hide offline contacts in roster :PROPERTIES: :CUSTOM_ID: option-hide-offline-contacts-roster :END: See "The roster buffer" in manual. *** Clean history from chat buffers :PROPERTIES: :CUSTOM_ID: clean-history-from-chat-buffers :END: See jabber-truncate-* functions and new options for jabber-alert-muc-hooks and jabber-alert-message-hooks. See section "Message history" in manual too. *** MUC bookmarks :PROPERTIES: :CUSTOM_ID: muc-bookmarks :END: See jabber-edit-bookmarks function and "Bookmarks" section in manual. *** Name of browse buffers customizable :PROPERTIES: :CUSTOM_ID: name-browse-buffers-customizable :END: See "Services" section in manual. *** Subscription requests are sent to chat buffers :PROPERTIES: :CUSTOM_ID: subscription-requests-are-sent-to-chat-buffers :END: Subscription requests now displayed in chat buffers. See "Presence subscription" section in manual. *** Option: hide avatar in chat buffer :PROPERTIES: :CUSTOM_ID: option-hide-avatar-chat-buffer :END: `jabber-chat-buffer-show-avatar'. *** Gmail notifications :PROPERTIES: :CUSTOM_ID: gmail-notifications :END: (Not documented nor autoloaded) *** GConf-based installation of URI handler :PROPERTIES: :CUSTOM_ID: gconf-based-installation-uri-handler :END: See "XMPP URIs" in manual. * [0.7.1] :PROPERTIES: :CUSTOM_ID: v0.7.1 :END: ** Added :PROPERTIES: :CUSTOM_ID: v0.7.1-added :END: *** STARTTLS :PROPERTIES: :CUSTOM_ID: starttls :END: *** SRV records :PROPERTIES: :CUSTOM_ID: srv-records :END: Requires No Gnus. *** Message composition buffer :PROPERTIES: :CUSTOM_ID: message-composition-buffer :END: Try jabber-compose. *** XMPP URIs are handled :PROPERTIES: :CUSTOM_ID: xmpp-uris-are-handled :END: See manual for setup. *** Autoaway :PROPERTIES: :CUSTOM_ID: autoaway-1 :END: *** MUC features :PROPERTIES: :CUSTOM_ID: muc-features :END: **** Don't display alerts for your own messages :PROPERTIES: :CUSTOM_ID: dont-display-alerts-your-own-messages :END: See jabber-muc-alert-self. **** Presence changes are sent to MUC rooms too :PROPERTIES: :CUSTOM_ID: presence-changes-are-sent-to-muc-rooms-too :END: **** Check room features before joining :PROPERTIES: :CUSTOM_ID: check-room-features-before-joining :END: *** Avatars :PROPERTIES: :CUSTOM_ID: avatars :END: Viewing and publishing JEP-0153 avatars (vCard-based) is now supported. *** File transfer :PROPERTIES: :CUSTOM_ID: file-transfer :END: *** Sound files per contact for alerts :PROPERTIES: :CUSTOM_ID: sound-files-per-contact-alerts :END: *** Per-user history files changed :PROPERTIES: :CUSTOM_ID: per-user-history-files-changed :END: For some time after 0.7 these file names erroneously contained double quotes. If you have used the CVS version you'll need to rename your history files manually. *** New function: jabber-send-directed-presence :PROPERTIES: :CUSTOM_ID: new-function-jabber-send-directed-presence :END: *** Entity time supported (XEP-0090) :PROPERTIES: :CUSTOM_ID: entity-time-supported-xep-0090 :END: *** Last activity supported (XEP-0012) :PROPERTIES: :CUSTOM_ID: last-activity-supported-xep-0012 :END: * [0.7] :PROPERTIES: :CUSTOM_ID: v0.7 :END: ** Added :PROPERTIES: :CUSTOM_ID: v0.7-added :END: *** SSL connections possible :PROPERTIES: :CUSTOM_ID: ssl-connections-possible :END: See variable `jabber-connection-type'. *** Chat buffers rewritten :PROPERTIES: :CUSTOM_ID: chat-buffers-rewritten :END: New modular design gives increased extensibility. **** Received URLs are displayed :PROPERTIES: :CUSTOM_ID: received-urls-are-displayed :END: **** Long lines are filled :PROPERTIES: :CUSTOM_ID: long-lines-are-filled :END: See jabber-chat-fill-long-lines. **** Rare timestamps are printed by default :PROPERTIES: :CUSTOM_ID: rare-timestamps-are-printed-by-default :END: See jabber-print-rare-time and jabber-rare-time-format. *** MUC features :PROPERTIES: :CUSTOM_ID: muc-features-1 :END: **** Different default nicknames for different MUC rooms :PROPERTIES: :CUSTOM_ID: different-default-nicknames-different-muc-rooms :END: See jabber-muc-default-nicknames. **** Autojoin MUC rooms on connection :PROPERTIES: :CUSTOM_ID: autojoin-muc-rooms-on-connection :END: See jabber-muc-autojoin. **** Change nickname :PROPERTIES: :CUSTOM_ID: change-nickname :END: Actually simply an alias from jabber-muc-nick to jabber-muc-join. **** Invitations :PROPERTIES: :CUSTOM_ID: invitations :END: Both sending and receiving invitiations is supported. **** Basic affiliation change support :PROPERTIES: :CUSTOM_ID: basic-affiliation-change-support :END: (Not finished) **** Private MUC messages :PROPERTIES: :CUSTOM_ID: private-muc-messages :END: **** Support for setting and displaying topic :PROPERTIES: :CUSTOM_ID: support-setting-displaying-topic :END: *** Global key bindings :PROPERTIES: :CUSTOM_ID: global-key-bindings :END: Global keymap under C-x C-j. *** Vcard viewer and editor :PROPERTIES: :CUSTOM_ID: vcard-viewer-editor :END: *** Roster export :PROPERTIES: :CUSTOM_ID: roster-export :END: *** Message events (JEP-0022) :PROPERTIES: :CUSTOM_ID: message-events-jep-0022 :END: *** Easy way to define external notifiers :PROPERTIES: :CUSTOM_ID: easy-way-to-define-external-notifiers :END: See define-jabber-alert. Alerts for Festival (speech synthesis), Sawfish, and xmessage added. *** Activity mode improved :PROPERTIES: :CUSTOM_ID: activity-mode-improved-1 :END: Can now display count in frame title. Update hook added. *** Roster display optimized :PROPERTIES: :CUSTOM_ID: roster-display-optimized :END: *** Optionally use per-contact history files :PROPERTIES: :CUSTOM_ID: optionally-use-per-contact-history-files :END: *** Jabber menu in menubar not enabled by default :PROPERTIES: :CUSTOM_ID: jabber-menu-menubar-not-enabled-by-default :END: Call jabber-menu to have it there. *** Flyspell in chat buffers :PROPERTIES: :CUSTOM_ID: flyspell-chat-buffers :END: Flyspell will only spell check what you're currently writing. *** Different time formats for instant and delayed messages :PROPERTIES: :CUSTOM_ID: different-time-formats-instant-delayed-messages :END: See `jabber-chat-time-format' and `jabber-chat-delayed-time-format'. You can see the complete timestamp in a tooltip by holding the mouse over the prompt. *** Chat buffers in inactive windows are scrolled :PROPERTIES: :CUSTOM_ID: chat-buffers-inactive-windows-are-scrolled :END: *** Roster is sorted by name also :PROPERTIES: :CUSTOM_ID: roster-is-sorted-by-name-also :END: * [0.6.1] :PROPERTIES: :CUSTOM_ID: v0.6.1 :END: ** Added :PROPERTIES: :CUSTOM_ID: v0.6.1-added :END: *** Message history :PROPERTIES: :CUSTOM_ID: message-history :END: Set jabber-history-enabled to t to activate it. *** Backlogs :PROPERTIES: :CUSTOM_ID: backlogs :END: If you have history enabled, the last few messages are inserted when you open a new chat buffer. *** Activity tracking on the mode line :PROPERTIES: :CUSTOM_ID: activity-tracking-on-mode-line :END: Activate it with M-x jabber-activity-mode. *** Receive an alert when a specific person goes online :PROPERTIES: :CUSTOM_ID: receive-alert-when-specific-person-goes-online :END: Use it with M-x jabber-watch-add. *** Support for /me in chats (xep-0245, except XHTML-IM) :PROPERTIES: :CUSTOM_ID: support-me-chats-xep-0245,-except-xhtml-im :END: As in "/me laughs" etc. *** Message alerts for current buffer can be disabled :PROPERTIES: :CUSTOM_ID: message-alerts-current-buffer-can-be-disabled :END: Set jabber-message-alert-same-buffer to nil to do that. *** Basic moderation support in MUC :PROPERTIES: :CUSTOM_ID: basic-moderation-support-muc :END: *** MUC alerts are separated from ordinary message alerts :PROPERTIES: :CUSTOM_ID: muc-alerts-are-separated-from-ordinary-message-alerts :END: Customize jabber-alert-muc-hooks to get your desired behaviour. emacs-jabber/Makefile000066400000000000000000000143171516610113500150360ustar00rootroot00000000000000.PHONY: all build clean install uninstall check test load \ do-test do-test-summary do-lint-check-declare do-lint-checkdoc \ do-lint-native-comp ifndef EMACS_CMD GUIX := $(shell command -v guix 2>/dev/null) ifdef GUIX GUIX_SHELL := guix shell -D -f guix.scm emacs-next emacs-package-lint emacs-relint -- EMACS_CMD := $(GUIX_SHELL) emacs else GUIX_SHELL := EMACS_CMD := emacs endif endif # For loop targets (test, per-file linters), enter guix shell once and # re-exec make so the inner loop calls plain `emacs` from the profile. GUIX_WRAP = $(if $(GUIX_SHELL),$(GUIX_SHELL) $(MAKE) --no-print-directory EMACS_CMD=emacs,$(MAKE) --no-print-directory) JOBS ?= $(shell nproc 2>/dev/null || echo 4) TEST_RESULTS := .test-results TESTS ?= tests/jabber-activity-tests.el \ tests/jabber-bookmarks-tests.el \ tests/jabber-carbons-tests.el \ tests/jabber-chatbuffer-tests.el \ tests/jabber-chatstates-tests.el \ tests/jabber-chat-tests.el \ tests/jabber-csi-tests.el \ tests/jabber-db-tests.el \ tests/jabber-disco-tests.el \ tests/jabber-mam-tests.el \ tests/jabber-message-correct-tests.el \ tests/jabber-message-reply-tests.el \ tests/jabber-modeline-tests.el \ tests/jabber-moderation-tests.el \ tests/jabber-muc-tests.el \ tests/jabber-omemo-message-tests.el \ tests/jabber-omemo-module-tests.el \ tests/jabber-omemo-protocol-tests.el \ tests/jabber-omemo-store-tests.el \ tests/jabber-omemo-trust-tests.el \ tests/jabber-openpgp-legacy-tests.el \ tests/jabber-presence-tests.el \ tests/jabber-pubsub-tests.el \ tests/jabber-receipts-tests.el \ tests/jabber-roster-tests.el \ tests/jabber-sm-tests.el \ tests/jabber-styling-tests.el \ tests/jabber-transient-tests.el \ tests/jabber-util-tests.el \ tests/jabber-xml-tests.el TEST_STAMPS := $(patsubst tests/%.el,$(TEST_RESULTS)/%.stamp,$(TESTS)) all: build build: autoload compile module dev: autoload compile module lint test autoload: $(EMACS_CMD) -q -Q --batch -L lisp \ --eval="(loaddefs-generate \"lisp\" \"lisp/jabber-autoloads.el\")" PICOMEMO_REPO = https://github.com/mierenhoop/picomemo.git PICOMEMO_COMMIT = 7ac189ad2461d99b765abcc28e8439e81a047bc8 src/picomemo/omemo.c: git submodule update --init --recursive 2>/dev/null || \ (git clone $(PICOMEMO_REPO) src/picomemo && \ git -C src/picomemo checkout $(PICOMEMO_COMMIT)) module: src/picomemo/omemo.c ifdef GUIX guix shell -D -f guix.scm -- $(MAKE) -C src else $(MAKE) -C src endif compile: autoload $(EMACS_CMD) -q -Q -L . -L lisp --batch \ --eval="(setq print-length nil load-prefer-newer t)" \ -f batch-byte-compile lisp/*.el lint-check-declare: @$(GUIX_WRAP) do-lint-check-declare do-lint-check-declare: for file in lisp/*.el ; do \ $(EMACS_CMD) -q -Q --batch --eval="(check-declare-file \"$$file\")" ; \ done lint-checkdoc: @$(GUIX_WRAP) do-lint-checkdoc do-lint-checkdoc: for file in lisp/*.el ; do \ $(EMACS_CMD) -q -Q --batch --eval="(checkdoc-file \"$$file\")" ; \ done lint-package-lint: $(EMACS_CMD) -Q --batch \ --eval='(package-initialize)' --eval="(require 'package-lint)" \ -f 'package-lint-batch-and-exit' $(wildcard lisp/*.el) lint-relint: $(EMACS_CMD) -Q --batch \ --eval='(package-initialize)' --eval="(require 'relint)" \ -f 'relint-batch' "lisp" lint-test-compile: $(EMACS_CMD) -q -Q --batch -L lisp -L tests \ -f batch-byte-compile tests/*.el lint-native-comp: autoload @$(GUIX_WRAP) do-lint-native-comp do-lint-native-comp: @fails=0; \ for file in lisp/*.el ; do \ case "$$file" in *autoloads*) continue;; esac; \ output=$$($(EMACS_CMD) -q -Q --batch -L lisp \ --eval="(native-compile \"$$file\")" 2>&1); \ matched=$$(echo "$$output" | grep "is not known to be defined" || true); \ if [ -n "$$matched" ]; then \ echo "$$matched"; \ fails=1; \ fi; \ done; \ exit $$fails lint: lint-check-declare lint-checkdoc lint-package-lint lint-relint lint-test-compile test: @rm -rf $(TEST_RESULTS) @mkdir -p $(TEST_RESULTS) @$(GUIX_WRAP) -j$(JOBS) -Otarget do-test do-test: do-test-summary $(TEST_RESULTS)/%.stamp: tests/%.el @output=$$($(EMACS_CMD) -Q --batch -L lisp -L tests \ -l ert -l $< -f ert-run-tests-batch-and-exit 2>&1); \ rc=$$?; \ n=$$(echo "$$output" | grep -o 'Ran [0-9]*' | grep -o '[0-9]*'); \ if [ $$rc -ne 0 ]; then \ printf "\033[31mFAIL\033[0m $< ($$n tests)\n"; \ echo "$$output" | grep ' FAILED'; \ printf "FAIL %s\n" "$$n" > $@; \ else \ printf "\033[32m OK\033[0m $< ($$n tests)\n"; \ printf "OK %s\n" "$$n" > $@; \ fi do-test-summary: $(TEST_STAMPS) @total=0; passed=0; failed=0; failed_files=""; \ for f in $(TEST_STAMPS); do \ read status n < $$f; \ total=$$((total + n)); \ if [ "$$status" = "FAIL" ]; then \ failed=$$((failed + n)); \ base=$$(basename $$f .stamp); \ failed_files="$$failed_files tests/$$base.el"; \ else \ passed=$$((passed + n)); \ fi; \ done; \ echo ""; \ if [ $$failed -eq 0 ]; then \ printf "\033[32m$$total tests, $$passed passed, 0 failed\033[0m\n"; \ rm -rf $(TEST_RESULTS); \ else \ printf "\033[31m$$total tests, $$passed passed, $$failed failed\033[0m\n"; \ for f in $$failed_files; do echo " $$f"; done; \ printf "\nStamps preserved in $(TEST_RESULTS)/ for debugging.\n"; \ fi; \ [ $$failed -eq 0 ] load: clean-elc @for f in lisp/*.el; do \ emacsclient --eval "(load-file \"$(CURDIR)/$$f\")" > /dev/null || \ printf "\033[31mFAIL\033[0m $$f\n"; \ done @printf "\033[32mLoaded all lisp/*.el into Emacs\033[0m\n" clean-elc: find . -name '*.elc' -delete clean-module: ifdef GUIX guix shell -D -f guix.scm -- $(MAKE) -C src clean else $(MAKE) -C src clean endif clean: clean-elc clean-module rm -rf $(TEST_RESULTS) prefix ?= /usr/local datarootdir ?= $(prefix)/share lispdir ?= $(datarootdir)/emacs/site-lisp/jabber check: test install: build install -d $(DESTDIR)$(lispdir) install -m 644 lisp/*.el $(DESTDIR)$(lispdir)/ -install -m 644 lisp/*.elc $(DESTDIR)$(lispdir)/ -install -m 755 lisp/jabber-omemo-core.so $(DESTDIR)$(lispdir)/ uninstall: rm -rf $(DESTDIR)$(lispdir) emacs-jabber/README.org000066400000000000000000000101311516610113500150320ustar00rootroot00000000000000#+TITLE: jabber.el - The XMPP client for Emacs * About [[https://elpa.nongnu.org/nongnu/jabber.svg]] =jabber.el= is an [[http://xmpp.org][XMPP]] client for Emacs. See the [[https://xmpp.org/software/jabber-el/][xmpp.org page]] for the full list of supported XEPs. + [[https://thanosapollo.org/projects/jabber/][Homepage]] + Source: + [[https://git.thanosapollo.org/emacs-jabber/][Upstream]] + [[https://codeberg.org/emacs-jabber/emacs-jabber/][Codeberg]] /Mirror/ * Requirements + Emacs 29.1 or later, compiled with dynamic module support ** OMEMO encryption (optional) OMEMO end-to-end encryption requires building a native C module. You need a C compiler, =pkg-config=, and =libmbedtls= (development headers). If you installed from source (=:vc= or =git clone=), Emacs will offer to fetch the [[https://github.com/mierenhoop/picomemo][picomemo]] dependency and build the module on first load. If you installed from ELPA, clone the repository and build manually: #+begin_src sh git clone https://git.thanosapollo.org/emacs-jabber/ cd emacs-jabber make module #+end_src Then copy the resulting =jabber-omemo-core.so= (or =.dylib= on macOS) into your ELPA package directory, which is already on =load-path=: #+begin_src sh cp lisp/jabber-omemo-core.so ~/.emacs.d/elpa/jabber-VERSION/ #+end_src * Installation =jabber.el= is available via [[https://elpa.nongnu.org/nongnu/jabber.html][NonGNU ELPA]]. You can install it via =M-x package-install RET jabber= ** package-vc (Emacs 30+) #+begin_src emacs-lisp (use-package jabber :ensure nil :vc (:url "https://git.thanosapollo.org/emacs-jabber/" :branch "master" :rev :newest :lisp-dir "lisp") :custom (jabber-account-list '(("user@example.org"))) :config (jabber-modeline-mode 1) :bind-keymap (("C-x C-j" . jabber-global-keymap)) :hook (kill-emacs . jabber-disconnect)) #+end_src ** GNU Guix The repository ships a =guix.scm= that builds straight from the current working tree, so you never need to update hashes or pin a commit. Whatever is checked out is what gets installed. Picomemo is fetched as a pinned input by =guix.scm=, so the optional OMEMO submodule does not need to be initialised. #+begin_src sh git clone https://git.thanosapollo.org/emacs-jabber/ cd emacs-jabber #+end_src One-shot install into your user profile: #+begin_src sh guix package -f guix.scm #+end_src A development shell with all build dependencies: #+begin_src sh guix shell -D -f guix.scm #+end_src To use =emacs-jabber= from a Guix Home configuration, load the package definition and reference it from your services: #+begin_src scheme (use-modules (gnu home) (gnu home services) (gnu home services guix) (gnu services) (guix channels) (guix gexp)) (define emacs-jabber-git (load "/path/to/emacs-jabber/guix.scm")) (home-environment (packages (list emacs-jabber-git))) #+end_src Re-run =guix home reconfigure= after pulling new commits and the package will be rebuilt from the updated checkout. * Configuration Accounts are configured via =jabber-account-list=. The simplest form uses auth-source =~/.authinfo.gpg= for passwords: #+begin_src emacs-lisp (setq jabber-account-list '(("user@example.org") ("second@account.org"))) #+end_src With =pass= (password-store): #+begin_src emacs-lisp (setq jabber-account-list `(("user@example.org" (:password . ,(auth-source-pass-get 'secret "xmpp/example.org/user"))))) #+end_src * Basic commands | Key | Command | |----------------------+----------------------------------| | =M-x jabber-connect= | Connect (prompts for account) | | =C-x C-j C-c= | Connect all accounts | | =C-x C-j C-d= | Disconnect | | =C-x C-j C-r= | Open roster buffer | | =C-x C-j C-j= | Start or switch to a chat | | =C-x C-j C-m= | Join/switch to a MUC (groupchat) | | =C-x C-j C-b= | Switch to a chat buffer | emacs-jabber/doap.xml000066400000000000000000000540221516610113500150400ustar00rootroot00000000000000 jabber.el jabber.el - XMPP client for Emacs jabber.el - XMPP για το Emacs jabber.el is an XMPP client for Emacs. Τὸ jabber.el εἶναι ἕνα XMPP πρόγραμμα-πελάτης γιά τὸ Ἤμαξ. 2023-09-09 Emacs Lisp Linux macOS Windows FreeBSD OpenBSD NetBSD Android (Termux) Thanos Apollo thanosapollo partial 2.13.1 Forms in incoming messages are not interpreted. See each specific protocol for whether forms are accepted in that context. Cancel messages are probably not consistently generated when they should be. This is partly a paradigm clash, as jabber.el doesn't use modal dialog boxes but buffers which can easily be buried. complete 0.3.1 complete 1.3.1 complete 2.0 0.10.0 complete 1.6.0 0.10.0 complete 1.4 0.7 complete 1.4 0.10.0 complete 2.5.0 partial 2.13.1 Requesting affiliation lists is not implemented. complete 1.2 complete 1.2 partial 1.3.0 complete 1.2 complete 1.3 partial 1.0 0.10.0 Used internally by MAM pagination, not exposed as a standalone API. partial 1.26.0 0.10.0 Publish, retrieve, subscribe, and delete. Used for bookmarks (XEP-0402) and OpenPGP key distribution. partial 1.6.0 0.8.0 Currently jabber.el cannot act as a server, not even on on Emacsen that support server sockets (GNU Emacs 22 and up). partial 1.5 Sending such URLs or doing anything with iq stanzas is not supported. complete 1.3.0 partial 2.4 URL redirections are not. complete 2.5 complete 1.1.1 Currently this is only used for file transfer. complete 1.1.4 complete 2.1 0.8 complete 1.0 complete 1.2 0.7.1 complete 1.4 complete 1.1 complete 1.2 jabber.el doesn't check service discovery results before sending a stream initiation request. partial 1.3.1 Hashes of received files are not checked. Ranged transfers and In-band bytestreams are not supported. complete 1.6.0 0.8.0 complete 1.0.1 complete 1.1 complete 1.1.0 0.7.1 The pixel size limits on avatars are not enforced. complete 1.2.2 0.10.1 complete 1.4.0 0.10.0 complete 1.3 0.10.0 complete 1.6.3 0.10.0 complete 2.0.1 complete 2.0 0.10.0 complete 2.0 partial 1.0 0.6.1 Rendered in plain-text message bodies only. /me in XHTML-IM messages is not handled. complete 1.2 0.10.0 complete 1.0.1 0.10.0 complete 1.0 partial 1.1.0 0.10.0 Query and paginated retrieval. No preferences or metadata support. partial 0.4.0 0.10.0 Received and displayed markers. No acknowledged marker support. partial 0.4.0 0.10.0 Element builders only, used by other modules to annotate outgoing stanzas. complete 1.1.0 0.10.0 partial 0.7.0 0.10.0 Origin-id generation on send, stanza-id parsing for MAM deduplication. complete 1.1.0 0.8.0 complete 1.1.0 0.10.1 ALPN not supported (Emacs GnuTLS bindings lack ALPN API). Servers multiplexing on port 443 that require ALPN will fall through to STARTTLS targets. partial 0.6.0 0.10.0 1:1 signcrypt and MUC encrypt-only. No signature verification on receive, no key fetch command. complete 0.4.0 0.10.0 complete 1.1.2 0.10.0 partial 0.2 0.10.0 Implements OMEMO 0.3 (legacy eu.siacs.conversations.axolotl namespace, XEP-0384 v0.2). 1:1 chat complete. MUC: send and receive in non-anonymous rooms; no affiliation list fetch for offline members. complete 1.1.3 0.10.0 complete 0.10.0 partial 0.4.2 0.10.0 Received as part of XEP-0425 moderated retraction flow. No standalone self-retraction. complete 0.3.0 0.10.0 complete 0.10.0 complete 0.1.0 0.10.0 complete 0.2.0 0.10.0 1.2.0 complete 0.10.0 MUC rejoin presence-tracking check not implemented (spec SHOULD). 0.10.5 2026-04-10 0.10.4 2026-04-08 0.10.3 2026-04-06 0.10.2 2026-04-04 0.10.1 2026-04-03 0.10.0 2026-04-02 0.9.0 2025 0.8 2009 emacs-jabber/guix.scm000066400000000000000000000141621516610113500150540ustar00rootroot00000000000000;;; guix.scm --- Build emacs-jabber from the current working tree. ;; ;; Usage: ;; ;; One-shot install into the user profile: ;; guix package -f guix.scm ;; ;; Development shell with all dependencies: ;; guix shell -D -f guix.scm ;; ;; Use from Guix Home (see README.org for the exact snippet). ;; ;; This file mirrors the upstream Guix recipe for `emacs-jabber' as ;; closely as possible so it doubles as a local test harness for the ;; recipe before it is merged. The only intentional differences are: ;; ;; - `source' is a `local-file' of the current checkout rather than ;; a `git-fetch' of a pinned commit, so the build always reflects ;; whatever is on disk. ;; - `version' is derived from `git describe' at evaluation time. ;; ;; Picomemo is fetched as a pinned `native-input' origin (mirroring ;; upstream), so the submodule does not need to be initialised for ;; this file to build. (use-modules (gnu packages) (gnu packages emacs) (gnu packages emacs-xyz) (gnu packages pkg-config) (gnu packages tls) (guix build-system emacs) (guix gexp) (guix git-download) ((guix licenses) #:prefix license:) (guix packages) (guix utils) (ice-9 popen) (ice-9 rdelim)) (define %source-dir (dirname (current-filename))) (define (git-output . args) "Run `git -C %source-dir ARGS...' and return its trimmed stdout, or #f if the command fails or produces no output." (let* ((port (apply open-pipe* OPEN_READ "git" "-C" %source-dir args)) (line (read-line port))) (close-pipe port) (if (eof-object? line) #f line))) (define %version ;; Prefer `git describe' (tag + commit count + short hash) when ;; available, otherwise fall back to the short hash, then to the ;; hard-coded release version if we are not inside a git checkout. (or (git-output "describe" "--tags" "--always" "--dirty") (and=> (git-output "rev-parse" "--short" "HEAD") (lambda (hash) (string-append "0.10.3-" hash))) "0.10.3-git")) (define (emacs-jabber-file? file stat) "Include every file in the checkout except VCS metadata and build artifacts. Submodule contents under `src/picomemo' are picked up as long as the submodule has been initialised." (let ((name (basename file))) (not (or (string-contains file "/.git/") (string=? name ".git") (string-suffix? ".elc" file) (string-suffix? ".o" file) (string-suffix? ".so" file) (string-suffix? "~" file) (string-suffix? ".tar" file) (string-suffix? ".tar.gz" file))))) (define-public emacs-jabber-git (package (name "emacs-jabber-git") (version %version) (source (local-file %source-dir "emacs-jabber-checkout" #:recursive? #t #:select? emacs-jabber-file?)) (build-system emacs-build-system) (arguments (list #:lisp-directory "lisp" #:include #~(cons "^[^/]*\\.so$" %default-include) #:emacs emacs ;requires gnutls #:test-command #~(list "make" "-C" ".." "test") #:phases #~(modify-phases %standard-phases (add-after 'unpack 'build-native-module (lambda _ (invoke "make" "-C" "../src"))) (add-before 'build-native-module 'unpack-picomemo (lambda _ (copy-recursively #$(this-package-native-input "emacs-jabber-picomemo") "../src/picomemo") (invoke "chmod" "--recursive" "u+w" "../src/picomemo"))) (add-after 'unpack 'fix-test-runner (lambda _ ;; Replace grep -oP (Perl regex) with a ;; POSIX-compatible alternative so the test ;; runner counts results correctly. (substitute* "../Makefile" (("grep -oP '\\^Ran \\\\K\\[0-9\\]\\+'") (string-append "grep -o 'Ran [0-9]*'" " | grep -o '[0-9]*'"))))) (add-after 'unpack 'disable-failing-tests (lambda _ ;; These 4 tests pass outside the build environment ;; but fail inside it. (define skip "\n (skip-unless nil)") (substitute* "../tests/jabber-disco-tests.el" ((".*query-if-needed-cache-miss \\(\\)" all) (string-append all skip)) ((".*process-caps-modern.*queries \\(\\)" all) (string-append all skip))) (substitute* (string-append "../tests/" "jabber-message-correct-tests.el") ((".*correct-last-uses-original-id \\(\\)" all) (string-append all skip)) ((".*mam-syncing-skipped.*dispatch \\(\\)" all) (string-append all skip)))))))) (native-inputs (list pkg-config (origin (method git-fetch) (uri (git-reference (url "https://github.com/mierenhoop/picomemo") (commit "1.1.0"))) (file-name "emacs-jabber-picomemo") (sha256 (base32 "044xd1gn9lpd5yrb3c1lmvqsc1chbkhd3vnh7800hxn23a0hxbzj"))))) (inputs (list mbedtls)) (propagated-inputs (list emacs-fsm)) (home-page "https://thanosapollo.org/projects/jabber/") (synopsis "XMPP (Jabber) client for Emacs") (description "@code{jabber.el} is an XMPP client for Emacs. XMPP (also known as \"Jabber\") is an instant messaging system; see @url{https://xmpp.org} for more information. It supports OMEMO end-to-end encryption via picomemo. This package definition builds straight from the current git checkout, so the installed version always matches the working tree.") (license (list license:gpl3+ ;gpl2+ elisp, gpl3+ C license:isc)))) ;picomemo emacs-jabber-git emacs-jabber/lisp/000077500000000000000000000000001516610113500143375ustar00rootroot00000000000000emacs-jabber/lisp/jabber-activity.el000066400000000000000000000433341516610113500177470ustar00rootroot00000000000000;;; jabber-activity.el --- show jabber activity in the mode line -*- lexical-binding: t; -*- ;; Copyright (C) 2004 Carl Henrik Lunde - ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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, or (at your option) ;; any later version. ;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: ;; Allows tracking messages from buddies using the global mode line ;; See (info "(jabber)Tracking activity") ;;; Code: (require 'cl-lib) (require 'seq) (require 'jabber-core) (require 'jabber-util) (defgroup jabber-activity nil "Activity tracking options." :group 'jabber) ;; All the (featurep 'jabber-activity) is so we don't call a function ;; with an autoloaded cookie while the file is loading, since that ;; would lead to endless load recursion. (defcustom jabber-activity-make-string 'jabber-activity-make-string-default "Function to call to show a string in the modeline. The default function returns the nick of the user." :set #'(lambda (var val) (custom-set-default var val) (when (and (featurep 'jabber-activity) (fboundp 'jabber-activity-make-name-alist)) (jabber-activity-make-name-alist) (jabber-activity-mode-line-update))) :type 'function) (defcustom jabber-activity-shorten-minimum 1 "Length of the strings returned by `jabber-activity-make-strings-shorten'. All strings returned by `jabber-activity-make-strings-shorten' will be at least this long, when possible." :type 'number) (defcustom jabber-activity-shorten-cutoff 2 "Maximum number of JIDs to display in the mode line. When non-nil and more JIDs are active than this number, only the first CUTOFF entries are shown followed by \", +N\"." :type '(choice (const :tag "No limit" nil) (integer :tag "Maximum entries"))) (defcustom jabber-activity-shorten-aggressively nil "If non-nil, shorten names more aggressively. When set, names may use prefixes shorter than `jabber-activity-shorten-minimum' as long as they remain unique." :type 'boolean) (defcustom jabber-activity-muc-prefix "#" "String prepended to MUC names in the mode line. Set to an empty string to disable the prefix." :type 'string) (defcustom jabber-activity-make-strings #'jabber-activity-make-strings-shorten "Function which should return an alist of JID -> string when given a list of JIDs." :set #'(lambda (var val) (custom-set-default var val) (when (and (featurep 'jabber-activity) (fboundp 'jabber-activity-make-name-alist)) (jabber-activity-make-name-alist) (jabber-activity-mode-line-update))) :type '(choice (function-item :tag "Keep strings" :value jabber-activity-make-strings-default) (function-item :tag "Shorten strings" :value jabber-activity-make-strings-shorten) (function :tag "Other function"))) (defcustom jabber-activity-count-in-title nil "If non-nil, display number of active JIDs in frame title." :type 'boolean) (defcustom jabber-activity-count-in-title-format '(jabber-activity-jids ("[" jabber-activity-count-string "] ")) "Format string used for displaying activity in frame titles. Same syntax as `mode-line-format'." :type 'sexp) (defcustom jabber-activity-show-p 'jabber-activity-show-p-default "Function that checks if the given JID should be shown on the mode line. Predicate function to call to check if the given JID should be shown in the mode line or not." :type 'function) (defcustom jabber-activity-query-unread t "Query the user as to whether killing Emacs should be cancelled when there are unread messages which otherwise would be lost." :type 'boolean) (defcustom jabber-activity-banned nil "List of regexps of banned JID" :type '(repeat string)) (defface jabber-activity-chat-face '((t :inherit font-lock-warning-face)) "Face for 1:1 chat activity in the mode line.") (defface jabber-activity-mention-face '((t :inherit font-lock-warning-face)) "Face for personal mentions (MUC highlight) in the mode line.") (defface jabber-activity-muc-face '((t :inherit font-lock-keyword-face)) "Face for MUC (groupchat) activity in the mode line.") (define-obsolete-face-alias 'jabber-activity-face 'jabber-activity-chat-face "30.1") (define-obsolete-face-alias 'jabber-activity-personal-face 'jabber-activity-mention-face "30.1") (defvar jabber-activity-jids nil "A list of JIDs which have caused activity.") (defvar jabber-activity-personal-jids nil "Subset of `jabber-activity-jids' for JIDs with \"personal\" activity.") (defvar jabber-activity-name-alist nil "Alist of mode line names for bare JIDs.") (defvar jabber-activity-mode-string "" "The mode string for jabber activity.") (defvar jabber-activity-count-string "0" "Number of active JIDs as a string.") (defvar jabber-activity-update-hook nil "Hook called when `jabber-activity-jids' changes. It is called after `jabber-activity-mode-string' and `jabber-activity-count-string' are updated.") (defvar jabber-activity--updating nil "Non-nil while activity code is running. Prevents recursive calls from `buffer-list-update-hook' and `window-configuration-change-hook' triggered during updates.") (defvar jabber-activity--shortened-names (make-hash-table :test #'equal) "Cache mapping sorted JID lists to shortened name alists. Invalidated when `jabber-activity-make-name-alist' rebuilds.") ;; Global reference declarations (declare-function jabber-chat-find-buffer "jabber-chat.el" (chat-with)) (declare-function jabber-muc-find-buffer "jabber-muc.el" (group)) (declare-function jabber-muc-private-find-buffer "jabber-muc.el" (group nickname)) (declare-function jabber-muc-sender-p "jabber-muc.el" (jid)) (declare-function jabber-muc-joined-p "jabber-muc.el" (group &optional jc)) (declare-function jabber-muc-looks-like-personal-p "jabber-muc-nick-completion.el" (message &optional group)) (defvar jabber-silent-mode) ; jabber.el ;; (defun jabber-activity-make-string-default (jid) "Return the nick of the JID. If no nick is available, return the user name part of the JID. In private MUC conversations, return the user's nickname." (if (jabber-muc-sender-p jid) (jabber-jid-resource jid) (let ((nick (jabber-jid-displayname jid)) (user (jabber-jid-user jid)) (username (jabber-jid-username jid))) (if (and username (string= nick user)) username nick)))) (defun jabber-activity-make-strings-default (jids) "Apply `jabber-activity-make-string' on JIDS." (mapcar #'(lambda (jid) (cons jid (funcall jabber-activity-make-string jid))) jids)) (defun jabber-activity-common-prefix (s1 s2) "Return length of common prefix string shared by S1 and S2." (let ((len (min (length s1) (length s2)))) (or (cl-dotimes (i len) (when (not (eq (aref s1 i) (aref s2 i))) (cl-return i))) ;; Substrings, equal, nil, or empty ("") len))) (defun jabber-activity--compute-shortening (jids) "Compute shortened names for JIDS. Return an alist of (JID . short-name). This is the uncached workhorse for `jabber-activity-make-strings-shorten'." (let ((alist (sort (mapcar (lambda (x) (cons x (funcall jabber-activity-make-string x))) jids) (lambda (x y) (string-lessp (cdr x) (cdr y))))) (min-len (if jabber-activity-shorten-aggressively 1 jabber-activity-shorten-minimum))) (cl-loop for ((_prev-jid . prev) (cur-jid . cur) (_next-jid . next)) on (cons nil alist) until (null cur) collect (cons cur-jid (substring cur 0 (min (length cur) (max min-len (1+ (jabber-activity-common-prefix cur prev)) (1+ (jabber-activity-common-prefix cur next))))))))) (defun jabber-activity-make-strings-shorten (jids) "Return an alist of (JID . short-names). This is acquired by running `jabber-activity-make-string' on JIDS, and then shortening the names as much as possible such that all strings still are unique and at least `jabber-activity-shorten-minimum' long. When `jabber-activity-shorten-aggressively' is non-nil, the minimum length constraint is relaxed to 1. Results are cached in `jabber-activity--shortened-names'." (let ((key (sort (copy-sequence jids) #'string-lessp))) (or (gethash key jabber-activity--shortened-names) (puthash key (jabber-activity--compute-shortening jids) jabber-activity--shortened-names)))) (defun jabber-activity-find-buffer-name (jid) "Find the buffer that messages from JID would use, or nil." (or (and (jabber-jid-resource jid) (jabber-muc-private-find-buffer (jabber-jid-user jid) (jabber-jid-resource jid))) (jabber-chat-find-buffer jid) (jabber-muc-find-buffer jid))) (defun jabber-activity-show-p-default (jid) "Return non-nil if JID should be shown in the mode line. A JID is shown when it is not banned and its buffer (if any) is not currently visible." (let ((buffer (jabber-activity-find-buffer-name jid))) (and (not (cl-dolist (entry jabber-activity-banned) (when (string-match entry jid) (cl-return t)))) (or (null buffer) (not (get-buffer-window buffer 'visible)))))) (defun jabber-activity-make-name-alist (&optional _jc) "Rebuild `jabber-activity-name-alist' based on currently known JIDs." (let ((jids (or (mapcar #'car jabber-activity-name-alist) (mapcar #'symbol-name *jabber-roster*)))) (setq jabber-activity-name-alist (funcall jabber-activity-make-strings jids))) (clrhash jabber-activity--shortened-names)) (defun jabber-activity-lookup-name (jid) "Lookup JID in `jabber-activity-name-alist'. Return a (jid . string) pair suitable for the mode line, creating an entry if needed." (let ((elm (assoc jid jabber-activity-name-alist))) (or elm (progn ;; Remake alist with the new JID (setq jabber-activity-name-alist (funcall jabber-activity-make-strings (cons jid (mapcar #'car jabber-activity-name-alist)))) (clrhash jabber-activity--shortened-names) (jabber-activity-lookup-name jid))))) (defun jabber-activity--propertize-entry (entry) "Return a propertized mode-line string for ENTRY. ENTRY is a (JID . name) cons cell from `jabber-activity-lookup-name'. MUC JIDs get a # prefix (not included in the shortening calculation)." (let* ((jid (car entry)) (name (cdr entry)) (mucp (jabber-muc-joined-p jid)) (display (if mucp (concat jabber-activity-muc-prefix name) name)) (face (cond ((member jid jabber-activity-personal-jids) 'jabber-activity-mention-face) (mucp 'jabber-activity-muc-face) (t 'jabber-activity-chat-face)))) (propertize display 'face face 'jabber-modeline t 'help-echo jid))) (defun jabber-activity--sort-jids (jids) "Return JIDS sorted with personal mentions first." (let (personal other) (dolist (jid jids) (if (member jid jabber-activity-personal-jids) (push jid personal) (push jid other))) (nconc (nreverse personal) (nreverse other)))) (defun jabber-activity-mode-line-update () "Update the string shown in the mode line. Recomputes `jabber-activity-mode-string' and `jabber-activity-count-string' from `jabber-activity-jids'." (unless jabber-activity--updating (let* ((jabber-activity--updating t) (sorted (jabber-activity--sort-jids jabber-activity-jids)) (entries (mapcar #'jabber-activity-lookup-name sorted)) (total (length entries)) (overflow (when (and jabber-activity-shorten-cutoff (> total jabber-activity-shorten-cutoff)) (- total jabber-activity-shorten-cutoff))) (visible (if overflow (seq-take entries jabber-activity-shorten-cutoff) entries)) (new-mode-string (if jabber-activity-jids (concat (propertize "[" 'face 'shadow 'jabber-modeline t) (mapconcat #'jabber-activity--propertize-entry visible (propertize "," 'face 'shadow 'jabber-modeline t)) (when overflow (propertize (format ", +%d" overflow) 'face 'shadow 'jabber-modeline t)) (propertize "]" 'face 'shadow 'jabber-modeline t)) "")) (new-count-string (number-to-string total)) (changed nil)) (unless (equal-including-properties jabber-activity-mode-string new-mode-string) (setq jabber-activity-mode-string new-mode-string changed t)) (unless (string= jabber-activity-count-string new-count-string) (setq jabber-activity-count-string new-count-string changed t)) (when changed (force-mode-line-update 'all) (run-hooks 'jabber-activity-update-hook))))) ;;; Hooks (defun jabber-activity-clean () "Remove JIDs where `jabber-activity-show-p' no longer is true." (unless jabber-activity--updating (let* ((jabber-activity--updating t) (new-jids (cl-remove-if-not jabber-activity-show-p jabber-activity-jids)) (new-personal (cl-remove-if-not jabber-activity-show-p jabber-activity-personal-jids)) (changed (or (not (equal new-jids jabber-activity-jids)) (not (equal new-personal jabber-activity-personal-jids))))) (setq jabber-activity-jids new-jids jabber-activity-personal-jids new-personal) (when changed (let ((jabber-activity--updating nil)) (jabber-activity-mode-line-update)))))) (defun jabber-activity-add (from _buffer _text _proposed-alert) "Add a JID to mode line when `jabber-activity-show-p'." (when (funcall jabber-activity-show-p from) (add-to-list 'jabber-activity-jids from) (add-to-list 'jabber-activity-personal-jids from) (jabber-activity-mode-line-update))) (defun jabber-activity-add-muc (_nick group _buffer text _proposed-alert) "Add GROUP to mode line. Track personal mentions separately." (when (funcall jabber-activity-show-p group) (add-to-list 'jabber-activity-jids group) (when (jabber-muc-looks-like-personal-p text group) (add-to-list 'jabber-activity-personal-jids group)) (jabber-activity-mode-line-update))) (defun jabber-activity-presence (who _oldstatus newstatus _statustext _proposed-alert) "Add a JID to mode line on subscription requests." (when (string= newstatus "subscribe") (add-to-list 'jabber-activity-jids (symbol-name who)) (add-to-list 'jabber-activity-personal-jids (symbol-name who)) (jabber-activity-mode-line-update))) (defun jabber-activity-kill-hook () "Query the user if is sure to kill Emacs when there are unread messages. Query the user as to whether killing Emacs should be cancelled when there are unread messages which otherwise would be lost, if `jabber-activity-query-unread' is t" (if (and jabber-activity-jids jabber-activity-query-unread) (or jabber-silent-mode (yes-or-no-p "You have unread Jabber messages, are you sure you want to quit?")) t)) ;;; Interactive functions (defvar jabber-activity-last-buffer nil "Last non-Jabber buffer used.") (defun jabber-activity-switch-to (&optional jid-param) "Switch to the buffer for JID-PARAM, or the next active JID. If no activity, switch back to the last non-Jabber buffer." (interactive) (if (or jid-param jabber-activity-jids) (let* ((jid (or jid-param (car jabber-activity-jids))) (buf (jabber-activity-find-buffer-name jid))) (unless (eq major-mode 'jabber-chat-mode) (setq jabber-activity-last-buffer (current-buffer))) (if buf (switch-to-buffer buf) (setq jabber-activity-jids (delete jid jabber-activity-jids) jabber-activity-personal-jids (delete jid jabber-activity-personal-jids)) (jabber-activity-mode-line-update) (message "Buffer for %s no longer exists" jid)) (jabber-activity-clean)) (if (eq major-mode 'jabber-chat-mode) (when (buffer-live-p jabber-activity-last-buffer) (switch-to-buffer jabber-activity-last-buffer)) (message "No new activity")))) ;;; Disconnect cleanup (defun jabber-activity--on-disconnect () "Clear activity tracking state on disconnect." (setq jabber-activity-jids nil jabber-activity-personal-jids nil) (jabber-activity-mode-line-update)) ;;; Init/teardown for jabber-modeline-mode (defun jabber-activity--init () "Register activity tracking hooks. Called by `jabber-modeline-mode' when enabling." (add-hook 'window-configuration-change-hook #'jabber-activity-clean) (add-hook 'jabber-message-hooks #'jabber-activity-add) (add-hook 'jabber-muc-hooks #'jabber-activity-add-muc) (add-hook 'jabber-presence-hooks #'jabber-activity-presence) (add-hook 'jabber-post-connect-hooks #'jabber-activity-make-name-alist) (add-hook 'kill-emacs-query-functions #'jabber-activity-kill-hook)) (defun jabber-activity--teardown () "Unregister activity tracking hooks. Called by `jabber-modeline-mode' when disabling." (remove-hook 'window-configuration-change-hook #'jabber-activity-clean) (remove-hook 'jabber-message-hooks #'jabber-activity-add) (remove-hook 'jabber-muc-hooks #'jabber-activity-add-muc) (remove-hook 'jabber-presence-hooks #'jabber-activity-presence) (remove-hook 'jabber-post-connect-hooks #'jabber-activity-make-name-alist) (remove-hook 'kill-emacs-query-functions #'jabber-activity-kill-hook)) (provide 'jabber-activity) ;;; jabber-activity.el ends here emacs-jabber/lisp/jabber-ahc-presence.el000066400000000000000000000110111516610113500204330ustar00rootroot00000000000000;;; jabber-ahc-presence.el --- provide remote control of presence -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 'jabber-presence) (require 'jabber-ahc) (defvar *jabber-current-show*) (defvar *jabber-current-status*) (defvar *jabber-current-priority*) (defvar jabber-xdata-xmlns) ; jabber-xml.el (defconst jabber-ahc-presence-node "http://jabber.org/protocol/rc#set-status" "Node used by function `jabber-ahc-presence'.") (jabber-ahc-add jabber-ahc-presence-node "Set presence" 'jabber-ahc-presence 'jabber-my-jid-p) (defun jabber-ahc-presence (jc xml-data) "Process presence change command. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((query (jabber-iq-query xml-data)) (sessionid (jabber-xml-get-attribute query 'sessionid)) (action (jabber-xml-get-attribute query 'action))) ;; No session state is kept; instead, lack of session-id is used ;; as indication of first command. (cond ;; command cancelled ((string= action "cancel") `(command ((xmlns . ,jabber-ahc-xmlns) (sessionid . ,sessionid) (node . ,jabber-ahc-presence-node) (status . "canceled")))) ;; return form ((null sessionid) `(command ((xmlns . ,jabber-ahc-xmlns) (sessionid . "jabber-ahc-presence") (node . ,jabber-ahc-presence-node) (status . "executing")) (x ((xmlns . ,jabber-xdata-xmlns) (type . "form")) (title nil ,(format "Set presence of %s" (jabber-connection-jid jc))) (instructions nil "Select new presence status.") (field ((var . "FORM_TYPE") (type . "hidden")) (value nil "http://jabber.org/protocol/rc")) (field ((var . "status") (label . "Status") (type . "list-single")) (value nil ,(if (string= *jabber-current-show* "") "online" *jabber-current-show*)) (option ((label . "Online")) (value nil "online")) (option ((label . "Chatty")) (value nil "chat")) (option ((label . "Away")) (value nil "away")) (option ((label . "Extended away")) (value nil "xa")) (option ((label . "Do not disturb")) (value nil "dnd"))) (field ((var . "status-message") (label . "Message") (type . "text-single")) (value nil ,*jabber-current-status*)) (field ((var . "status-priority") (label . "Priority") (type . "text-single")) (value nil ,(int-to-string *jabber-current-priority*)))))) ;; process form (t (let* ((x (car (jabber-xml-get-children query 'x))) ;; we assume that the first is the jabber:x:data one (fields (jabber-xml-get-children x 'field)) (new-show *jabber-current-show*) (new-status *jabber-current-status*) (new-priority *jabber-current-priority*)) (dolist (field fields) (let ((var (jabber-xml-get-attribute field 'var)) ;; notice that multi-value fields won't be handled properly ;; by this (value (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value)))))) (cond ((string= var "status") (setq new-show (if (string= value "online") "" value))) ((string= var "status-message") (setq new-status value)) ((string= var "status-priority") (setq new-priority (string-to-number value)))))) (jabber-send-presence new-show new-status new-priority)) `(command ((xmlns . ,jabber-ahc-xmlns) (sessionid . ,sessionid) (node . ,jabber-ahc-presence-node) (status . "completed")) (note ((type . "info")) "Presence has been changed.")))))) (provide 'jabber-ahc-presence) ;;; jabber-ahc-presence.el ends hereemacs-jabber/lisp/jabber-ahc.el000066400000000000000000000206541516610113500166460ustar00rootroot00000000000000;; jabber-ahc.el - Ad-Hoc Commands by JEP-0050 -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'jabber-disco) (require 'jabber-widget) (defconst jabber-ahc-xmlns "http://jabber.org/protocol/commands" "XEP-0050 Ad-Hoc Commands namespace.") (defvar jabber-ahc-sessionid nil "Session ID of Ad-Hoc Command session.") (defvar jabber-ahc-node nil "Node to send commands to.") (defvar jabber-ahc-commands nil "Alist of ad-hoc commands provided. The keys are node names as strings (which means that they must not conflict). The values are plists having the following properties - acl - function taking connection object and JID of requester, returning non-nil for access allowed. No function means open for everyone. name - name of command func - function taking connection object and entire IQ stanza as arguments and returning a node Use the function `jabber-ahc-add' to add a command to this list.") ;; Global reference declarations (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-xdata-xmlns) ; jabber-xml.el ;; ;;; SERVER (add-to-list 'jabber-disco-info-nodes (list jabber-ahc-xmlns `((identity ((category . "automation") (type . "command-list") (name . "Ad-Hoc Command list"))) (feature ((var . ,jabber-ahc-xmlns))) (feature ((var . ,jabber-disco-xmlns-items))) (feature ((var . ,jabber-disco-xmlns-info)))))) (defun jabber-ahc-add (node name func acl) "Add a command to internal lists. NODE is the node name to be used. It must be unique. NAME is the natural-language name of the command. FUNC is a function taking the entire IQ stanza as single argument when this command is invoked, and returns a node. ACL is a function taking JID as single argument, returning non-nil for access allowed. nil means open for everyone." (add-to-list 'jabber-ahc-commands (cons node (list 'name name 'func func 'acl acl))) (add-to-list 'jabber-disco-info-nodes (list node `((identity ((category . "automation") (type . "command-node") (name . ,name))) (feature ((var . ,jabber-ahc-xmlns))) (feature ((var . ,jabber-disco-xmlns-info))) (feature ((var . ,jabber-xdata-xmlns))))))) (jabber-disco-advertise-feature jabber-ahc-xmlns) (add-to-list 'jabber-disco-items-nodes (list jabber-ahc-xmlns #'jabber-ahc-disco-items nil)) (defun jabber-ahc-disco-items (jc xml-data) "Return commands in response to disco#items request. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((jid (jabber-xml-get-attribute xml-data 'from))) (mapcar (function (lambda (command) (let ((node (car command)) (plist (cdr command))) (let ((acl (plist-get plist 'acl)) (name (plist-get plist 'name))) (when (or (not (functionp acl)) (funcall acl jc jid)) `(item ((name . ,name) (jid . ,(jabber-connection-jid jc)) (node . ,node)))))))) jabber-ahc-commands))) (add-to-list 'jabber-iq-set-xmlns-alist (cons jabber-ahc-xmlns 'jabber-ahc-process)) (defun jabber-ahc-process (jc xml-data) (let ((to (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id)) (node (jabber-xml-get-attribute (jabber-iq-query xml-data) 'node))) ;; find command (let* ((plist (cdr (assoc node jabber-ahc-commands))) (acl (plist-get plist 'acl)) (func (plist-get plist 'func))) (if plist ;; found (if (or (not (functionp acl)) (funcall acl jc to)) ;; access control passed (jabber-send-iq jc to "result" (funcall func jc xml-data) nil nil nil nil id) ;; ...or failed (jabber-signal-error "Cancel" 'not-allowed)) ;; No such node (jabber-signal-error "Cancel" 'item-not-found))))) ;;; CLIENT (defun jabber-ahc-get-list (jc to) "Request list of ad-hoc commands. See XEP-0050. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Request command list from: " nil nil nil nil nil))) (jabber-get-disco-items jc to jabber-ahc-xmlns)) (defun jabber-ahc-execute-command (jc to node) "Execute ad-hoc command. See XEP-0050. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Execute command of: " nil nil nil nil nil) (jabber-read-node "Node of command: "))) (jabber-send-iq jc to "set" `(command ((xmlns . ,jabber-ahc-xmlns) (node . ,node) (action . "execute"))) #'jabber-process-data #'jabber-ahc-display #'jabber-process-data "Command execution failed")) (defun jabber-ahc-display (jc xml-data) (let* ((from (jabber-xml-get-attribute xml-data 'from)) (query (jabber-iq-query xml-data)) (node (jabber-xml-get-attribute query 'node)) (notes (jabber-xml-get-children query 'note)) (sessionid (jabber-xml-get-attribute query 'sessionid)) (status (jabber-xml-get-attribute query 'status)) (actions (car (jabber-xml-get-children query 'actions))) xdata (inhibit-read-only t)) (setq-local jabber-ahc-sessionid sessionid) (setq-local jabber-ahc-node node) (setq-local jabber-buffer-connection jc) (dolist (x (jabber-xml-get-children query 'x)) (when (string= (jabber-xml-get-attribute x 'xmlns) jabber-xdata-xmlns) (setq xdata x))) (cond ((string= status "executing") (insert "Executing command\n\n")) ((string= status "completed") (insert "Command completed\n\n")) ((string= status "canceled") (insert "Command canceled\n\n"))) (dolist (note notes) (let ((note-type (jabber-xml-get-attribute note 'type))) (cond ((string= note-type "warn") (insert "Warning: ")) ((string= note-type "error") (insert "Error: "))) (insert (car (jabber-xml-node-children note)) "\n"))) (insert "\n") (when xdata (jabber-widget-init-buffer from) (let ((formtype (jabber-xml-get-attribute xdata 'type))) (if (string= formtype "result") (jabber-widget-render-xdata-search-results xdata) (jabber-widget-render-xdata-form xdata) (when (string= status "executing") (let ((button-titles (cond ((null actions) '(complete cancel)) (t (let ((children (mapcar #'jabber-xml-node-name (jabber-xml-node-children actions))) (default-action (jabber-xml-get-attribute actions 'execute))) (if (or (null default-action) (memq (intern default-action) children)) children (cons (intern default-action) children))))))) (dolist (button-title button-titles) (widget-create 'push-button :notify (lambda (&rest _ignore) (jabber-ahc-submit button-title)) (symbol-name button-title)) (widget-insert "\t"))) (widget-insert "\n")))) (widget-setup) (widget-minor-mode 1)))) (defun jabber-ahc-submit (action) "Submit Ad-Hoc Command." (jabber-send-iq jabber-buffer-connection jabber-widget-submit-to "set" `(command ((xmlns . ,jabber-ahc-xmlns) (sessionid . ,jabber-ahc-sessionid) (node . ,jabber-ahc-node) (action . ,(symbol-name action))) ,(if (and (not (eq action 'cancel)) (eq jabber-widget-form-type 'xdata)) (jabber-widget-parse-xdata-form))) #'jabber-process-data #'jabber-ahc-display #'jabber-process-data "Command execution failed")) (provide 'jabber-ahc) ;;; jabber-ahc.el ends here. emacs-jabber/lisp/jabber-alert.el000066400000000000000000000507171516610113500172250ustar00rootroot00000000000000;;; jabber-alert.el --- alert hooks -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2005, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'cl-lib) (require 'jabber-util) (require 'jabber-xml) (defgroup jabber-alerts nil "auditory and visual alerts for jabber events" :group 'jabber) (defcustom jabber-alert-message-hooks '(jabber-message-echo jabber-message-scroll) "Hooks run when a new message arrives. Arguments are FROM, BUFFER, TEXT and TITLE. FROM is the JID of the sender, BUFFER is the the buffer where the message can be read, and TEXT is the text of the message. TITLE is the string returned by `jabber-alert-message-function' for these arguments, so that hooks do not have to call it themselves. This hook is meant for user customization of message alerts. For other uses, see `jabber-message-hooks'. Desktop notifications are added by `jabber-notifications' when loaded." :type 'hook :options '(jabber-message-beep jabber-message-wave jabber-message-echo jabber-message-switch jabber-message-display jabber-message-scroll)) (defvar jabber-message-hooks nil "Internal hooks run when a new message arrives. This hook works just like `jabber-alert-message-hooks', except that it's not meant to be customized by the user.") (defcustom jabber-alert-message-function 'jabber-message-default-message "Function for constructing short message alert messages. Arguments are FROM, BUFFER, and TEXT. This function should return a string containing an appropriate text message, or nil if no message should be displayed. The provided hooks displaying a text message get it from this function, and show no message if it returns nil. Other hooks do what they do every time." :type 'function) (defcustom jabber-alert-muc-hooks '(jabber-muc-echo-personal jabber-muc-scroll) "Hooks run when a new MUC message arrives. Arguments are NICK, GROUP, BUFFER, TEXT and TITLE. NICK is the nickname of the sender. GROUP is the JID of the group. BUFFER is the the buffer where the message can be read, and TEXT is the text of the message. TITLE is the string returned by `jabber-alert-muc-function' for these arguments, so that hooks do not have to call it themselves. The default uses `jabber-muc-echo-personal' so that only messages mentioning your nickname are echoed. Use `jabber-muc-echo' instead to be notified of all MUC messages. Desktop notifications are added by `jabber-notifications' when loaded." :type 'hook :options '(jabber-muc-beep jabber-muc-wave jabber-muc-echo jabber-muc-switch jabber-muc-display jabber-muc-scroll jabber-muc-beep-personal jabber-muc-wave-personal jabber-muc-echo-personal jabber-muc-switch-personal jabber-muc-display-personal)) (defvar jabber-muc-hooks '() "Internal hooks run when a new MUC message arrives. This hook works just like `jabber-alert-muc-hooks', except that it's not meant to be customized by the user.") (defcustom jabber-alert-muc-function 'jabber-muc-default-message "Function for constructing short message alert messages. Arguments are NICK, GROUP, BUFFER, and TEXT. This function should return a string containing an appropriate text message, or nil if no message should be displayed. The provided hooks displaying a text message get it from this function, and show no message if it returns nil. Other hooks do what they do every time." :type 'function) (defcustom jabber-alert-presence-hooks '(jabber-presence-echo) "Hooks run when a user's presence changes. Arguments are WHO, OLDSTATUS, NEWSTATUS, STATUSTEXT and PROPOSED-ALERT. WHO is a symbol whose text is the JID of the contact, and which has various interesting properties. OLDSTATUS is the old presence or nil if disconnected. NEWSTATUS is the new presence, or one of \"subscribe\", \"unsubscribe\", \"subscribed\" and \"unsubscribed\". TITLE is the string returned by `jabber-alert-presence-message-function' for these arguments." :type 'hook :options '(jabber-presence-beep jabber-presence-wave jabber-presence-switch jabber-presence-display jabber-presence-echo)) (defvar jabber-presence-hooks nil "Internal hooks run when a user's presence changes. This hook works just like `jabber-alert-presence-hooks', except that it's not meant to be customized by the user.") (defcustom jabber-alert-presence-message-function 'jabber-presence-default-message "Function for constructing title of presence alert messages. Arguments are WHO, OLDSTATUS, NEWSTATUS and STATUSTEXT. See `jabber-alert-presence-hooks' for documentation. This function should return a string containing an appropriate text message, or nil if no message should be displayed. The provided hooks displaying a text message get it from this function. All hooks refrain from action if this function returns nil." :type 'function) (defcustom jabber-alert-info-message-hooks '(jabber-info-display jabber-info-echo) "Hooks run when an info request is completed. First argument is WHAT, a symbol telling the kind of info request completed. That might be \='roster, for requested roster updates, and \='browse, for browse requests. Second argument in BUFFER, a buffer containing the result. Third argument is PROPOSED-ALERT, containing the string returned by `jabber-alert-info-message-function' for these arguments." :type 'hook :options '(jabber-info-beep jabber-info-wave jabber-info-echo jabber-info-switch jabber-info-display)) (defvar jabber-info-message-hooks '() "Internal hooks run when an info request is completed. This hook works just like `jabber-alert-info-message-hooks', except that it's not meant to be customized by the user.") (defcustom jabber-alert-info-message-function 'jabber-info-default-message "Function for constructing info alert messages. Arguments are WHAT, a symbol telling the kind of info request completed, and BUFFER, a buffer containing the result." :type 'function) (defcustom jabber-info-message-alist '((roster . "Roster display updated") (browse . "Browse request completed")) "Alist for info alert messages, used by `jabber-info-default-message'." :type '(alist :key-type symbol :value-type string :options (roster browse))) (defcustom jabber-alert-message-wave "" "A sound file to play when a message arrived. See `jabber-alert-message-wave-alist' if you want other sounds for specific contacts." :type 'file) (defcustom jabber-alert-message-wave-alist nil "Specific sound files for messages from specific contacts. The keys are regexps matching the JID, and the values are sound files." :type '(alist :key-type regexp :value-type file)) (defcustom jabber-alert-muc-wave "" "A sound file to play when a MUC message arrived." :type 'file) (defcustom jabber-alert-presence-wave "" "A sound file to play when a presence arrived." :type 'file) (defcustom jabber-alert-presence-wave-alist nil "Specific sound files for presence from specific contacts. The keys are regexps matching the JID, and the values are sound files." :type '(alist :key-type regexp :value-type file)) (defcustom jabber-alert-info-wave "" "A sound file to play when an info query result arrived." :type 'file) (defcustom jabber-play-sound-file 'play-sound-file "A function to call to play alert sound files." :type 'function) ;; Global reference declarations (declare-function jabber-chat-get-buffer "jabber-chat.el" (chat-with &optional jc)) (declare-function jabber-chat-find-buffer "jabber-chat.el" (chat-with)) (declare-function jabber-chat-send "jabber-chat.el" (jc body &optional extra-elements)) (declare-function jabber-muc-sender-p "jabber-muc.el" (jid)) (declare-function jabber-muc-nickname "jabber-muc.el" (group &optional jc)) (declare-function jabber-muc-our-nick-p "jabber-muc.el" (group nick)) (defvar jabber-presence-strings) ; jabber.el (defvar jabber-xml-data) ; jabber.el (defvar jabber-roster-buffer) ; jabber-core.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el ;; (defmacro define-jabber-alert (name docstring function) "Define a new family of external alert hooks. Use this macro when your hooks do nothing except displaying a string in some new innovative way. You write a string display function, and this macro does all the boring and repetitive work. NAME is the name of the alert family. The resulting hooks will be called jabber-{message,muc,presence,info}-NAME. DOCSTRING is the docstring to use for those hooks. FUNCTION is a function that takes one argument, a string, and displays it in some meaningful way. It can be either a lambda form or a quoted function name. The created functions are inserted as options in Customize. Examples: \(define-jabber-alert foo \"Send foo alert\" \\='foo-message) \(define-jabber-alert bar \"Send bar alert\" (lambda (msg) (bar msg 42)))" (let ((sn (symbol-name name))) (let ((msg (intern (format "jabber-message-%s" sn))) (muc (intern (format "jabber-muc-%s" sn))) (pres (intern (format "jabber-presence-%s" sn))) (info (intern (format "jabber-info-%s" sn)))) `(progn (defun ,msg (_from _buffer text title) ,docstring (when title (funcall ,function text title))) (cl-pushnew (quote ,msg) (get 'jabber-alert-message-hooks 'custom-options)) (defun ,muc (_nick _group _buffer text title) ,docstring (when title (funcall ,function text title))) (cl-pushnew (quote ,muc) (get 'jabber-alert-muc-hooks 'custom-options)) (defun ,pres (_who _oldstatus _newstatus statustext title) ,docstring (when title (funcall ,function statustext title))) (cl-pushnew (quote ,pres) (get 'jabber-alert-presence-hooks 'custom-options)) (defun ,info (_infotype _buffer text) ,docstring (when text (funcall ,function text))) (cl-pushnew (quote ,info) (get 'jabber-alert-info-message-hooks 'custom-options)))))) ;; Alert hooks (define-jabber-alert echo "Show a message in the echo area" (lambda (text &optional title) (message "%s" (or title text)))) (define-jabber-alert beep "Beep on event" (lambda (&rest _ignore) (beep))) ;; Message alert hooks (defcustom jabber-message-alert-same-buffer t "If nil, don't display message alerts for the current buffer." :type 'boolean) (defcustom jabber-muc-alert-self nil "If nil, don't display MUC alerts for your own messages." :type 'boolean) (defun jabber-message-default-message (from buffer _text) (when (or jabber-message-alert-same-buffer (not (memq (selected-window) (get-buffer-window-list buffer)))) (if (jabber-muc-sender-p from) (format "Private message from %s in %s" (jabber-jid-resource from) (jabber-jid-displayname (jabber-jid-user from))) (format "%s:" (jabber-jid-displayname from))))) (defun jabber-message-wave (from _buffer _text title) "Play the wave file specified in `jabber-alert-message-wave'." (when title (let* ((case-fold-search t) (bare-jid (jabber-jid-user from)) (sound-file (or (cl-dolist (entry jabber-alert-message-wave-alist) (when (string-match (car entry) bare-jid) (cl-return (cdr entry)))) jabber-alert-message-wave))) (unless (equal sound-file "") (funcall jabber-play-sound-file sound-file))))) (defun jabber-message-display (_from buffer _text title) "Display the buffer where a new message has arrived." (when title (display-buffer buffer))) (defun jabber-message-switch (_from buffer _text title) "Switch to the buffer where a new message has arrived." (when title (switch-to-buffer buffer))) (defun jabber-message-scroll (_from buffer _text _title) "Scroll all nonselected windows where the chat buffer is displayed." ;; jabber-chat-buffer-display will DTRT with point in the buffer. ;; But this change will not take effect in nonselected windows. ;; Therefore we do that manually here. ;; ;; There are three cases: ;; 1. The user started typing a message in this window. Point is ;; greater than jabber-point-insert. In that case, we don't ;; want to move point. ;; 2. Point was at the end of the buffer, but no message was being ;; typed. After displaying the message, point is now close to ;; the end of the buffer. We advance it to the end. ;; 3. The user was perusing history in this window. There is no ;; simple way to distinguish this from 2, so the user loses. (let ((windows (get-buffer-window-list buffer nil t)) (new-point-max (with-current-buffer buffer (point-max)))) (dolist (w windows) (unless (eq w (selected-window)) (set-window-point w new-point-max))))) ;; MUC alert hooks (defun jabber-muc-default-message (nick group buffer _text) (when (or jabber-message-alert-same-buffer (not (and (buffer-live-p buffer) (memq (selected-window) (get-buffer-window-list buffer))))) (if nick (when (or jabber-muc-alert-self (not (jabber-muc-our-nick-p group nick))) (format "Message from %s in %s" nick (jabber-jid-displayname group))) (format "Message in %s" (jabber-jid-displayname group))))) (defun jabber-muc-wave (_nick _group _buffer _text title) "Play the wave file specified in `jabber-alert-muc-wave'." (when title (funcall jabber-play-sound-file jabber-alert-muc-wave))) (defun jabber-muc-display (_nick _group buffer _text title) "Display the buffer where a new message has arrived." (when (and title (buffer-live-p buffer)) (display-buffer buffer))) (defun jabber-muc-switch (_nick _group buffer _text title) "Switch to the buffer where a new message has arrived." (when (and title (buffer-live-p buffer)) (switch-to-buffer buffer))) (defun jabber-muc-scroll (_nick _group buffer _text _title) "Scroll buffer even if it is in an unselected window." (when (buffer-live-p buffer) (jabber-message-scroll nil buffer nil nil))) ;; Presence alert hooks (defun jabber-presence-default-message (who oldstatus newstatus _statustext) "Return a string with the status change if OLDSTATUS and NEWSTATUS differs. Return nil if OLDSTATUS and NEWSTATUS are equal, and in other cases a string of the form \"\\='name\\=' (jid) is now NEWSTATUS (STATUSTEXT)\". This function is not called directly, but is the default for `jabber-alert-presence-message-function'." (cond ((equal oldstatus newstatus) nil) (t (let ((formattedname (if (> (length (get who 'name)) 0) (get who 'name) (symbol-name who))) (formattedstatus (or (cdr (assoc newstatus '(("subscribe" . " requests subscription to your presence") ("subscribed" . " has granted presence subscription to you") ("unsubscribe" . " no longer subscribes to your presence") ("unsubscribed" . " cancels your presence subscription")))) (concat " is now " (or (cdr (assoc newstatus jabber-presence-strings)) newstatus))))) (concat formattedname formattedstatus))))) (defun jabber-presence-only-chat-open-message (who oldstatus newstatus statustext) "Same as `jabber-presence-default-message' but managing the presence messages. Return the same as `jabber-presence-default-message' but only if there is a chat buffer open for WHO, keeping the amount of presence messages at a more manageable level when there are lots of users. This function is not called directly, but can be used as the value for `jabber-alert-presence-message-function'." (when (jabber-chat-find-buffer (jabber-xml-get-attribute jabber-xml-data 'from)) (jabber-presence-default-message who oldstatus newstatus statustext))) (defun jabber-presence-wave (who _oldstatus _newstatus _statustext proposed-alert) "Play the wave file specified in `jabber-alert-presence-wave'." (when proposed-alert (let* ((case-fold-search t) (bare-jid (symbol-name who)) (sound-file (or (cl-dolist (entry jabber-alert-presence-wave-alist) (when (string-match (car entry) bare-jid) (cl-return (cdr entry)))) jabber-alert-presence-wave))) (unless (equal sound-file "") (funcall jabber-play-sound-file sound-file))))) (defun jabber-presence-display (_who _oldstatus _newstatus _statustext proposed-alert) "Display the roster buffer." (when proposed-alert (display-buffer jabber-roster-buffer))) (defun jabber-presence-switch (_who _oldstatus _newstatus _statustext proposed-alert) "Switch to the roster buffer." (when proposed-alert (switch-to-buffer jabber-roster-buffer))) ;;; Info alert hooks (defun jabber-info-default-message (infotype buffer) "Function for constructing info alert messages. The argument is INFOTYPE, a symbol telling the kind of info request completed. This function uses `jabber-info-message-alist' to find a message." (concat (cdr (assq infotype jabber-info-message-alist)) " (buffer "(buffer-name buffer) ")")) (defun jabber-info-wave (_infotype _buffer proposed-alert) "Play the wave file specified in `jabber-alert-info-wave'." (if proposed-alert (funcall jabber-play-sound-file jabber-alert-info-wave))) (defun jabber-info-display (_infotype buffer proposed-alert) "Display buffer of completed request." (when proposed-alert (display-buffer buffer))) (defun jabber-info-switch (_infotype buffer proposed-alert) "Switch to buffer of completed request." (when proposed-alert (switch-to-buffer buffer))) ;;; Personal alert hooks (defmacro define-personal-jabber-alert (name) "From ALERT function, make ALERT-personal function. This makes sense only for MUC. NAME: the name of the sender." (let ((sn (symbol-name name))) (let ((func (intern (format "%s-personal" sn)))) `(progn (declare-function jabber-muc-looks-like-personal-p "jabber-muc-nick-completion.el" (message &optional group)) (defun ,func (nick group buffer text title) (if (jabber-muc-looks-like-personal-p text group) (,name nick group buffer text title))) (cl-pushnew (quote ,func) (get 'jabber-alert-muc-hooks 'custom-options)))))) (define-personal-jabber-alert jabber-muc-beep) (define-personal-jabber-alert jabber-muc-wave) (define-personal-jabber-alert jabber-muc-echo) (define-personal-jabber-alert jabber-muc-switch) (define-personal-jabber-alert jabber-muc-display) (defcustom jabber-autoanswer-alist nil "Specific phrases to autoanswer on specific message. The keys are regexps matching the incoming message text, and the values are autoanswer phrase." :type '(alist :key-type regexp :value-type string)) (defun jabber-autoanswer-answer (from buffer text proposed-alert) "Answer automaticaly when incoming text is in `jabber-autoanswer-alist'. Answer automaticaly when incoming text match the first element of `jabber-autoanswer-alist'" (when (and from buffer text proposed-alert jabber-autoanswer-alist) (let ((message (cl-dolist (entry jabber-autoanswer-alist) (when (string-match (car entry) text) (cl-return (cdr entry)))))) (if message (jabber-chat-send jabber-buffer-connection message))))) (cl-pushnew 'jabber-autoanswer-answer (get 'jabber-alert-message-hooks 'custom-options)) (defun jabber-autoanswer-answer-muc (nick group buffer text proposed-alert) "Answer automaticaly when incoming text is in `jabber-autoanswer-alist'. Answer automaticaly when incoming text match first element of `jabber-autoanswer-alist'." (when (and nick group buffer text proposed-alert jabber-autoanswer-alist) (let ((message (cl-dolist (entry jabber-autoanswer-alist) (when (string-match (car entry) text) (cl-return (cdr entry)))))) (if message (jabber-chat-send jabber-buffer-connection message))))) (cl-pushnew 'jabber-autoanswer-answer-muc (get 'jabber-alert-muc-hooks 'custom-options)) (provide 'jabber-alert) ;;; jabber-alert.el ends here emacs-jabber/lisp/jabber-autoaway.el000066400000000000000000000205251516610113500177420ustar00rootroot00000000000000;;; jabber-autoaway.el --- change status to away after idleness -*- lexical-binding: t; -*- ;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru ;; Copyright (C) 2010 - Terechkov Evgenii - evg@altlinux.org ;; Copyright (C) 2006, 2008 Magnus Henoch ;; Copyright (C) 2026 Thanos Apollo ;; Author: Magnus Henoch ;; Maintainer: Thanos Apollo ;; This file 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, or (at your option) ;; any later version. ;; This file 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 GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; ;;; Code: (eval-when-compile (require 'cl-lib)) (require 'time-date) (require 'jabber-util) (require 'jabber-presence) (defgroup jabber-autoaway nil "Change status to away after idleness." :group 'jabber) (defcustom jabber-autoaway-methods (list 'jabber-current-idle-time 'jabber-xprintidle-get-idle-time 'jabber-termatime-get-idle-time 'jabber-windows-get-idle-time) "Methods used to keep track of idleness. This is a list of functions that takes no arguments, and returns the number of seconds since the user was active, or nil on error." :type 'hook :options '(jabber-current-idle-time jabber-xprintidle-get-idle-time jabber-termatime-get-idle-time jabber-windows-get-idle-time)) (defcustom jabber-autoaway-timeout 5 "Minutes of inactivity before changing status to away." :type 'number) (defcustom jabber-autoaway-xa-timeout 10 "Minutes of inactivity before changing status to xa. Set to 0 to disable." :type 'number) (defcustom jabber-autoaway-status "Idle" "Status string for autoaway." :type 'string) (defcustom jabber-autoaway-xa-status "Extended away" "Status string for autoaway in xa state." :type 'string) (defcustom jabber-autoaway-priority nil "Priority for autoaway. If nil, don't change priority. See the manual for more information about priority." :type '(choice (const :tag "Don't change") (integer :tag "Priority")) :link '(info-link "(jabber)Presence")) (defcustom jabber-autoaway-xa-priority nil "Priority for autoaway in xa state. If nil, don't change priority. See the manual for more information about priority." :type '(choice (const :tag "Don't change") (integer :tag "Priority")) :link '(info-link "(jabber)Presence")) (defcustom jabber-xprintidle-program (executable-find "xprintidle") "Name of the xprintidle program." :type 'string) (defcustom jabber-autoaway-verbose nil "If nil, don't print autoaway status messages." :type 'boolean) (defvar jabber-autoaway-timer nil) (defvar jabber-autoaway-last-idle-time nil "Seconds of idle time the last time we checked. This is used to detect whether the user has become unidle.") ;; Global reference declarations (defvar *jabber-current-status*) ; jabber.el (defvar *jabber-current-show*) ; jabber.el (defvar *jabber-current-priority*) ; jabber.el (defvar jabber-default-show) ; jabber.el (defvar jabber-default-priority) ; jabber.el (defvar jabber-default-status) ; jabber.el ;; (defun jabber-autoaway-message (&rest args) (when jabber-autoaway-verbose (apply #'message args))) ;;;###autoload (defun jabber-autoaway-start (&optional _ignored) "Start autoaway timer. The IGNORED argument is there so you can put this function in `jabber-post-connect-hooks'." (interactive) (unless jabber-autoaway-timer (setq jabber-autoaway-timer (run-with-timer (* jabber-autoaway-timeout 60) nil #'jabber-autoaway-timer)) (jabber-autoaway-message "Autoaway timer started"))) (defun jabber-autoaway-stop () "Stop autoaway timer." (interactive) (when jabber-autoaway-timer (cancel-timer jabber-autoaway-timer) (setq jabber-autoaway-timer nil) (jabber-autoaway-message "Autoaway timer stopped"))) (defun jabber-autoaway-get-idle-time () "Get idle time in seconds according to `jabber-autoaway-methods'. Return nil on error." (car (sort (mapcar #'funcall jabber-autoaway-methods) (lambda (a b) (if a (if b (< a b) t) nil))))) (defun jabber-autoaway-timer () ;; We use one-time timers, so reset the variable. (setq jabber-autoaway-timer nil) (let ((idle-time (jabber-autoaway-get-idle-time))) (when (numberp idle-time) ;; Has "idle timeout" passed? (if (> idle-time (* 60 jabber-autoaway-timeout)) ;; If so, mark ourselves idle. (jabber-autoaway-set-idle) ;; Else, start a timer for the remaining amount. (setq jabber-autoaway-timer (run-with-timer (- (* 60 jabber-autoaway-timeout) idle-time) nil #'jabber-autoaway-timer)))))) (defun jabber-autoaway-set-idle (&optional xa) (jabber-autoaway-message "Autoaway triggered") ;; Send presence, unless the user has set a custom presence (unless (member *jabber-current-show* '("xa" "dnd")) (jabber-send-presence (if xa "xa" "away") (if (or (string= *jabber-current-status* jabber-default-status) (string= *jabber-current-status* jabber-autoaway-status)) (if xa jabber-autoaway-xa-status jabber-autoaway-status) *jabber-current-status*) (or (if xa jabber-autoaway-priority jabber-autoaway-xa-priority) *jabber-current-priority*))) (setq jabber-autoaway-last-idle-time (jabber-autoaway-get-idle-time)) ;; Run unidle timer every 10 seconds (if xa specified, timer already running) (unless xa (setq jabber-autoaway-timer (run-with-timer 10 10 #'jabber-autoaway-maybe-unidle)))) (defun jabber-autoaway-maybe-unidle () (let ((idle-time (jabber-autoaway-get-idle-time))) (jabber-autoaway-message "Idle for %d seconds" idle-time) (if (member *jabber-current-show* '("xa" "away")) ;; As long as idle time increases monotonically, stay idle. (if (> idle-time jabber-autoaway-last-idle-time) (progn ;; Has "Xa timeout" passed? (if (and (> jabber-autoaway-xa-timeout 0) (> idle-time (* 60 jabber-autoaway-xa-timeout))) ;; iIf so, mark ourselves xa. (jabber-autoaway-set-idle t)) (setq jabber-autoaway-last-idle-time idle-time)) ;; But if it doesn't, go back to unidle state. (jabber-autoaway-message "Back to unidle") ;; But don't mess with the user's custom presence. (if (or (string= *jabber-current-status* jabber-autoaway-status) (string= *jabber-current-status* jabber-autoaway-xa-status)) (jabber-send-default-presence) (progn (jabber-send-presence jabber-default-show *jabber-current-status* jabber-default-priority) (jabber-autoaway-message "%S /= %S - not resetting presence" *jabber-current-status* jabber-autoaway-status))) (jabber-autoaway-stop) (jabber-autoaway-start))))) (defun jabber-xprintidle-get-idle-time () "Get idle time through the xprintidle program." (when jabber-xprintidle-program (with-temp-buffer (when (zerop (call-process jabber-xprintidle-program nil t)) (/ (string-to-number (buffer-string)) 1000.0))))) (defun jabber-termatime-get-idle-time () "Get idle time through atime of terminal. The method for finding the terminal only works on GNU/Linux." (let ((terminal (cond ((file-exists-p "/proc/self/fd/0") "/proc/self/fd/0") (t nil)))) (when terminal (let* ((atime-of-tty (nth 4 (file-attributes terminal))) (diff (time-to-seconds (time-since atime-of-tty)))) (when (> diff 0) diff))))) (defun jabber-windows-get-idle-time () "Get idle time from Windows." (and (fboundp 'w32-system-idle-time) (pcase (w32-system-idle-time) (-1 nil) (ms (/ ms 1000.0))))) (defun jabber-current-idle-time () "Get idle time through `current-idle-time'." (let ((idle-time (current-idle-time))) (if (null idle-time) 0 (float-time idle-time)))) (provide 'jabber-autoaway) ;;; jabber-autoaway.el ends hereemacs-jabber/lisp/jabber-avatar.el000066400000000000000000000165131516610113500173700ustar00rootroot00000000000000;;; jabber-avatar.el --- generic functions for avatars -*- lexical-binding: t; -*- ;; Copyright (C) 2006, 2007, 2008 Magnus Henoch ;; Copyright (C) 2026 Thanos Apollo ;; Author: Magnus Henoch ;; Maintainer: Thanos Apollo ;; This file 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, or (at your option) ;; any later version. ;; This file 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 GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; There are several methods for transporting avatars in Jabber. [1][2][3] ;; ;; They all have in common that they identify avatars by their SHA1 ;; checksum, and (at least partially) use Base64-encoded image data. ;; Thus this library of support functions for interpreting and caching ;; avatars. ;; A contact with an avatar has the image in the avatar property of ;; the JID symbol. Use `jabber-avatar-set' to set it. ;; ;; [1] XEP-0008: IQ-Based Avatars ;; https://xmpp.org/extensions/xep-0008.html ;; [2] XEP-0084: User Avatar ;; https://xmpp.org/extensions/xep-0084.html ;; [3] XEP-0153: vCard-Based Avatars ;; https://xmpp.org/extensions/xep-0153.html ;;; Code: (require 'mailcap) (eval-when-compile (require 'cl-lib)) (require 'jabber-util) (require 'jabber-image) ;;;; Variables (defgroup jabber-avatar nil "Avatar related settings" :group 'jabber) (defcustom jabber-avatar-cache-directory (expand-file-name "jabber/avatars" user-emacs-directory) "Directory to use for cached avatars." :type 'directory) (defcustom jabber-avatar-verbose nil "Display messages about irregularities with other people's avatars." :type 'boolean) (defcustom jabber-avatar-max-width 96 "Maximum width of avatars." :type 'integer) (defcustom jabber-avatar-max-height 96 "Maximum height of avatars." :type 'integer) ;;;; Avatar data handling (cl-defstruct avatar sha1-sum mime-type url base64-data height width bytes) (defun jabber-avatar-from-url (url) "Construct an avatar structure from the given URL. Retrieves the image to find info about it." (with-current-buffer (let ((coding-system-for-read 'binary)) (url-retrieve-synchronously url)) (let* ((case-fold-search t) (mime-type (ignore-errors (search-forward-regexp "^content-type:[ \t]*\\(.*\\)$") (match-string 1))) (data (progn (search-forward "\n\n") (buffer-substring (point) (point-max))))) (prog1 (jabber-avatar-from-data data nil mime-type) (kill-buffer nil))))) (defun jabber-avatar-from-file (filename) "Construct an avatar structure from FILENAME." (require 'mailcap) (let ((data (with-temp-buffer (insert-file-contents-literally filename) (buffer-string))) (mime-type (when (string-match "\\.[^.]+$" filename) (mailcap-extension-to-mime (match-string 0 filename))))) (jabber-avatar-from-data data nil mime-type))) (defun jabber-avatar-from-base64-string (base64-string &optional mime-type) "Construct an avatar stucture from BASE64-STRING. If MIME-TYPE is not specified, try to find it from the image data." (jabber-avatar-from-data nil base64-string mime-type)) (defun jabber-avatar-from-data (raw-data base64-string &optional mime-type) "Construct an avatar structure from RAW-DATA and/or BASE64-STRING. If either is not provided, it is computed. If MIME-TYPE is not specified, try to find it from the image data." (let* ((data (or raw-data (base64-decode-string base64-string))) (bytes (length data)) (sha1-sum (sha1 data)) (base64-data (or base64-string (base64-encode-string raw-data))) (type (or mime-type (when-let* ((detected (ignore-errors (image-type data nil t)))) (symbol-name detected))))) (make-avatar :mime-type type :sha1-sum sha1-sum :base64-data base64-data :bytes bytes))) (defun jabber-avatar--line-height () "Return the pixel height of a line, suitable for inline avatars." (frame-char-height)) (defun jabber-avatar-image (avatar) "Create an image from AVATAR sized to fit a single line. Return nil if images of this type are not supported." (condition-case nil (let ((h (jabber-avatar--line-height))) (jabber-image-create (with-temp-buffer (set-buffer-multibyte nil) (insert (avatar-base64-data avatar)) (base64-decode-region (point-min) (point-max)) (buffer-string)) (avatar-mime-type avatar) h h)) (error nil))) ;;;; Avatar cache (defun jabber-avatar-find-cached (sha1-sum) "Return file name of cached image for avatar identified by SHA1-SUM. If there is no cached image, return nil." (let ((filename (expand-file-name sha1-sum jabber-avatar-cache-directory))) (if (file-exists-p filename) filename nil))) (defun jabber-avatar-cache (avatar) "Cache the AVATAR." (let* ((id (avatar-sha1-sum avatar)) (base64-data (avatar-base64-data avatar)) (filename (expand-file-name id jabber-avatar-cache-directory))) (unless (file-directory-p jabber-avatar-cache-directory) (make-directory jabber-avatar-cache-directory t)) (if (file-exists-p filename) (when jabber-avatar-verbose (message "Caching avatar, but %s already exists" filename)) (with-temp-buffer (let ((require-final-newline nil) (coding-system-for-write 'binary)) (set-buffer-multibyte nil) (insert base64-data) (base64-decode-region (point-min) (point-max)) (write-region (point-min) (point-max) filename nil 'silent)))))) ;;;; Set avatar for contact (defun jabber-avatar-set (jid avatar) "Set the avatar of JID to be AVATAR. JID is a string containing a bare JID. AVATAR may be one of: * An avatar structure. * The SHA1 sum of a cached avatar. * nil, meaning no avatar." ;; We want to optimize for the case of same avatar. ;; Loading an image is expensive, so do it lazily. (let ((jid-symbol (jabber-jid-symbol jid)) image hash) (cond ((avatar-p avatar) (setq hash (avatar-sha1-sum avatar)) (setq image (lambda () (jabber-avatar-image avatar)))) ((stringp avatar) (setq hash avatar) (setq image (lambda () (when-let* ((file (jabber-avatar-find-cached avatar))) (condition-case nil (let ((h (jabber-avatar--line-height))) (jabber-image-create-from-file file h h)) (error nil)))))) (t (setq hash nil) (setq image #'ignore))) (unless (string= hash (get jid-symbol 'avatar-hash)) (put jid-symbol 'avatar (funcall image)) (put jid-symbol 'avatar-hash hash)))) (defun jabber-create-image (file-or-data &optional _type data-p) "Create a line-height-sized image from FILE-OR-DATA." (let ((h (jabber-avatar--line-height))) (if data-p (jabber-image-create file-or-data nil h h) (jabber-image-create-from-file file-or-data h h)))) (provide 'jabber-avatar) ;;; jabber-avatar.el ends here emacs-jabber/lisp/jabber-blocking.el000066400000000000000000000142071516610113500177000ustar00rootroot00000000000000;;; jabber-blocking.el --- XEP-0191: Blocking Command -*- lexical-binding: t; -*- ;; Copyright (C) 2026 - Thanos Apollo ;; Author: Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;; XEP-0191 Blocking Command support. Allows users to block and ;; unblock JIDs, and retrieve their server-side blocklist. ;;; Code: (require 'jabber-util) (require 'jabber-xml) (require 'jabber-iq) (require 'jabber-disco) (defconst jabber-blocking-xmlns "urn:xmpp:blocking" "XML namespace for XEP-0191 Blocking Command.") (declare-function jabber-connection-bare-jid "jabber-util" (jc)) (declare-function jabber-read-jid-completing "jabber-util" (prompt &optional subset require-match default resource fulljids)) (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-chatting-with) ; jabber-chat.el ;;;###autoload (defun jabber-blocking-block-jid (jc jid) "Block JID on connection JC. JC is the Jabber connection. JID is the bare JID to block." (interactive (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Block JID: ")))) (jabber-send-iq jc nil "set" `(block ((xmlns . ,jabber-blocking-xmlns)) (item ((jid . ,jid)))) (lambda (_jc _xml _ctx) (message "Blocked %s" jid)) nil (lambda (_jc xml _ctx) (message "Failed to block %s: %S" jid xml)) nil)) ;;;###autoload (defun jabber-blocking-unblock-jid (jc jid) "Unblock JID on connection JC. JC is the Jabber connection. JID is the bare JID to unblock." (interactive (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Unblock JID: ")))) (jabber-send-iq jc nil "set" `(unblock ((xmlns . ,jabber-blocking-xmlns)) (item ((jid . ,jid)))) (lambda (_jc _xml _ctx) (message "Unblocked %s" jid)) nil (lambda (_jc xml _ctx) (message "Failed to unblock %s: %S" jid xml)) nil)) ;;;###autoload (defun jabber-blocking-list (jc) "Retrieve and display the blocklist for connection JC. JC is the Jabber connection." (interactive (list (jabber-read-account))) (jabber-send-iq jc nil "get" `(blocklist ((xmlns . ,jabber-blocking-xmlns))) #'jabber-blocking--display-list nil (lambda (_jc xml _ctx) (message "Failed to retrieve blocklist: %S" xml)) nil)) (defun jabber-blocking--display-list (jc xml-data _closure) "Display the blocklist from XML-DATA. JC is the Jabber connection." (let* ((blocklist (jabber-xml-get-children (car (jabber-xml-get-children xml-data 'blocklist)) 'item)) (jids (mapcar (lambda (item) (jabber-xml-get-attribute item 'jid)) blocklist))) (if (null jids) (message "Blocklist for %s is empty" (jabber-connection-bare-jid jc)) (with-output-to-temp-buffer "*jabber-blocklist*" (princ (format "Blocklist for %s:\n\n" (jabber-connection-bare-jid jc))) (dolist (jid jids) (princ (format " %s\n" jid))))))) ;;;###autoload (defun jabber-blocking-block-chat-peer (jc) "Block the JID of the current chat buffer. JC is the Jabber connection." (interactive (list jabber-buffer-connection)) (unless (bound-and-true-p jabber-chatting-with) (user-error "Not in a chat buffer")) (let ((jid (jabber-jid-user jabber-chatting-with))) (when (yes-or-no-p (format "Block %s? " jid)) (jabber-blocking-block-jid jc jid)))) ;;;###autoload (defun jabber-blocking-toggle-chat-peer (jc) "Toggle block state of the JID in the current chat buffer. Fetches the blocklist from the server, then blocks or unblocks accordingly. JC is the Jabber connection." (interactive (list jabber-buffer-connection)) (unless (bound-and-true-p jabber-chatting-with) (user-error "Not in a chat buffer")) (let ((jid (jabber-jid-user jabber-chatting-with))) (jabber-send-iq jc nil "get" `(blocklist ((xmlns . ,jabber-blocking-xmlns))) (lambda (jc xml-data _ctx) (jabber-blocking--toggle jc xml-data jid)) nil (lambda (_jc xml _ctx) (message "Failed to retrieve blocklist: %S" xml)) nil))) (defun jabber-blocking--toggle (jc xml-data jid) "Block or unblock JID based on current blocklist in XML-DATA. JC is the Jabber connection." (let* ((blocklist (jabber-xml-get-children (car (jabber-xml-get-children xml-data 'blocklist)) 'item)) (blocked-jids (mapcar (lambda (item) (jabber-xml-get-attribute item 'jid)) blocklist)) (blocked-p (member jid blocked-jids))) (if blocked-p (when (yes-or-no-p (format "Unblock %s? " jid)) (jabber-blocking-unblock-jid jc jid)) (when (yes-or-no-p (format "Block %s? " jid)) (jabber-blocking-block-jid jc jid))))) (jabber-disco-advertise-feature jabber-blocking-xmlns) (provide 'jabber-blocking) ;;; jabber-blocking.el ends here emacs-jabber/lisp/jabber-bookmarks.el000066400000000000000000000735521516610113500201100ustar00rootroot00000000000000;;; jabber-bookmarks.el --- bookmarks according to XEP-0048 -*- lexical-binding: t; -*- ;; Copyright (C) 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'cl-lib) (require 'jabber-private) (require 'jabber-pubsub) (require 'transient) (defconst jabber-bookmarks-xmlns "storage:bookmarks" "XEP-0048 bookmarks namespace.") (defconst jabber-bookmarks2-xmlns "urn:xmpp:bookmarks:1" "XEP-0402 Bookmarks 2 namespace.") (defconst jabber-bookmarks2-compat-xmlns "urn:xmpp:bookmarks:1#compat" "XEP-0402 compat feature advertised in server disco.") (defconst jabber-bookmarks2--publish-options '(("pubsub#persist_items" . "true") ("pubsub#max_items" . "max") ("pubsub#send_last_published_item" . "never") ("pubsub#access_model" . "whitelist")) "Publish-options required by XEP-0402.") ;; Global reference declarations (defvar jabber-muc-default-nicknames) ; jabber-muc.el (defvar jabber-muc-autojoin) ; jabber-muc.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-pre-disconnect-hook) ; jabber-core.el (declare-function jabber-disco-get-info "jabber-disco.el" (jc jid node callback closure-data &optional force)) (declare-function jabber-muc-joined-p "jabber-muc" (group &optional jc)) (declare-function jabber-muc-nickname "jabber-muc" (group &optional jc)) (declare-function jabber-muc-join "jabber-muc" (jc group nickname &optional popup)) (declare-function jabber-muc-leave "jabber-muc" (jc group)) (declare-function jabber-muc-get-buffer "jabber-muc" (group &optional jc)) (declare-function fsm-get-state-data "fsm" (fsm)) ;; Disco feature: request PubSub notifications for bookmarks (jabber-disco-advertise-feature (concat jabber-bookmarks2-xmlns "+notify")) (defcustom jabber-bookmarks-auto-add t "Whether to automatically bookmark rooms on join. When non-nil, joining a room automatically adds it to bookmarks with autojoin enabled, matching the behavior of Dino and Conversations." :group 'jabber-chat :type 'boolean) (defvar jabber-bookmarks (make-hash-table :test 'equal) "Mapping from bare JIDs to bookmark lists. Values are a list of bookmark plists, or t if no bookmarks were found. nil means bookmarks have not been retrieved yet.") (defvar jabber-bookmarks--legacy-accounts (make-hash-table :test 'equal) "Set of bare JIDs whose servers only support XEP-0049 legacy bookmarks. Non-nil value means the account fell back to legacy on last fetch.") ;;;###autoload (defun jabber-get-conference-data (jc conference-jid cont &optional key) "Get bookmark data for CONFERENCE-JID. KEY may be nil or one of :name, :autojoin, :nick and :password. If KEY is nil, a plist containing the above keys is returned. CONT is called when the result is available, with JC and the result as arguments. If CONT is nil, return the requested data immediately, and return nil if it is not in the cache." (if (null cont) (let ((cache (jabber-get-bookmarks-from-cache jc))) (if (and cache (listp cache)) (jabber-get-conference-data-internal cache conference-jid key))) (jabber-get-bookmarks jc (lambda (jc result) (let ((entry (jabber-get-conference-data-internal result conference-jid key))) (funcall cont jc entry)))))) (defun jabber-get-conference-data-internal (result conference-jid key) (let ((entry (cl-dolist (plist result) (when (string= (plist-get plist :jid) conference-jid) (cl-return plist))))) (if key (plist-get entry key) entry))) ;;;###autoload (defun jabber-parse-conference-bookmark (node) "Convert a tag into a plist. The plist may contain the keys :jid, :name, :autojoin, :nick and :password." (when (eq (jabber-xml-node-name node) 'conference) (list :jid (jabber-xml-get-attribute node 'jid) :name (jabber-xml-get-attribute node 'name) :autojoin (member (jabber-xml-get-attribute node 'autojoin) '("true" "1")) :nick (car (jabber-xml-node-children (car (jabber-xml-get-children node 'nick)))) :password (car (jabber-xml-node-children (car (jabber-xml-get-children node 'password))))))) ;;; XEP-0402 parse/build helpers (defun jabber-bookmarks2--parse-item (item) "Parse a PubSub ITEM sexp into a bookmark plist. JID comes from the item id attribute; the rest from the child element. Returns (:jid JID :name NAME :autojoin BOOL :nick NICK :password PASS), or nil if ITEM has no child." (let* ((jid (jabber-xml-get-attribute item 'id)) (conf (car (jabber-xml-get-children item 'conference)))) (when conf (list :jid jid :name (jabber-xml-get-attribute conf 'name) :autojoin (member (jabber-xml-get-attribute conf 'autojoin) '("true" "1")) :nick (car (jabber-xml-node-children (car (jabber-xml-get-children conf 'nick)))) :password (car (jabber-xml-node-children (car (jabber-xml-get-children conf 'password)))))))) (defun jabber-bookmarks2--build-conference (plist) "Build an XEP-0402 element from bookmark PLIST. PLIST keys: :name, :autojoin, :nick, :password. The :jid key is not included in the element (it becomes the PubSub item id)." `(conference ((xmlns . ,jabber-bookmarks2-xmlns) ,@(when (plist-get plist :name) `((name . ,(plist-get plist :name)))) ,@(when (plist-get plist :autojoin) '((autojoin . "true")))) ,@(when (plist-get plist :nick) `((nick () ,(plist-get plist :nick)))) ,@(when (plist-get plist :password) `((password () ,(plist-get plist :password)))))) ;;; XEP-0402 PubSub event handler (live sync) (defun jabber-bookmarks2--update-cache (jc bookmark) "Update the bookmark cache for JC with BOOKMARK plist. Replaces any existing entry with the same :jid." (let* ((my-jid (jabber-connection-bare-jid jc)) (old (let ((c (gethash my-jid jabber-bookmarks))) (when (listp c) c))) (jid (plist-get bookmark :jid)) (new (cons bookmark (cl-remove-if (lambda (bm) (string= (plist-get bm :jid) jid)) old)))) (puthash my-jid new jabber-bookmarks))) (defun jabber-bookmarks2--remove-from-cache (jc jid) "Remove the bookmark for JID from the cache for JC." (let* ((my-jid (jabber-connection-bare-jid jc)) (old (let ((c (gethash my-jid jabber-bookmarks))) (when (listp c) c))) (new (cl-remove-if (lambda (bm) (string= (plist-get bm :jid) jid)) old))) (puthash my-jid (or new t) jabber-bookmarks))) (defun jabber-bookmarks2--maybe-join (jc bookmark) "Join the room in BOOKMARK if autojoin is set and not already joined." (let ((jid (plist-get bookmark :jid))) (unless (jabber-muc-joined-p jid jc) (jabber-muc-join jc jid (or (plist-get bookmark :nick) (plist-get (fsm-get-state-data jc) :username)))))) (defun jabber-bookmarks2--maybe-leave (jc jid) "Leave room JID if currently joined, with a status message." (when (jabber-muc-joined-p jid jc) (let ((buf (jabber-muc-get-buffer jid))) (when (buffer-live-p buf) (with-current-buffer buf (goto-char (point-max)) (insert (propertize "\n*** Left room (bookmark removed by another client)\n" 'face 'shadow))))) (jabber-muc-leave jc jid))) (defun jabber-bookmarks2--handle-event (jc _from _node items) "Handle PubSub event notifications for bookmarks. JC is the connection. ITEMS is the list of and child elements from the event. Legacy accounts ignore these events." (unless (jabber-bookmarks--legacy-p jc) (dolist (child items) (pcase (jabber-xml-node-name child) ('item (let ((bookmark (jabber-bookmarks2--parse-item child))) (when bookmark (jabber-bookmarks2--update-cache jc bookmark) (if (plist-get bookmark :autojoin) (jabber-bookmarks2--maybe-join jc bookmark) (jabber-bookmarks2--maybe-leave jc (plist-get bookmark :jid)))))) ('retract (let ((jid (jabber-xml-get-attribute child 'id))) (jabber-bookmarks2--remove-from-cache jc jid) (jabber-bookmarks2--maybe-leave jc jid))))))) (with-eval-after-load "jabber-pubsub" (setf (alist-get jabber-bookmarks2-xmlns jabber-pubsub-node-handlers nil nil #'equal) #'jabber-bookmarks2--handle-event)) ;;; Fetch bookmarks ;;;###autoload (defun jabber-get-bookmarks (jc cont &optional refresh) "Retrieve bookmarks (if needed) and call CONT. Arguments to CONT are JC and a list of bookmark plists. CONT is called asynchronously. If REFRESH is non-nil, always fetch from server and re-detect protocol." (let ((bookmarks (gethash (jabber-connection-bare-jid jc) jabber-bookmarks))) (if (and (not refresh) bookmarks) (run-with-timer 0 nil cont jc (when (listp bookmarks) bookmarks)) (jabber-bookmarks--detect-and-fetch jc cont refresh)))) (defun jabber-bookmarks--detect-and-fetch (jc cont &optional refresh) "Detect bookmark protocol via disco and fetch. Query bare JID for the `#compat' feature. If present, use XEP-0402 PubSub; otherwise fall back to XEP-0049 Private XML Storage. When REFRESH is non-nil, re-run disco detection." (if (and (not refresh) (jabber-bookmarks--legacy-p jc)) (jabber-bookmarks--get-legacy jc cont) (jabber-disco-get-info jc (jabber-connection-bare-jid jc) nil (lambda (jc _closure result) (if (and (listp result) (not (eq (car result) 'error)) (member jabber-bookmarks2-compat-xmlns (cadr result))) (jabber-bookmarks2--fetch jc cont) (jabber-bookmarks--get-legacy jc cont))) nil))) (defun jabber-bookmarks2--fetch (jc cont) "Fetch bookmarks via XEP-0402 PubSub. CONT is called with JC and the bookmark plist list. Falls back to legacy on PubSub error." (jabber-pubsub-request jc nil jabber-bookmarks2-xmlns (lambda (jc xml-data _closure) (jabber-bookmarks2--handle-fetch jc xml-data cont)) (lambda (jc _xml-data _closure) (message "jabber-bookmarks: PubSub fetch error, falling back to legacy") (jabber-bookmarks--get-legacy jc cont)))) (defun jabber-bookmarks2--handle-fetch (jc xml-data cont) "Process a PubSub items response for XEP-0402 bookmarks. Parses items, updates cache, and calls CONT with the plist list." (let* ((pubsub (car (jabber-xml-get-children xml-data 'pubsub))) (items-node (car (jabber-xml-get-children pubsub 'items))) (items (jabber-xml-get-children items-node 'item)) (plists (delq nil (mapcar #'jabber-bookmarks2--parse-item items))) (value (or plists t))) (remhash (jabber-connection-bare-jid jc) jabber-bookmarks--legacy-accounts) (puthash (jabber-connection-bare-jid jc) value jabber-bookmarks) (funcall cont jc (when (listp value) value)))) (defun jabber-bookmarks--get-legacy (jc cont) "Fetch bookmarks via XEP-0049 Private XML Storage (legacy fallback). Parses conference elements to plists and calls CONT." (jabber-private-get jc 'storage jabber-bookmarks-xmlns (lambda (jc result) (jabber-bookmarks--handle-legacy jc result cont)) (lambda (jc _result) (message "jabber-bookmarks: legacy fetch failed for %s" (jabber-connection-bare-jid jc)) (funcall cont jc nil)))) (defun jabber-bookmarks--handle-legacy (jc result cont) "Process an XEP-0049 storage response. Parses conference elements to plists, updates cache, calls CONT." (let* ((children (when (eq (jabber-xml-node-name result) 'storage) (jabber-xml-node-children result))) (plists (delq nil (mapcar (lambda (node) (when (eq (jabber-xml-node-name node) 'conference) (jabber-parse-conference-bookmark node))) children))) (value (or plists t))) (puthash (jabber-connection-bare-jid jc) t jabber-bookmarks--legacy-accounts) (puthash (jabber-connection-bare-jid jc) value jabber-bookmarks) (funcall cont jc (when (listp value) value)))) ;;;###autoload (defun jabber-get-bookmarks-from-cache (jc) "Return cached bookmarks for JC. If bookmarks have not yet been fetched by `jabber-get-bookmarks', return nil." (gethash (jabber-connection-bare-jid jc) jabber-bookmarks)) (defun jabber-bookmarks--legacy-p (jc) "Return non-nil if JC uses legacy XEP-0049 bookmarks." (gethash (jabber-connection-bare-jid jc) jabber-bookmarks--legacy-accounts)) (defun jabber-bookmarks--cache-snapshot (jc) "Return the current bookmark cache value for JC." (gethash (jabber-connection-bare-jid jc) jabber-bookmarks)) (defun jabber-bookmarks--restore-cache (jc snapshot) "Restore the bookmark cache for JC to SNAPSHOT." (puthash (jabber-connection-bare-jid jc) snapshot jabber-bookmarks)) (defun jabber-bookmarks2--publish (jc plist &optional callback error-callback) "Publish a single bookmark PLIST to PubSub via JC. CALLBACK and ERROR-CALLBACK follow `jabber-send-iq' conventions." (jabber-pubsub-publish jc nil jabber-bookmarks2-xmlns (plist-get plist :jid) (jabber-bookmarks2--build-conference plist) jabber-bookmarks2--publish-options callback error-callback)) (defun jabber-bookmarks2--retract (jc room-jid &optional callback error-callback) "Remove bookmark for ROOM-JID from PubSub via JC. CALLBACK and ERROR-CALLBACK follow `jabber-send-iq' conventions." (jabber-pubsub-retract jc nil jabber-bookmarks2-xmlns room-jid t callback error-callback)) (defun jabber-bookmarks--save-all (jc callback) "Write the full bookmark cache for JC via XEP-0049 Private XML Storage. CALLBACK is called with JC, nil, and success flag (t or nil)." (let* ((my-jid (jabber-connection-bare-jid jc)) (bookmarks (let ((c (gethash my-jid jabber-bookmarks))) (when (listp c) c)))) (jabber-bookmarks--set-legacy jc bookmarks (lambda (jc _xml success) (funcall callback jc nil success))))) (defun jabber-set-bookmarks (jc new-bookmarks &optional callback) "Set bookmarks to NEW-BOOKMARKS, a list of bookmark plists. Diffs against cache: publishes added/changed, retracts removed. For legacy accounts, writes via XEP-0049 Private XML Storage. For PubSub accounts, publishes per-item and falls back to XEP-0049 on error. CALLBACK, if non-nil, is called with JC and t or nil on success or failure." (unless callback (setq callback #'ignore)) (if (jabber-bookmarks--legacy-p jc) (jabber-bookmarks--set-legacy jc new-bookmarks callback) (let* ((my-jid (jabber-connection-bare-jid jc)) (old (let ((c (gethash my-jid jabber-bookmarks))) (when (listp c) c))) (old-jids (mapcar (lambda (bm) (plist-get bm :jid)) old)) (new-jids (mapcar (lambda (bm) (plist-get bm :jid)) new-bookmarks)) (to-retract (cl-set-difference old-jids new-jids :test #'string=)) (pending 0) (failed nil)) ;; Track completions (cl-flet ((done (_jc _xml _closure) (cl-decf pending) (when (zerop pending) (unless failed (puthash my-jid (or new-bookmarks t) jabber-bookmarks)) (funcall callback jc (not failed)))) (fail (_jc _xml _closure) (setq failed t) (cl-decf pending) (when (zerop pending) ;; Fall back to XEP-0049 bulk write (jabber-bookmarks--set-legacy jc new-bookmarks callback)))) ;; Publish each bookmark (dolist (bm new-bookmarks) (cl-incf pending) (jabber-bookmarks2--publish jc bm #'done #'fail)) ;; Retract removed (dolist (jid to-retract) (cl-incf pending) (jabber-bookmarks2--retract jc jid #'done #'fail)) ;; If nothing to do, succeed immediately (when (zerop pending) (puthash my-jid (or new-bookmarks t) jabber-bookmarks) (funcall callback jc t)))))) (defun jabber-bookmarks--set-legacy (jc bookmarks &optional callback) "Write BOOKMARKS via XEP-0049 Private XML Storage (legacy fallback). BOOKMARKS is a list of plists. Converts to XEP-0048 XML format. CALLBACK is called with JC, XML-DATA, and t on success or nil on failure." (unless callback (setq callback #'ignore)) (let ((xml-elems (mapcar (lambda (bm) `(conference ((jid . ,(plist-get bm :jid)) ,@(when (plist-get bm :name) `((name . ,(plist-get bm :name)))) (autojoin . ,(if (plist-get bm :autojoin) "1" "0"))) ,@(when (plist-get bm :nick) `((nick () ,(plist-get bm :nick)))) ,@(when (plist-get bm :password) `((password () ,(plist-get bm :password)))))) bookmarks))) (jabber-private-set jc `(storage ((xmlns . ,jabber-bookmarks-xmlns)) ,@xml-elems) callback t (lambda (jc xml-data _closure) (message "jabber-bookmarks: legacy write failed for %s" (jabber-connection-bare-jid jc)) (funcall callback jc xml-data nil)) nil))) ;;; Tabulated-list bookmark editor (defvar jabber-bookmarks-mode-map (let ((map (make-sparse-keymap))) (define-key map "a" #'jabber-bookmarks-add) (define-key map "d" #'jabber-bookmarks-delete) (define-key map "t" #'jabber-bookmarks-toggle-autojoin) (define-key map "e" #'jabber-bookmarks-edit) (define-key map "h" #'jabber-bookmarks-menu) (define-key map "?" #'jabber-bookmarks-menu) map) "Keymap for `jabber-bookmarks-mode'.") (defun jabber-bookmarks--column-format () "Compute `tabulated-list-format' based on window width." (let* ((w (- (window-width) (* 5 2))) ; subtract padding (5 cols * 2) (jid-w (floor (* w 0.35))) (name-w (floor (* w 0.20))) (autojoin-w (floor (* w 0.10))) (nick-w (floor (* w 0.20))) (password-w (- w jid-w name-w autojoin-w nick-w))) (vector (list "JID" jid-w t) (list "Name" name-w t) (list "Autojoin" autojoin-w t) (list "Nick" nick-w t) (list "Password" password-w t)))) (define-derived-mode jabber-bookmarks-mode tabulated-list-mode "Bookmarks" "Major mode for displaying XMPP bookmarks." (setq tabulated-list-format (jabber-bookmarks--column-format)) (setq tabulated-list-padding 2) (tabulated-list-init-header) (setq tabulated-list-entries #'jabber-bookmarks--entries) (add-hook 'tabulated-list-revert-hook #'jabber-bookmarks--revert nil t)) (defun jabber-bookmarks--entries () "Build tabulated-list entries from the bookmark cache." (let ((cache (jabber-get-bookmarks-from-cache jabber-buffer-connection))) (when (listp cache) (mapcar (lambda (bm) (list (plist-get bm :jid) (vector (or (plist-get bm :jid) "") (or (plist-get bm :name) "") (if (plist-get bm :autojoin) "true" "false") (or (plist-get bm :nick) "") (if (plist-get bm :password) "***" "")))) cache)))) (defun jabber-bookmarks--revert () "Re-fetch bookmarks from server before reverting." (jabber-get-bookmarks jabber-buffer-connection (lambda (_jc _bookmarks) (when-let* ((buf (get-buffer "*jabber-bookmarks*"))) (with-current-buffer buf (setq tabulated-list-format (jabber-bookmarks--column-format)) (tabulated-list-init-header) (tabulated-list-print t)))) t)) ;;;###autoload (defun jabber-edit-bookmarks (jc) "Display bookmarks in a tabulated list. JC is the Jabber connection." (interactive (list (jabber-read-account))) (jabber-get-bookmarks jc #'jabber-bookmarks--show-editor t)) (defun jabber-bookmarks--show-editor (jc _bookmarks) "Populate the bookmark editor buffer. JC is the Jabber connection." (with-current-buffer (get-buffer-create "*jabber-bookmarks*") (jabber-bookmarks-mode) (setq jabber-buffer-connection jc) (tabulated-list-print t) (switch-to-buffer (current-buffer)))) ;;; Direct commands (defun jabber-bookmarks--get-bookmark-at-point () "Return the bookmark plist for the entry at point, or nil." (when-let* ((jid (tabulated-list-get-id))) (let ((cache (jabber-get-bookmarks-from-cache jabber-buffer-connection))) (when (listp cache) (cl-find jid cache :key (lambda (bm) (plist-get bm :jid)) :test #'string=))))) (defun jabber-bookmarks-add (jid) "Add a bookmark for JID with autojoin enabled." (interactive "sRoom JID: ") (jabber-bookmarks--publish-one jabber-buffer-connection jid)) (defun jabber-bookmarks-auto-add-maybe (jc jid nick) "Bookmark JID with NICK if `jabber-bookmarks-auto-add' is enabled. Does nothing if JID is already bookmarked. JC is the connection." (when jabber-bookmarks-auto-add (let ((cache (jabber-get-bookmarks-from-cache jc))) (unless (and (listp cache) (cl-find jid cache :key (lambda (bm) (plist-get bm :jid)) :test #'string=)) (jabber-bookmarks--publish-one jc jid nick))))) (defun jabber-bookmarks--publish-one (jc jid &optional nick) "Publish a bookmark for JID via JC. NICK, if non-nil, is stored in the bookmark." (let ((plist (list :jid jid :autojoin t :nick (or nick (jabber-muc-nickname jid jc))))) (if (jabber-bookmarks--legacy-p jc) (let ((snapshot (jabber-bookmarks--cache-snapshot jc))) (jabber-bookmarks2--update-cache jc plist) (jabber-bookmarks--save-all jc (lambda (jc _xml success) (if success (progn (jabber-bookmarks2--maybe-join jc plist) (jabber-bookmarks--refresh-buffer) (message "Bookmark added: %s" jid)) (jabber-bookmarks--restore-cache jc snapshot) (jabber-bookmarks--refresh-buffer) (message "Failed to add bookmark: %s" jid))))) (jabber-bookmarks2--publish jc plist (lambda (jc _xml _closure) (jabber-bookmarks2--update-cache jc plist) (jabber-bookmarks2--maybe-join jc plist) (jabber-bookmarks--refresh-buffer) (message "Bookmark added: %s" jid)) (lambda (_jc _xml _closure) (message "Failed to add bookmark: %s" jid)))))) (defun jabber-bookmarks--retract-one (jc jid) "Remove bookmark for JID via JC." (if (jabber-bookmarks--legacy-p jc) (let ((snapshot (jabber-bookmarks--cache-snapshot jc))) (jabber-bookmarks2--remove-from-cache jc jid) (jabber-bookmarks--save-all jc (lambda (_jc _xml success) (if success (progn (jabber-bookmarks--refresh-buffer) (message "Bookmark removed: %s" jid)) (jabber-bookmarks--restore-cache jc snapshot) (jabber-bookmarks--refresh-buffer) (message "Failed to remove bookmark: %s" jid))))) (jabber-bookmarks2--retract jc jid (lambda (_jc _xml _closure) (jabber-bookmarks2--remove-from-cache jc jid) (jabber-bookmarks--refresh-buffer) (message "Bookmark removed: %s" jid)) (lambda (_jc _xml _closure) (message "Failed to remove bookmark: %s" jid))))) (defun jabber-bookmarks-delete () "Delete the bookmark at point." (interactive) (let ((jid (tabulated-list-get-id)) (jc jabber-buffer-connection)) (unless jid (user-error "No bookmark at point")) (when (yes-or-no-p (format "Delete bookmark %s? " jid)) (jabber-bookmarks--retract-one jc jid)))) (defun jabber-bookmarks-toggle-autojoin () "Toggle autojoin for the bookmark at point." (interactive) (let ((bm (jabber-bookmarks--get-bookmark-at-point))) (unless bm (user-error "No bookmark at point")) (let* ((jid (plist-get bm :jid)) (new-autojoin (not (plist-get bm :autojoin))) (new-plist (plist-put (copy-sequence bm) :autojoin new-autojoin)) (jc jabber-buffer-connection) (on-success (lambda (jc) (if new-autojoin (jabber-bookmarks2--maybe-join jc new-plist) (jabber-bookmarks2--maybe-leave jc jid)) (jabber-bookmarks--refresh-buffer) (message "%s autojoin %s" jid (if new-autojoin "on" "off"))))) (if (jabber-bookmarks--legacy-p jc) (let ((snapshot (jabber-bookmarks--cache-snapshot jc))) (jabber-bookmarks2--update-cache jc new-plist) (jabber-bookmarks--save-all jc (lambda (jc _xml success) (if success (funcall on-success jc) (jabber-bookmarks--restore-cache jc snapshot) (jabber-bookmarks--refresh-buffer) (message "Failed to toggle autojoin for %s" jid))))) (jabber-bookmarks2--publish jc new-plist (lambda (jc _xml _closure) (jabber-bookmarks2--update-cache jc new-plist) (funcall on-success jc)) (lambda (_jc _xml _closure) (message "Failed to toggle autojoin for %s" jid))))))) (defun jabber-bookmarks--refresh-buffer () "Refresh the bookmarks buffer if it exists." (when-let* ((buf (get-buffer "*jabber-bookmarks*"))) (with-current-buffer buf (tabulated-list-print t)))) ;;; Transient editor (defun jabber-bookmarks-set-nick () "Change nick for the bookmark at point." (interactive) (jabber-bookmarks--set-field :nick "Nick")) (defun jabber-bookmarks-set-name () "Change name for the bookmark at point." (interactive) (jabber-bookmarks--set-field :name "Name")) (defun jabber-bookmarks-set-password () "Change password for the bookmark at point." (interactive) (jabber-bookmarks--set-field :password "Password")) (defun jabber-bookmarks--set-field (key prompt) "Set field KEY of bookmark at point, prompting with PROMPT." (let ((bm (jabber-bookmarks--get-bookmark-at-point))) (unless bm (user-error "No bookmark at point")) (let* ((old (or (plist-get bm key) "")) (new (read-string (format "%s: " prompt) old)) (new-val (unless (string-empty-p new) new)) (new-plist (plist-put (copy-sequence bm) key new-val)) (jc jabber-buffer-connection) (jid (plist-get bm :jid)) (on-success (lambda () (jabber-bookmarks--refresh-buffer) (message "%s %s set to %s" jid prompt (or new-val "(empty)"))))) (if (jabber-bookmarks--legacy-p jc) (let ((snapshot (jabber-bookmarks--cache-snapshot jc))) (jabber-bookmarks2--update-cache jc new-plist) (jabber-bookmarks--save-all jc (lambda (_jc _xml success) (if success (funcall on-success) (jabber-bookmarks--restore-cache jc snapshot) (jabber-bookmarks--refresh-buffer) (message "Failed to set %s for %s" prompt jid))))) (jabber-bookmarks2--publish jc new-plist (lambda (_jc _xml _closure) (jabber-bookmarks2--update-cache jc new-plist) (funcall on-success)) (lambda (_jc _xml _closure) (message "Failed to set %s for %s" prompt jid))))))) (transient-define-prefix jabber-bookmarks-edit () "Edit bookmark at point." [:description (lambda () (format "Edit: %s" (or (tabulated-list-get-id) "(none)"))) [("a" "Toggle autojoin" jabber-bookmarks-toggle-autojoin) ("n" "Change nick" jabber-bookmarks-set-nick) ("N" "Change name" jabber-bookmarks-set-name) ("p" "Change password" jabber-bookmarks-set-password)]]) (transient-define-prefix jabber-bookmarks-menu () "Bookmarks commands." [["Bookmark" ("a" "Add bookmark" jabber-bookmarks-add) ("d" "Delete bookmark" jabber-bookmarks-delete) ("t" "Toggle autojoin" jabber-bookmarks-toggle-autojoin) ("e" "Edit bookmark" jabber-bookmarks-edit) ("g" "Refresh" revert-buffer)]]) ;;; Disconnect cleanup (defun jabber-bookmarks--on-disconnect () "Pre-disconnect hook. Clear bookmark caches." (clrhash jabber-bookmarks) (clrhash jabber-bookmarks--legacy-accounts)) (with-eval-after-load "jabber-core" (add-hook 'jabber-pre-disconnect-hook #'jabber-bookmarks--on-disconnect)) (provide 'jabber-bookmarks) ;;; jabber-bookmarks.el ends hereemacs-jabber/lisp/jabber-browse.el000066400000000000000000000103131516610113500174030ustar00rootroot00000000000000;;; jabber-browse.el --- jabber browsing by XEP-0011 -*- lexical-binding: t; -*- ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2003, 2004 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; Legacy entity browsing via jabber:iq:browse (XEP-0011, deprecated). ;; Sends browse queries and renders results (users, services, ;; conferences) into a buffer. Read-only: we answer no browse ;; requests. Modern servers use Service Discovery (XEP-0030) instead; ;; see `jabber-disco.el'. ;;; Code: (require 'jabber-iq) (require 'jabber-xml) (require 'jabber-util) (require 'jabber-menu) (defconst jabber-browse-xmlns "jabber:iq:browse" "XEP-0011 Jabber Browsing namespace.") (defun jabber-get-browse (jc to) "Send a browse infoquery request to someone. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "browse: " nil nil nil nil t))) (jabber-send-iq jc to "get" `(query ((xmlns . ,jabber-browse-xmlns))) #'jabber-process-data #'jabber-process-browse #'jabber-process-data "Browse failed")) (defconst jabber-browse--category-labels '((user . "$ USER") (service . "* SERVICE") (conference . "@ CONFERENCE")) "Alist mapping browse category symbols to display labels.") (defun jabber-browse--category-heading (item) "Return a heading string for browse ITEM." (let* ((name (jabber-xml-node-name item)) (category (jabber-xml-get-attribute item 'category)) (label (or (cdr (assq name jabber-browse--category-labels)) (cdr (assq (intern-soft (or category "")) jabber-browse--category-labels)) (format "! OTHER: %s" (if (and category (> (length category) 0)) category name))))) (propertize label 'face 'jabber-title))) (defun jabber-browse--insert-item (jc item) "Insert a single browse result ITEM into the current buffer. JC is the Jabber connection." (let ((jid (jabber-xml-get-attribute item 'jid)) (beginning (point))) (insert (jabber-browse--category-heading item) "\n\n") (dolist (attr '((type . "Type:\t\t") (jid . "JID:\t\t") (name . "Name:\t\t") (version . "Version:\t"))) (let ((data (jabber-xml-get-attribute item (car attr)))) (when (> (length data) 0) (insert (cdr attr) data "\n")))) (dolist (ns (jabber-xml-get-children item 'ns)) (let ((text (car (jabber-xml-node-children ns)))) (when (stringp text) (insert "Namespace:\t" text "\n")))) (insert "\n") (put-text-property beginning (point) 'jabber-jid jid) (put-text-property beginning (point) 'jabber-account jc) (when (listp (car (jabber-xml-node-children item))) (jabber-process-browse jc item)))) (defun jabber-process-browse (jc xml-data) "Handle results from jabber:iq:browse requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (dolist (item (jabber-xml-node-children xml-data)) (when (and (listp item) (not (eq (jabber-xml-node-name item) 'ns))) (jabber-browse--insert-item jc item)))) (provide 'jabber-browse) ;;; jabber-browse.el ends here. emacs-jabber/lisp/jabber-carbons.el000066400000000000000000000057621516610113500175450ustar00rootroot00000000000000;;; jabber-carbons.el --- Support for XEP-0280: Message Carbons -*- lexical-binding: t; -*- ;; Copyright (C) 2026 - Thanos Apollo ;; Author: Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'jabber-util) (require 'jabber-xml) (require 'jabber-menu) (require 'jabber-iq) (require 'jabber-disco) (defconst jabber-carbons-xmlns "urn:xmpp:carbons:2" "XML namespace for XEP-0280 Message Carbons.") (defcustom jabber-carbons-enable t "When non-nil, enable XEP-0280 Message Carbons on connect. Carbons copy outbound messages to all your other connected devices, keeping conversations in sync across clients." :type 'boolean :group 'jabber) (defun jabber-carbon-success (jc xml-data _context) (when (equal "result" (jabber-xml-get-attribute xml-data 'type)) (message "Carbons feature successfully enabled for %s" (jabber-connection-jid jc)))) (defun jabber-carbon-failure (_jc xml-data _context) (message "Carbons feature could not be enabled: %S" xml-data)) ;;;###autoload (defun jabber-enable-carbons (jc) "Send request to enable XEP-0280 Message Carbons. JC is the Jabber connection." (interactive (list (jabber-read-account))) (jabber-send-iq jc nil "set" `(enable ((xmlns . ,jabber-carbons-xmlns))) #'jabber-carbon-success nil #'jabber-carbon-failure nil)) ;;;###autoload (defun jabber-disable-carbons (jc) "Send request to disable XEP-0280 Message Carbons. JC is the Jabber connection." (interactive (list (jabber-read-account))) (jabber-send-iq jc nil "set" `(disable ((xmlns . ,jabber-carbons-xmlns))) (lambda (_jc _xml _ctx) (message "Carbons disabled")) nil (lambda (_jc xml _ctx) (message "Failed to disable carbons: %S" xml)) nil)) ;;;###autoload (defun jabber-carbons-maybe-enable (jc) "Enable carbons for JC if `jabber-carbons-enable' is non-nil." (when jabber-carbons-enable (jabber-enable-carbons jc))) (jabber-disco-advertise-feature jabber-carbons-xmlns) (provide 'jabber-carbons) ;;; jabber-carbons.el ends here emacs-jabber/lisp/jabber-chat.el000066400000000000000000002041151516610113500170260ustar00rootroot00000000000000;;; jabber-chat.el --- one-to-one chats -*- lexical-binding: t; -*- ;; Copyright (C) 2005, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'jabber-core) (require 'jabber-alert) (require 'jabber-chatbuffer) (require 'ewoc) (require 'goto-addr) (require 'url-parse) (require 'url-queue) (require 'hex-util) (eval-when-compile (require 'cl-lib)) (defgroup jabber-chat nil "chat display options" :group 'jabber) (defcustom jabber-chat-buffer-format "*%j-%a*" "The format specification for the name of chat buffers. These fields are available (all are about the person you are chatting with): %n Nickname, or JID if no nickname set %j Bare JID (without resource) %r Resource These fields are about your account: %a Your bare JID (account) %u Your username %s Your server" :type 'string) (defvar jabber-chat-header-line-format '("" (jabber-chat-buffer-show-avatar (:eval (let ((buddy (jabber-jid-symbol jabber-chatting-with))) (propertize " " 'display (get buddy 'avatar))))) (:eval (jabber-jid-displayname jabber-chatting-with)) " " (:eval (let ((buddy (jabber-jid-symbol jabber-chatting-with))) (propertize (or (cdr (assoc (get buddy 'show) jabber-presence-strings)) (get buddy 'show)) 'face (or (cdr (assoc (get buddy 'show) jabber-presence-faces)) 'jabber-roster-user-online)))) " " (:eval (jabber-fix-status (get (jabber-jid-symbol jabber-chatting-with) 'status))) " " (:eval jabber-chat-encryption-message) ;see jabber-chatbuffer.el (:eval jabber-chat-receipt-message) ;see jabber-receipts.el (:eval (when jabber-chat-mam-syncing (propertize " [syncing]" 'face 'shadow)))) "The specification for the header line of chat buffers. The format is that of `mode-line-format' and `header-line-format'.") (defcustom jabber-chat-buffer-show-avatar nil "Show avatars in header line of chat buffer? This variable might not take effect if you have changed `jabber-chat-header-line-format'." :type 'boolean) (defcustom jabber-chat-time-format "%H:%M" "The format specification for instant messages in the chat buffer. See also `jabber-chat-delayed-time-format'. See `format-time-string' for valid values." :type 'string) (defcustom jabber-chat-delayed-time-format "%H:%M" "The format specification for delayed messages in the chat buffer. See also `jabber-chat-time-format'. See `format-time-string' for valid values." :type 'string) (defcustom jabber-print-rare-time t "Non-nil means to print \"rare time\" indications in chat buffers. The default settings tell every new hour." :type 'boolean) (defcustom jabber-rare-time-format "%a %e %b %Y %H:00" "The format specification for the rare time information. Rare time information will be printed whenever the current time, formatted according to this string, is different to the last rare time printed." :type 'string) (defcustom jabber-chat-display-images t "When non-nil, fetch and display image URLs inline in chat buffers." :type 'boolean) (defface jabber-rare-time-face '((t :inherit font-lock-comment-face :underline t)) "Face for displaying rare time information.") (defcustom jabber-chat-encrypted-indicator (propertize "[E]" 'face 'shadow) "String prepended to the timestamp of encrypted messages." :type 'string) (defface jabber-chat-nick-encrypted '((t :inherit font-lock-constant-face)) "Face for own nick on encrypted messages.") (defface jabber-chat-nick-foreign-encrypted '((t :inherit font-lock-keyword-face :weight bold)) "Face for foreign nick on encrypted messages.") (defface jabber-chat-nick-plaintext '((t :inherit font-lock-warning-face :slant italic)) "Face for own nick on plaintext messages.") (defface jabber-chat-nick-foreign-plaintext '((t :inherit font-lock-keyword-face :slant italic)) "Face for foreign nick on plaintext messages.") (defface jabber-chat-nick-system '((t :inherit font-lock-constant-face :weight bold)) "Face for system and special messages.") (defface jabber-chat-text-local '((t ())) "Face used for text you write.") (defface jabber-chat-text-foreign '((t ())) "Face used for text others write.") (defface jabber-chat-error '((t :inherit error)) "Face used for error messages.") ;;;###autoload (defvar jabber-chatting-with nil "JID of the person you are chatting with.") (defvar jabber-chat-printers '(jabber-chat-print-subject jabber-chat-print-body jabber-chat-print-url jabber-chat-goto-address jabber-chat-mark-oob-attachment jabber-chat-mark-aesgcm-url jabber-chat--schedule-image-scan) "List of functions that may be able to print part of a message. Each function receives these arguments: XML-DATA The entire message stanza WHO :local or :foreign, for sent or received stanza, respectively MODE :insert or :printp. For :insert, insert text at point. For :printp, return non-nil if function would insert text.") (defvar jabber-body-printers '(jabber-chat-normal-body) "List of functions that may be able to print a body for a message. Each function receives these arguments: XML-DATA The entire message stanza WHO :local, :foreign or :error MODE :insert or :printp. For :insert, insert text at point. For :printp, return non-nil if function would insert text. These functions are called in order, until one of them returns non-nil. Add a function to the beginning of this list if the tag it handles replaces the contents of the tag.") (defvar jabber-chat-send-hooks nil "List of functions called when a chat message is sent. The arguments are the text to send, and the id attribute of the message. The functions should return a list of XML nodes they want to be added to the outgoing message.") (defun jabber-chat--run-send-hooks (stanza body id) "Run `jabber-chat-send-hooks' and nconc results onto STANZA. BODY and ID are passed to each hook function." (dolist (hook jabber-chat-send-hooks) (if (eq hook t) (when (local-variable-p 'jabber-chat-send-hooks) (dolist (global-hook (default-value 'jabber-chat-send-hooks)) (nconc stanza (funcall global-hook body id)))) (nconc stanza (funcall hook body id))))) ;; Global reference declarations (declare-function jabber-compose "jabber-compose.el" (jc &optional recipient)) (declare-function jabber-omemo--send-chat "jabber-omemo" (jc body &optional extra-elements)) (declare-function jabber-openpgp--send-chat "jabber-openpgp" (jc body &optional extra-elements)) (declare-function jabber-openpgp-legacy--send-chat "jabber-openpgp-legacy" (jc body &optional extra-elements)) (declare-function jabber-muc-private-create-buffer "jabber-muc.el" (jc group nickname)) (declare-function jabber-muc-print-prompt "jabber-muc.el" (msg &optional local dont-print-nick-p)) (declare-function jabber-muc-private-print-prompt "jabber-muc.el" (msg)) (declare-function jabber-muc-system-prompt "jabber-muc.el" (&rest _ignore)) (declare-function jabber-muc-message-p "jabber-muc.el"(message)) (declare-function jabber-muc-sender-p "jabber-muc.el" (jid)) (declare-function jabber-muc-private-message-p "jabber-muc.el" (message)) (declare-function jabber-muc-nickname "jabber-muc.el" (group &optional jc)) (declare-function jabber-muc-our-nick-p "jabber-muc.el" (group nick)) (defvar jabber-muc-xmlns-user) (declare-function jabber-image-fetch "jabber-image" (url callback &rest cbargs)) (declare-function jabber-omemo-aesgcm-decrypt "jabber-omemo" (key iv ciphertext-with-tag)) (defvar jabber-backlog-days) (defvar jabber-backlog-number) (declare-function jabber-db-backlog "jabber-db.el" (account peer &optional count start-time resource msg-type)) (declare-function jabber-db--store-outgoing "jabber-db.el" (jc to body type)) (declare-function jabber-db-store-message "jabber-db.el" (account peer direction type body timestamp &optional resource stanza-id server-id occupant-id oob-entries encrypted)) (declare-function jabber-db--extract-occupant-id "jabber-db.el" (xml-data)) (declare-function jabber-message-correct--replace-id "jabber-message-correct" (xml-data)) (declare-function jabber-message-correct--apply "jabber-message-correct" (replace-id new-body new-from muc-p buffer)) (defvar jabber-group) ; jabber-muc.el (defvar jabber-muc-printers) ; jabber-muc.el (declare-function jabber-mam-chat-opened "jabber-mam" (jc peer)) (declare-function jabber-chatstates--clear-typing "jabber-chatstates" ()) (defvar jabber-oob-xmlns) ; jabber-xml.el (defvar jabber-carbons-xmlns) ; jabber-carbons.el (defvar jabber-image-max-width) ; jabber-image.el (defvar jabber-image-max-height) ; jabber-image.el ;; (defvar jabber-chat-earliest-backlog nil "Float-time of earliest backlog entry inserted into buffer. nil if no backlog has been inserted.") (defvar jabber-chat-muc-presence-patterns-history nil "History values selected for `jabber-muc-decorate-presence-patterns'") (defface jabber-muc-presence-dim '((t :inherit shadow :slant italic)) "Face for diminished presence notifications.") (defcustom jabber-muc-decorate-presence-patterns-alist '(("Show enter/leave diminished" ("." . jabber-muc-presence-dim)) ("Show all" ("." . jabber-chat-text-foreign)) ("Hide all" (".")) ("Hide enter/leave" ("\\( enters the room ([^)]+)\\| has left the chatroom\\)$") ("." . jabber-muc-presence-dim))) "List presence treatment specifications. Each specification consists of a label (string) and a list of pattern/face pairs which are suitable values for `jabber-muc-decorate-presence-patterns'. These pairs describe how to highlight presence events in MUC chat logs." :type '(alist :key-type string :value-type (repeat :tag "Patterns" (cons :format "%v" (regexp :tag "Regexp") (choice (const :tag "Ignore" nil) (face :tag "Face" :value jabber-muc-presence-dim))))) :group 'jabber-alerts) (defcustom jabber-muc-decorate-presence-patterns (cdar jabber-muc-decorate-presence-patterns-alist) "List of regular expressions and face pairs. When a presence notification matches a pattern, display it with associated face. Ignore notification if face is `nil'." :type '(repeat :tag "Patterns" (cons :format "%v" (regexp :tag "Regexp") (choice (const :tag "Ignore" nil) (face :tag "Face" :value jabber-muc-presence-dim)))) :group 'jabber-alerts) ;;;###autoload (defun jabber-chat-get-buffer (chat-with &optional jc) "Return the chat buffer name for chatting with CHAT-WITH (bare or full JID). When JC is provided, account-specific format specs (%a, %u, %s) are expanded. Either a string or a buffer is returned, so use `get-buffer' or `get-buffer-create'." (format-spec jabber-chat-buffer-format (list (cons ?n (jabber-jid-displayname chat-with)) (cons ?j (jabber-jid-user chat-with)) (cons ?r (or (jabber-jid-resource chat-with) "")) (cons ?a (if jc (jabber-connection-bare-jid jc) "")) (cons ?u (if jc (plist-get (fsm-get-state-data jc) :username) "")) (cons ?s (if jc (plist-get (fsm-get-state-data jc) :server) ""))))) (defun jabber-chat-find-buffer (chat-with) "Find an existing 1:1 chat buffer for CHAT-WITH, or nil." (jabber-chatbuffer--registry-get 'chat (jabber-jid-user chat-with))) (defun jabber-chat-create-buffer (jc chat-with) "Prepare a buffer for chatting with CHAT-WITH. This function is idempotent. JC is the Jabber connection." (with-current-buffer (get-buffer-create (jabber-chat-get-buffer chat-with jc)) (unless (eq major-mode 'jabber-chat-mode) (jabber-chat-mode) (setq-local jabber-chatting-with chat-with) (jabber-chatbuffer--registry-put 'chat (jabber-jid-user chat-with)) (jabber-chat-mode-setup jc #'jabber-chat-pp) (setq jabber-send-function #'jabber-chat-send) (setq header-line-format jabber-chat-header-line-format) (setq-local jabber-chat-earliest-backlog nil) ;; insert backlog (when (null jabber-chat-earliest-backlog) (let ((backlog-entries (jabber-db-backlog (jabber-connection-bare-jid jc) (jabber-jid-user chat-with)))) (if (null backlog-entries) (setq jabber-chat-earliest-backlog (float-time)) ;; backlog-entries is DESC; last element is oldest. (setq jabber-chat-earliest-backlog (float-time (plist-get (car (last backlog-entries)) :timestamp))) ;; ewoc-enter-first with DESC input produces ascending display. ;; Insert in chunks to keep the UI responsive. (cl-incf jabber-chat--backlog-generation) (jabber-chat--insert-backlog-chunked (current-buffer) backlog-entries #'jabber-chat-display-buffer-images jabber-chat--backlog-generation)))) ;; Catch up missed 1:1 messages from MAM. (jabber-mam-chat-opened jc (jabber-jid-user chat-with)) (when-let* ((win (get-buffer-window (current-buffer)))) (with-selected-window win (goto-char jabber-point-insert) (recenter -1)))) ;; Make sure the connection variable is up to date. (setq jabber-buffer-connection jc) (current-buffer))) (defconst jabber-chat-backlog-chunk-size 100 "Number of backlog entries to insert per timer tick.") (defun jabber-chat-insert-backlog-entry (msg-plist) "Insert backlog MSG-PLIST at beginning of buffer." ;; Rare timestamps are especially important in backlog. We risk ;; having superfluous timestamps if we just add before each backlog ;; entry. (let* ((message-time (plist-get msg-plist :timestamp)) (direction (plist-get msg-plist :direction)) (msg-type (plist-get msg-plist :msg-type)) (node-type (cond ((string= msg-type "groupchat") (let ((nick (jabber-jid-resource (plist-get msg-plist :from)))) (if (or (and nick (jabber-muc-our-nick-p jabber-group nick)) (string= direction "out")) :muc-local :muc-foreign))) ((string= direction "out") :local) (t :foreign))) (node-data (list node-type msg-plist))) ;; Insert after existing rare timestamp? (let ((node (if (and jabber-print-rare-time (ewoc-nth jabber-chat-ewoc 0) (eq (car (ewoc-data (ewoc-nth jabber-chat-ewoc 0))) :rare-time) (not (jabber-rare-time-needed message-time (cadr (ewoc-data (ewoc-nth jabber-chat-ewoc 0)))))) (ewoc-enter-after jabber-chat-ewoc (ewoc-nth jabber-chat-ewoc 0) node-data) (let ((n (ewoc-enter-first jabber-chat-ewoc node-data))) (when jabber-print-rare-time (ewoc-enter-first jabber-chat-ewoc (list :rare-time message-time))) n)))) (when-let* ((id (plist-get msg-plist :id))) (puthash id node jabber-chat--msg-nodes))))) (defun jabber-chat--insert-backlog-chunked (buffer entries callback &optional generation) "Insert ENTRIES into BUFFER's ewoc in chunks to avoid blocking. Inserts `jabber-chat-backlog-chunk-size' entries per timer tick. Call CALLBACK with no arguments when all entries are inserted. GENERATION, when non-nil, is checked against the buffer's `jabber-chat--backlog-generation'; a mismatch means a newer refresh has started and this insert sequence should abort." (if (or (null entries) (not (buffer-live-p buffer)) (and generation (not (eql generation (buffer-local-value 'jabber-chat--backlog-generation buffer))))) (when (and callback (buffer-live-p buffer) (or (null generation) (eql generation (buffer-local-value 'jabber-chat--backlog-generation buffer)))) (with-current-buffer buffer (funcall callback))) (with-current-buffer buffer (let* ((buffer-undo-list t) (inhibit-read-only t) (chunk (cl-subseq entries 0 (min jabber-chat-backlog-chunk-size (length entries)))) (rest (nthcdr (length chunk) entries))) (mapc #'jabber-chat-insert-backlog-entry chunk) (if rest (run-with-timer 0.1 nil #'jabber-chat--insert-backlog-chunked buffer rest callback generation) (when callback (funcall callback))))))) (defun jabber-chat-display-more-backlog (how-many) "Display more messages from local history. HOW-MANY is the number of additional messages to show. When nil or 0, display all messages." (interactive (let ((input (read-string "How many more messages (empty for all)? "))) (list (if (string-empty-p input) nil (string-to-number input))))) (let* ((current-count (length (ewoc-collect jabber-chat-ewoc (lambda (data) (not (eq (car data) :rare-time)))))) (target-count (if (or (null how-many) (zerop how-many)) t (+ current-count how-many)))) (setq jabber-chat-buffer-msg-count target-count) (jabber-chat-buffer-refresh) (let ((new-count (length (ewoc-collect jabber-chat-ewoc (lambda (data) (not (eq (car data) :rare-time))))))) (if (> new-count current-count) (message "Loaded %d messages from local history" new-count) (message "No older messages in local history"))))) (jabber-chain-add 'jabber-message-chain #'jabber-process-chat) (defun jabber-get-forwarded-message (xml-data) "Extract the inner message from a carbon-forwarded stanza. Returns the inner message element, or nil if XML-DATA is not a carbon." (cdr (jabber-chat--extract-carbon xml-data))) (defun jabber-chat--extract-carbon (xml-data) "Extract carbon type and inner message from XML-DATA. Returns (TYPE . MESSAGE) where TYPE is `sent' or `received', or nil if XML-DATA is not a carbon." (let ((wrapper (or (car (jabber-xml-get-children xml-data 'sent)) (car (jabber-xml-get-children xml-data 'received))))) (when wrapper (let* ((type (jabber-xml-node-name wrapper)) (fwd (car (jabber-xml-get-children wrapper 'forwarded))) (msg (car (jabber-xml-get-children fwd 'message)))) (when msg (cons type msg)))))) (defun jabber-chat--unwrap-carbon (jc xml-data) "If XML-DATA is a carbon-forwarded message, unwrap it. Return (EFFECTIVE-XML-DATA . CHAT-BUFFER-OR-NIL). JC is the Jabber connection. Validates that the outer stanza's `from' matches our bare JID to prevent forged carbons (CVE-2017-5589)." (let ((carbon (jabber-chat--extract-carbon xml-data))) (if (not carbon) (cons xml-data nil) (let ((outer-from (jabber-jid-user (jabber-xml-get-attribute xml-data 'from)))) (if (not (string= outer-from (jabber-connection-bare-jid jc))) (progn (warn "jabber: dropping forged carbon from %s" outer-from) (cons xml-data nil)) (let* ((type (car carbon)) (inner-msg (cdr carbon))) (pcase type ('sent (let ((to (jabber-xml-get-attribute inner-msg 'to))) (cons inner-msg (when to (jabber-chat-create-buffer jc to))))) ('received (cons inner-msg nil))))))))) (defun jabber-chat--store-carbon (jc xml-data) "Store a carbon-forwarded message in the database. JC is the Jabber connection. XML-DATA is the inner (unwrapped, possibly decrypted) message stanza. Direction is determined by comparing the sender to our bare JID. Correction stanzas (XEP-0308) are skipped; the correction handler updates the original row instead." (unless (jabber-message-correct--replace-id xml-data) (let* ((from (jabber-xml-get-attribute xml-data 'from)) (to (jabber-xml-get-attribute xml-data 'to)) (body (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'body))))) (stanza-id (jabber-xml-get-attribute xml-data 'id)) (timestamp (jabber-message-timestamp xml-data)) (our-jid (jabber-connection-bare-jid jc)) (sent-p (string= (jabber-jid-user from) our-jid)) (direction (if sent-p "out" "in")) (peer-jid (if sent-p to from)) (peer (when peer-jid (jabber-jid-user peer-jid))) (encrypted (or (jabber-xml-child-with-xmlns xml-data "eu.siacs.conversations.axolotl") (jabber-xml-child-with-xmlns xml-data "jabber:x:encrypted") (jabber-xml-child-with-xmlns xml-data "urn:xmpp:openpgp:0")))) (when (and peer body) (jabber-db-store-message our-jid peer direction "chat" body (floor (float-time (or timestamp (current-time)))) (when from (jabber-jid-resource from)) stanza-id nil (jabber-db--extract-occupant-id xml-data) nil encrypted))))) (defun jabber-chat--select-buffer (jc from &optional carbon-buffer) "Return the chat buffer for an incoming message from FROM. CARBON-BUFFER, if non-nil, is a buffer already created for a carbon-forwarded message. JC is the Jabber connection." (if (jabber-muc-sender-p from) (jabber-muc-private-create-buffer jc (jabber-jid-user from) (jabber-jid-resource from)) (or carbon-buffer (jabber-chat-create-buffer jc from)))) (defun jabber-chat--set-body (xml-data text) "Replace or create the child of XML-DATA with TEXT. Mutates XML-DATA in place and returns it." (let ((body-el (car (jabber-xml-get-children xml-data 'body)))) (if body-el (setcar (cddr body-el) text) (nconc xml-data (list `(body () ,text))))) xml-data) (defvar jabber-chat-decrypt-handlers nil "Alist of registered decryption handlers. Each entry is (ID . PLIST) where PLIST has keys: :detect - function (XML-DATA) -> parsed-data or nil :decrypt - function (JC XML-DATA PARSED) -> XML-DATA (modified) :priority - integer, lower runs first (default 50) :error-label - string for error body, e.g. \"OMEMO\" Handlers are tried in :priority order (ascending). The first whose :detect returns non-nil wins.") (defvar jabber-chat--sorted-decrypt-handlers-cache nil "Cached sorted handler list. Invalidated on register/unregister.") (defun jabber-chat-register-decrypt-handler (id &rest props) "Register decryption handler ID with properties PROPS. ID is a symbol (e.g. `omemo', `openpgp', `openpgp-legacy'). PROPS is a plist with keys :detect, :decrypt, :priority, :error-label. If ID is already registered, replace it." (setq jabber-chat-decrypt-handlers (assq-delete-all id jabber-chat-decrypt-handlers)) (push (cons id props) jabber-chat-decrypt-handlers) (setq jabber-chat--sorted-decrypt-handlers-cache nil)) (defun jabber-chat-unregister-decrypt-handler (id) "Remove decryption handler ID." (setq jabber-chat-decrypt-handlers (assq-delete-all id jabber-chat-decrypt-handlers)) (setq jabber-chat--sorted-decrypt-handlers-cache nil)) (defun jabber-chat--sorted-decrypt-handlers () "Return `jabber-chat-decrypt-handlers' sorted by :priority." (or jabber-chat--sorted-decrypt-handlers-cache (setq jabber-chat--sorted-decrypt-handlers-cache (sort (copy-sequence jabber-chat-decrypt-handlers) (lambda (a b) (< (or (plist-get (cdr a) :priority) 50) (or (plist-get (cdr b) :priority) 50))))))) (defun jabber-chat--try-decrypt (jc xml-data parsed handler-props) "Call the :decrypt function from HANDLER-PROPS with error handling. On success, return the (mutated) XML-DATA. On error, replace the body with \"[LABEL: could not decrypt]\" and return XML-DATA." (condition-case err (funcall (plist-get handler-props :decrypt) jc xml-data parsed) (error (message "%s decrypt failed: %s" (plist-get handler-props :error-label) (error-message-string err)) (jabber-chat--set-body xml-data (format "[%s: could not decrypt]" (plist-get handler-props :error-label))) xml-data))) (defvar jabber-chat--crypto-loaded nil "Non-nil after crypto modules have been loaded.") (defun jabber-chat--decrypt-if-needed (jc xml-data) "Dispatch XML-DATA to the first matching decrypt handler. On first call, loads crypto modules so their handlers are registered. Tries handlers in :priority order. Returns XML-DATA, possibly with its body replaced by decrypted plaintext (or an error placeholder). Skips dispatch when XML-DATA has no `from' attribute. JC is the Jabber connection." (unless jabber-chat--crypto-loaded (condition-case nil (require 'jabber-omemo nil t) (error nil)) (condition-case nil (require 'jabber-openpgp nil t) (error nil)) (condition-case nil (require 'jabber-openpgp-legacy nil t) (error nil)) (setq jabber-chat--crypto-loaded t)) ;; First-match-wins: the dispatcher stops at the first handler whose ;; :detect returns non-nil, so re-entrancy guards are unnecessary. (if (null (jabber-xml-get-attribute xml-data 'from)) xml-data (cl-loop for (_id . props) in (jabber-chat--sorted-decrypt-handlers) for parsed = (funcall (plist-get props :detect) xml-data) when parsed return (jabber-chat--try-decrypt jc xml-data parsed props) finally return xml-data))) (defun jabber-chat--display-message (_jc _xml-data chat-buffer error-p from msg-plist) "Display an incoming message and run alert hooks. Insert an EWOC entry into CHAT-BUFFER for the message described by MSG-PLIST, then run `jabber-message-hooks' and `jabber-alert-message-hooks'. ERROR-P is non-nil when the stanza contains an error element. FROM is the sender JID. _JC and _XML-DATA are reserved for future use by OMEMO." (let ((body-text (plist-get msg-plist :body))) (with-current-buffer chat-buffer (jabber-chatstates--clear-typing) (jabber-maybe-print-rare-time (jabber-chat-ewoc-enter (list (if error-p :error :foreign) msg-plist))) (unless error-p (let ((inhibit-message jabber-chat-mam-syncing)) (dolist (hook '(jabber-message-hooks jabber-alert-message-hooks)) (run-hook-with-args hook from (current-buffer) body-text (funcall jabber-alert-message-function from (current-buffer) body-text)))))))) (defun jabber-process-chat (jc xml-data) "If XML-DATA is a one-to-one chat message, handle it as such. JC is the Jabber connection." (when (and (not (jabber-muc-message-p xml-data)) (jabber-xml-get-attribute xml-data 'from)) (let* ((unwrapped (jabber-chat--unwrap-carbon jc xml-data)) (is-carbon (not (eq xml-data (car unwrapped)))) (xml-data (jabber-chat--decrypt-if-needed jc (car unwrapped))) (carbon-buffer (cdr unwrapped)) (from (jabber-xml-get-attribute xml-data 'from)) (error-p (jabber-xml-get-children xml-data 'error)) (msg-plist (jabber-chat--msg-plist-from-stanza xml-data))) (when is-carbon (jabber-chat--store-carbon jc xml-data)) (let ((replace-id (jabber-message-correct--replace-id xml-data))) (if (and replace-id (not jabber-chat-mam-syncing)) (jabber-message-correct--apply replace-id (plist-get msg-plist :body) from nil (jabber-chat-find-buffer from)) (when (or error-p (run-hook-with-args-until-success 'jabber-chat-printers msg-plist :foreign :printp)) (jabber-chat--display-message jc xml-data (jabber-chat--select-buffer jc from carbon-buffer) error-p from msg-plist))))))) (defun jabber-chat-send (jc body &optional extra-elements) "Send BODY through connection JC, and display it in chat buffer. JC is the Jabber connection. EXTRA-ELEMENTS, when non-nil, is a list of XML sexp elements to splice into the stanza after the body (e.g. OOB, hints)." (pcase jabber-chat-encryption ('omemo (jabber-omemo--send-chat jc body extra-elements)) ('openpgp (require 'jabber-openpgp) (jabber-openpgp--send-chat jc body extra-elements)) ('openpgp-legacy (require 'jabber-openpgp-legacy) (jabber-openpgp-legacy--send-chat jc body extra-elements)) (_ ;; Build the stanza... (let* ((id (format "emacs-msg-%.6f" (float-time))) (stanza-to-send `(message ((to . ,jabber-chatting-with) (type . "chat") (id . ,id)) (body () ,body) ,@extra-elements))) ;; ...add additional elements... (jabber-chat--run-send-hooks stanza-to-send body id) ;; ...display it (skip for corrections, caller handles display). (unless (assq 'replace extra-elements) (let ((msg-plist (jabber-chat--msg-plist-from-stanza stanza-to-send))) (plist-put msg-plist :status :sent) (when (run-hook-with-args-until-success 'jabber-chat-printers msg-plist :local :printp) (jabber-maybe-print-rare-time (jabber-chat-ewoc-enter (list :local msg-plist)))))) ;; ...and send it... (jabber-send-sexp jc stanza-to-send))))) (defun jabber-find-previous-visible-node (node) "Return first visible EWOC node preceding NODE. Step backward over hidden nodes, like MUC presence join/leave messages." (let* ((node-location (ewoc-location node)) (prev (ewoc-prev jabber-chat-ewoc node)) (prev-location (and prev (ewoc-location prev)))) (while (and prev (not (equal (ewoc-data node) (ewoc-data prev))) (equal (marker-position node-location) (marker-position prev-location))) (setq prev (ewoc-prev jabber-chat-ewoc prev) prev-location (and prev (ewoc-location prev)))) prev)) (defun jabber-chat-muc-presence-patterns-select (global) "Select a MUC presence treatment. Prompts user to select a presence treatment by name, where the name is the `car' of an entry in `jabber-muc-decorate-presence-patterns-alist'. The variable `jabber-muc-decorate-presence-patterns' is set to the `cdr' of the selected treatment. By default, when `jabber-muc-decorate-presence-patterns' is updated, it is made buffer local. With a prefix argument, the buffer-local state of the variable is not changed. The chat buffer is redisplayed using the new value of `jabber-muc-decorate-presence-patterns'. Redisplaying the buffer may take a few second, especially in MUCs with a large number of participants connected through intermittent networks (like mobile clients)." (interactive "P") (when-let* ((patterns (cdr (assoc-string (completing-read "MUC presence treatment: " (mapcar #'car jabber-muc-decorate-presence-patterns-alist) nil t nil 'jabber-chat-muc-presence-patterns-history) jabber-muc-decorate-presence-patterns-alist)))) (unless (equal patterns jabber-muc-decorate-presence-patterns) (if global (setq jabber-muc-decorate-presence-patterns patterns) (setq-local jabber-muc-decorate-presence-patterns patterns)) (jabber-chat-redisplay)))) (defun jabber-chat-muc-presence-highlight (message) "Return non-`nil' to control MUC presence notification display. This matches :muc-notification message text with the list `jabber-muc-decorate-presence-patterns' and returns the pattern entry when a match is found, or nil if no matching pattern is found." (seq-find (lambda (pair) (string-match (car pair) message nil 'inhibit-modify)) jabber-muc-decorate-presence-patterns)) (defun jabber-chat--oob-field (oob-node child) "Return text content of CHILD element inside OOB-NODE, or nil." (when oob-node (car (jabber-xml-node-children (car (jabber-xml-get-children oob-node child)))))) (defun jabber-chat--extract-oob-entries (xml-data) "Extract all jabber:x:oob entries from XML-DATA. Returns a list of (URL . DESC) cons cells, or nil." (let (entries) (dolist (child (jabber-xml-node-children xml-data)) (when (and (listp child) (string= (jabber-xml-get-attribute child 'xmlns) jabber-oob-xmlns)) (let ((url (jabber-chat--oob-field child 'url)) (desc (jabber-chat--oob-field child 'desc))) (when url (push (cons url desc) entries))))) (nreverse entries))) (defun jabber-chat--has-muc-invite-p (xml-data) "Return non-nil if XML-DATA contains a MUC invitation." (let ((muc-x (jabber-xml-child-with-xmlns xml-data jabber-muc-xmlns-user))) (and muc-x (jabber-xml-get-children muc-x 'invite)))) (defun jabber-chat--build-msg-plist (xml-data delayed) "Build a message plist from the fields in XML-DATA. DELAYED marks the message as delayed unconditionally." (let* ((msg-timestamp (jabber-message-timestamp xml-data)) (oob-entries (jabber-chat--extract-oob-entries xml-data)) (error-node (car (jabber-xml-get-children xml-data 'error))) (sid-el (jabber-xml-child-with-xmlns xml-data "urn:xmpp:sid:0")) (reply-el (jabber-xml-child-with-xmlns xml-data "urn:xmpp:reply:0")) (unstyled-el (jabber-xml-child-with-xmlns xml-data "urn:xmpp:styling:0")) (raw-body (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'body))))) (body raw-body)) (list :id (jabber-xml-get-attribute xml-data 'id) :server-id (when sid-el (jabber-xml-get-attribute sid-el 'id)) :from (jabber-xml-get-attribute xml-data 'from) :body body :subject (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'subject)))) :timestamp (or msg-timestamp (current-time)) :delayed (or delayed (and msg-timestamp t)) :encrypted (and (jabber-xml-child-with-xmlns xml-data "eu.siacs.conversations.axolotl") t) :oob-entries oob-entries :oob-url (caar oob-entries) :oob-desc (cdar oob-entries) :error-text (when error-node (jabber-parse-error error-node)) :reply-to-id (when reply-el (jabber-xml-get-attribute reply-el 'id)) :reply-to-jid (when reply-el (jabber-xml-get-attribute reply-el 'to)) :unstyled (and unstyled-el t)))) (defun jabber-chat--msg-plist-from-stanza (xml-data &optional delayed) "Extract display fields from XML-DATA into a message plist. If DELAYED is non-nil, mark the message as delayed regardless of whether a delay element is present." (let ((plist (jabber-chat--build-msg-plist xml-data delayed))) (when (jabber-chat--has-muc-invite-p xml-data) (plist-put plist :xml-data xml-data)) plist)) (defun jabber-chat--insert-status-indicator (msg) "Insert a receipt status indicator for outgoing MSG. Shows a dot for sent, check for delivered, green check for seen, or X for undelivered." (when-let* ((status (plist-get msg :status))) (let ((indicator (pcase status (:sending (propertize " \u00b7" 'face 'warning)) (:sent (propertize " \u00b7" 'face 'shadow)) (:delivered (propertize " \u2713" 'face 'shadow)) (:displayed (propertize " \u2713" 'face 'success)) (:undelivered (propertize " \u2717" 'face 'error))))) (when indicator (insert indicator))))) (defun jabber-chat-pp--local (data) "Render a locally sent message from DATA." (let* ((msg (cadr data)) (body (plist-get msg :body)) (/me-p (and (stringp body) (string-prefix-p "/me " body)))) (jabber-chat-self-prompt msg (plist-get msg :timestamp) (plist-get msg :delayed) /me-p) (run-hook-with-args 'jabber-chat-printers msg :local :insert) (when (plist-get msg :edited) (insert (propertize " (edited)" 'face 'shadow))) (jabber-chat--insert-status-indicator msg) (insert "\n"))) (defun jabber-chat-pp--foreign (data) "Render a received message from DATA." (let* ((msg (cadr data)) (body (plist-get msg :body)) (/me-p (and (stringp body) (string-prefix-p "/me " body)))) (jabber-chat-print-prompt msg (plist-get msg :timestamp) (plist-get msg :delayed) /me-p) (run-hook-with-args 'jabber-chat-printers msg :foreign :insert) (when (plist-get msg :edited) (insert (propertize " (edited)" 'face 'shadow))) (insert "\n"))) (defun jabber-chat--insert-tombstone (msg) "Insert a retraction tombstone for MSG." (let ((moderator (plist-get msg :retracted-by)) (reason (plist-get msg :retraction-reason))) (when moderator (setq moderator (or (jabber-jid-resource moderator) moderator))) (insert (propertize (concat "[Message retracted" (when moderator (concat " by: " moderator)) (when reason (concat " reason: " reason)) "]") 'face 'shadow)))) (defun jabber-chat-pp--muc-local (data) "Render a locally sent MUC message from DATA." (let* ((msg (cadr data)) (body (plist-get msg :body)) (/me-p (and (stringp body) (string-prefix-p "/me " body)))) (jabber-muc-print-prompt msg t /me-p) (if (plist-get msg :retracted) (jabber-chat--insert-tombstone msg) (mapc (lambda (f) (funcall f msg :muc-local :insert)) (append jabber-muc-printers jabber-chat-printers)) (when (plist-get msg :edited) (insert (propertize " (edited)" 'face 'shadow))) (jabber-chat--insert-status-indicator msg)) (insert "\n"))) (defun jabber-chat-pp--muc-foreign (data) "Render a received MUC message from DATA." (let* ((msg (cadr data)) (body (plist-get msg :body)) (/me-p (and (stringp body) (string-prefix-p "/me " body)))) (jabber-muc-print-prompt msg nil /me-p) (if (plist-get msg :retracted) (jabber-chat--insert-tombstone msg) (mapc (lambda (f) (funcall f msg :muc-foreign :insert)) (append jabber-muc-printers jabber-chat-printers)) (when (plist-get msg :edited) (insert (propertize " (edited)" 'face 'shadow)))) (insert "\n"))) (defun jabber-chat-pp--error (data) "Render an error message from DATA." (let* ((msg (cadr data)) (timestamp (when (listp msg) (plist-get msg :timestamp)))) (jabber-chat-system-prompt (or timestamp (current-time))) (if (stringp msg) (insert (propertize msg 'face 'jabber-chat-error) "\n") (jabber-chat-print-error msg)))) (defun jabber-chat-pp--muc-error (data) "Render a MUC error message from DATA." (let ((msg (cadr data))) (jabber-muc-system-prompt) (if (stringp msg) (insert (propertize msg 'face 'jabber-chat-error) "\n") (jabber-chat-print-error msg)))) (defun jabber-chat-pp--notice (data) "Render a system notice from DATA." (let* ((msg (cadr data)) (timestamp (when (listp msg) (plist-get msg :timestamp)))) (jabber-chat-system-prompt (or timestamp (current-time))) (insert msg "\n"))) (defun jabber-chat-pp--typing (data) "Render a typing indicator from DATA." (insert (propertize (cadr data) 'face 'shadow) "\n")) (defun jabber-chat-pp--muc-notice (data) "Render a MUC presence notice from DATA. Respects `jabber-muc-decorate-presence-patterns' for highlight/hide behavior." (let* ((msg (cadr data)) (match (jabber-chat-muc-presence-highlight msg)) (face (cdr-safe match))) (cond ;; Matched with face: show prompt and body with that face (face (let ((prompt-start (point))) (jabber-muc-system-prompt) (put-text-property prompt-start (point) 'face face)) (insert (propertize msg 'face face) "\n")) ;; Matched with no face: hide entirely (match) ;; No match: show normally (t (jabber-muc-system-prompt) (insert msg "\n"))))) (defun jabber-chat-pp--rare-time (data) "Insert rare-time separator from DATA. When the previous visible node is also a :rare-time entry, remove its text to suppress consecutive duplicates." (let* ((msg (cadr data)) (node (jabber-chat-find-node data)) (prev (jabber-find-previous-visible-node node))) (when (and prev (eq (car (ewoc-data prev)) :rare-time)) (delete-region (marker-position (ewoc-location prev)) (point))) (insert (propertize (format-time-string jabber-rare-time-format msg) 'face 'jabber-rare-time-face) "\n"))) (defun jabber-chat-pp--subscription-request (data) "Render a subscription request from DATA." (let* ((msg (cadr data)) (timestamp (when (listp msg) (plist-get msg :timestamp)))) (jabber-chat-system-prompt (or timestamp (current-time))) (insert "This user requests subscription to your presence.\n") (when (and (stringp msg) (not (zerop (length msg)))) (insert "Message: " msg "\n")) (insert "Accept?\n\n") (insert-button "Mutual" 'action 'jabber-subscription-accept-mutual) (insert "\t") (insert-button "One-way" 'action 'jabber-subscription-accept-one-way) (insert "\t") (insert-button "Decline" 'action 'jabber-subscription-decline) (insert "\n"))) (defconst jabber-chat-pp-dispatch '((:local . jabber-chat-pp--local) (:foreign . jabber-chat-pp--foreign) (:muc-local . jabber-chat-pp--muc-local) (:muc-foreign . jabber-chat-pp--muc-foreign) (:error . jabber-chat-pp--error) (:muc-error . jabber-chat-pp--muc-error) (:notice . jabber-chat-pp--notice) (:muc-notice . jabber-chat-pp--muc-notice) (:rare-time . jabber-chat-pp--rare-time) (:subscription-request . jabber-chat-pp--subscription-request) (:typing . jabber-chat-pp--typing)) "Alist mapping message types to their render functions.") (defun jabber-chat-pp (data) "Pretty-print a chat message DATA for EWOC display. Dispatches to a type-specific render function via `jabber-chat-pp-dispatch', then marks the region read-only." (let ((beg (point-marker)) (type (car data))) (funcall (alist-get type jabber-chat-pp-dispatch) data) (put-text-property beg (point) 'read-only t) (put-text-property beg (point) 'front-sticky t) (put-text-property beg (point) 'rear-nonsticky t) (set-marker beg nil))) (defun jabber-rare-time-needed (time1 time2) "Return non-nil if a timestamp should be printed between TIME1 and TIME2." (not (string= (format-time-string jabber-rare-time-format time1) (format-time-string jabber-rare-time-format time2)))) (defun jabber-chat-entry-time (entry) "Return timestamp from EWOC node ENTRY. Handles both msg-plist entries (with :timestamp) and legacy string entries like :notice/:muc-notice (with :time in cddr)." (pcase (car entry) (:rare-time (cadr entry)) (_ (if (stringp (cadr entry)) (plist-get (cddr entry) :time) (plist-get (cadr entry) :timestamp))))) (defun jabber-chat-find-node (data) "Find EWOC node whose data element equals DATA." (let* ((node (ewoc-locate jabber-chat-ewoc (point))) (node-time (jabber-chat-entry-time (ewoc-data node))) (data-time (jabber-chat-entry-time data)) (node-iter (if (time-less-p data-time node-time) #'ewoc-next #'ewoc-prev))) (cl-macrolet ((search ())) (while (and node (not (equal data (ewoc-data node)))) (setq node (funcall node-iter jabber-chat-ewoc node))) (search) ;; In the off chance we searched the wrong direction, switch ;; directions and re-search. (unless node (setq node (ewoc-locate jabber-chat-ewoc (point)) node-iter (if (equal node-iter #'ewoc-prev) #'ewoc-next #'ewoc-prev)) (search))) node)) (defun jabber-maybe-print-rare-time (node) "Print rare time before NODE, if appropriate. NODE may be nil (e.g. when a duplicate was suppressed)." (when node (let* ((prev (ewoc-prev jabber-chat-ewoc node)) (data (ewoc-data node)) (prev-data (when prev (ewoc-data prev)))) (cl-flet ((entry-time (entry) (pcase (car entry) (:rare-time (cadr entry)) (_ (plist-get (cadr entry) :timestamp))))) (when (and jabber-print-rare-time (or (null prev) (jabber-rare-time-needed (entry-time prev-data) (entry-time data)))) ;; When jabber-parse-time supports fraction seconds (optional ;; with XEP-0082), jabber-chat-pp chokes on :rate-time ewoc ;; elements. Ensure that the timestamp is in lisp form, ;; rather than (cons bignum . bignum). (let ((buffer-undo-list t)) (ewoc-enter-before jabber-chat-ewoc node (list :rare-time (time-convert (entry-time data) 'list))))))))) (defun jabber-chat--format-time (timestamp delayed) "Format TIMESTAMP for prompt display. Use short format normally, long format when DELAYED." (format-time-string (if delayed jabber-chat-delayed-time-format jabber-chat-time-format) timestamp)) (defun jabber-chat--insert-prompt (timestamp nick face &optional plaintext-face encrypted) "Insert a chat prompt: TIMESTAMP . NICK gets FACE when ENCRYPTED, PLAINTEXT-FACE otherwise. When ENCRYPTED, `jabber-chat-encrypted-indicator' is prepended." (when encrypted (insert jabber-chat-encrypted-indicator)) (insert (propertize timestamp 'face 'shadow) " ") (when (> (length nick) 0) (insert (propertize (format "<%s> " nick) 'face (if encrypted face (or plaintext-face face)) 'rear-nonsticky t)))) (defun jabber-chat-print-prompt (msg timestamp delayed dont-print-nick-p) "Print prompt for received message MSG." (let* ((from (plist-get msg :from)) (timestamp (or timestamp (plist-get msg :timestamp))) (nick (if dont-print-nick-p "" (if (jabber-muc-sender-p from) (jabber-jid-resource from) (jabber-jid-displayname from))))) (jabber-chat--insert-prompt (jabber-chat--format-time timestamp delayed) nick 'jabber-chat-nick-foreign-encrypted 'jabber-chat-nick-foreign-plaintext (plist-get msg :encrypted)))) (defun jabber-chat-system-prompt (timestamp) "Print system prompt at TIMESTAMP." (jabber-chat--insert-prompt (jabber-chat--format-time timestamp nil) "" 'jabber-chat-nick-system)) (defun jabber-chat-self-prompt (msg timestamp delayed dont-print-nick-p) "Print prompt for sent message MSG." (let* ((state-data (fsm-get-state-data jabber-buffer-connection)) (username (plist-get state-data :username))) (jabber-chat--insert-prompt (jabber-chat--format-time timestamp delayed) (if dont-print-nick-p "" username) 'jabber-chat-nick-encrypted 'jabber-chat-nick-plaintext (plist-get msg :encrypted)))) (defun jabber-chat-print-error (msg) "Print error from message plist MSG in a readable way." (let ((error-text (plist-get msg :error-text))) (insert (propertize (concat "Error: " (or error-text "Unknown error")) 'face 'jabber-chat-error) "\n"))) (defun jabber-chat-print-subject (msg _who mode) "Print subject from message plist MSG, if any." (let ((subject (plist-get msg :subject))) (when (not (zerop (length subject))) (pcase mode (:printp t) (:insert (insert (propertize "Subject: " 'face 'jabber-chat-nick-system) (propertize subject 'face 'jabber-chat-text-foreign) "\n")))))) (defun jabber-chat-print-body (msg who mode) (run-hook-with-args-until-success 'jabber-body-printers msg who mode)) (defun jabber-chat-normal-body (msg who mode) "Print body from message plist MSG." (let ((body (plist-get msg :body))) (when body (when (eql mode :insert) (if (and (> (length body) 4) (string= (substring body 0 4) "/me ")) (let ((action (substring body 4)) (nick (cond ((eq who :local) (plist-get (fsm-get-state-data jabber-buffer-connection) :username)) ((memq who '(:muc-local :muc-foreign)) (jabber-jid-resource (plist-get msg :from))) (t (jabber-jid-displayname (plist-get msg :from)))))) (insert (propertize (concat nick " " action) 'face 'jabber-chat-nick-system))) (let ((face (pcase who ((or :foreign :muc-foreign) 'jabber-chat-text-foreign) ((or :local :muc-local) 'jabber-chat-text-local)))) (insert (propertize body 'face face))))) t))) (defun jabber-chat-print-url (msg _who mode) "Print OOB URLs from message plist MSG. Skips printing when the body already contains the URL to avoid duplication (e.g. HTTP Upload messages)." (let ((entries (or (plist-get msg :oob-entries) (when-let* ((url (plist-get msg :oob-url))) (list (cons url (plist-get msg :oob-desc)))))) (body (plist-get msg :body)) (printed nil)) (dolist (entry entries) (let ((url (car entry)) (desc (cdr entry))) (when (and url (not (equal body url))) (when (eql mode :insert) (insert (format "\n%s%s<%s>" (propertize "URL: " 'face 'jabber-chat-nick-system) (if (stringp desc) (concat desc " ") "") url))) (setq printed t)))) printed)) (defun jabber-chat--parse-aesgcm-url (url) "Parse an aesgcm:// URL into a plist. Returns (:https-url URL :iv BYTES :key BYTES) or nil if URL is not a valid aesgcm:// URL. The fragment must be 88 hex characters \(12-byte IV + 32-byte key) or 96 hex characters (16-byte IV + 32-byte key, used by some older clients)." (when (string-match "\\`aesgcm://\\([^#]*\\)#\\([[:xdigit:]]\\{88\\}\\|[[:xdigit:]]\\{96\\}\\)\\'" url) (let* ((path (match-string 1 url)) (hex (match-string 2 url)) (bytes (decode-hex-string hex)) (key-len 32) (iv (substring bytes 0 (- (length bytes) key-len))) (key (substring bytes (- (length bytes) key-len)))) (list :https-url (concat "https://" path) :iv iv :key key)))) (defun jabber-chat--fetch-aesgcm-image (url callback &rest cbargs) "Fetch and decrypt an aesgcm:// image URL. Downloads via HTTPS, decrypts with AES-256-GCM, calls CALLBACK with the created image (or nil) followed by CBARGS." (let ((parsed (jabber-chat--parse-aesgcm-url url))) (if (null parsed) (apply callback nil cbargs) (url-queue-retrieve (plist-get parsed :https-url) (lambda (status key iv cb args) (let ((url-buffer (current-buffer)) (image (unless (plist-get status :error) (set-buffer-multibyte nil) (goto-char (point-min)) (when (re-search-forward "\r?\n\r?\n" nil t) (let* ((encrypted (buffer-substring-no-properties (point) (point-max))) (plaintext (condition-case nil (jabber-omemo-aesgcm-decrypt key iv encrypted) (error nil)))) (when plaintext (let ((img (create-image plaintext nil t))) (if (null img) (progn (message "aesgcm: failed to create image (%d bytes decrypted)" (length plaintext)) nil) (setf (image-property img :max-width) jabber-image-max-width) (setf (image-property img :max-height) jabber-image-max-height) img)))))))) (kill-buffer url-buffer) (apply cb image args))) (list (plist-get parsed :key) (plist-get parsed :iv) callback cbargs) 'silent 'inhibit-cookies)))) (defconst jabber-chat--image-extension-types '(("png" . png) ("jpg" . jpeg) ("jpeg" . jpeg) ("gif" . gif) ("webp" . webp) ("svg" . svg) ("avif" . avif) ("tiff" . tiff)) "Alist mapping file extensions to Emacs image type symbols.") (defun jabber-chat--supported-image-extensions () "Return file extensions whose image types Emacs can render." (cl-loop for (ext . type) in jabber-chat--image-extension-types when (image-type-available-p type) collect ext)) (defun jabber-chat--image-ext-regexp () "Return a regexp alternation matching supported image extensions." (regexp-opt (jabber-chat--supported-image-extensions) t)) (defun jabber-chat--image-url-p (url) "Return non-nil if URL looks like an image based on file extension." (string-match-p (concat "\\." (jabber-chat--image-ext-regexp) "\\(?:[?#].*\\)?$") (downcase url))) (defvar jabber-chat-url-keymap (let ((map (make-sparse-keymap))) (define-key map (kbd "RET") #'jabber-chat-url-action-at-point) (define-key map "w" #'jabber-chat-copy-url) map) "Keymap active on inline images and downloadable URLs in chat buffers.") (defun jabber-chat-copy-url () "Copy the URL at point to the kill ring and display it." (interactive) (if-let* ((url (get-text-property (point) 'jabber-chat-image-url))) (progn (kill-new url) (message "%s" url)) (user-error "No URL at point"))) (defcustom jabber-chat-download-directory nil "Default directory for file downloads. When nil, use the last download directory from this session or `default-directory'." :type '(choice (const :tag "Last used or default-directory" nil) (directory :tag "Fixed directory"))) (defvar jabber-chat-last-download-directory nil "Last directory used for file downloads this session.") (defun jabber-chat--download-default-directory () "Return the default directory for file downloads." (or jabber-chat-download-directory jabber-chat-last-download-directory default-directory)) (defun jabber-chat--download-destination (url) "Prompt for a save path for URL, returning the chosen filename." (let* ((filename (file-name-nondirectory (url-filename (url-generic-parse-url url))))) (read-file-name (format "Save %s to: " filename) (jabber-chat--download-default-directory) nil nil filename))) (defun jabber-chat--record-download-directory (dest) "Remember the directory of DEST for future downloads." (setq jabber-chat-last-download-directory (file-name-directory dest))) (defun jabber-chat-url-action-at-point () "Download the file or image URL at point. Handles aesgcm:// URLs by decrypting after download." (interactive) (let ((url (or (get-text-property (point) 'jabber-chat-file-url) (get-text-property (point) 'jabber-chat-image-url)))) (unless url (user-error "No downloadable URL at point")) (jabber-chat-download-url url))) (defun jabber-chat-download-url (url) "Prompt to download URL to a local file. For aesgcm:// URLs, fetches via HTTPS and decrypts with AES-256-GCM." (let* ((parsed (and (string-prefix-p "aesgcm://" url) (jabber-chat--parse-aesgcm-url url))) (fetch-url (if parsed (plist-get parsed :https-url) url)) (dest (jabber-chat--download-destination fetch-url))) (jabber-chat--record-download-directory dest) (if parsed (jabber-chat--download-aesgcm fetch-url dest (plist-get parsed :key) (plist-get parsed :iv)) (url-copy-file fetch-url dest t) (message "Downloaded %s" dest)))) (defun jabber-chat--download-aesgcm (url dest key iv) "Fetch URL, decrypt with KEY and IV, write to DEST." (url-queue-retrieve url (lambda (status dest-file key iv) (let ((url-buffer (current-buffer))) (if (plist-get status :error) (progn (kill-buffer url-buffer) (message "Download failed: %s" (plist-get status :error))) (set-buffer-multibyte nil) (goto-char (point-min)) (re-search-forward "\r?\n\r?\n" nil t) (let* ((encrypted (buffer-substring-no-properties (point) (point-max))) (plaintext (condition-case err (jabber-omemo-aesgcm-decrypt key iv encrypted) (error (message "Decryption failed: %s" (error-message-string err)) nil)))) (kill-buffer url-buffer) (when plaintext (with-temp-file dest-file (set-buffer-multibyte nil) (insert plaintext)) (message "Downloaded and decrypted %s" dest-file)))))) (list dest key iv) 'silent 'inhibit-cookies)) (defun jabber-chat--replace-url-with-image (image beg end buffer) "Delete URL text between markers BEG and END, insert IMAGE. Uses `insert-image' so the URL serves as alt-text." (when (and image (buffer-live-p buffer)) (with-current-buffer buffer (let ((inhibit-read-only t) (url (buffer-substring-no-properties beg end))) (save-excursion (delete-region beg end) (goto-char beg) (let ((start (point))) (insert-image image url) (put-text-property start (point) 'jabber-chat-image-url url) (put-text-property start (point) 'keymap jabber-chat-url-keymap))))))) (defvar-local jabber-chat--image-scan-timer nil "Idle timer for scanning image URLs in this buffer.") (defun jabber-chat--schedule-image-scan (_msg _who mode) "Schedule an async image scan after message insertion. Added to `jabber-chat-printers' to trigger after each message." (when (eql mode :insert) (let ((buf (current-buffer))) (when jabber-chat--image-scan-timer (cancel-timer jabber-chat--image-scan-timer)) (setq jabber-chat--image-scan-timer (run-with-idle-timer 0.3 nil (lambda () (when (buffer-live-p buf) (with-current-buffer buf (jabber-chat-display-buffer-images))))))))) (defconst jabber-chat--image-url-re (concat "\\(?:https?\\|aesgcm\\)://[^ \t\n<>\"]+" "\\." (jabber-chat--image-ext-regexp) "\\(?:[?#][^ \t\n<>\"]*\\)?") "Regexp matching HTTP(S) and aesgcm:// image URLs.") (defun jabber-chat-display-buffer-images () "Scan buffer for image URLs and replace them with inline images. Skips URLs already processed (marked with `jabber-chat-image-url'). When the image arrives the URL text is deleted and the image inserted." (interactive) (save-excursion (let ((inhibit-read-only t) (limit (and (markerp jabber-point-insert) jabber-point-insert))) (when (and jabber-chat-display-images (display-graphic-p)) (goto-char (point-min)) (while (re-search-forward jabber-chat--image-url-re limit t) (unless (get-text-property (match-beginning 0) 'jabber-chat-image-url) (let ((url (match-string-no-properties 0)) (url-beg (match-beginning 0)) (url-end (match-end 0))) ;; Insert newline before URL so images appear on their ;; own line. (when (and (> url-beg (point-min)) (not (eq (char-before url-beg) ?\n))) (save-excursion (goto-char url-beg) (insert "\n")) (setq url-beg (1+ url-beg) url-end (1+ url-end))) (put-text-property url-beg url-end 'jabber-chat-image-url url) (let ((beg (copy-marker url-beg)) (end (copy-marker url-end)) (buf (current-buffer))) (if (string-prefix-p "aesgcm://" url) (jabber-chat--fetch-aesgcm-image url #'jabber-chat--replace-url-with-image beg end buf) (jabber-image-fetch url #'jabber-chat--replace-url-with-image beg end buf)))))))))) (defun jabber-chat-goto-address (_msg _who mode) "Call `goto-address' on the newly written text." (when (eq mode :insert) (condition-case err (let ((end (point)) (limit (max (- (point) 1000) (1+ (point-min))))) ;; We only need to fontify the text written since the last ;; prompt. The prompt has a field property, so we can find it ;; using `field-beginning'. (goto-address-fontify (field-beginning nil nil limit) end)) (error (message "jabber-chat: goto-address-fontify failed: %s" err))))) (defun jabber-chat-mark-oob-attachment (msg _who mode) "Mark non-image OOB attachment URLs with download keymap. Runs after `jabber-chat-goto-address' so the goto-address overlay exists when we set our keymap as its parent." (when (eql mode :insert) (let ((entries (or (plist-get msg :oob-entries) (when-let* ((url (plist-get msg :oob-url))) (list (cons url nil)))))) (dolist (entry entries) (let ((oob-url (car entry))) (when (and oob-url (not (jabber-chat--image-url-p oob-url))) (save-excursion (when (search-backward oob-url nil t) (let ((beg (match-beginning 0)) (end (match-end 0)) (inhibit-read-only t)) (put-text-property beg end 'jabber-chat-file-url oob-url) (let ((ov (seq-find (lambda (o) (overlay-get o 'keymap)) (overlays-in beg end)))) (if ov (set-keymap-parent (overlay-get ov 'keymap) jabber-chat-url-keymap) (put-text-property beg end 'keymap jabber-chat-url-keymap)))))))))))) (defconst jabber-chat--aesgcm-url-re "aesgcm://[^ \t\n<>\"#]+#\\(?:[[:xdigit:]]\\{88\\}\\|[[:xdigit:]]\\{96\\}\\)\\b" "Regexp matching aesgcm:// URLs with 88 or 96-hex-char fragment.") (defun jabber-chat-mark-aesgcm-url (_msg _who mode) "Mark non-image aesgcm:// URLs with download keymap and link face. Skips URLs already handled by the image scanner." (when (eql mode :insert) (save-excursion (let ((end (point)) (limit (max (- (point) 1000) (1+ (point-min)))) (inhibit-read-only t)) (goto-char limit) (while (re-search-forward jabber-chat--aesgcm-url-re end t) (let ((beg (match-beginning 0)) (url-end (match-end 0)) (url (match-string-no-properties 0))) (unless (or (get-text-property beg 'jabber-chat-file-url) (jabber-chat--image-url-p url)) (put-text-property beg url-end 'jabber-chat-file-url url) (put-text-property beg url-end 'keymap jabber-chat-url-keymap) (add-face-text-property beg url-end 'link t)))))))) ;; jabber-compose is autoloaded in jabber.el (defun jabber-send-message (jc to subject body type) "Send a message tag to the server. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "to: ") (jabber-read-with-input-method "subject: ") (jabber-read-with-input-method "body: ") (read-string "type: "))) (jabber-send-sexp jc `(message ((to . ,to) ,(if (> (length type) 0) `(type . ,type))) ,(if (> (length subject) 0) `(subject () ,subject)) ,(if (> (length body) 0) `(body () ,body)))) (jabber-db--store-outgoing jc to body type)) (defun jabber-chat-with (jc jid &optional other-window) "Open an empty chat window for chatting with JID. With a prefix argument, open buffer in other window. Returns the chat buffer. JC is the Jabber connection." (interactive (let* ((jid (jabber-read-jid-completing "chat with:")) (account (jabber-read-account nil jid))) (list account jid current-prefix-arg))) (let ((buffer (jabber-chat-create-buffer jc jid))) (if other-window (switch-to-buffer-other-window buffer) (switch-to-buffer buffer)))) (defun jabber-chat-with-jid-at-point (&optional other-window) "Start chat with JID at point. Signal an error if there is no JID at point. With a prefix argument, open buffer in other window." (interactive "P") (let ((jid-at-point (get-text-property (point) 'jabber-jid)) (account (get-text-property (point) 'jabber-account))) (if (and jid-at-point account) (jabber-chat-with account jid-at-point other-window) (error "No contact at point")))) (provide 'jabber-chat) ;;; jabber-chat.el ends here emacs-jabber/lisp/jabber-chatbuffer.el000066400000000000000000000637271516610113500202340ustar00rootroot00000000000000;;; jabber-chatbuffer.el --- functions common to all chat buffers -*- lexical-binding: t; -*- ;; Copyright (C) 2005, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'jabber-util) (require 'jabber-core) (require 'jabber-menu) (require 'transient) (defvar jabber-point-insert nil "Position where the message being composed starts.") (defvar jabber-send-function nil "Function for sending a message from a chat buffer.") (defvar jabber-chat-mode-hook nil "Hook called at the end of `jabber-chat-mode'. Note that functions in this hook have no way of knowing what kind of chat buffer is being created.") (defvar jabber-chat-ewoc nil "The ewoc showing the messages of this chat buffer.") (defvar-local jabber-chat--msg-nodes nil "Hash table mapping stanza IDs to ewoc nodes. Enables O(1) lookup for in-place updates (receipts, corrections).") (defvar-local jabber-chat-mam-syncing nil "Non-nil while this buffer's peer has an active MAM sync.") (defvar-local jabber-chat--backlog-generation 0 "Generation counter for chunked backlog inserts. Incremented before each new insert sequence so stale timers from a previous sequence detect the mismatch and stop.") ;; Global reference declarations (declare-function jabber-muc-nick-completion-at-point "jabber-muc-nick-completion.el" ()) (declare-function jabber-httpupload--upload "jabber-httpupload" (jc filepath callback)) (declare-function jabber-omemo--prefetch-sessions "jabber-omemo" (jc jid)) (declare-function jabber-omemo--prefetch-muc-sessions "jabber-omemo" (jc group)) (declare-function jabber-omemo--muc-participant-jids "jabber-omemo" (group participants)) (declare-function jabber-omemo-fingerprints "jabber-omemo" ()) (declare-function jabber-connection-bare-jid "jabber-util" (jc)) (declare-function jabber-blocking-toggle-chat-peer "jabber-blocking" (jc)) (declare-function jabber-get-info "jabber-info" (jc to)) (declare-function jabber-roster-change "jabber-presence" (jc jid name groups)) (declare-function jabber-roster-delete "jabber-presence" (jc jid)) (declare-function jabber-mam-sync-buffer "jabber-mam" ()) (declare-function jabber-moderation-retract "jabber-moderation" ()) (declare-function jabber-moderation-retract-by-occupant "jabber-moderation" ()) (declare-function jabber-chat-reply "jabber-message-reply" ()) (declare-function jabber-chat-cancel-reply "jabber-message-reply" ()) (declare-function jabber-jid-user "jabber-util" (jid)) (declare-function jabber-jid-resource "jabber-util" (jid)) (declare-function jabber-db-set-chat-encryption "jabber-db" (account peer encryption)) (declare-function jabber-db-get-chat-encryption "jabber-db" (account peer)) ;; (defvar-local jabber-buffer-connection nil "The connection used by this buffer.") (defvar jabber-chatting-with) ; jabber-chat.el (defvar jabber-chat-header-line-format) ; jabber-chat.el (defvar jabber-chat-earliest-backlog) ; jabber-chat.el (defvar jabber-group) ; jabber-muc.el (defvar jabber-muc-header-line-format) ; jabber-muc.el (defvar jabber-muc-participants) ; jabber-muc.el (defvar jabber-httpupload--pending-url) ; jabber-httpupload.el ;;; Buffer lookup registry (defvar jabber-chatbuffer--registry (make-hash-table :test #'equal) "Hash table mapping (TYPE . KEY) to a live buffer. TYPE is `chat', `muc', or `muc-private'. KEY: bare JID for chat; group JID for muc; \"group/nick\" for muc-private.") (defun jabber-chatbuffer--registry-put (type key) "Register current buffer under TYPE and KEY." (puthash (cons type key) (current-buffer) jabber-chatbuffer--registry)) (defun jabber-chatbuffer--registry-get (type key) "Return the live buffer registered under TYPE and KEY, or nil." (let* ((k (cons type key)) (buf (gethash k jabber-chatbuffer--registry))) (if (buffer-live-p buf) buf (remhash k jabber-chatbuffer--registry) nil))) (defun jabber-chatbuffer--registry-remove () "Remove current buffer from registry. Used as `kill-buffer-hook'." (cond ((and (local-variable-p 'jabber-group) jabber-group) (remhash (cons 'muc jabber-group) jabber-chatbuffer--registry)) ((and (local-variable-p 'jabber-chatting-with) jabber-chatting-with) ;; MUC-private: jabber-chatting-with is "group/nick" (has resource). ;; 1:1 chat: jabber-chatting-with may be full JID or bare — always ;; normalise to bare JID to match the key stored at registration time. (if (jabber-jid-resource jabber-chatting-with) (remhash (cons 'muc-private jabber-chatting-with) jabber-chatbuffer--registry) (remhash (cons 'chat (jabber-jid-user jabber-chatting-with)) jabber-chatbuffer--registry))))) (add-hook 'kill-buffer-hook #'jabber-chatbuffer--registry-remove) (defun jabber-chat-attach-file (filepath) "Upload FILEPATH and insert the URL into the composition area. The file is uploaded via HTTP Upload. Once the upload finishes, the GET URL is inserted at point so you can preview and edit before sending with RET." (interactive "fFile to upload: ") (require 'jabber-httpupload) (unless jabber-buffer-connection (error "No active connection in this buffer")) (let ((buffer (current-buffer))) (jabber-httpupload--upload jabber-buffer-connection filepath (lambda (get-url) (with-current-buffer buffer (goto-char (point-max)) (insert get-url) (setq jabber-httpupload--pending-url get-url) (message "Uploaded: %s (send with RET)" get-url)))))) (defcustom jabber-chat-default-encryption 'omemo "Default encryption mode for new chat buffers." :type '(choice (const :tag "OMEMO" omemo) (const :tag "OpenPGP" openpgp) (const :tag "PGP (legacy)" openpgp-legacy) (const :tag "Plaintext" plaintext)) :group 'jabber-chat) (defvar-local jabber-chat-encryption nil "Encryption mode for this chat buffer. Possible values: `plaintext', `omemo', `openpgp', `openpgp-legacy'. Set from `jabber-chat-default-encryption' on buffer creation.") (defvar-local jabber-chat-encryption-message "" "Header-line string showing current encryption state.") (defface jabber-chat-encryption-omemo '((t :inherit success)) "Face for OMEMO encryption indicator in chat header." :group 'jabber-chat) (defface jabber-chat-encryption-openpgp '((t :inherit success)) "Face for OpenPGP encryption indicator in chat header." :group 'jabber-chat) (defface jabber-chat-encryption-openpgp-legacy '((t :inherit success)) "Face for legacy PGP encryption indicator in chat header." :group 'jabber-chat) (defface jabber-chat-encryption-plaintext '((t :inherit error)) "Face for plaintext indicator in chat header." :group 'jabber-chat) (defun jabber-chat-encryption--update-header () "Update `jabber-chat-encryption-message' from current state." (setq jabber-chat-encryption-message (propertize (pcase jabber-chat-encryption ('omemo "[OMEMO]") ('openpgp "[OpenPGP]") ('openpgp-legacy "[PGP]") (_ "[plaintext]")) 'face (pcase jabber-chat-encryption ('omemo 'jabber-chat-encryption-omemo) ('openpgp 'jabber-chat-encryption-openpgp) ('openpgp-legacy 'jabber-chat-encryption-openpgp-legacy) (_ 'jabber-chat-encryption-plaintext))))) (defun jabber-chat--peer-jid () "Return the bare JID of the chat peer in this buffer. Works for both 1:1 chat (`jabber-chatting-with') and MUC (`jabber-group')." (cond ((bound-and-true-p jabber-chatting-with) (jabber-jid-user jabber-chatting-with)) ((bound-and-true-p jabber-group) jabber-group))) (defun jabber-chat-encryption--save (mode) "Persist encryption MODE for the current chat buffer." (when-let* ((jc jabber-buffer-connection) (peer (jabber-chat--peer-jid))) (jabber-db-set-chat-encryption (jabber-connection-bare-jid jc) peer mode))) (defun jabber-chat-encryption-set-omemo () "Set encryption to OMEMO for this chat buffer." (interactive) (require 'jabber-omemo) (unless (bound-and-true-p jabber-omemo--available) (user-error "OMEMO encryption requires the jabber-omemo-core native module")) (setq jabber-chat-encryption 'omemo) (jabber-chat-encryption--save 'omemo) (jabber-chat-encryption--update-header) (force-mode-line-update) (when jabber-buffer-connection (cond ((bound-and-true-p jabber-chatting-with) (jabber-omemo--prefetch-sessions jabber-buffer-connection jabber-chatting-with)) ((bound-and-true-p jabber-group) (jabber-omemo--prefetch-muc-sessions jabber-buffer-connection jabber-group)))) (when (and (bound-and-true-p jabber-group) (null (jabber-omemo--muc-participant-jids jabber-group (cdr (assoc jabber-group jabber-muc-participants))))) (message "OMEMO: no participant JIDs visible — room may be anonymous"))) (defun jabber-chat-encryption-set-openpgp () "Set encryption to OpenPGP for this chat buffer." (interactive) (require 'jabber-openpgp) (setq jabber-chat-encryption 'openpgp) (jabber-chat-encryption--save 'openpgp) (jabber-chat-encryption--update-header) (force-mode-line-update)) (defun jabber-chat-encryption-set-openpgp-legacy () "Set encryption to legacy PGP (XEP-0027) for this chat buffer." (interactive) (require 'jabber-openpgp-legacy) (setq jabber-chat-encryption 'openpgp-legacy) (jabber-chat-encryption--save 'openpgp-legacy) (jabber-chat-encryption--update-header) (force-mode-line-update)) (defun jabber-chat-encryption-set-plaintext () "Set encryption to plaintext for this chat buffer." (interactive) (setq jabber-chat-encryption 'plaintext) (jabber-chat-encryption--save 'plaintext) (jabber-chat-encryption--update-header) (force-mode-line-update)) (transient-define-prefix jabber-chat-encryption-menu () "Select encryption for this chat buffer." [:description (lambda () (format "Encryption (current: %s)" jabber-chat-encryption)) ("o" "OMEMO" jabber-chat-encryption-set-omemo) ("g" "OpenPGP" jabber-chat-encryption-set-openpgp) ("l" "PGP (legacy)" jabber-chat-encryption-set-openpgp-legacy) ("p" "Plaintext" jabber-chat-encryption-set-plaintext)]) (defun jabber-chat-show-fingerprints () "Display OMEMO fingerprints for the current chat peer." (interactive) (require 'jabber-omemo) (jabber-omemo-fingerprints)) (defvar jabber-backlog-number) ; jabber-db.el (defvar-local jabber-chat-buffer-msg-count nil "Per-buffer message count for backlog and sync. When non-nil, overrides `jabber-backlog-number' for refresh and MAM sync in this buffer. Set via the transient -n argument.") (defun jabber-chat-buffer-msg-count () "Return the effective message count for this buffer." (or jabber-chat-buffer-msg-count jabber-backlog-number)) (transient-define-suffix jabber-chat-set-msg-count (count) "Set the message count for the current chat buffer to COUNT." :transient t :description (lambda () (concat "Message count: " (propertize (number-to-string (jabber-chat-buffer-msg-count)) 'face 'transient-value))) (interactive (list (read-number "Message count: " (jabber-chat-buffer-msg-count)))) (setq jabber-chat-buffer-msg-count (and (> count 0) count)) (message "Buffer message count: %d" (jabber-chat-buffer-msg-count))) (defun jabber-chat-get-info () "Show version, disco info and ping for the current chat peer." (interactive) (unless (bound-and-true-p jabber-chatting-with) (user-error "Not in a chat buffer")) (jabber-get-info jabber-buffer-connection jabber-chatting-with)) (defun jabber-chat-add-contact () "Add the current chat peer to the roster." (interactive) (unless (bound-and-true-p jabber-chatting-with) (user-error "Not in a chat buffer")) (let* ((jid (jabber-jid-user jabber-chatting-with)) (sym (jabber-jid-symbol jid))) (jabber-roster-change jabber-buffer-connection sym (read-string (format "Name for %s: " jid)) nil))) (defun jabber-chat-remove-contact () "Remove the current chat peer from the roster." (interactive) (unless (bound-and-true-p jabber-chatting-with) (user-error "Not in a chat buffer")) (let ((jid (jabber-jid-user jabber-chatting-with))) (when (yes-or-no-p (format "Remove %s from roster? " jid)) (jabber-roster-delete jabber-buffer-connection jid)))) (transient-define-prefix jabber-chat-operations-menu () "Chat buffer operations." [["Encryption" ("e" "Encryption..." jabber-chat-encryption-menu) ("f" "Fingerprints" jabber-chat-show-fingerprints)] ["Files" ("a" "Attach file" jabber-chat-attach-file)] ["Contact" ("I" "Get info" jabber-chat-get-info) ("A" "Add contact" jabber-chat-add-contact) ("D" "Remove contact" jabber-chat-remove-contact) ("B" "Block/unblock user" jabber-blocking-toggle-chat-peer)] ["Messages" ("E" "Edit last message" jabber-correct-last-message) ("r" "Reply to message" jabber-chat-reply)] ["MUC" ("m" "MUC operations..." jabber-muc-menu) ("M" "Retract message at point" jabber-moderation-retract) ("X" "Retract all by occupant" jabber-moderation-retract-by-occupant)] ["Buffer" ("n" jabber-chat-set-msg-count) ("R" "Refresh" jabber-chat-buffer-refresh) ("S" "Sync & refresh" jabber-mam-sync-buffer)]]) ;; Spell check only what you're currently writing. (defun jabber-chat-mode-flyspell-verify () "Return non-nil if point is in the composition area." (>= (point) jabber-point-insert)) (defun jabber-chat-newline () "Insert a newline in the composition area without sending." (interactive) (insert "\n")) (defvar-keymap jabber-chat-mode-map :parent jabber-common-keymap "RET" #'jabber-chat-buffer-send "S-" #'jabber-chat-newline "TAB" #'completion-at-point "C-c C-a" #'jabber-chat-attach-file "C-c C-o" #'jabber-chat-operations-menu "C-c C-e" #'jabber-chat-encryption-menu "C-c C-r" #'jabber-chat-reply "C-c C-k" #'jabber-chat-cancel-reply) (define-derived-mode jabber-chat-mode fundamental-mode "jabber-chat" "Major mode for Jabber chat buffers. \\{jabber-chat-mode-map}" (visual-line-mode 1) (setq-local word-wrap t) (display-line-numbers-mode 0) (put 'jabber-chat-mode 'flyspell-mode-predicate #'jabber-chat-mode-flyspell-verify)) (defun jabber-chat-mode-setup (jc ewoc-pp) "Initialize chat buffer state for connection JC. EWOC-PP is the pretty-printer function for the message EWOC." (add-hook 'completion-at-point-functions #'jabber-muc-nick-completion-at-point nil t) (setq-local jabber-send-function nil) (setq-local scroll-conservatively 5) ;; jabber-chat-ewoc and jabber-point-insert are conditionally set in ;; the `unless' block below; make-local-variable is idempotent and ;; preserves the existing value on repeated calls. (make-local-variable 'jabber-point-insert) (make-local-variable 'jabber-chat-ewoc) (setq jabber-buffer-connection jc) (unless jabber-chat-ewoc (let ((buffer-undo-list t)) (setq jabber-chat-ewoc (ewoc-create ewoc-pp nil (concat (jabber-separator) "\n") 'nosep)) (setq jabber-chat--msg-nodes (make-hash-table :test 'equal)) (goto-char (point-max)) (put-text-property (point-min) (point) 'read-only t) (let ((inhibit-read-only t)) (put-text-property (point-min) (point) 'front-sticky t) (put-text-property (point-min) (point) 'rear-nonsticky t)) (setq jabber-point-insert (point-marker)))) (unless jabber-chat-encryption (let ((saved (when-let* ((peer (jabber-chat--peer-jid))) (jabber-db-get-chat-encryption (jabber-connection-bare-jid jabber-buffer-connection) peer)))) (setq jabber-chat-encryption (or saved jabber-chat-default-encryption)) ;; MUC buffers default to plaintext until the user explicitly ;; enables OMEMO, unless they previously saved a preference. (when (bound-and-true-p jabber-group) (unless saved (setq jabber-chat-encryption 'plaintext)))) (when (eq jabber-chat-encryption 'omemo) (require 'jabber-omemo nil t) (unless (bound-and-true-p jabber-omemo--available) (setq jabber-chat-encryption 'plaintext)))) (jabber-chat-encryption--update-header)) (declare-function jabber-chat-find-buffer "jabber-chat" (chat-with)) (declare-function jabber-muc-find-buffer "jabber-muc" (group)) (declare-function jabber-muc-sender-p "jabber-muc" (jid)) (declare-function jabber-db-backlog "jabber-db" (account peer &optional count start-time resource msg-type)) (declare-function jabber-chat-insert-backlog-entry "jabber-chat" (msg-plist)) (declare-function jabber-chat--insert-backlog-chunked "jabber-chat" (buffer entries callback &optional generation)) (declare-function jabber-chat-display-buffer-images "jabber-chat" ()) (defun jabber-chat-buffer-refresh () "Refresh the current chat buffer from the database without killing it. Clears the ewoc and reloads backlog entries in place. Cancels any in-progress chunked insert by bumping the generation counter. Uses `jabber-chat-buffer-msg-count' for the number of messages." (interactive) (cl-incf jabber-chat--backlog-generation) (let ((generation jabber-chat--backlog-generation) (count (jabber-chat-buffer-msg-count)) (buffer-undo-list t) (inhibit-read-only t) (node (ewoc-nth jabber-chat-ewoc 0))) ;; Delete all ewoc nodes (while node (let ((next (ewoc-next jabber-chat-ewoc node))) (ewoc-delete jabber-chat-ewoc node) (setq node next))) ;; Clear message ID tracking (clrhash jabber-chat--msg-nodes) ;; Reload from DB (let* ((peer (jabber-chat--peer-jid)) (account (jabber-connection-bare-jid jabber-buffer-connection)) (resource (when (and (bound-and-true-p jabber-chatting-with) (not (bound-and-true-p jabber-group)) (jabber-muc-sender-p jabber-chatting-with)) (jabber-jid-resource jabber-chatting-with))) (msg-type (when (and (bound-and-true-p jabber-group) (not resource)) "groupchat")) (entries (jabber-db-backlog account peer count nil resource msg-type))) (if (null entries) (setq jabber-chat-earliest-backlog (float-time)) (setq jabber-chat-earliest-backlog (float-time (plist-get (car (last entries)) :timestamp))) (jabber-chat--insert-backlog-chunked (current-buffer) entries #'jabber-chat-display-buffer-images generation))))) (defun jabber-chat-buffer-send () (interactive) ;; If user accidentally hits RET without writing anything, just ;; ignore it. (when (cl-plusp (- (point-max) jabber-point-insert)) ;; If connection was lost... (unless (memq jabber-buffer-connection jabber-connections) ;; ...maybe there is a new connection to the same account. (let ((new-jc (jabber-find-active-connection jabber-buffer-connection))) (if new-jc ;; If so, just use it. (setq jabber-buffer-connection new-jc) ;; Otherwise, ask for a new account. (setq jabber-buffer-connection (jabber-read-account t))))) (let ((body (delete-and-extract-region jabber-point-insert (point-max)))) (funcall jabber-send-function jabber-buffer-connection body)))) (defun jabber-chat-buffer-switch () "Switch to a specified jabber chat buffer." (interactive) (let* ((jabber-buffers (cl-loop for buffer in (buffer-list) when (with-current-buffer buffer (eq major-mode 'jabber-chat-mode)) collect (buffer-name buffer))) (jabber-buffer (and jabber-buffers (completing-read "Switch to jabber buffer: " jabber-buffers)))) (if jabber-buffer (switch-to-buffer jabber-buffer) (error "No jabber buffer found")))) (defun jabber-chat-redisplay (&optional all-chats) "Regenerate the EWOC text and header for one or more buffers. With prefix argument, regenerate all `jabber-chat-mode' buffers, otherwise regenerate the current buffer display. Scrolls each buffer so the chat log is visible with the prompt line at the bottom of the window." (interactive "P") (let ((current-buffer (current-buffer))) (mapc (lambda (buffer) (with-current-buffer buffer (let ((buffer-undo-list t)) (ewoc-refresh jabber-chat-ewoc)) (setq header-line-format (if (bound-and-true-p jabber-group) jabber-muc-header-line-format jabber-chat-header-line-format)) (when-let* ((peer (jabber-chat--peer-jid)) (saved (jabber-db-get-chat-encryption (jabber-connection-bare-jid jabber-buffer-connection) peer))) (setq jabber-chat-encryption saved)) (jabber-chat-encryption--update-header) (force-mode-line-update) (when-let* ((win (get-buffer-window buffer))) (with-selected-window win (goto-char jabber-point-insert) (recenter -1))))) (seq-filter (lambda (buffer) (with-current-buffer buffer (and (eq major-mode 'jabber-chat-mode) (or all-chats (eq buffer current-buffer))))) (buffer-list))))) ;;; Ewoc mutation API (undo-suppressed) ;; ;; All ewoc mutations in chat buffers go through these wrappers to ;; keep the undo list clean. Only the composition area (after ;; `jabber-point-insert') records undo entries. (defun jabber-chat-ewoc-enter (data) "Insert DATA into the chat ewoc and register by stanza ID. DATA is (TYPE MSG-PLIST). When the plist has a non-nil :id or :server-id, the returned ewoc node is stored in `jabber-chat--msg-nodes' for O(1) lookup. Returns the ewoc node, or nil if the message was a duplicate." (let* ((msg (cadr data)) (msg-p (listp msg)) (id (and msg-p (plist-get msg :id))) (sid (and msg-p (plist-get msg :server-id)))) ;; Skip if this stanza ID is already displayed. (unless (or (and id (gethash id jabber-chat--msg-nodes)) (and sid (gethash sid jabber-chat--msg-nodes))) (let ((buffer-undo-list t) (node (ewoc-enter-last jabber-chat-ewoc data))) (when id (puthash id node jabber-chat--msg-nodes)) (when sid (puthash sid node jabber-chat--msg-nodes)) node)))) (defun jabber-chat-ewoc-find-by-id (stanza-id) "Return the ewoc node for STANZA-ID, or nil." (when (and stanza-id jabber-chat--msg-nodes) (gethash stanza-id jabber-chat--msg-nodes))) (defun jabber-chat-ewoc-invalidate (node) "Redraw ewoc NODE without recording undo." (let ((buffer-undo-list t)) (ewoc-invalidate jabber-chat-ewoc node))) (defun jabber-chat-ewoc-delete (node) "Delete ewoc NODE without recording undo." (let ((buffer-undo-list t) (inhibit-read-only t)) (ewoc-delete jabber-chat-ewoc node))) ;;; Cleanup on disconnect (defvar jabber-connections) ; jabber-core.el (defun jabber-chatbuffer--kill-stale () "Kill chat buffers whose connection is no longer active." (dolist (buf (buffer-list)) (when (buffer-local-value 'jabber-buffer-connection buf) (unless (memq (buffer-local-value 'jabber-buffer-connection buf) jabber-connections) (kill-buffer buf))))) ;;; MAM hook listeners (defvar jabber-mam-peer-syncing-functions) ; jabber-mam.el (defvar jabber-mam-sync-complete-functions) ; jabber-mam.el (defun jabber-chat--handle-mam-peer-syncing (peer type syncing-p) "Update syncing indicator for PEER's chat buffer. TYPE is \"groupchat\" or \"chat\". SYNCING-P is non-nil when sync starts, nil when it ends." (when-let* ((buffer (if (string= type "groupchat") (jabber-muc-find-buffer peer) (jabber-chat-find-buffer peer))) ((buffer-live-p buffer))) (with-current-buffer buffer (setq jabber-chat-mam-syncing syncing-p) (force-mode-line-update)))) (add-hook 'jabber-mam-peer-syncing-functions #'jabber-chat--handle-mam-peer-syncing) (defun jabber-chat--handle-mam-sync-complete (peers) "Refresh chat buffers that received MAM messages. PEERS is a list of (PEER . TYPE) pairs." (dolist (entry peers) (let* ((peer (car entry)) (type (cdr entry)) (buffer (if (string= type "groupchat") (jabber-muc-find-buffer peer) (jabber-chat-find-buffer peer)))) (when (and buffer (buffer-live-p buffer)) (with-current-buffer buffer (jabber-chat-buffer-refresh)))))) (add-hook 'jabber-mam-sync-complete-functions #'jabber-chat--handle-mam-sync-complete) (with-eval-after-load "jabber-core" (add-hook 'jabber-post-disconnect-hook #'jabber-chatbuffer--kill-stale)) (provide 'jabber-chatbuffer) ;;; jabber-chatbuffer.el ends here emacs-jabber/lisp/jabber-chatstates.el000066400000000000000000000176371516610113500202650ustar00rootroot00000000000000;;; jabber-chatstate.el --- Chat state notification (XEP-0085) implementation -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Author: Ami Fischman ;; (based entirely on jabber-events.el by Magnus Henoch ) ;; Maintainer: Thanos Apollo ;; This file 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, or (at your option) ;; any later version. ;; This file 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 GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: ;; ;; All five chat states (active, composing, paused, inactive, gone) are ;; sent and received per XEP-0085. ;;; Code: (require 'cl-lib) (require 'ewoc) (require 'jabber-core) (require 'jabber-chat) (require 'jabber-chatbuffer) (require 'jabber-disco) (require 'jabber-xml) (declare-function jabber-jid-displayname "jabber-util" (jid)) (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el (defvar jabber-chatting-with) ; jabber-chat.el (defgroup jabber-chatstates nil "Chat state notifications." :group 'jabber) (defconst jabber-chatstates-xmlns "http://jabber.org/protocol/chatstates" "XML namespace for the chatstates feature.") (defcustom jabber-chatstates-confirm t "Send notifications about chat states?" :type 'boolean) (defvar-local jabber-chatstates-requested t "Whether chat state notifications should be sent. Non-nil means send states, nil means don't.") (defvar-local jabber-chatstates-last-state nil "The last seen chat state.") (defvar-local jabber-chatstates-message "" "Human-readable presentation of chat state information.") (defvar-local jabber-chatstates--ewoc-node nil "Ewoc node for the typing indicator, or nil.") (defvar-local jabber-chatstates-composing-sent nil "Has composing notification been sent? It can be sent and cancelled several times.") ;;; INCOMING ;; Code for requesting chat state notifications from others and handling ;; them. (defun jabber-chatstates-update-message () (setq jabber-chatstates-message (if (and jabber-chatstates-last-state (not (eq 'active jabber-chatstates-last-state))) (format " (%s)" (symbol-name jabber-chatstates-last-state)) ""))) (defun jabber-chatstates--update-ewoc (state) "Show or remove the typing indicator ewoc node for STATE." (let ((inhibit-read-only t)) (if (eq state 'composing) (unless jabber-chatstates--ewoc-node (setq jabber-chatstates--ewoc-node (jabber-chat-ewoc-enter (list :typing (format "%s is typing..." (jabber-jid-displayname jabber-chatting-with)))))) (when jabber-chatstates--ewoc-node (jabber-chat-ewoc-delete jabber-chatstates--ewoc-node) (setq jabber-chatstates--ewoc-node nil))))) (defun jabber-chatstates--clear-typing () "Remove the typing indicator ewoc node if present." (when jabber-chatstates--ewoc-node (jabber-chat-ewoc-delete jabber-chatstates--ewoc-node) (setq jabber-chatstates--ewoc-node nil))) (add-hook 'jabber-chat-send-hooks #'jabber-chatstates-when-sending) (defun jabber-chatstates-when-sending (_text _id) (jabber-chatstates--clear-typing) (jabber-chatstates-stop-timer) (when jabber-chatstates-confirm (setq jabber-chatstates-composing-sent nil) `((active ((xmlns . ,jabber-chatstates-xmlns)))))) ;;; OUTGOING ;; Code for handling requests for chat state notifications and providing ;; them, modulo user preferences. (defvar-local jabber-chatstates-paused-timer nil "Timer that counts down from `composing' state to `paused'.") (defvar-local jabber-chatstates-inactive-timer nil "Timer that counts down from `paused' state to `inactive'.") (defun jabber-chatstates-stop-timer () "Stop the `paused' and `inactive' timers." (when jabber-chatstates-paused-timer (cancel-timer jabber-chatstates-paused-timer)) (when jabber-chatstates-inactive-timer (cancel-timer jabber-chatstates-inactive-timer))) (defun jabber-chatstates-kick-timer () "Start (or restart) the `paused' timer as approriate." (jabber-chatstates-stop-timer) (setq jabber-chatstates-paused-timer (run-with-timer 5 nil #'jabber-chatstates-send-paused))) (defun jabber-chatstates-send-paused () "Send a `paused' state notification, then start the inactive timer." (when (and jabber-chatstates-confirm jabber-chatting-with) (setq jabber-chatstates-composing-sent nil) (jabber-send-sexp-if-connected jabber-buffer-connection `(message ((to . ,jabber-chatting-with) (type . "chat")) (paused ((xmlns . ,jabber-chatstates-xmlns))))) (setq jabber-chatstates-inactive-timer (run-with-timer 30 nil #'jabber-chatstates-send-inactive)))) (defun jabber-chatstates-send-inactive () "Send an `inactive' state notification." (when (and jabber-chatstates-confirm jabber-chatting-with) (jabber-send-sexp-if-connected jabber-buffer-connection `(message ((to . ,jabber-chatting-with) (type . "chat")) (inactive ((xmlns . ,jabber-chatstates-xmlns))))))) (defun jabber-chatstates-send-gone () "Send a `gone' state notification and cancel timers. Added to `kill-buffer-hook' in chat buffers." (when (and jabber-chatstates-confirm jabber-chatting-with) (jabber-chatstates-stop-timer) (jabber-send-sexp-if-connected jabber-buffer-connection `(message ((to . ,jabber-chatting-with) (type . "chat")) (gone ((xmlns . ,jabber-chatstates-xmlns))))))) (defun jabber-chatstates-after-change () (let* ((composing-now (not (= (point-max) jabber-point-insert))) (state (if composing-now 'composing 'active))) (when (and jabber-chatstates-confirm jabber-chatting-with (not (eq composing-now jabber-chatstates-composing-sent))) (jabber-send-sexp-if-connected jabber-buffer-connection `(message ((to . ,jabber-chatting-with) (type . "chat")) (,state ((xmlns . ,jabber-chatstates-xmlns))))) (when (setq jabber-chatstates-composing-sent composing-now) (jabber-chatstates-kick-timer))))) ;;; COMMON (defun jabber-handle-incoming-message-chatstates (jc xml-data) (when-let* ((from (jabber-xml-get-attribute xml-data 'from)) (buffer (get-buffer (jabber-chat-get-buffer from jc)))) (with-current-buffer buffer (cond ;; If we get an error message, we shouldn't report any ;; events, as the requests are mirrored from us. ((string= (jabber-xml-get-attribute xml-data 'type) "error") (remove-hook 'post-command-hook #'jabber-chatstates-after-change t) (setq jabber-chatstates-requested nil)) (t (let ((state (jabber-xml-node-name (cl-find jabber-chatstates-xmlns (jabber-xml-node-children xml-data) :key (lambda (x) (jabber-xml-get-attribute x 'xmlns)) :test #'string=)))) ;; Set up hooks for composition notification (when (and jabber-chatstates-confirm state) (setq jabber-chatstates-requested t) (add-hook 'post-command-hook #'jabber-chatstates-after-change nil t) (add-hook 'kill-buffer-hook #'jabber-chatstates-send-gone nil t)) (setq jabber-chatstates-last-state state) (jabber-chatstates--update-ewoc state))))))) (jabber-chain-add 'jabber-message-chain #'jabber-handle-incoming-message-chatstates 50) (jabber-disco-advertise-feature jabber-chatstates-xmlns) (provide 'jabber-chatstates) ;;; jabber-chatstates.el ends hereemacs-jabber/lisp/jabber-compose.el000066400000000000000000000057711516610113500175630ustar00rootroot00000000000000;;; jabber-compose.el --- compose a Jabber message in a buffer -*- lexical-binding: t; -*- ;; Copyright (C) 2006, 2007 Magnus Henoch ;; Copyright (C) 2026 Thanos Apollo ;; Author: Magnus Henoch ;; Maintainer: Thanos Apollo ;; Keywords: ;; This file 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, or (at your option) ;; any later version. ;; This file 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 GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; ;;; Code: (require 'jabber-core) (require 'jabber-util) (require 'jabber-widget) (require 'jabber-chat) ;; Global reference declarations (defvar jabber-buffer-connection) ; jabber-chatbuffer.el ;; ;;;###autoload (defun jabber-compose (jc &optional recipient) "Create a buffer for composing a Jabber message. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "To whom? "))) (with-current-buffer (get-buffer-create (generate-new-buffer-name (concat "Jabber-Compose" (when recipient (format "-%s" (jabber-jid-displayname recipient)))))) (setq-local jabber-widget-alist nil) (setq jabber-buffer-connection jc) (use-local-map widget-keymap) (insert (propertize "Compose Jabber message\n" 'face 'jabber-title)) (insert (substitute-command-keys "\\Completion available with \\[widget-complete].\n")) (push (cons :recipients (widget-create '(repeat :tag "Recipients" jid) :value (when recipient (list recipient)))) jabber-widget-alist) (insert "\nSubject: ") (push (cons :subject (widget-create 'editable-field :value "")) jabber-widget-alist) (insert "\nText:\n") (push (cons :text (widget-create 'text :value "")) jabber-widget-alist) (insert "\n") (widget-create 'push-button :notify #'jabber-compose-send "Send") (widget-setup) (switch-to-buffer (current-buffer)) (goto-char (point-min)))) (defun jabber-compose-send (&rest _ignore) (let ((recipients (widget-value (cdr (assq :recipients jabber-widget-alist)))) (subject (widget-value (cdr (assq :subject jabber-widget-alist)))) (text (widget-value (cdr (assq :text jabber-widget-alist))))) (when (null recipients) (error "No recipients specified")) (dolist (to recipients) (jabber-send-message jabber-buffer-connection to subject text nil)) (bury-buffer) (message "Message sent"))) (provide 'jabber-compose) ;;; jabber-compose.el ends hereemacs-jabber/lisp/jabber-conn.el000066400000000000000000000245301516610113500170450ustar00rootroot00000000000000;;; jabber-conn.el --- Network transport functions -*- lexical-binding: t; -*- ;; Copyright (C) 2005 - Georg Lehner - jorge@magma.com.ni ;; mostly inspired by Gnus. ;; Copyright (C) 2005 - Carl Henrik Lunde - chlunde+jabber+@ping.uio.no ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;; A collection of functions, that hide the details of transmitting to ;; and from a Jabber Server. Mostly inspired by Gnus. ;;; Code: (eval-when-compile (require 'cl-lib)) (require 'jabber-core) (require 'fsm) (require 'gnutls) (require 'jabber-srv) (defconst jabber-tls-xmlns "urn:ietf:params:xml:ns:xmpp-tls" "RFC 6120 XMPP STARTTLS namespace.") (defgroup jabber-conn nil "Jabber Connection Settings." :group 'jabber) (defconst jabber-default-connection-type 'starttls "Default connection type. See `jabber-connect-methods'.") (defcustom jabber-invalid-certificate-servers () "Jabber servers for which we accept invalid TLS certificates. This is a list of server names, each matching the hostname part of your JID. This option has effect only when using native GnuTLS." :type '(repeat string)) (defcustom jabber-direct-tls-lookup t "Whether to query _xmpps-client SRV records for direct TLS. When non-nil, `jabber-srv-targets' queries both _xmpps-client._tcp and _xmpp-client._tcp SRV records per XEP-0368, merging them by priority and weight. Direct TLS targets use TLS-on-connect without a STARTTLS upgrade." :type 'boolean :group 'jabber-conn) (defvar jabber-connect-methods '((network jabber-network-connect jabber-network-send) (starttls jabber-network-connect jabber-network-send) (virtual jabber-virtual-connect jabber-virtual-send)) "Alist of connection methods and functions. First item is the symbol naming the method. Second item is the connect function. Third item is the send function.") ;; Global reference declarations (declare-function gnutls-negotiate "gnutls.el" (&rest spec &key process type hostname priority-string trustfiles crlfiles keylist min-prime-bits verify-flags verify-error verify-hostname-error &allow-other-keys)) (defvar jabber-process-buffer) ; jabber.el (defvar jabber-debug-keep-process-buffers) ; jabber.el ;; (defun jabber-get-connect-function (type) "Get the connect function associated with TYPE. TYPE is a symbol; see `jabber-connection-type'." (let ((entry (assq type jabber-connect-methods))) (nth 1 entry))) (defun jabber-get-send-function (type) "Get the send function associated with TYPE. TYPE is a symbol; see `jabber-connection-type'." (let ((entry (assq type jabber-connect-methods))) (nth 2 entry))) (defun jabber-srv-targets (server network-server port) "Find connection targets for SERVER. If NETWORK-SERVER and/or PORT are specified, use them (always STARTTLS). Otherwise query SRV records; when `jabber-direct-tls-lookup' is non-nil, query both _xmpps-client and _xmpp-client per XEP-0368. Returns a list of (HOST PORT DIRECTTLS-P) where DIRECTTLS-P is non-nil for direct TLS targets." (if (or network-server port) ;; User override: cannot assume direct TLS without SRV. (list (list (or network-server server) (or port 5222) nil)) (or (condition-case nil (if jabber-direct-tls-lookup (jabber-srv-lookup-mixed server) (mapcar (lambda (pair) (list (car pair) (cdr pair) nil)) (jabber-srv-lookup (concat "_xmpp-client._tcp." server)))) (error nil)) (list (list server 5222 nil))))) ;; Plain TCP/IP connection (defun jabber-network-connect (fsm server network-server port) "Connect to a Jabber server with a plain network connection. Send a message of the form (:connected CONNECTION) to FSM if connection succeeds. Send a message (:connection-failed ERRORS) if connection fails." (jabber-network-connect-async fsm server network-server port)) (defun jabber-conn--tls-parameters (server) "Build :tls-parameters for direct TLS to SERVER. SERVER is the JID domain, used for SNI and certificate verification." (let ((verifyp (not (member server jabber-invalid-certificate-servers)))) (cons 'gnutls-x509pki (gnutls-boot-parameters :type 'gnutls-x509pki :hostname server :verify-hostname-error verifyp :verify-error verifyp)))) (defcustom jabber-connection-timeout 30 "Seconds to wait for each connection target before trying the next. Set to nil to disable the per-target timeout and rely on the OS TCP timeout instead." :type '(choice (integer :tag "Seconds") (const :tag "No timeout" nil)) :group 'jabber-conn) (defun jabber-conn--make-process (host port buffer directtls-p server) "Create a network process connecting to HOST:PORT in BUFFER. When DIRECTTLS-P is non-nil, use TLS-on-connect with SNI for SERVER." (let ((args (list :name "jabber" :buffer buffer :host host :service port :coding 'utf-8 :nowait t))) (when directtls-p (setq args (nconc args (list :tls-parameters (jabber-conn--tls-parameters server))))) (apply #'make-network-process args))) (defun jabber-network-connect-async (fsm server network-server port) ;; Get all potential targets... (let ((targets (jabber-srv-targets server network-server port)) errors) ;; ...and connect to them one after another, asynchronously, until ;; connection succeeds. (cl-labels ((connect (target remaining-targets) (let ((host (nth 0 target)) (svc (nth 1 target)) (directtls-p (nth 2 target)) (timeout-timer nil) (settled nil)) (cl-labels ((cancel-timeout () (when timeout-timer (cancel-timer timeout-timer) (setq timeout-timer nil))) (connection-successful (c) (unless settled (setq settled t) (cancel-timeout) ;; This mustn't be `fsm-send-sync', because the FSM ;; needs to change the sentinel, which cannot be done ;; from inside the sentinel. (fsm-send fsm (list :connected c directtls-p)))) (connection-failed (c status) (unless settled (setq settled t) (cancel-timeout) (when (and (> (length status) 0) (eq (aref status (1- (length status))) ?\n)) (setq status (substring status 0 -1))) (let ((err (format "Couldn't connect to %s:%s: %s" host svc status))) (message "%s" err) (push err errors)) (when c (delete-process c)) (if remaining-targets (progn (message "Connecting to %s:%s..." (nth 0 (car remaining-targets)) (nth 1 (car remaining-targets))) (connect (car remaining-targets) (cdr remaining-targets))) (fsm-send fsm (list :connection-failed (nreverse errors))))))) (condition-case e (let ((proc (jabber-conn--make-process host svc (generate-new-buffer jabber-process-buffer) directtls-p server))) (set-process-sentinel proc (lambda (connection status) (cond ((string-match "^open" status) (connection-successful connection)) ((string-match "^failed" status) (connection-failed connection status)) ((string-match "^deleted" status) nil) (t (message "Unknown sentinel status `%s'" status))))) (when jabber-connection-timeout (setq timeout-timer (run-at-time jabber-connection-timeout nil (lambda () (connection-failed proc "connection timed out")))))) (file-error (connection-failed nil (car (cddr e)))) (error (connection-failed nil (error-message-string e)))))))) (message "Connecting to %s:%s..." (nth 0 (car targets)) (nth 1 (car targets))) (connect (car targets) (cdr targets))))) (defun jabber-network-send (connection string) "Send a string via a plain TCP/IP connection to the Jabber Server." (process-send-string connection string)) (defun jabber-starttls-initiate (fsm) "Initiate a STARTTLS connection." (jabber-send-sexp fsm `(starttls ((xmlns . ,jabber-tls-xmlns))))) (defun jabber-starttls-process-input (fsm xml-data) "Process result of starttls request. On failure, signal error. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (cond ((eq (car xml-data) 'proceed) (let* ((state-data (fsm-get-state-data fsm)) (connection (plist-get state-data :connection)) (hostname (plist-get state-data :server)) (verifyp (not (member hostname jabber-invalid-certificate-servers)))) (gnutls-negotiate :process connection :hostname hostname :verify-hostname-error verifyp :verify-error verifyp))) ((eq (car xml-data) 'failure) (error "Command rejected by server")))) (defvar *jabber-virtual-server-function* nil "Function to use for sending stanzas on a virtual connection. The function should accept two arguments, the connection object and a string that the connection wants to send.") (defun jabber-virtual-connect (fsm _server _network-server _port) "Connect to a virtual \"server\". Use `*jabber-virtual-server-function*' as send function. FSM is the finite state machine created in jabber.el library." (unless (functionp *jabber-virtual-server-function*) (error "No virtual server function specified")) ;; We pass the fsm itself as "connection object", as that is what a ;; virtual server needs to send stanzas. (fsm-send fsm (list :connected fsm))) (defun jabber-virtual-send (connection string) (funcall *jabber-virtual-server-function* connection string)) (provide 'jabber-conn) ;;; jabber-conn.el ends here emacs-jabber/lisp/jabber-console.el000066400000000000000000000131341516610113500175500ustar00rootroot00000000000000;;; jabber-console.el --- XML Console mode -*- lexical-binding: t; -*- ;; Copyright (C) 2009, 2010 - Demyan Rogozhin ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; Use *-jabber-console-* for sending custom XMPP code. Be careful! ;;; Code: (require 'jabber-menu) (require 'jabber-util) (require 'jabber-truncate) (require 'xml) (require 'ewoc) (require 'sgml-mode) ;we base on this mode to hightlight XML (defcustom jabber-debug-log-xml nil "Set to non-nil to log all XML i/o in *-jabber-console-JID-* buffer. Set to string to also dump XML i/o in specified file." :type '(choice (const :tag "Do not dump XML i/o" nil) (const :tag "Dump XML i/o in console" t) (string :tag "Dump XML i/o in console and this file")) :group 'jabber-debug) (defcustom jabber-console-name-format "*-jabber-console-%s-*" "Format for console buffer name. %s mean connection jid." :type 'string :group 'jabber-debug) (defcustom jabber-console-truncate-lines 3000 "Maximum number of lines in console buffer. Not truncate if set to 0." :type 'integer :group 'jabber-debug) (defvar jabber-point-insert nil "Position where the message being composed starts.") (defvar jabber-send-function nil "Function for sending a message from a chat buffer.") (defvar jabber-console-mode-hook nil "Hook called at the end of `jabber-console-mode'. Note that functions in this hook have no way of knowing what kind of chat buffer is being created.") (defvar jabber-console-ewoc nil "The ewoc showing the XML elements of this stream buffer.") (defvar-keymap jabber-console-mode-map :parent jabber-common-keymap "RET" #'jabber-chat-buffer-send) ;; Global reference declarations (declare-function jabber-send-string "jabber-core.el" (jc string)) (declare-function jabber-chat-buffer-send "jabber-chatbuffer.el" ()) (defvar jabber-buffer-connection) ; jabber-chatbuffer.el ;; (defun jabber-console-create-buffer (jc) (with-current-buffer (get-buffer-create (format jabber-console-name-format (jabber-connection-bare-jid jc))) (unless (eq major-mode 'jabber-console-mode) (jabber-console-mode)) ;; Make sure the connection variable is up to date. (setq jabber-buffer-connection jc) (current-buffer))) (defun jabber-console-send (jc data) ;; Put manual string into buffers ewoc (jabber-process-console jc "raw" data) ;; ...than sent it to server (jabber-send-string jc data)) (defun jabber-console-comment (str) "Insert comment into console buffer." (let ((string (concat comment-start str "@" (jabber-encode-time (current-time)) ":" comment-end "\n"))) (when (stringp jabber-debug-log-xml) (jabber-append-string-to-file string jabber-debug-log-xml)) (insert string))) (defun jabber-console-pp (data) "Pretty Printer for XML-sexp and raw data." (let ((direction (car data)) (xml-list (cdr data)) (raw (cadr data))) (jabber-console-comment direction) (if (stringp raw) ;; raw code input (progn (insert raw) (when (stringp jabber-debug-log-xml) (jabber-append-string-to-file raw jabber-debug-log-xml))) ;; receive/sending (progn (xml-print xml-list) (when (stringp jabber-debug-log-xml) (jabber-append-string-to-file "\n" jabber-debug-log-xml 'xml-print xml-list)))))) (define-derived-mode jabber-console-mode sgml-mode "Jabber Console" "Major mode for debug XMPP protocol." (setq-local jabber-send-function #'jabber-console-send) (setq-local jabber-point-insert nil) (setq-local jabber-console-ewoc nil) (unless jabber-console-ewoc (setq jabber-console-ewoc (ewoc-create #'jabber-console-pp nil "")) (goto-char (point-max)) (put-text-property (point-min) (point) 'read-only t) (let ((inhibit-read-only t)) (put-text-property (point-min) (point) 'front-sticky t) (put-text-property (point-min) (point) 'rear-nonsticky t)) (setq jabber-point-insert (point-marker)))) (put 'jabber-console-mode 'mode-class 'special) (defun jabber-console-sanitize (xml-data) "Sanitize XML-DATA for `jabber-process-console'." (if (listp xml-data) (jabber-tree-map (lambda (x) (if (numberp x) (format "%s" x) x)) xml-data) xml-data)) ;;;###autoload (defun jabber-process-console (jc direction xml-data) "Log XML-DATA i/o as XML in \"*-jabber-console-JID-*\" buffer." (let ((buffer (get-buffer-create (jabber-console-create-buffer jc)))) (with-current-buffer buffer (progn (ewoc-enter-last jabber-console-ewoc (list direction (jabber-console-sanitize xml-data))) (when (< 1 jabber-console-truncate-lines) (let ((_jabber-log-lines-to-keep jabber-console-truncate-lines)) (jabber-truncate-top buffer jabber-console-ewoc))))))) (provide 'jabber-console) ;;; jabber-console.el ends here emacs-jabber/lisp/jabber-core.el000066400000000000000000001301551516610113500170410ustar00rootroot00000000000000;;; jabber-core.el --- core functions -*- lexical-binding: t; -*- ;; 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 ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'cl-lib) (require 'jabber-sasl) (require 'jabber-xml) (require 'jabber-console) (require 'jabber-keepalive) (require 'jabber-sm) (require 'fsm) (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.") (defvar *jabber-roster* nil "The roster list.") (defvar jabber-jid-obarray (make-vector 127 0) "Obarray for keeping JIDs.") (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)))))))) (defvar-local jabber-namespace-prefixes nil "XML namespace prefixes used for the current connection.") (defgroup jabber-core nil "customize core functionality." :group 'jabber) (defcustom jabber-post-connect-hooks '(jabber-send-current-presence jabber-muc-autojoin jabber-muc-self-ping-start jabber-whitespace-ping-start jabber-vcard-avatars-find-current jabber-carbons-maybe-enable jabber-sm-maybe-start) "*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-muc-self-ping-start jabber-whitespace-ping-start jabber-keepalive-start jabber-vcard-avatars-find-current jabber-autoaway-start jabber-sm-maybe-start)) (defcustom jabber-post-resume-hooks '(jabber-muc-self-ping-rooms jabber-mam-maybe-catchup jabber-muc-self-ping-start jabber-whitespace-ping-start) "Hooks run after successful SM stream resumption. These run instead of `jabber-post-connect-hooks' when the session was resumed rather than freshly established. MAM catchup is needed because SM replay covers only a finite window of unacked stanzas. MUC self-ping verifies room membership survived the offline period. The functions should accept one argument, the connection object." :type 'hook :options '(jabber-muc-self-ping-rooms jabber-mam-maybe-catchup jabber-muc-self-ping-start jabber-whitespace-ping-start)) (defcustom jabber-pre-disconnect-hook nil "*Hooks run just before voluntary disconnection. This might be due to failed authentication." :type 'hook) (defcustom jabber-lost-connection-hooks nil "*Hooks run after involuntary disconnection. The functions are called with one argument: the connection object." :type 'hook) (defcustom jabber-post-disconnect-hook nil "*Hooks run after disconnection." :type 'hook) (defcustom jabber-auto-reconnect t "Reconnect automatically after losing connection? When non-nil, attempts to reconnect after an unexpected disconnection, using Stream Management resume when available. Requires that your password is accessible via auth-source or cached in memory." :type 'boolean) (defcustom jabber-reconnect-delay 5 "Seconds to wait before reconnecting." :type 'integer) (defcustom jabber-roster-buffer "*-jabber-roster-*" "The name of the roster buffer." :type 'string) (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) (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. ;; Global reference declarations (declare-function jabber-send-iq "jabber-iq.el" (jc to type query success-callback success-closure-data error-callback error-closure-data &optional result-id)) (declare-function jabber-muc-connection-closed "jabber-muc.el" (bare-jid)) (declare-function jabber-roster-update "jabber-roster.el" (jc new-items changed-items deleted-items)) (declare-function jabber-roster--refresh "jabber-roster.el" ()) (declare-function jabber-process-roster "jabber-presence.el" (jc xml-data closure-data)) (declare-function jabber-initial-roster-failure "jabber-presence.el" (jc xml-data _closure-data)) (declare-function jabber-get-register "jabber-register.el" (jc to)) (declare-function jabber-get-connect-function "jabber-conn.el" (type)) (declare-function jabber-get-send-function "jabber-conn.el" (type)) (declare-function jabber-starttls-process-input "jabber-conn.el" (fsm xml-data)) (declare-function jabber-starttls-initiate "jabber-conn.el" (fsm)) (declare-function jabber-mode-line-presence-update "jabber-modeline.el" (&rest _)) (declare-function jabber-get-bookmarks "jabber-bookmarks.el" (jc cont &optional refresh)) (defvar jabber-debug-keep-process-buffers) ; jabber.el (defvar jabber-silent-mode) ; jabber.el (defvar jabber-account-list) ; jabber.el (defvar jabber-default-resource) ; jabber.el (defvar jabber-xml-data) ; jabber.el (defvar jabber-default-connection-type) ; jabber-conn.el (defvar jabber-connect-methods) ; jabber-conn.el (defvar jabber-modeline-mode) ; jabber-modeline.el (defvar jabber-roster-xmlns) ; jabber-xml.el ;; ;;;###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 (cl-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 (or (cdr (assq :password alist)) (jabber-read-password (jabber-jid-user jid)))) (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) (or (jabber-jid-resource jid) jabber-default-resource) 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) (or (jabber-jid-resource jid) jabber-default-resource) 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) (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 (jabber-sm--reset (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)) ;; Stop SM timer (setq state-data (jabber-sm--stop-r-timer state-data)) (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)) (sm-resumable (and (plist-get state-data :sm-enabled) (plist-get state-data :sm-id)))) ;; If SM is active and disconnect is unexpected, preserve SM state ;; for resume attempt. Skip MUC cleanup since contacts still see ;; us as online during the server's resume window. (if (and sm-resumable (not expected)) (setq state-data (plist-put state-data :sm-resuming t)) ;; Otherwise clear MUC data and SM state. (jabber-muc-connection-closed (jabber-connection-bare-jid fsm)) (setq state-data (jabber-sm--reset state-data))) ;; Remove lost connections from the roster buffer. (jabber-roster--refresh) (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-modeline-mode (jabber-mode-line-presence-update)) (jabber-roster--refresh) ;; 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. (pcase 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) (pcase (or (car-safe event) event) (:connected (let ((connection (cadr event)) (directtls-p (caddr event))) (setq state-data (plist-put state-data :connection connection)) ;; Direct TLS (XEP-0368): connection is already encrypted. (when directtls-p (setq state-data (plist-put state-data :encrypted t))) (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 start tag. (list state-data nil)) (define-state jabber-connection :connected (fsm state-data event _callback) (pcase (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) ;; XEP-0368: STARTTLS MUST NOT be used over direct TLS. (not (plist-get state-data :encrypted))) (list :starttls state-data)) ;; XXX: require encryption for registration? ((plist-get state-data :registerp) ;; We could check for the 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 "") (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) (pcase (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 "") (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 (pcase (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 "") (list nil (plist-put state-data :disconnection-expected t))))) (define-enter-state jabber-connection :legacy-auth (_fsm state-data) (message "jabber: server requires non-SASL auth, which is no longer supported") (list nil (plist-put state-data :disconnection-expected t))) (define-state jabber-connection :legacy-auth (fsm state-data event _callback) (pcase (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)) (list nil (plist-put state-data :disconnection-expected t))) (:do-disconnect (jabber-send-string fsm "") (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) (pcase (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 "") (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) (pcase (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)) (cond ;; SM resume attempt (post-SASL, per XEP-0198 section 5)? ((and (plist-get state-data :sm-resuming) (jabber-xml-child-with-xmlns stanza jabber-sm-xmlns)) (list :sm-resume state-data)) ;; SM resume was hoped for but server doesn't offer SM here. ((plist-get state-data :sm-resuming) (jabber-muc-connection-closed (jabber-connection-bare-jid fsm)) (setq state-data (jabber-sm--reset state-data)) (setq state-data (plist-put state-data :sm-resuming nil)) ;; Fall through to normal bind. (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)))) (resource (plist-get state-data :resource))) (jabber-send-iq fsm nil "set" `(bind ((xmlns . ,jabber-bind-xmlns)) ,@(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))) ;; Normal bind flow. ((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)))) (resource (plist-get state-data :resource))) (jabber-send-iq fsm nil "set" `(bind ((xmlns . ,jabber-bind-xmlns)) ,@(when resource `((resource () ,resource)))) handle-bind t handle-bind nil) (list :bind state-data))) (t (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 . ,jabber-session-xmlns))) handle-session t handle-session nil) (list :bind state-data)) ;; Session establishment not offered - assume not necessary. (jabber-sm--maybe-enable-or-establish state-data))) (:session-success ;; We have a session (jabber-sm--maybe-enable-or-establish 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 "") (list nil (plist-put state-data :disconnection-expected t))))) (define-enter-state jabber-connection :sm-enable (fsm state-data) (jabber-send-string fsm (jabber-sm--make-enable-xml)) (list state-data nil)) (define-state jabber-connection :sm-enable (fsm state-data event _callback) (pcase (or (car-safe event) event) (:filter (let ((process (cadr event)) (string (car (cddr event)))) (jabber-pre-filter process string fsm) (list :sm-enable state-data))) (:sentinel (jabber-fsm-handle-sentinel state-data event)) (:stanza (let ((stanza (cadr event))) (cond ((jabber-sm--enabled-p stanza) (let ((info (jabber-sm--parse-enabled stanza))) (setq state-data (jabber-sm--apply-enabled state-data info)) (list :session-established state-data))) ((jabber-sm--failed-p stanza) (message "Stream Management negotiation failed, continuing without SM") (list :session-established state-data)) (t (or (jabber-process-stream-error stanza state-data) (list :sm-enable state-data)))))) (:do-disconnect (jabber-send-string fsm "") (list nil (plist-put state-data :disconnection-expected t))))) (define-enter-state jabber-connection :sm-resume (fsm state-data) (jabber-send-string fsm (jabber-sm--make-resume-xml (plist-get state-data :sm-inbound-count) (plist-get state-data :sm-id))) (list state-data nil)) (define-state jabber-connection :sm-resume (fsm state-data event _callback) (pcase (or (car-safe event) event) (:filter (let ((process (cadr event)) (string (car (cddr event)))) (jabber-pre-filter process string fsm) (list :sm-resume state-data))) (:sentinel (jabber-fsm-handle-sentinel state-data event)) (:stanza (let ((stanza (cadr event))) (cond ((jabber-sm--resumed-p stanza) (let* ((result (jabber-sm--handle-resumed state-data stanza)) (new-state-data (car result)) (to-resend (cdr result))) ;; Resend unacked stanzas (bypass gate to avoid re-queuing). (dolist (sexp to-resend) (jabber-send-sexp--immediate fsm sexp)) ;; Drain any stanzas queued before disconnect. (setq new-state-data (jabber-sm--drain-pending fsm new-state-data #'jabber-send-sexp--immediate)) (list :session-established new-state-data))) ((jabber-sm--failed-p stanza) (message "Stream Management resume failed, falling back to auth") ;; Resume failed: clean up MUC state now, reset SM, do full auth. (jabber-muc-connection-closed (jabber-connection-bare-jid fsm)) (setq state-data (jabber-sm--reset state-data)) (setq state-data (plist-put state-data :sm-resuming nil)) (list :sasl-auth state-data)) (t (or (jabber-process-stream-error stanza state-data) (list :sm-resume state-data)))))) (:do-disconnect (jabber-send-string fsm "") (list nil (plist-put state-data :disconnection-expected t))))) (defvar jabber-pending-presence-timeout 0.5 "Wait this long before doing presence packet batch processing.") (define-enter-state jabber-connection :session-established (fsm state-data) (if (plist-get state-data :sm-resumed) ;; On SM resume, the session was never lost; skip roster fetch ;; and bookmark prefetch. Run resume-specific hooks (MAM ;; catchup, keepalive restart) since SM replay only covers a ;; finite window of unacked stanzas. (progn (when (plist-get state-data :sm-enabled) (setq state-data (jabber-sm--start-r-timer fsm state-data))) (setq state-data (plist-put state-data :sm-resumed nil)) (run-hook-with-args 'jabber-post-resume-hooks fsm)) ;; Normal connect: fetch roster (which triggers post-connect hooks ;; from the roster callback) and prefetch bookmarks. (jabber-send-iq fsm nil "get" `(query ((xmlns . ,jabber-roster-xmlns))) #'jabber-process-roster 'initial #'jabber-initial-roster-failure nil) (jabber-get-bookmarks fsm #'ignore)) (list (plist-put state-data :ever-session-established t) nil)) (define-state jabber-connection :session-established (fsm state-data event _callback) (pcase (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 (let ((stanza (cadr event))) (cond ((jabber-sm--r-p stanza) (jabber-sm--send-ack fsm state-data) (list :session-established state-data :keep)) ((jabber-sm--a-p stanza) (setq state-data (jabber-sm--process-ack state-data stanza)) (setq state-data (jabber-sm--drain-pending fsm state-data #'jabber-send-sexp--immediate)) (list :session-established state-data :keep)) (t ;; Only message/presence/iq stanzas reach here; / are ;; SM control elements and must not be counted (XEP-0198 §4). (setq state-data (jabber-sm--count-inbound fsm state-data stanza)) (or (jabber-process-stream-error stanza state-data) (progn (jabber-process-input fsm stanza) (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)) (:connection-dead ;; Connection process vanished without a proper FSM transition ;; (e.g. race between stream error and sentinel). Reconnect. (unless (plist-get state-data :disconnection-reason) (setq state-data (plist-put state-data :disconnection-reason "Connection process lost"))) (list nil state-data)) (:do-disconnect (jabber-send-string fsm "") (list nil (plist-put state-data :disconnection-expected t))))) (defun jabber-disconnect (&optional arg interactivep) "Disconnect from all Jabber servers. If ARG supplied, disconnect one account." (interactive "P\np") (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 interactivep (message "Disconnected from Jabber server(s)"))))))) (defun jabber-disconnect-one (jc &optional dont-redisplay interactivep) "Disconnect from one Jabber server. If DONT-REDISPLAY is non-nil, don't update roster buffer. JC is the Jabber connection." (interactive (list (jabber-read-account) nil 'interactive)) (fsm-send-sync jc :do-disconnect) (when interactivep (message "Disconnected from %s" (jabber-connection-jid jc))) (unless dont-redisplay (jabber-roster--refresh))) (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))) (defvar jabber-core--filtering nil "Re-entrance guard for `jabber-pre-filter'.") (defun jabber-pre-filter (process string fsm) (with-current-buffer (process-buffer process) ;; Append new data (goto-char (point-max)) (insert string) (unless jabber-core--filtering (let ((jabber-core--filtering t)) (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) (cl-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 "") (cl-return (fsm-send fsm :stream-end))) ;; Stream header? (when (looking-at "]*\\(>\\)") ;; 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 (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))) )))) (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-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) jabber-streams-xmlns)) (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)))) (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--immediate (jc sexp) "Send SEXP to JC immediately, bypassing the back-pressure gate. Log the XML, send it (with a proactive for countable stanzas when SM is enabled), and update the outbound counter." (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))) ;; SM stanza counting (modifies state-data in place via plist-put). (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) (jabber-sm--enqueue-pending state-data sexp) (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-stream-header (jc) "Send stream header to connection JC." (let ((stream-header (concat " "))) (jabber-log-xml jc "sending" stream-header) (jabber-send-string jc stream-header))) (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))) (provide 'jabber-core) ;;; jabber-core.el ends here emacs-jabber/lisp/jabber-csi.el000066400000000000000000000053021516610113500166620ustar00rootroot00000000000000;;; jabber-csi.el --- XEP-0352 Client State Indication -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; Send and top-level elements per XEP-0352 ;; based on whether any Emacs frame currently has input focus. ;;; Code: (require 'jabber-core) (require 'jabber-disco) (declare-function jabber-send-sexp-if-connected "jabber-core" (jc sexp)) (defconst jabber-csi-xmlns "urn:xmpp:csi:0" "XML namespace for XEP-0352 Client State Indication.") (defgroup jabber-csi nil "Client State Indication." :group 'jabber) (defcustom jabber-csi-enable t "Send CSI active/inactive notifications to the server." :type 'boolean) (defvar jabber-csi--last-state nil "Last CSI state sent: `active', `inactive', or nil.") (defun jabber-csi--focused-p () "Return non-nil if any Emacs frame has input focus." (cl-some #'frame-focus-state (frame-list))) (defun jabber-csi--send-state () "Send CSI active or inactive to all connections." (when jabber-csi-enable (let ((state (if (jabber-csi--focused-p) 'active 'inactive))) (unless (eq state jabber-csi--last-state) (setq jabber-csi--last-state state) (dolist (jc jabber-connections) (jabber-send-sexp-if-connected jc `(,state ((xmlns . ,jabber-csi-xmlns))))))))) (defun jabber-csi--focus-changed () "Hook for `after-focus-change-function'. Defers to a zero-delay timer to avoid running in a sensitive context." (run-at-time 0 nil #'jabber-csi--send-state)) (defun jabber-csi--on-connect (_jc) "Send current CSI state after connection. Added to `jabber-post-connect-hooks'." (setq jabber-csi--last-state nil) (jabber-csi--send-state)) (add-hook 'jabber-post-connect-hooks #'jabber-csi--on-connect) (add-function :after after-focus-change-function #'jabber-csi--focus-changed) (jabber-disco-advertise-feature jabber-csi-xmlns) (provide 'jabber-csi) ;;; jabber-csi.el ends here emacs-jabber/lisp/jabber-db.el000066400000000000000000001225041516610113500164750ustar00rootroot00000000000000;;; jabber-db.el --- SQLite message storage for jabber.el -*- lexical-binding: t; -*- ;; Copyright (C) 2024 emacs-jabber contributors ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; SQLite-based message storage for jabber.el, replacing flat-file ;; history. Requires Emacs 29.1+ built-in `sqlite' support. ;; ;; Provides: ;; - Persistent message storage with full-text search (FTS5) ;; - Backlog retrieval compatible with `jabber-chat-insert-backlog-entry' ;; - Paginated queries and FTS5 search ;; - XEP-0359 stanza-id / server-id columns for future MAM dedup ;; - One-time migration from flat-file history ;;; Code: (require 'jabber-util) (eval-when-compile (require 'cl-lib) (require 'seq)) ;; Global reference declarations (declare-function jabber-chain-add "jabber-core" (chain-var handler &optional depth)) (declare-function jabber-xml-child-with-xmlns "jabber-xml.el" (node xmlns)) (declare-function jabber-xml-get-attribute "jabber-xml.el" (node attribute)) (declare-function jabber-muc-joined-p "jabber-muc" (group &optional jc)) (declare-function jabber-muc-sender-p "jabber-muc" (jid)) (declare-function jabber-xml-encrypted-p "jabber-xml" (xml-data)) (defvar jabber-chatting-with) ; jabber-chat.el (defvar jabber-chat-send-hooks) ; jabber-chat.el (defvar jabber-chat-encryption) ; jabber-chatbuffer.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-message-chain nil) ; jabber-core.el (defvar jabber-post-connect-hooks nil) ; jabber-core.el (defvar jabber-pre-disconnect-hook nil) ; jabber-core.el (defvar jabber-oob-xmlns) ; jabber-xml.el (defgroup jabber-db nil "SQLite message storage for jabber.el." :group 'jabber) (defcustom jabber-db-path (expand-file-name "jabber/jabber.db" user-emacs-directory) "Path to the SQLite database file for message storage. Set to nil to disable message storage entirely." :type '(choice (file :tag "Database file") (const :tag "Disabled" nil))) (defcustom jabber-backlog-days nil "Age limit on messages in chat buffer backlog, in days." :type '(choice (number :tag "Number of days") (const :tag "No limit" nil))) (defcustom jabber-backlog-number 30 "Maximum number of messages in chat buffer backlog." :type 'integer) (defvar jabber-history-inhibit-received-message-functions nil "Functions determining whether to log an incoming message stanza. The functions in this list are called with two arguments, the connection and the full message stanza. If any of the functions returns non-nil, the stanza is not logged in the message history.") ;;; Database connection (defvar jabber-db--connection nil "Active SQLite database connection, or nil.") (defconst jabber-db--schema-ddl '("CREATE TABLE IF NOT EXISTS message ( id INTEGER PRIMARY KEY, stanza_id TEXT, server_id TEXT, account TEXT NOT NULL, peer TEXT NOT NULL, resource TEXT, occupant_id TEXT, direction TEXT NOT NULL CHECK(direction IN ('in','out')), type TEXT CHECK(type IN ('chat','groupchat','headline')), body TEXT, timestamp INTEGER NOT NULL, encrypted INTEGER DEFAULT 0, delivered_at INTEGER, displayed_at INTEGER, retracted_by TEXT, retraction_reason TEXT, edited INTEGER DEFAULT 0)" "CREATE INDEX IF NOT EXISTS idx_msg_peer_ts ON message(account, peer, timestamp)" "CREATE INDEX IF NOT EXISTS idx_msg_stanza_id ON message(account, stanza_id) WHERE stanza_id IS NOT NULL" "CREATE INDEX IF NOT EXISTS idx_msg_server_id ON message(account, server_id) WHERE server_id IS NOT NULL" "CREATE INDEX IF NOT EXISTS idx_msg_occupant_id ON message(account, peer, occupant_id) WHERE occupant_id IS NOT NULL" "CREATE VIRTUAL TABLE IF NOT EXISTS message_fts USING fts5( body, content='message', content_rowid='id')" "CREATE TRIGGER IF NOT EXISTS message_ai AFTER INSERT ON message BEGIN INSERT INTO message_fts(rowid, body) VALUES (new.id, new.body); END" "CREATE TRIGGER IF NOT EXISTS message_ad AFTER DELETE ON message BEGIN INSERT INTO message_fts(message_fts, rowid, body) VALUES ('delete', old.id, old.body); END" "CREATE TRIGGER IF NOT EXISTS message_au AFTER UPDATE ON message BEGIN INSERT INTO message_fts(message_fts, rowid, body) VALUES ('delete', old.id, old.body); INSERT INTO message_fts(rowid, body) VALUES (new.id, new.body); END" "CREATE TABLE IF NOT EXISTS omemo_store ( account TEXT PRIMARY KEY, store_blob BLOB NOT NULL)" "CREATE TABLE IF NOT EXISTS omemo_sessions ( account TEXT NOT NULL, jid TEXT NOT NULL, device_id INTEGER NOT NULL, session_blob BLOB NOT NULL, PRIMARY KEY (account, jid, device_id))" "CREATE TABLE IF NOT EXISTS omemo_trust ( account TEXT NOT NULL, jid TEXT NOT NULL, device_id INTEGER NOT NULL, identity_key BLOB NOT NULL, trust INTEGER DEFAULT 0, first_seen INTEGER NOT NULL, PRIMARY KEY (account, jid, device_id))" "CREATE TABLE IF NOT EXISTS omemo_skipped_keys ( account TEXT NOT NULL, jid TEXT NOT NULL, device_id INTEGER NOT NULL, dh_key BLOB NOT NULL, message_number INTEGER NOT NULL, message_key BLOB NOT NULL, created_at INTEGER NOT NULL, PRIMARY KEY (account, jid, device_id, dh_key, message_number))" "CREATE TABLE IF NOT EXISTS omemo_devices ( account TEXT NOT NULL, jid TEXT NOT NULL, device_id INTEGER NOT NULL, active INTEGER DEFAULT 1, last_seen INTEGER NOT NULL, PRIMARY KEY (account, jid, device_id))" "CREATE INDEX IF NOT EXISTS idx_omemo_trust_jid ON omemo_trust (account, jid)" "CREATE INDEX IF NOT EXISTS idx_omemo_devices_jid ON omemo_devices (account, jid)" "CREATE INDEX IF NOT EXISTS idx_omemo_sessions_jid ON omemo_sessions (account, jid)" "CREATE TABLE IF NOT EXISTS omemo_device_id ( account TEXT PRIMARY KEY, device_id INTEGER NOT NULL)" "CREATE TABLE IF NOT EXISTS chat_settings ( account TEXT NOT NULL, peer TEXT NOT NULL, encryption TEXT DEFAULT 'default', PRIMARY KEY (account, peer))" "CREATE TABLE IF NOT EXISTS message_oob ( id INTEGER PRIMARY KEY, message_id INTEGER NOT NULL REFERENCES message(id) ON DELETE CASCADE, url TEXT NOT NULL, desc TEXT)" "CREATE INDEX IF NOT EXISTS idx_oob_message_id ON message_oob(message_id)" "CREATE TABLE IF NOT EXISTS caps_cache ( hash TEXT NOT NULL, ver TEXT NOT NULL, identities TEXT NOT NULL, features TEXT NOT NULL, PRIMARY KEY (hash, ver))") "DDL statements for the latest database schema.") (defun jabber-db--init-schema (db) "Initialize the database schema in DB." (dolist (ddl jabber-db--schema-ddl) (sqlite-execute db ddl))) (defconst jabber-db--schema-version 4 "Current schema version. Bump this when adding migrations. A database whose version exceeds this value is from a newer (or development) build and cannot be used; the user is prompted to delete it.") (defun jabber-db--handle-unknown-schema (db) "Detect a schema newer than `jabber-db--schema-version' and offer to reset. Returns non-nil if the database was deleted and the caller should re-open it." (let ((version (caar (sqlite-select db "PRAGMA user_version")))) (when (> version jabber-db--schema-version) (sqlite-close db) (if (y-or-n-p (format "Database schema v%d is newer than supported v%d at %s.\n\ Delete it and start fresh? " version jabber-db--schema-version jabber-db-path)) (progn (delete-file jabber-db-path) (message "Deleted incompatible database %s" jabber-db-path) t) (user-error "Cannot open database (v%d > supported v%d); \ delete %s manually to continue" version jabber-db--schema-version jabber-db-path))))) (defun jabber-db--migrate (db) "Check user_version and apply migrations to DB." (let ((version (caar (sqlite-select db "PRAGMA user_version")))) (when (zerop version) (jabber-db--init-schema db) (sqlite-execute db (format "PRAGMA user_version=%d" jabber-db--schema-version)) (setq version jabber-db--schema-version)) (when (= version 1) (sqlite-execute db "ALTER TABLE message ADD COLUMN occupant_id TEXT") (sqlite-execute db "ALTER TABLE message DROP COLUMN raw_xml") (sqlite-execute db "\ CREATE INDEX IF NOT EXISTS idx_msg_occupant_id ON message(account, peer, occupant_id) WHERE occupant_id IS NOT NULL") (sqlite-execute db "PRAGMA user_version=2") (setq version 2)) (when (= version 2) (sqlite-execute db "\ CREATE TABLE IF NOT EXISTS message_oob ( id INTEGER PRIMARY KEY, message_id INTEGER NOT NULL REFERENCES message(id) ON DELETE CASCADE, url TEXT NOT NULL, desc TEXT)") (sqlite-execute db "\ CREATE INDEX IF NOT EXISTS idx_oob_message_id ON message_oob(message_id)") (sqlite-execute db "\ INSERT INTO message_oob (message_id, url, desc) SELECT id, oob_url, oob_desc FROM message WHERE oob_url IS NOT NULL") (sqlite-execute db "ALTER TABLE message DROP COLUMN oob_url") (sqlite-execute db "ALTER TABLE message DROP COLUMN oob_desc") (sqlite-execute db "PRAGMA user_version=3") (setq version 3)) (when (= version 3) (sqlite-execute db "\ CREATE TABLE IF NOT EXISTS caps_cache ( hash TEXT NOT NULL, ver TEXT NOT NULL, identities TEXT NOT NULL, features TEXT NOT NULL, PRIMARY KEY (hash, ver))") (sqlite-execute db "PRAGMA user_version=4") (setq version 4)))) (defun jabber-db-ensure-open () "Open the SQLite database, creating it if needed. Idempotent. Return the database connection, or nil if storage is disabled." (when jabber-db-path (unless (and jabber-db--connection (sqlitep jabber-db--connection)) (let ((dir (file-name-directory jabber-db-path))) (unless (file-directory-p dir) (make-directory dir t))) (let ((db (sqlite-open jabber-db-path))) (when (jabber-db--handle-unknown-schema db) ;; Database was deleted; re-open fresh. (setq db (sqlite-open jabber-db-path))) (setq jabber-db--connection db)) (sqlite-execute jabber-db--connection "PRAGMA journal_mode=WAL") (sqlite-execute jabber-db--connection "PRAGMA synchronous=NORMAL") (sqlite-execute jabber-db--connection "PRAGMA foreign_keys=ON") (jabber-db--migrate jabber-db--connection)) jabber-db--connection)) (defun jabber-db-close () "Close the database connection." (when (and jabber-db--connection (sqlitep jabber-db--connection)) (sqlite-close jabber-db--connection) (setq jabber-db--connection nil))) ;;; Transactions (defmacro jabber-db-with-transaction (&rest body) "Execute BODY inside a SQLite transaction. Opens a BEGIN/COMMIT pair around BODY. If BODY signals an error, the transaction is still committed (partial data is better than a stuck open transaction in single-threaded Emacs)." (declare (indent 0) (debug t)) `(when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "BEGIN") (unwind-protect (progn ,@body) (sqlite-execute db "COMMIT")))) ;;; Chat settings (defun jabber-db-set-chat-encryption (account peer encryption) "Store ENCRYPTION mode for ACCOUNT + PEER. ENCRYPTION is a symbol: `omemo', `plaintext', or `default'." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "\ INSERT OR REPLACE INTO chat_settings (account, peer, encryption) VALUES (?, ?, ?)" (list account peer (symbol-name encryption))))) (defun jabber-db-get-chat-encryption (account peer) "Load encryption mode for ACCOUNT + PEER. Returns a symbol (`omemo', `plaintext'), or nil if not set or `default'." (when-let* ((db (jabber-db-ensure-open))) (when-let* ((val (caar (sqlite-select db "\ SELECT encryption FROM chat_settings WHERE account = ? AND peer = ?" (list account peer))))) (unless (string= val "default") (intern val))))) ;;; Caps cache (defun jabber-db-caps-store (hash ver identities features) "Persist a caps cache entry for HASH and VER. IDENTITIES is a list of vectors [name category type]. FEATURES is a list of feature strings." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "\ INSERT OR REPLACE INTO caps_cache (hash, ver, identities, features) VALUES (?, ?, ?, ?)" (list hash ver (prin1-to-string identities) (prin1-to-string features))))) (defun jabber-db-caps-lookup (hash ver) "Look up a caps cache entry for HASH and VER. Return (IDENTITIES FEATURES) or nil if not found." (when-let* ((db (jabber-db-ensure-open))) (when-let* ((row (car (sqlite-select db "\ SELECT identities, features FROM caps_cache WHERE hash = ? AND ver = ?" (list hash ver))))) (list (car (read-from-string (car row))) (car (read-from-string (cadr row))))))) ;;; Storage (defun jabber-db--detect-duplicate (db account peer timestamp body stanza-id server-id &optional type) "Check whether a message already exists in DB. Return a symbol indicating the match type: `stanza_id', `server_id', `content', or nil for no match. Optional TYPE is the message type; stanza_id dedup is skipped for \"groupchat\" because MUC servers recycle short message IDs." (cond ;; Server-assigned IDs (XEP-0359) are globally unique; check first. ((and server-id (caar (sqlite-select db "SELECT 1 FROM message \ WHERE server_id = ? AND account = ? LIMIT 1" (list server-id account)))) 'server_id) ;; Stanza IDs (origin-id or message id attr) can be recycled by ;; MUC servers, so only use them for 1:1 chat dedup. ((and stanza-id (not (equal type "groupchat")) (caar (sqlite-select db "SELECT 1 FROM message \ WHERE stanza_id = ? AND account = ? AND peer = ? LIMIT 1" (list stanza-id account peer)))) 'stanza_id) ;; Content-based dedup: matches messages stored by the ;; live handler (nil IDs) against MAM replays (with IDs), ;; or MUC history replayed on every join. ((caar (sqlite-select db "SELECT 1 FROM message \ WHERE account = ? AND peer = ? AND timestamp = ? AND body = ? LIMIT 1" (list account peer timestamp body))) 'content))) (defun jabber-db--insert-message (db account peer resource occupant-id direction type body timestamp stanza-id server-id encrypted oob-entries) "Insert a new message row into DB and attach OOB entries." (sqlite-execute db "INSERT INTO message \ (account, peer, resource, occupant_id, direction, type, body, timestamp, \ stanza_id, server_id, encrypted) \ VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" (list account peer resource occupant-id direction type body timestamp stanza-id server-id (if encrypted 1 0))) (when oob-entries (let ((msg-id (caar (sqlite-select db "SELECT last_insert_rowid()")))) (dolist (entry oob-entries) (sqlite-execute db "INSERT INTO message_oob (message_id, url, desc) VALUES (?, ?, ?)" (list msg-id (car entry) (cdr entry))))))) (defun jabber-db--update-duplicate-ids (db account peer timestamp body stanza-id server-id oob-entries dup-id-col) "Update an existing duplicate matched by DUP-ID-COL. Normalizes timestamp and replaces failed-decrypt placeholders. Skips retracted messages to prevent MAM replays from undoing retractions. PEER is used for stanza_id scoping (stanza IDs can collide in MUC)." (let* ((id-val (if (eq dup-id-col 'stanza_id) stanza-id server-id)) ;; stanza_id needs peer scope; server_id is globally unique. (where-clause (if (eq dup-id-col 'stanza_id) (format "%s = ? AND account = ? AND peer = ?" dup-id-col) (format "%s = ? AND account = ?" dup-id-col))) (where-params (if (eq dup-id-col 'stanza_id) (list id-val account peer) (list id-val account))) (retracted (caar (sqlite-select db (format "SELECT 1 FROM message WHERE %s \ AND retracted_by IS NOT NULL LIMIT 1" where-clause) where-params)))) (unless retracted ;; Normalize timestamp only when it differs. (sqlite-execute db (format "UPDATE message SET timestamp = ? WHERE %s AND timestamp != ?" where-clause) (append (list timestamp) where-params (list timestamp))) ;; Replace failed-decrypt placeholder if new body is real text. (when (and body (not (string-match-p "\\`: could not decrypt\\]" body))) (let ((msg-id (caar (sqlite-select db (format "SELECT id FROM message WHERE %s \ AND body LIKE '%%: could not decrypt]' LIMIT 1" where-clause) where-params)))) (when msg-id (sqlite-execute db "UPDATE message SET body = ? WHERE id = ?" (list body msg-id)) (sqlite-execute db "DELETE FROM message_oob WHERE message_id = ?" (list msg-id)) (dolist (entry oob-entries) (sqlite-execute db "INSERT INTO message_oob (message_id, url, desc) \ VALUES (?, ?, ?)" (list msg-id (car entry) (cdr entry)))))))))) (defun jabber-db--upgrade-content-match (db account peer timestamp body stanza-id server-id) "Upgrade a content-matched row with server-assigned IDs." (when (or stanza-id server-id) (sqlite-execute db "UPDATE message SET stanza_id = COALESCE(stanza_id, ?), \ server_id = COALESCE(server_id, ?) \ WHERE account = ? AND peer = ? AND timestamp = ? AND body = ? \ AND stanza_id IS NULL AND server_id IS NULL" (list stanza-id server-id account peer timestamp body)))) (defun jabber-db-store-message (account peer direction type body timestamp &optional resource stanza-id server-id occupant-id oob-entries encrypted) "Store a message in the database. ACCOUNT is the bare JID of the local account. PEER is the bare JID of the contact or room. DIRECTION is \"in\" or \"out\". TYPE is the message type (\"chat\", \"groupchat\", \"headline\"). BODY is the message text. TIMESTAMP is a unix epoch integer. Optional RESOURCE is the sender resource. Optional STANZA-ID is the XEP-0359 origin id. Optional SERVER-ID is the XEP-0359 server-assigned id. Optional OCCUPANT-ID is the XEP-0421 occupant id. Optional OOB-ENTRIES is a list of (URL . DESC) cons cells for jabber:x:oob elements. Optional ENCRYPTED is non-nil if the message was OMEMO-encrypted." (when-let* ((db (jabber-db-ensure-open))) (let ((dup-id-col (jabber-db--detect-duplicate db account peer timestamp body stanza-id server-id type))) (pcase dup-id-col ('nil (jabber-db--insert-message db account peer resource occupant-id direction type body timestamp stanza-id server-id encrypted oob-entries)) ((or 'stanza_id 'server_id) (jabber-db--update-duplicate-ids db account peer timestamp body stanza-id server-id oob-entries dup-id-col)) ('content (jabber-db--upgrade-content-match db account peer timestamp body stanza-id server-id)))))) ;;; Receipt updates (defun jabber-db-update-receipt (account peer stanza-id column timestamp) "Set COLUMN to TIMESTAMP for outgoing message with STANZA-ID. ACCOUNT and PEER scope the update to prevent cross-conversation collision. Only updates outgoing messages (direction=out). COLUMN is \"delivered_at\" or \"displayed_at\". The IS NULL guard prevents overwriting an earlier timestamp." (when (and jabber-db--connection stanza-id) (sqlite-execute jabber-db--connection (format "UPDATE message SET %s = ? \ WHERE account = ? AND peer = ? AND stanza_id = ? \ AND direction = 'out' AND %s IS NULL" column column) (list timestamp account peer stanza-id)))) (defun jabber-db-cascade-displayed (account peer timestamp ref-timestamp) "Mark all outgoing messages before REF-TIMESTAMP as displayed. ACCOUNT and PEER identify the conversation. TIMESTAMP is the current time to store as displayed_at. REF-TIMESTAMP is the timestamp of the referenced message. Only updates messages with direction=out that have delivered_at set but displayed_at IS NULL." (when jabber-db--connection (sqlite-execute jabber-db--connection "UPDATE message SET displayed_at = ? \ WHERE account = ? AND peer = ? AND direction = 'out' \ AND timestamp <= ? AND delivered_at IS NOT NULL AND displayed_at IS NULL" (list timestamp account peer ref-timestamp)))) (defun jabber-db-retract-message (server-id retracted-by &optional reason) "Mark the message with SERVER-ID as retracted by RETRACTED-BY. Optional REASON is the human-readable retraction reason string." (when (and jabber-db--connection server-id) (sqlite-execute jabber-db--connection "UPDATE message SET retracted_by = ?, retraction_reason = ? WHERE server_id = ?" (list retracted-by reason server-id)))) (defun jabber-db-occupant-id-by-server-id (server-id) "Return the occupant-id for the message with SERVER-ID, or nil." (when (and jabber-db--connection server-id) (caar (sqlite-select jabber-db--connection "SELECT occupant_id FROM message \ WHERE server_id = ? LIMIT 1" (list server-id))))) (defun jabber-db-server-ids-by-occupant-id (account peer occupant-id) "Return server-ids for messages with OCCUPANT-ID in PEER on ACCOUNT. Only returns non-retracted messages that have a server-id." (when-let* ((db (jabber-db-ensure-open))) (mapcar #'car (sqlite-select db "SELECT server_id FROM message \ WHERE account = ? AND peer = ? AND occupant_id = ? \ AND server_id IS NOT NULL AND retracted_by IS NULL" (list account peer occupant-id))))) (defun jabber-db-correct-message (stanza-id new-body) "Replace body of message with STANZA-ID with NEW-BODY and mark as edited." (when (and jabber-db--connection stanza-id) (sqlite-execute jabber-db--connection "UPDATE message SET body = ?, edited = 1 WHERE stanza_id = ?" (list new-body stanza-id)))) (defun jabber-db-delete-peer-messages (account peer) "Delete all messages for PEER on ACCOUNT." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "DELETE FROM message WHERE account = ? AND peer = ?" (list account peer)))) (defun jabber-db-message-sender-by-stanza-id (stanza-id) "Return the from-JID of the stored message with STANZA-ID, or nil. For incoming messages returns the full sender JID (peer/resource or peer). For outgoing messages returns the account bare JID, enabling validation of carbon copies of corrections sent from another device." (when (and jabber-db--connection stanza-id) (when-let* ((row (car (sqlite-select jabber-db--connection "SELECT direction, peer, resource, account \ FROM message WHERE stanza_id = ? LIMIT 1" (list stanza-id))))) (seq-let (direction peer resource account) row (if (string= direction "in") (if resource (concat peer "/" resource) peer) account))))) ;;; Retrieval (defun jabber-db--row-to-plist (row) "Convert a backlog ROW to a message plist. ROW columns match the SELECT in `jabber-db-backlog'. The :oob-entries key is populated later by `jabber-db--attach-oob-entries'." (seq-let (id account peer direction body timestamp resource type encrypted stanza-id delivered-at displayed-at server-id retracted-by retraction-reason edited) row (let ((from (cond ;; Incoming: peer/resource (or just peer if no resource). ((string= direction "in") (if resource (concat peer "/" resource) peer)) ;; Outgoing groupchat: peer/resource so the nick renders. ((and (equal type "groupchat") resource) (concat peer "/" resource)) ;; Outgoing 1:1: account bare JID. (t account)))) (list :db-id id :id stanza-id :server-id server-id :from from :body (or body "") :subject nil :timestamp (seconds-to-time timestamp) :delayed t :encrypted (and encrypted (not (zerop encrypted))) :retracted (and retracted-by t) :retracted-by retracted-by :retraction-reason retraction-reason :edited (and edited (not (zerop edited))) :direction direction :msg-type type :oob-entries nil :oob-url nil :oob-desc nil :error-text nil :status (cond (displayed-at :displayed) (delivered-at :delivered)))))) (defun jabber-db--attach-oob-entries (db plists) "Batch-query OOB entries and attach to PLISTS. DB is the SQLite connection. Each plist must have a :db-id key. Sets :oob-entries, :oob-url, and :oob-desc on each plist." (when plists (let* ((ids (cl-loop for p in plists for id = (plist-get p :db-id) when id collect id)) (oob-rows (when ids (sqlite-select db (format "SELECT message_id, url, desc FROM message_oob \ WHERE message_id IN (%s) ORDER BY message_id, id" (mapconcat (lambda (id) (number-to-string id)) ids ","))))) (grouped (make-hash-table :test #'eql))) (dolist (row oob-rows) (let ((msg-id (nth 0 row)) (url (nth 1 row)) (desc (nth 2 row))) (push (cons url desc) (gethash msg-id grouped)))) (dolist (p plists) (when-let* ((db-id (plist-get p :db-id))) (let ((entries (nreverse (gethash db-id grouped)))) (plist-put p :oob-entries entries) (plist-put p :oob-url (caar entries)) (plist-put p :oob-desc (cdar entries))))))) plists) (defun jabber-db-backlog (account peer &optional count start-time resource msg-type) "Return the last COUNT messages for PEER on ACCOUNT. Messages are returned as plists with keys :from, :body, :timestamp, :delayed, :direction, :msg-type, etc. COUNT defaults to `jabber-backlog-number'. START-TIME is a float-time; only messages after this time are returned. If nil, `jabber-backlog-days' is used to compute the cutoff. RESOURCE, when non-nil, filters to messages from that resource only. This is used for MUC private message buffers. MSG-TYPE, when non-nil, filters to messages of that type only \(e.g. \"groupchat\" for MUC buffers)." (when-let* ((db (jabber-db-ensure-open))) (let* ((n (or count jabber-backlog-number)) (cutoff (cond (start-time (floor start-time)) (jabber-backlog-days (floor (- (float-time) (* jabber-backlog-days 86400.0)))) (t 0))) (base-cols "SELECT id, account, peer, direction, body, timestamp, \ resource, type, encrypted, stanza_id, delivered_at, displayed_at, \ server_id, retracted_by, retraction_reason, edited FROM message") (sql (cond (resource (concat base-cols " WHERE account = ? AND peer = ? \ AND type = 'chat' AND (resource = ? OR direction = 'out') \ AND timestamp >= ? ORDER BY timestamp DESC LIMIT ?")) (msg-type (concat base-cols " WHERE account = ? AND peer = ? \ AND type = ? AND timestamp >= ? \ ORDER BY timestamp DESC LIMIT ?")) (t (concat base-cols " WHERE account = ? AND peer = ? \ AND timestamp >= ? ORDER BY timestamp DESC LIMIT ?")))) (params (cond (resource (list account peer resource cutoff (if (eq n t) -1 n))) (msg-type (list account peer msg-type cutoff (if (eq n t) -1 n))) (t (list account peer cutoff (if (eq n t) -1 n))))) (rows (sqlite-select db sql params)) (plists (mapcar #'jabber-db--row-to-plist rows))) (jabber-db--attach-oob-entries db plists)))) (defun jabber-db--raw-row-to-plist (row) "Convert a raw query ROW to a plist. ROW columns: id, stanza_id, server_id, account, peer, resource, occupant_id, direction, type, body, timestamp, encrypted." (seq-let (id stanza-id server-id account peer resource occupant-id direction type body timestamp encrypted) row (list :id id :stanza-id stanza-id :server-id server-id :account account :peer peer :resource resource :occupant-id occupant-id :direction direction :type type :body body :timestamp timestamp :encrypted encrypted))) (defun jabber-db-query (account peer &optional start-time end-time limit offset) "Query messages for PEER on ACCOUNT with pagination. Returns a list of plists with keys :id, :stanza-id, :server-id, :account, :peer, :resource, :occupant-id, :direction, :type, :body, :timestamp, :encrypted. START-TIME and END-TIME are unix epoch integers. LIMIT defaults to 50, OFFSET defaults to 0." (when-let* ((db (jabber-db-ensure-open))) (let* ((lim (or limit 50)) (off (or offset 0)) (st (or start-time 0)) (et (or end-time (floor (float-time)))) (rows (sqlite-select db "SELECT id, stanza_id, server_id, account, peer, resource, \ occupant_id, direction, type, body, timestamp, encrypted \ FROM message \ WHERE account = ? AND peer = ? AND timestamp >= ? AND timestamp <= ? \ ORDER BY timestamp ASC LIMIT ? OFFSET ?" (list account peer st et lim off)))) (mapcar #'jabber-db--raw-row-to-plist rows)))) (defun jabber-db-search (account query &optional peer limit) "Full-text search for QUERY in messages on ACCOUNT. Optional PEER restricts to a specific contact. LIMIT defaults to 50. Returns matching messages as plists." (when-let* ((db (jabber-db-ensure-open))) (let* ((lim (or limit 50)) (rows (if peer (sqlite-select db "SELECT m.id, m.stanza_id, m.server_id, m.account, \ m.peer, m.resource, m.occupant_id, m.direction, m.type, m.body, m.timestamp, \ m.encrypted \ FROM message m \ JOIN message_fts f ON f.rowid = m.id \ WHERE f.body MATCH ? AND m.account = ? AND m.peer = ? \ ORDER BY m.timestamp DESC LIMIT ?" (list query account peer lim)) (sqlite-select db "SELECT m.id, m.stanza_id, m.server_id, m.account, \ m.peer, m.resource, m.occupant_id, m.direction, m.type, m.body, m.timestamp, \ m.encrypted \ FROM message m \ JOIN message_fts f ON f.rowid = m.id \ WHERE f.body MATCH ? AND m.account = ? \ ORDER BY m.timestamp DESC LIMIT ?" (list query account lim))))) (mapcar #'jabber-db--raw-row-to-plist rows)))) (defun jabber-db-last-timestamp (account peer) "Return the latest stored timestamp for PEER on ACCOUNT. Returns a unix epoch integer, or nil if no messages exist." (when-let* ((db (jabber-db-ensure-open))) (caar (sqlite-select db "SELECT MAX(timestamp) FROM message \ WHERE account = ? AND peer = ?" (list account peer))))) (defun jabber-db-last-server-id (account &optional peer) "Return the most recent server_id for ACCOUNT, or nil. This is the XEP-0359 stanza-id assigned by the server, used as the sync point for MAM catch-up queries. When PEER is non-nil, scope to messages with that peer (for MUC MAM)." (when-let* ((db (jabber-db-ensure-open))) (if peer (caar (sqlite-select db "SELECT server_id FROM message \ WHERE account = ? AND peer = ? AND server_id IS NOT NULL \ ORDER BY id DESC LIMIT 1" (list account peer))) (caar (sqlite-select db "SELECT server_id FROM message \ WHERE account = ? AND server_id IS NOT NULL \ ORDER BY id DESC LIMIT 1" (list account)))))) ;;; Message chain handlers (defun jabber-db--extract-occupant-id (xml-data) "Extract XEP-0421 occupant-id from XML-DATA, or nil." (jabber-xml-get-attribute (jabber-xml-child-with-xmlns xml-data "urn:xmpp:occupant-id:0") 'id)) (defun jabber-db--extract-oob-entries (xml-data) "Extract all jabber:x:oob entries from XML-DATA. Returns a list of (URL . DESC) cons cells, or nil." (let (entries) (dolist (child (jabber-xml-node-children xml-data)) (when (and (listp child) (string= (jabber-xml-get-attribute child 'xmlns) jabber-oob-xmlns)) (let ((url (car (jabber-xml-node-children (car (jabber-xml-get-children child 'url))))) (desc (car (jabber-xml-node-children (car (jabber-xml-get-children child 'desc)))))) (when url (push (cons url desc) entries))))) (nreverse entries))) (defun jabber-db--message-handler (jc xml-data) "Store incoming message in the database. JC is the Jabber connection. XML-DATA is the parsed stanza." (unless (or (null (jabber-xml-get-attribute xml-data 'from)) (run-hook-with-args-until-success 'jabber-history-inhibit-received-message-functions jc xml-data)) (let* ((from (jabber-xml-get-attribute xml-data 'from)) (body (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'body))))) (timestamp (jabber-message-timestamp xml-data)) (type (jabber-xml-get-attribute xml-data 'type)) (stanza-id (jabber-xml-get-attribute xml-data 'id)) (server-id (when-let* ((sid-el (jabber-xml-child-with-xmlns xml-data "urn:xmpp:sid:0")) (by (jabber-xml-get-attribute sid-el 'by)) ;; Trust stanza-id from our bare JID (1:1) ;; or from a room we've joined (MUC). ((or (string= by (jabber-connection-bare-jid jc)) (and (string= type "groupchat") (jabber-muc-joined-p (jabber-jid-user from)))))) (jabber-xml-get-attribute sid-el 'id))) (oob-entries (jabber-db--extract-oob-entries xml-data)) (encrypted (jabber-xml-encrypted-p xml-data))) (when (and from body) (jabber-db-store-message (jabber-connection-bare-jid jc) (jabber-jid-user from) "in" (or type "chat") body (floor (float-time (or timestamp (current-time)))) (jabber-jid-resource from) stanza-id server-id (jabber-db--extract-occupant-id xml-data) oob-entries encrypted))))) (defun jabber-db--outgoing-handler (body id) "Store outgoing chat message in the database. BODY is the message text. ID is the stanza id for dedup. Called from `jabber-chat-send-hooks'." (when (and jabber-chatting-with jabber-buffer-connection) (jabber-db-store-message (jabber-connection-bare-jid jabber-buffer-connection) (jabber-jid-user jabber-chatting-with) "out" "chat" body (floor (float-time)) (when (jabber-muc-sender-p jabber-chatting-with) (jabber-jid-resource jabber-chatting-with)) id nil nil nil (memq jabber-chat-encryption '(omemo openpgp openpgp-legacy)))) nil) (defun jabber-db--store-outgoing (jc to body type) "Store an outgoing message sent via `jabber-send-message'. JC is the connection, TO is the recipient JID, BODY is the text, TYPE is the message type." (when (and body (not (string= type "groupchat"))) (jabber-db-store-message (jabber-connection-bare-jid jc) (jabber-jid-user to) "out" (or type "chat") body (floor (float-time))))) ;;; History import ;; ;; One-time migration from the legacy flat-file history format ;; (formerly in jabber-history.el) into the SQLite database. (defcustom jabber-history-dir (locate-user-emacs-file "jabber-history" ".emacs-jabber") "Base directory where per-contact history files are stored. Used only when `jabber-use-global-history' is nil." :type 'directory) (defcustom jabber-global-history-filename (locate-user-emacs-file "jabber-global-message-log" ".jabber_global_message_log") "Global file where all messages are logged. Used when `jabber-use-global-history' is non-nil." :type 'file) (defcustom jabber-use-global-history (file-exists-p jabber-global-history-filename) "Whether to use a global file for message history. If non-nil, `jabber-global-history-filename' is used, otherwise, messages are stored in per-user files under the `jabber-history-dir' directory." :type 'boolean) (defun jabber-db-import-history (account) "Import message history from flat files into the SQLite database. ACCOUNT is the bare JID to associate with imported messages. Reads from either the global history file or per-user history files, depending on the value of `jabber-use-global-history'." (interactive (list (read-string "Account JID: "))) (jabber-db-ensure-open) (let ((files (if jabber-use-global-history (when (file-readable-p jabber-global-history-filename) (list jabber-global-history-filename)) (when (file-directory-p jabber-history-dir) (directory-files jabber-history-dir t "^[^.]")))) (count 0)) (unless files (user-error "No history files found")) (let ((progress (make-progress-reporter "Importing history..." 0 (length files))) (file-idx 0)) (jabber-db-with-transaction (dolist (file files) (when (file-readable-p file) (with-temp-buffer (let ((coding-system-for-read 'utf-8)) (insert-file-contents file)) (goto-char (point-min)) (while (not (eobp)) (condition-case nil (let* ((entry (read (current-buffer))) (time-str (aref entry 0)) (direction (aref entry 1)) (from (aref entry 2)) (to (aref entry 3)) (body (aref entry 4)) (peer (jabber-jid-user (if (string= from "me") to from))) (timestamp (floor (float-time (jabber-parse-time time-str))))) (jabber-db-store-message account peer direction "chat" body timestamp) (cl-incf count)) (error (forward-line 1)))))) (cl-incf file-idx) (progress-reporter-update progress file-idx))) (progress-reporter-done progress)) (message "Imported %d messages into database" count))) ;;; Lifecycle hooks (defun jabber-db--on-connect (_jc) "Open the database on connect." (jabber-db-ensure-open)) (defun jabber-db--on-disconnect () "Close the database on disconnect." (jabber-db-close)) ;;; Registration (with-eval-after-load "jabber-core" (jabber-chain-add 'jabber-message-chain #'jabber-db--message-handler 90)) (add-hook 'jabber-chat-send-hooks #'jabber-db--outgoing-handler) (add-hook 'jabber-post-connect-hooks #'jabber-db--on-connect) (add-hook 'jabber-pre-disconnect-hook #'jabber-db--on-disconnect) (add-hook 'kill-emacs-hook #'jabber-db-close) (provide 'jabber-db) ;;; jabber-db.el ends here emacs-jabber/lisp/jabber-disco.el000066400000000000000000000736561516610113500172260ustar00rootroot00000000000000;;; jabber-disco.el --- service discovery functions -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; Jabber discovery module, handles service discovery functions. ;;; Code: (require 'jabber-iq) (require 'jabber-xml) (require 'jabber-menu) ;; Global reference declarations (declare-function jabber-chain-add "jabber-core" (chain-var handler &optional depth)) (declare-function jabber-db-caps-store "jabber-db.el" (hash ver identities features)) (declare-function jabber-db-caps-lookup "jabber-db.el" (hash ver)) (defvar jabber-presence-chain) ; jabber-core.el (defvar jabber-connections) ; jabber-core.el (defvar jabber-xdata-xmlns) ; jabber-xml.el (defconst jabber-disco-xmlns-info "http://jabber.org/protocol/disco#info" "XEP-0030 Service Discovery info namespace.") (defconst jabber-disco-xmlns-items "http://jabber.org/protocol/disco#items" "XEP-0030 Service Discovery items namespace.") (defconst jabber-caps-xmlns "http://jabber.org/protocol/caps" "XEP-0115 Entity Capabilities namespace.") ;; ;;; Respond to disco requests (with-eval-after-load "jabber-core" (jabber-chain-add 'jabber-presence-chain #'jabber-process-caps 10)) (defvar jabber-caps-cache (make-hash-table :test 'equal)) (defconst jabber-caps-hash-names '(("sha-1" . sha1) ("sha-224" . sha224) ("sha-256" . sha256) ("sha-384" . sha384) ("sha-512" . sha512)) "Hash function name map. Maps names defined in http://www.iana.org/assignments/hash-function-text-names to symbols accepted by `secure-hash'. XEP-0115 currently recommends SHA-1, but let's be future-proof.") ;; Keys are ("jid" . "node"), where "node" is nil if appropriate. ;; Values are (identities features), where each identity is ["name" ;; "category" "type"], and each feature is a string. (defvar jabber-disco-info-cache (make-hash-table :test 'equal)) ;; Keys are ("jid" . "node"). Values are (items), where each ;; item is ["name" "jid" "node"] (some values may be nil). (defvar jabber-disco-items-cache (make-hash-table :test 'equal)) (defvar jabber-advertised-features (list jabber-disco-xmlns-info jabber-disco-xmlns-items jabber-caps-xmlns) "Features advertised on service discovery requests. Don't add your feature to this list directly. Instead, call `jabber-disco-advertise-feature'.") (defvar jabber-disco-items-nodes (list (list "" nil nil)) "Alist of node names and information about returning disco item data. Key is node name as a string, or \"\" for no node specified. Value is a list of two items. First item is data to return. If it is a function, that function is called and its return value is used; if it is a list, that list is used. The list should be the XML data to be returned inside the element, like this: \((item ((name . \"Name of first item\") (jid . \"first.item\") (node . \"node\")))) Second item is access control function. That function is passed the JID, and returns non-nil if access is granted. If the second item is nil, access is always granted.") (defvar jabber-disco-info-nodes (list (list "" #'jabber-disco-return-client-info nil)) "Alist of node names and information returning disco info data. Key is node name as a string, or \"\" for no node specified. Value is a list of two items. First item is data to return. If it is a function, that function is called and its return value is used; if it is a list, that list is used. The list should be the XML data to be returned inside the element, like this: \((identity ((category . \"client\") (type . \"pc\") (name . \"Jabber client\"))) (feature ((var . \"some-feature\")))) Second item is access control function. That function is passed the JID, and returns non-nil if access is granted. If the second item is nil, access is always granted.") ;; Global reference declarations (declare-function jabber-send-current-presence "jabber-presence.el" (&optional jc)) (declare-function jabber-widget-xdata-formtype "jabber-widget.el" (x)) (defvar jabber-presence-element-functions) ; jabber-presence.el ;; (add-to-list 'jabber-iq-get-xmlns-alist (cons jabber-disco-xmlns-info 'jabber-return-disco-info)) (add-to-list 'jabber-iq-get-xmlns-alist (cons jabber-disco-xmlns-items 'jabber-return-disco-info)) (defun jabber-caps-get-cached (jid) "Get disco info from Entity Capabilities cache. JID should be a string containing a full JID. Return (IDENTITIES FEATURES), or nil if not in cache." (let* ((symbol (jabber-jid-symbol jid)) (resource (or (jabber-jid-resource jid) "")) (resource-plist (cdr (assoc resource (get symbol 'resources)))) (key (plist-get resource-plist 'caps))) (when key (let ((cache-entry (gethash key jabber-caps-cache))) (when (and (consp cache-entry) (not (floatp (car cache-entry)))) cache-entry))))) ;;;###autoload (defun jabber-process-caps (jc xml-data) "Look for entity capabilities in presence stanzas. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((from (jabber-xml-get-attribute xml-data 'from)) (type (jabber-xml-get-attribute xml-data 'type)) (c (jabber-xml-path xml-data `((,jabber-caps-xmlns . "c"))))) (when (and (null type) c) (jabber-xml-let-attributes (_ext hash node ver) c (cond (hash ;; If the element has a hash attribute, it follows the ;; "modern" version of XEP-0115. (jabber-process-caps-modern jc from hash node ver)) (t ;; No hash attribute. Use legacy version of XEP-0115. ;; TODO: do something clever here. )))))) (defun jabber-caps--store-hash (jid key) "Store caps hash KEY in the resource plist for JID. KEY is a cons cell (HASH . VER) identifying the entity capabilities. JID is a full JID string; the resource portion is used as the key in the symbol's `resources' property." (let* ((symbol (jabber-jid-symbol jid)) (resource (or (jabber-jid-resource jid) "")) (resource-entry (assoc resource (get symbol 'resources))) (new-resource-plist (plist-put (cdr resource-entry) 'caps key))) (if resource-entry (setf (cdr resource-entry) new-resource-plist) (push (cons resource new-resource-plist) (get symbol 'resources))))) (defun jabber-caps--query-if-needed (jc jid hash node ver key cache-entry) "Decide whether to send a disco#info query for entity capabilities. JC is the Jabber connection. JID is the full JID of the entity. HASH, NODE, and VER are the XEP-0115 capability fields. KEY is (HASH . VER), the cache key. CACHE-ENTRY is the current value in `jabber-caps-cache' for KEY. When CACHE-ENTRY is a pending query (timestamp float), either add JID to the fallback list or re-query if the timeout (10s) has elapsed. When CACHE-ENTRY is nil, record a pending query and send a disco#info request. Otherwise, copy the cached capabilities into `jabber-disco-info-cache' for JID." (cl-flet ((request-disco-info () (jabber-send-iq jc jid "get" `(query ((xmlns . ,jabber-disco-xmlns-info) (node . ,(concat node "#" ver)))) #'jabber-process-caps-info-result (list hash node ver) #'jabber-process-caps-info-error (list hash node ver)))) (cond ((and (consp cache-entry) (floatp (car cache-entry))) ;; We have a record of asking someone about this hash. (if (< (- (float-time) (car cache-entry)) 10.0) ;; We asked someone about this hash less than 10 seconds ago. ;; Let's add the new JID to the entry, just in case that ;; doesn't work out. (cl-pushnew jid (cdr cache-entry) :test #'string=) ;; We asked someone about it more than 10 seconds ago. ;; They're probably not going to answer. Let's ask ;; this contact about it instead. (setf (car cache-entry) (float-time)) (request-disco-info))) ((null cache-entry) ;; Check persistent storage before querying the network. (let ((db-entry (jabber-db-caps-lookup hash ver))) (if db-entry (progn (puthash key db-entry jabber-caps-cache) (puthash (cons jid nil) db-entry jabber-disco-info-cache)) (puthash key (list (float-time)) jabber-caps-cache) (request-disco-info)))) (t ;; We already know what this hash represents, so we ;; can cache info for this contact. (puthash (cons jid nil) cache-entry jabber-disco-info-cache))))) (defun jabber-process-caps-modern (jc jid hash node ver) "Processes the capabilities of a contact which supports XEP-0115 v1.5 or later. JC is the jabber connection of the sender, JID is the Jabber ID of the entity sending the capabilities information. HASH is the generated hash representing the sender's capabilities. NODE is the namespace of the format. and VER is the entity's version number." (when (assoc hash jabber-caps-hash-names) ;; We support the hash function used. (let* ((key (cons hash ver)) (cache-entry (gethash key jabber-caps-cache))) (jabber-caps--store-hash jid key) (jabber-caps--query-if-needed jc jid hash node ver key cache-entry)))) (defun jabber-process-caps-info-result (jc xml-data closure-data) "Process the result of a jabber server's caps info request. JC is the jabber connection. XML-DATA is the XML data received from the server. CLOSURE-DATA is in the format of (HASH NODE VER), where HASH is the verification hash received from the server. NODE represents the software identification, and VER is the software version. If the verification string matches with VER, the software's discovery /disco/ information will be stored in the jabber-caps-cache, otherwise, it will try the next available option." (pcase-let* ((`(,hash ,node ,ver) closure-data) (key (cons hash ver)) (query (jabber-iq-query xml-data)) (verification-string (jabber-caps-ver-string query hash))) (if (string= ver verification-string) ;; The hash is correct; save info. (let ((info (jabber-disco-parse-info xml-data))) (puthash key info jabber-caps-cache) (jabber-db-caps-store hash ver (car info) (cadr info))) ;; The hash is incorrect. (jabber-caps-try-next jc hash node ver)))) (defun jabber-process-caps-info-error (jc _xml-data closure-data) "Process error in caps info for Jabber. JC is the Jabber connection. CLOSURE-DATA is a list of three parameters: hash, node, and version. This function makes another attempt to process the caps info when an error occurs." (pcase-let ((`(,hash ,node ,ver) closure-data)) (jabber-caps-try-next jc hash node ver))) (defun jabber-caps-try-next (jc hash node ver) "Try the next JID for a cached entry in Jabber CAPS Cache. JC is the Jabber connection. HASH is the hash value of the CAPS. NODE is the node identifier in the XEP-0115 specification. VER is the version string of the CAPS." (let* ((key (cons hash ver)) (cache-entry (gethash key jabber-caps-cache))) (when (floatp (car-safe cache-entry)) (let ((next-jid (pop (cdr cache-entry)))) ;; Do we know someone else we could ask about this hash? (if next-jid (progn (setf (car cache-entry) (float-time)) (jabber-send-iq jc next-jid "get" `(query ((xmlns . ,jabber-disco-xmlns-info) (node . ,(concat node "#" ver)))) #'jabber-process-caps-info-result (list hash node ver) #'jabber-process-caps-info-error (list hash node ver))) ;; No, forget about it for now. (remhash key jabber-caps-cache)))))) (defun jabber-caps--identity-string (identities) "Build the identity portion of a caps verification string. IDENTITIES is a list of XML nodes. Return the concatenated sorted identity entries." (mapconcat (lambda (identity) (jabber-xml-let-attributes (category type xml:lang name) identity (concat category "/" type "/" xml:lang "/" name "<"))) (sort identities #'jabber-caps-identity-<))) (defun jabber-caps--feature-string (features) "Build the feature portion of a caps verification string. FEATURES is a list of feature var strings. Return the concatenated sorted feature entries." (mapconcat (lambda (f) (concat f "<")) (sort features #'string<))) (defun jabber-caps--form-string (forms) "Build the XEP-0128 data form portion of a caps verification string. FORMS is a list of XML nodes (already filtered for FORM_TYPE). Return the concatenated sorted form entries." (let ((sorted (sort forms (lambda (a b) (string< (jabber-widget-xdata-formtype a) (jabber-widget-xdata-formtype b)))))) (mapconcat (lambda (form) (let ((fields (sort (jabber-xml-get-children form 'field) (lambda (a b) (string< (jabber-xml-get-attribute a 'var) (jabber-xml-get-attribute b 'var)))))) (concat (jabber-widget-xdata-formtype form) "<" (mapconcat (lambda (field) (if (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE") "" (let ((values (sort (mapcar (lambda (v) (car (jabber-xml-node-children v))) (jabber-xml-get-children field 'value)) #'string<))) (concat (jabber-xml-get-attribute field 'var) "<" (mapconcat (lambda (v) (concat (or v "") "<")) values))))) fields)))) sorted))) (defun jabber-caps-ver-string (query hash) "Create an XEP-0115 version string for a QUERY node with a specified HASH." ;; XEP-0115, section 5.1 (let* ((identities (jabber-xml-get-children query 'identity)) (features (mapcar (lambda (f) (jabber-xml-get-attribute f 'var)) (jabber-xml-get-children query 'feature))) (forms (cl-remove-if-not (lambda (x) (and (string= (jabber-xml-get-xmlns x) jabber-xdata-xmlns) (jabber-widget-xdata-formtype x))) (jabber-xml-get-children query 'x))) (s (encode-coding-string (concat (jabber-caps--identity-string identities) (jabber-caps--feature-string features) (jabber-caps--form-string forms)) 'utf-8 t)) (algorithm (cdr (assoc hash jabber-caps-hash-names)))) (base64-encode-string (jabber-caps--secure-hash algorithm s) t))) (defun jabber-caps--secure-hash (algorithm string) "Compute and return a secure hash from STRING using ALGORITHM." (secure-hash algorithm string nil nil t)) (defun jabber-caps-identity-< (a b) "Compare two Jabber identity XML elements A and B, return t if A < B." (let ((a-category (jabber-xml-get-attribute a 'category)) (b-category (jabber-xml-get-attribute b 'category))) (or (string< a-category b-category) (and (string= a-category b-category) (let ((a-type (jabber-xml-get-attribute a 'type)) (b-type (jabber-xml-get-attribute b 'type))) (or (string< a-type b-type) (and (string= a-type b-type) (let ((a-xml:lang (jabber-xml-get-attribute a 'xml:lang)) (b-xml:lang (jabber-xml-get-attribute b 'xml:lang))) (string< a-xml:lang b-xml:lang))))))))) (defvar jabber-caps-default-hash-function "sha-1" "Hash function to use when sending caps in presence stanzas. The value should be a key in `jabber-caps-hash-names'.") (defvar jabber-caps-current-hash nil "The current disco hash we're sending out in presence stanzas.") (defconst jabber-caps-node "http://emacs-jabber.sourceforge.net") ;;;###autoload (defun jabber-disco-advertise-feature (feature) "Add a new FEATURE to `jabber-advertised-features', if not already present." (unless (member feature jabber-advertised-features) (push feature jabber-advertised-features) (when jabber-caps-current-hash (jabber-caps-recalculate-hash) ;; If we're already connected, we need to send updated presence ;; for the new feature. (mapc #'jabber-send-current-presence jabber-connections)))) (defun jabber-caps-recalculate-hash () "Update `jabber-caps-current-hash' for feature list change. Also update `jabber-disco-info-nodes', so we return results for the right node." (let* ((old-hash jabber-caps-current-hash) (old-node (and old-hash (concat jabber-caps-node "#" old-hash))) (new-hash (jabber-caps-ver-string `(query () ,@(jabber-disco-return-client-info)) jabber-caps-default-hash-function)) (new-node (concat jabber-caps-node "#" new-hash))) (when old-node (let ((old-entry (assoc old-node jabber-disco-info-nodes))) (when old-entry (setq jabber-disco-info-nodes (delq old-entry jabber-disco-info-nodes))))) (push (list new-node #'jabber-disco-return-client-info nil) jabber-disco-info-nodes) (setq jabber-caps-current-hash new-hash))) ;;;###autoload (defun jabber-caps-presence-element (_jc) "Generate XML presence element using `jabber-caps-current-hash' and _JC param." (unless jabber-caps-current-hash (jabber-caps-recalculate-hash)) (list `(c ((xmlns . ,jabber-caps-xmlns) (hash . ,jabber-caps-default-hash-function) (node . ,jabber-caps-node) (ver . ,jabber-caps-current-hash))))) ;;;###autoload (with-eval-after-load "jabber-presence" (add-to-list 'jabber-presence-element-functions #'jabber-caps-presence-element)) (defun jabber-return-disco-info (jc xml-data) "Respond to a service discovery request. See XEP-0030. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((to (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id)) (xmlns (jabber-iq-xmlns xml-data)) (which-alist (cond ((string= xmlns jabber-disco-xmlns-info) jabber-disco-info-nodes) ((string= xmlns jabber-disco-xmlns-items) jabber-disco-items-nodes))) (node (or (jabber-xml-get-attribute (jabber-iq-query xml-data) 'node) "")) (return-list (cdr (assoc node which-alist))) (func (nth 0 return-list)) (access-control (nth 1 return-list))) (if return-list (if (and (functionp access-control) (not (funcall access-control jc to))) (jabber-signal-error "Cancel" 'not-allowed) ;; Access control passed (let ((result (if (functionp func) (funcall func jc xml-data) func))) (jabber-send-iq jc to "result" `(query ((xmlns . ,xmlns) ,@(when node (list (cons 'node node)))) ,@result) nil nil nil nil id))) ;; No such node (jabber-signal-error "Cancel" 'item-not-found)))) (defun jabber-disco-return-client-info (&optional _jc _xml-data) "Return a Jabber Disco information according to the client env. Generate a list which represents the identity and features supported by the Emacs Jabber client. The type of the client is decided based on the window system. If Emacs is running under a window system (x, w32, mac, ns), the type is classified as pc, otherwise console." `( ;; If running under a window system, this is ;; a GUI client. If not, it is a console client. (identity ((category . "client") (name . "Emacs Jabber client") (type . ,(if (memq window-system '(x w32 mac ns)) "pc" "console")))) ,@(mapcar #'(lambda (featurename) `(feature ((var . ,featurename)))) jabber-advertised-features))) (defun jabber-get-disco-items (jc to &optional node) "Send a service discovery request for items. JC, the Jabber connection, is typically required to be active. TO is the JID (Jabber ID) of the entity to request items from. NODE is an optional parameter specifying a particular node to request items for." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Send items disco request to: " nil nil nil 'full t) (jabber-read-node "Node (or leave empty): "))) (jabber-send-iq jc to "get" (list 'query (append (list (cons 'xmlns jabber-disco-xmlns-items)) (if (> (length node) 0) (list (cons 'node node))))) #'jabber-process-data #'jabber-process-disco-items #'jabber-process-data "Item discovery failed")) (defun jabber-get-disco-info (jc to &optional node) "Send a service discovery request for info. JC is the Jabber connection. TO is the JID (Jabber ID) of the entity to request items from. NODE is an optional parameter specifying a particular node to request items for." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Send info disco request to: " nil nil nil 'full t) (jabber-read-node "Node (or leave empty): "))) (jabber-send-iq jc to "get" (list 'query (append (list (cons 'xmlns jabber-disco-xmlns-info)) (if (> (length node) 0) (list (cons 'node node))))) #'jabber-process-data #'jabber-process-disco-info #'jabber-process-data "Info discovery failed")) (defun jabber-process-disco-info (jc xml-data) "Handle results from info disco requests. Return a formatted string with identities and features." (let ((result (with-temp-buffer (dolist (x (jabber-xml-node-children (jabber-iq-query xml-data))) (cond ((eq (jabber-xml-node-name x) 'identity) (let ((name (jabber-xml-get-attribute x 'name)) (category (jabber-xml-get-attribute x 'category)) (type (jabber-xml-get-attribute x 'type))) (insert (propertize (or name (concat category (when type (concat " (" type ")")))) 'face 'jabber-title) "\n\n") (when type (insert "Type:\t\t" type "\n")) (insert "\n"))) ((eq (jabber-xml-node-name x) 'feature) (let ((var (jabber-xml-get-attribute x 'var))) (insert "Feature:\t" var "\n"))))) (buffer-string)))) (when (length> result 0) (put-text-property 0 (length result) 'jabber-jid (jabber-xml-get-attribute xml-data 'from) result) (put-text-property 0 (length result) 'jabber-account jc result) result))) (defun jabber-process-disco-items (jc xml-data) "Handle results from items disco requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((items (jabber-xml-get-children (jabber-iq-query xml-data) 'item))) (if items (dolist (item items) (let ((jid (jabber-xml-get-attribute item 'jid)) (name (jabber-xml-get-attribute item 'name)) (node (jabber-xml-get-attribute item 'node))) (insert (propertize (concat (propertize (concat jid "\n" (if node (format "Node: %s\n" node))) 'face 'jabber-title) name "\n\n") 'jabber-jid jid 'jabber-account jc 'jabber-node node)))) (insert "No items found.\n")))) (defun jabber-disco-get-info (jc jid node callback closure-data &optional force) "Get disco info for JID and NODE, using connection JC. Call CALLBACK with JC and CLOSURE-DATA as first and second arguments and result as third argument when result is available. On success, result is (IDENTITIES FEATURES), where each identity is [\"name\" \"category\" \"type\"], and each feature is a string. On error, result is the error node, recognizable by (eq (car result) \\='error). If CALLBACK is nil, just fetch data. If FORCE is non-nil, invalidate cache and get fresh data." (when force (remhash (cons jid node) jabber-disco-info-cache)) (let ((result (unless force (jabber-disco-get-info-immediately jid node)))) (if result (and callback (run-with-timer 0 nil callback jc closure-data result)) (jabber-send-iq jc jid "get" `(query ((xmlns . ,jabber-disco-xmlns-info) ,@(when node `((node . ,node))))) #'jabber-disco-got-info (cons callback closure-data) (lambda (jc xml-data callback-data) (when (car callback-data) (funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data)))) (cons callback closure-data))))) (defun jabber-disco-got-info (jc xml-data callback-data) "Process the received jabber-disco info query response. Parse received disco-info from XML-DATA and caches it. If a CALLBACK-DATA function is provided, it's called with the JC, CALLBACK-DATA and RESULT. JC: The jabber connection. XML-DATA: The XML data containing the info query response. CALLBACK-DATA: Optional function to be triggered after processing info query response." (let ((jid (jabber-xml-get-attribute xml-data 'from)) (node (jabber-xml-get-attribute (jabber-iq-query xml-data) 'node)) (result (jabber-disco-parse-info xml-data))) (puthash (cons jid node) result jabber-disco-info-cache) (when (car callback-data) (funcall (car callback-data) jc (cdr callback-data) result)))) (defun jabber-disco-parse-info (xml-data) "Extract data from an stanza containing a disco#info result. See `jabber-disco-get-info' for a description of the return value. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (list (mapcar #'(lambda (id) (vector (jabber-xml-get-attribute id 'name) (jabber-xml-get-attribute id 'category) (jabber-xml-get-attribute id 'type))) (jabber-xml-get-children (jabber-iq-query xml-data) 'identity)) (mapcar #'(lambda (feature) (jabber-xml-get-attribute feature 'var)) (jabber-xml-get-children (jabber-iq-query xml-data) 'feature)))) (defun jabber-disco-get-info-immediately (jid node) "Get cached disco info for JID and NODE. Return nil if no info available. Fill the cache with `jabber-disco-get-info'." (or ;; Check "normal" cache... (gethash (cons jid node) jabber-disco-info-cache) ;; And then check Entity Capabilities. (and (null node) (jabber-caps-get-cached jid)))) (defun jabber-disco-get-items (jc jid node callback closure-data &optional force) "Get disco items for JID and NODE, using connection JC. Call CALLBACK with JC and CLOSURE-DATA as first and second arguments and items result as third argument when result is available. On success, result is a list of items, where each item is [\"name\" \"jid\" \"node\"] (some values may be nil). On error, result is the error node, recognizable by (eq (car result) \='error). If CALLBACK is nil, just fetch data. If FORCE is non-nil, invalidate cache and get fresh data." (when force (remhash (cons jid node) jabber-disco-items-cache)) (let ((result (gethash (cons jid node) jabber-disco-items-cache))) (if result (and callback (run-with-timer 0 nil callback jc closure-data result)) (jabber-send-iq jc jid "get" `(query ((xmlns . ,jabber-disco-xmlns-items) ,@(when node `((node . ,node))))) #'jabber-disco-got-items (cons callback closure-data) (lambda (jc xml-data callback-data) (when (car callback-data) (funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data)))) (cons callback closure-data))))) (defun jabber-disco-got-items (jc xml-data callback-data) "Process received Jabber disco items. Processes the received disco items XML-DATA from the Jabber connection JC & updates the disco items cache. If a callback function is provided in CALLBACK-DATA, it will then be called with JC, the remaining CALLBACK-DATA, and the obtained RESULT." (let ((jid (jabber-xml-get-attribute xml-data 'from)) (node (jabber-xml-get-attribute (jabber-iq-query xml-data) 'node)) (result (mapcar #'(lambda (item) (vector (jabber-xml-get-attribute item 'name) (jabber-xml-get-attribute item 'jid) (jabber-xml-get-attribute item 'node))) (jabber-xml-get-children (jabber-iq-query xml-data) 'item)))) (puthash (cons jid node) result jabber-disco-items-cache) (when (car callback-data) (funcall (car callback-data) jc (cdr callback-data) result)))) (defun jabber-disco-get-items-immediately (jid node) "Retrieve items from `jabber-disco-items-cache' using JID & NODE as key." (gethash (cons jid node) jabber-disco-items-cache)) (defun jabber-disco-publish (jc node item-name item-jid item-node) "Publish the given item under disco node NODE. JC is the Jabber connection." (jabber-send-iq jc nil "set" `(query ((xmlns . ,jabber-disco-xmlns-items) ,@(when node `((node . ,node)))) (item ((action . "update") (jid . ,item-jid) ,@(when item-name `((name . ,item-name))) ,@(when item-node `((node . ,item-node)))))) 'jabber-report-success "Disco publish" 'jabber-report-success "Disco publish")) (defun jabber-disco-publish-remove (jc node item-jid item-node) "Remove the given item from published disco items. JC: Jabber Client connection. NODE: Disco node to remove item from. Can be nil. ITEM-JID: JID (Jabber ID) of the disco item to be removed. ITEM-NODE: Specific node of the disco item to be removed. Can be nil." (jabber-send-iq jc nil "set" `(query ((xmlns . ,jabber-disco-xmlns-items) ,@(when node `((node . ,node)))) (item ((action . "remove") (jid . ,item-jid) ,@(when item-node `((node . ,item-node)))))) 'jabber-report-success "Disco removal" 'jabber-report-success "Disco removal")) (provide 'jabber-disco) ;;; jabber-disco.el ends here. emacs-jabber/lisp/jabber-eme.el000066400000000000000000000031131516610113500166500ustar00rootroot00000000000000;;; jabber-eme.el --- XEP-0380 Explicit Message Encryption -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; XML element builder for XEP-0380 Explicit Message Encryption. ;; Callers splice the returned element into outgoing encrypted stanzas ;; so non-supporting clients can display a meaningful fallback. ;;; Code: (defconst jabber-eme-xmlns "urn:xmpp:eme:0" "XML namespace for XEP-0380 Explicit Message Encryption.") (defun jabber-eme-encryption (namespace &optional name) "Return an element for NAMESPACE. Optional NAME is a human-readable encryption name." `(encryption ((xmlns . ,jabber-eme-xmlns) (namespace . ,namespace) ,@(when name `((name . ,name)))))) (provide 'jabber-eme) ;;; jabber-eme.el ends here emacs-jabber/lisp/jabber-hints.el000066400000000000000000000033751516610113500172410ustar00rootroot00000000000000;;; jabber-hints.el --- XEP-0334 message processing hints -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; XML element builders for XEP-0334 Message Processing Hints. ;; Callers splice these into outgoing stanzas to advise servers ;; and other entities on how to handle messages. ;;; Code: (defconst jabber-hints-xmlns "urn:xmpp:hints" "XML namespace for XEP-0334 Message Processing Hints.") (defun jabber-hints-store () "Return a hint element." `(store ((xmlns . ,jabber-hints-xmlns)))) (defun jabber-hints-no-store () "Return a hint element." `(no-store ((xmlns . ,jabber-hints-xmlns)))) (defun jabber-hints-no-copy () "Return a hint element." `(no-copy ((xmlns . ,jabber-hints-xmlns)))) (defun jabber-hints-no-permanent-store () "Return a hint element." `(no-permanent-store ((xmlns . ,jabber-hints-xmlns)))) (provide 'jabber-hints) ;;; jabber-hints.el ends here emacs-jabber/lisp/jabber-httpupload.el000066400000000000000000000353451516610113500203020ustar00rootroot00000000000000;;; jabber-httpupload.el --- HTTP File Upload (XEP-0363) -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; This file implements XEP-0363: HTTP File Upload, providing a way to ;; send files through XMPP by uploading them to the server's HTTP ;; storage. The procedure is: ;; ;; 1. Discover HTTP Upload support via Disco (urn:xmpp:http:upload:0). ;; 2. Request a slot (PUT + GET URLs) from the upload service. ;; 3. Upload the file to the PUT URL via curl. ;; 4. Send the GET URL to the recipient (with OOB metadata), or copy ;; it to the kill ring. ;; ;; Commands: ;; `jabber-httpupload-send-file' - Upload and send to a contact/MUC. ;; `jabber-httpupload-upload-file' - Upload and copy URL to kill ring. ;;; Code: (require 'fsm) (require 'mailcap) (require 'jabber) (eval-when-compile (require 'cl-lib)) (declare-function jabber-chat-send "jabber-chat.el" (jc body &optional extra-elements)) (declare-function jabber-chat-create-buffer "jabber-chat.el" (jc chat-with)) (declare-function jabber-muc-joined-p "jabber-muc.el" (group &optional jc)) (defvar jabber-oob-xmlns) ; jabber-xml.el (defconst jabber-httpupload-xmlns "urn:xmpp:http:upload:0" "XML namespace for XEP-0363 HTTP File Upload.") (defgroup jabber-httpupload nil "Jabber HTTP Upload Settings." :group 'jabber) (defcustom jabber-httpupload-upload-function #'jabber-httpupload-put-file-curl "Function to upload a file to the HTTP server. Must accept (FILEPATH HEADERS PUT-URL CALLBACK CALLBACK-ARG &optional IGNORE-CERT-PROBLEMS) and call (funcall CALLBACK CALLBACK-ARG) on success. Return non-nil if the upload started." :type 'function) (defvar jabber-httpupload-pre-upload-transform nil "When non-nil, a function to transform a file before upload. Called with (FILEPATH CALLBACK) inside `jabber-httpupload--upload' after HTTP Upload support is confirmed. Must return \(TRANSFORMED-FILEPATH . WRAPPED-CALLBACK) to replace both, or nil to upload the original file unchanged. OMEMO sets this to encrypt the file and wrap the callback to build an aesgcm:// URL from the server's HTTPS get-url.") (defvar jabber-httpupload-send-url-function nil "When non-nil, a function to override URL delivery. Called with (JC JID GET-URL) at the start of `jabber-httpupload--send-url'. If it returns non-nil, the default plaintext+OOB send is skipped. OMEMO sets this to send aesgcm:// URLs as encrypted messages.") ;; Discovering support (defvar jabber-httpupload-support nil "Alist of Jabber connections and the node with HTTP Upload support. Each element is (jabber-connection . upload-iri).") (defun jabber-httpupload-test-all-connections-support () "Test all connections in `jabber-connections' for HTTP Upload support. Store the results in `jabber-httpupload-support'. If the connection was already tested and the test was successful, do not re-test it." (dolist (jc jabber-connections) (unless (jabber-httpupload-server-has-support jc) (jabber-httpupload-test-connection-support jc)))) (defun jabber-httpupload-test-connection-support (jc) "Test if HTTP Upload is supported on the JC connection's server. If supported, store the item IRI in `jabber-httpupload-support'." (jabber-httpupload-apply-to-items jc (lambda (jc result) (jabber-httpupload-test-item-support jc (elt result 1))))) (defun jabber-httpupload-test-item-support (jc iri) "Test if the IRI Disco item supports HTTP Upload. Get the Disco Info from IRI on JC; if the HTTP Upload namespace is present, store the IRI in `jabber-httpupload-support'." (jabber-disco-get-info jc iri nil (lambda (jc _data result) (when (member jabber-httpupload-xmlns (nth 1 result)) (push (cons jc iri) jabber-httpupload-support))) nil)) (defun jabber-httpupload-apply-to-items (jc callback) "Retrieve Disco items from JC's server and call CALLBACK on each. CALLBACK receives two arguments: the Jabber connection and the item vector." (let ((node (plist-get (fsm-get-state-data jc) :server))) (jabber-disco-get-items jc node nil (lambda (jc _data result) (dolist (item result) (funcall callback jc item))) nil))) (defun jabber-httpupload-server-has-support (jc) "Return (JC . upload-iri) if the server supports HTTP Upload, nil otherwise." (assq jc jabber-httpupload-support)) ;; Slot parsing (defun jabber-httpupload--sanitize-header (value) "Strip newline characters from header VALUE per XEP-0363 Section 11." (when value (replace-regexp-in-string "[\r\n]" "" value))) (defun jabber-httpupload-parse-slot-answer (xml-data) "Parse PUT/GET URLs from a slot response XML-DATA. Return ((put-url . ((header-name . header-value) ...)) get-url). Header names are matched case-insensitively and newlines are stripped from both names and values per XEP-0363 Section 11." (let* ((put (jabber-xml-path xml-data '(slot put))) (get (jabber-xml-path xml-data '(slot get))) (put-url (jabber-xml-get-attribute put 'url)) (get-url (jabber-xml-get-attribute get 'url))) (unless (and put-url get-url) (error "HTTP Upload: server returned incomplete slot (put=%s get=%s)" put-url get-url)) (unless (and (string-prefix-p "https://" (downcase put-url)) (string-prefix-p "https://" (downcase get-url))) (error "HTTP Upload: server returned non-HTTPS URL (put=%s get=%s)" put-url get-url)) (list (cons put-url (cl-loop for header in (jabber-xml-get-children put 'header) for raw-name = (jabber-xml-get-attribute header 'name) for name = (jabber-httpupload--sanitize-header raw-name) when (member (downcase name) '("authorization" "cookie" "expires")) for value = (jabber-httpupload--sanitize-header (car (jabber-xml-node-children header))) when value collect (cons name value))) get-url))) ;; Curl upload (defun jabber-httpupload-ignore-certificate (jc) "Return non-nil if JC's server is in `jabber-invalid-certificate-servers'." (member (plist-get (fsm-get-state-data jc) :server) jabber-invalid-certificate-servers)) (defun jabber-httpupload-put-file-curl (filepath headers put-url callback callback-arg &optional ignore-cert-problems) "Upload FILEPATH to PUT-URL via curl with HEADERS. When done, call (funcall CALLBACK CALLBACK-ARG). IGNORE-CERT-PROBLEMS allows connecting to servers with invalid certificates. Return the process on success, nil if curl is not found." (when-let* ((curl-path (executable-find "curl"))) (let ((buffer (get-buffer-create "*jabber-httpupload-curl*")) (command `("--fail" "--upload-file" ,filepath ,@(cl-loop for (name . value) in headers append (list "-H" (format "%s: %s" name value))) ,put-url))) (when ignore-cert-problems (push "--insecure" command)) (push curl-path command) (with-current-buffer buffer (let ((inhibit-read-only t)) (goto-char (point-max)) (insert (format "%s Uploading with curl:\n%S\n" (current-time-string) command)))) (make-process :name "jabber-httpupload-curl" :buffer buffer :command command :sentinel (lambda (process event) (when (buffer-live-p (process-buffer process)) (with-current-buffer (process-buffer process) (let ((inhibit-read-only t)) (goto-char (point-max)) (insert (format "Sentinel: %S\n" event))))) (if (string= event "finished\n") (funcall callback callback-arg) (message "HTTP Upload failed: %s" (string-trim event)))))))) ;; Core upload pipeline (defun jabber-httpupload--discover-and-upload (jc filepath callback) "Discover HTTP Upload support for JC, then upload FILEPATH. On success, call (funcall CALLBACK get-url). Error if the server does not support HTTP Upload." (message "Discovering HTTP Upload support...") (let ((done nil)) (jabber-httpupload-apply-to-items jc (lambda (jc item) (let ((iri (elt item 1))) (jabber-disco-get-info jc iri nil (lambda (jc _data result) (when (and (not done) (member jabber-httpupload-xmlns (nth 1 result))) (setq done t) (unless (assq jc jabber-httpupload-support) (push (cons jc iri) jabber-httpupload-support)) (jabber-httpupload--upload jc filepath callback))) nil)))))) (defun jabber-httpupload--upload (jc filepath callback) "Upload FILEPATH via HTTP Upload on JC. On success, call (funcall CALLBACK get-url). If support has not been discovered yet, discover it first." (if (not (jabber-httpupload-server-has-support jc)) (jabber-httpupload--discover-and-upload jc filepath callback) (let* ((transform (and jabber-httpupload-pre-upload-transform (funcall jabber-httpupload-pre-upload-transform filepath callback))) (filepath (expand-file-name (if transform (car transform) filepath))) (callback (if transform (cdr transform) callback)) (size (file-attribute-size (file-attributes filepath))) (content-type (or (and-let* ((ext (file-name-extension filepath))) (mailcap-extension-to-mime ext)) "application/octet-stream")) (filename (file-name-nondirectory filepath))) (jabber-send-iq jc (cdr (jabber-httpupload-server-has-support jc)) "get" `(request ((xmlns . ,jabber-httpupload-xmlns) (filename . ,filename) (size . ,size) (content-type . ,content-type))) (lambda (_jc xml-data _data) (let* ((urls (jabber-httpupload-parse-slot-answer xml-data)) (get-url (cadr urls)) (put-url (caar urls)) (headers (cdar urls))) (push (cons "content-length" size) headers) (push (cons "content-type" content-type) headers) (unless (funcall jabber-httpupload-upload-function filepath headers put-url callback get-url (jabber-httpupload-ignore-certificate jc)) (error "Upload function failed to PUT %s" filename)))) nil (lambda (_jc xml-data _data) (error "HTTP Upload slot rejected for %s: %S" filename xml-data)) nil)))) ;; Pending OOB for deferred sends (C-c C-a in chat buffers) (defvar-local jabber-httpupload--pending-url nil "URL from a pending upload, awaiting send.") (defun jabber-httpupload--send-hook (body _id) "Attach OOB element if BODY contains a pending upload URL. Returns the OOB element list for `jabber-chat-send-hooks', and clears the pending state. If the URL is no longer in BODY (user deleted it), the pending state is cleared with no effect." (when-let* ((url jabber-httpupload--pending-url)) (setq jabber-httpupload--pending-url nil) (when (string-match-p (regexp-quote url) body) (list `(x ((xmlns . ,jabber-oob-xmlns)) (url () ,url)))))) (add-hook 'jabber-chat-send-hooks #'jabber-httpupload--send-hook) ;; Sending the URL (defun jabber-httpupload--send-url (jc jid get-url) "Send GET-URL to JID with OOB metadata. For groupchat, send directly. For 1:1, use `jabber-chat-send'. If `jabber-httpupload-send-url-function' is set and handles the URL, skip the default plaintext send." (unless (and jabber-httpupload-send-url-function (funcall jabber-httpupload-send-url-function jc jid get-url)) (if (jabber-muc-joined-p jid) (jabber-send-sexp jc `(message ((to . ,jid) (type . "groupchat")) (body () ,get-url) (x ((xmlns . ,jabber-oob-xmlns)) (url () ,get-url)))) (with-current-buffer (jabber-chat-create-buffer jc jid) (jabber-chat-send jc get-url (list `(x ((xmlns . ,jabber-oob-xmlns)) (url () ,get-url)))))))) ;; Interactive commands ;;;###autoload (defun jabber-httpupload-send-file (jc jid filepath) "Upload FILEPATH and send the URL to JID via JC." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Send file to: " nil nil nil 'full t) (read-file-name "File to send: "))) (jabber-httpupload--upload jc filepath (lambda (get-url) (jabber-httpupload--send-url jc jid get-url)))) ;;;###autoload (defun jabber-httpupload-upload-file (jc filepath) "Upload FILEPATH and copy the URL to the kill ring." (interactive (list (jabber-read-account) (read-file-name "File to upload: "))) (jabber-httpupload--upload jc filepath (lambda (get-url) (kill-new get-url) (message "Uploaded: %s (copied to kill ring)" get-url)))) (add-hook 'jabber-post-connect-hooks #'jabber-httpupload-test-connection-support) (provide 'jabber-httpupload) ;;; jabber-httpupload.el ends here emacs-jabber/lisp/jabber-image.el000066400000000000000000000140241516610113500171670ustar00rootroot00000000000000;;; jabber-image.el --- image display support -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Author: Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; Shared image creation and async fetching for avatars and inline ;; previews. All images use dynamic sizing via `image-property' ;; with :max-width/:max-height instead of ImageMagick scaling. ;;; Code: (require 'mm-decode) (require 'url-queue) (require 'url-parse) (defgroup jabber-image nil "Image display settings." :group 'jabber) (defcustom jabber-image-max-width 300 "Maximum width in pixels for inline images." :type 'integer) (defcustom jabber-image-max-height 300 "Maximum height in pixels for inline images." :type 'integer) (defun jabber-image--mime-to-type (mime-type) "Return an image type symbol for MIME-TYPE string, or nil." (when mime-type (pcase mime-type ("image/png" 'png) ("image/jpeg" 'jpeg) ("image/gif" 'gif) ("image/webp" 'webp) ("image/svg+xml" 'svg) ("image/bmp" 'bmp) ("image/x-xbitmap" 'xbm) ("image/x-xpixmap" 'xpm) ("image/tiff" 'tiff) (_ nil)))) (defun jabber-image-create (data &optional mime-type max-width max-height) "Create a dynamically-sized image from raw DATA string. MIME-TYPE is a MIME type string like \"image/png\"; if nil Emacs auto-detects the type. MAX-WIDTH and MAX-HEIGHT default to `jabber-image-max-width' and `jabber-image-max-height'." (let ((image (create-image data (jabber-image--mime-to-type mime-type) t))) (setf (image-property image :max-width) (or max-width jabber-image-max-width)) (setf (image-property image :max-height) (or max-height jabber-image-max-height)) image)) (defun jabber-image-create-from-file (file &optional max-width max-height) "Create a dynamically-sized image from FILE path. MAX-WIDTH and MAX-HEIGHT default to `jabber-image-max-width' and `jabber-image-max-height'." (let ((image (create-image file))) (setf (image-property image :max-width) (or max-width jabber-image-max-width)) (setf (image-property image :max-height) (or max-height jabber-image-max-height)) image)) (defun jabber-image-fetch (url callback &rest cbargs) "Fetch image at URL asynchronously. When complete, call CALLBACK with the image object (or nil on error) followed by CBARGS. Image is sized per `jabber-image-max-width' and `jabber-image-max-height'." (url-queue-retrieve url (lambda (status cb args) (let ((url-buffer (current-buffer)) (image (unless (plist-get status :error) (goto-char (point-min)) (when (re-search-forward "\r?\n\r?\n" nil t) (let* ((handle (mm-dissect-buffer t)) (img (mm-get-image handle))) (when img (setf (image-property img :max-width) jabber-image-max-width) (setf (image-property img :max-height) jabber-image-max-height) img)))))) (kill-buffer url-buffer) (apply cb image args))) (list callback cbargs) 'silent 'inhibit-cookies)) (defun jabber-image--replace-placeholder (image beg end buffer) "Replace placeholder between BEG and END in BUFFER with IMAGE." (when (and image (buffer-live-p buffer)) (with-current-buffer buffer (let ((inhibit-read-only t)) (put-text-property beg end 'display image))))) (defun jabber-image--load-at-point (url beg end buffer) "Fetch URL and display the image over the placeholder in BUFFER." (jabber-image-fetch url #'jabber-image--replace-placeholder beg end buffer)) (defvar jabber-image-placeholder-keymap (let ((map (make-sparse-keymap))) (define-key map [mouse-1] #'jabber-image-placeholder-click) (define-key map (kbd "RET") #'jabber-image-placeholder-click) map) "Keymap for clickable image placeholders.") (defun jabber-image-placeholder-click () "Load the image at the placeholder under point." (interactive) (let ((url (get-text-property (point) 'jabber-image-url)) (beg (previous-single-property-change (1+ (point)) 'jabber-image-url)) (end (next-single-property-change (point) 'jabber-image-url))) (when url (jabber-image--load-at-point url (or beg (point-min)) (or end (point-max)) (current-buffer))))) (defun jabber-image-insert-placeholder (url &optional text) "Insert a clickable image placeholder for URL at point. TEXT is the display text; defaults to \"[Image: FILENAME]\" where FILENAME is extracted from URL." (let ((label (or text (format "[Image: %s]" (file-name-nondirectory (url-filename (url-generic-parse-url url))))))) (insert (propertize label 'face 'link 'jabber-image-url url 'keymap jabber-image-placeholder-keymap 'mouse-face 'highlight 'help-echo "Click to load image")))) (provide 'jabber-image) ;;; jabber-image.el ends here emacs-jabber/lisp/jabber-info.el000066400000000000000000000203551516610113500170440ustar00rootroot00000000000000;;; jabber-info.el --- aggregate info queries -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'jabber-util) (eval-when-compile (require 'jabber-muc)) ; jabber-muc-argument-list macro ;; Global reference declarations (declare-function jabber-ping-send "jabber-ping.el" (jc to process-func on-success on-error)) (declare-function jabber-browse--buffer "jabber-iq.el" (jid)) (declare-function jabber-browse--insert "jabber-iq.el" (jc xml-data closure-data)) (declare-function jabber-send-iq "jabber-iq.el" (jc to type query success-callback success-closure-data error-callback error-closure-data &optional result-id)) (declare-function jabber-muc-read-nickname "jabber-muc.el" (group prompt)) (declare-function jabber-process-version "jabber-version.el" (jc xml-data)) (declare-function jabber-process-disco-info "jabber-disco.el" (jc xml-data)) (declare-function jabber-process-ping "jabber-ping.el" (jc xml-data)) (declare-function jabber-process-time "jabber-time.el" (jc xml-data)) (declare-function jabber-process-last "jabber-time.el" (jc xml-data)) (defvar jabber-group) ; jabber-muc.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defun jabber-info--connected-resources (bare-jid) "Return list of full JIDs for connected resources of BARE-JID." (let* ((sym (jabber-jid-symbol bare-jid)) (resources (get sym 'resources)) (full-jids nil)) (dolist (entry resources) (when (plist-get (cdr entry) 'connected) (push (concat bare-jid "/" (car entry)) full-jids))) (nreverse full-jids))) (defun jabber-info--make-marker () "Return an advancing marker at point. The marker has insertion-type t so it advances past text inserted at its position." (let ((m (point-marker))) (set-marker-insertion-type m t) m)) (defun jabber-info--make-callback (marker) "Return a callback that inserts results at MARKER position." (lambda (jc xml-data closure-data) (when (buffer-live-p (marker-buffer marker)) (with-current-buffer (marker-buffer marker) (let ((inhibit-read-only t)) (goto-char marker) (save-excursion (cond ((functionp closure-data) (let ((result (funcall closure-data jc xml-data))) (when (stringp result) (insert result "\n\n")))) ((stringp closure-data) (insert closure-data ": " (jabber-parse-error (jabber-iq-error xml-data)) "\n\n")) (t (insert (format "%S\n\n" xml-data)))))))))) (defun jabber-info--query-bare (jc bare-jid marker) "Fire queries appropriate for a bare JID. Results are inserted at MARKER in its buffer." (let ((cb (jabber-info--make-callback marker))) (jabber-send-iq jc bare-jid "get" '(query ((xmlns . "http://jabber.org/protocol/disco#info"))) cb #'jabber-process-disco-info cb "Disco info request failed") (jabber-send-iq jc bare-jid "get" '(query ((xmlns . "jabber:iq:last"))) cb #'jabber-process-last cb "Last online request failed"))) (defun jabber-info--query-resource (jc full-jid marker) "Fire queries appropriate for FULL-JID. Results are inserted at MARKER in its buffer." (let ((cb (jabber-info--make-callback marker))) (jabber-send-iq jc full-jid "get" '(query ((xmlns . "jabber:iq:version"))) cb #'jabber-process-version cb "Version request failed") (jabber-send-iq jc full-jid "get" '(query ((xmlns . "http://jabber.org/protocol/disco#info"))) cb #'jabber-process-disco-info cb "Disco info request failed") (jabber-ping-send jc full-jid cb #'jabber-process-ping "Ping is unsupported") (jabber-send-iq jc full-jid "get" '(time ((xmlns . "urn:xmpp:time"))) cb #'jabber-process-time cb "Time request failed") (jabber-send-iq jc full-jid "get" '(query ((xmlns . "jabber:iq:last"))) cb #'jabber-process-last cb "Idle time request failed"))) ;;;###autoload (defun jabber-get-info (jc to) "Query JC for all available info about TO. For a bare JID, queries disco info, last activity, and also queries each connected resource for version, disco, ping, time and idle time. For a full JID, queries the resource directly. Results appear in the browse buffer for TO." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Get info for: " nil nil nil 'full t))) (let* ((bare (jabber-jid-user to)) (resource (jabber-jid-resource to)) (full-jids (if resource (list to) (jabber-info--connected-resources bare)))) (let ((buf (jabber-browse--buffer bare))) (with-current-buffer buf (let ((inhibit-read-only t)) (erase-buffer) (insert (propertize bare 'face 'jabber-title) "\n\n") (if resource (jabber-info--query-resource jc to (jabber-info--make-marker)) ;; Build the full outline skeleton, then create markers. (insert (propertize "* Account:" 'face 'jabber-title) "\n\n") (let ((account-pos (point))) (if full-jids (let ((resource-entries nil)) (insert (propertize "* Clients:" 'face 'jabber-title) "\n\n") (dolist (full-jid full-jids) (insert (propertize (concat "** " (jabber-jid-resource full-jid) ":") 'face 'jabber-title) "\n\n") (push (cons full-jid (point)) resource-entries)) ;; Create markers and fire queries. (goto-char account-pos) (jabber-info--query-bare jc bare (jabber-info--make-marker)) (dolist (entry (nreverse resource-entries)) (goto-char (cdr entry)) (jabber-info--query-resource jc (car entry) (jabber-info--make-marker)))) (jabber-info--query-bare jc bare (jabber-info--make-marker)) (goto-char (point-max)) (insert "No connected resources found.\n\n")))))) (display-buffer buf)))) ;;;###autoload (defun jabber-muc-get-info (jc group nickname) "Query version, disco info and ping for NICKNAME in GROUP. JC is the Jabber connection." (interactive (jabber-muc-argument-list (list (jabber-muc-read-nickname jabber-group "Nickname: ")))) (let* ((full-jid (format "%s/%s" group nickname)) (buf (jabber-browse--buffer full-jid))) (with-current-buffer buf (let ((inhibit-read-only t)) (erase-buffer) (insert (propertize full-jid 'face 'jabber-title) "\n\n") (jabber-info--query-resource jc full-jid (jabber-info--make-marker)))) (display-buffer buf))) (provide 'jabber-info) ;;; jabber-info.el ends here emacs-jabber/lisp/jabber-iq.el000066400000000000000000000225351516610113500165240ustar00rootroot00000000000000;;; jabber-iq.el --- infoquery functions -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'jabber-util) (require 'jabber-alert) (require 'jabber-menu) (defvar *jabber-open-info-queries* nil "Alist of open query id and their callback functions.") (defvar jabber--iq-counter 0 "Monotonic counter for generating unique IQ stanza IDs.") (defvar jabber-iq-get-xmlns-alist nil "Mapping from XML namespace to handler for IQ GET requests.") (defvar jabber-iq-set-xmlns-alist nil "Mapping from XML namespace to handler for IQ SET requests.") (defvar-keymap jabber-browse-mode-map :parent jabber-common-keymap) (defcustom jabber-browse-mode-hook nil "Hook run when entering Browse mode." :group 'jabber :type 'hook) (defgroup jabber-browse nil "browse display options" :group 'jabber) (defcustom jabber-browse-buffer-format "*browse:%n*" "The format specification for the name of browse buffers. These fields are available at this moment: %n JID to browse" :type 'string) ;; Global reference declarations (declare-function jabber-chain-add "jabber-core" (chain-var handler &optional depth)) (declare-function jabber-send-sexp "jabber-core.el" (jc sexp)) (defvar jabber-iq-chain) ; jabber-core.el (defvar jabber-stanzas-xmlns) ; jabber-xml.el ;; (define-derived-mode jabber-browse-mode special-mode "jabber-browse" "Special mode." ;; FIXME: Improve! (setq buffer-read-only t) (setq-local outline-regexp "\\*+ ") (setq-local outline-minor-mode-cycle t) (outline-minor-mode 1)) (with-eval-after-load "jabber-core" (jabber-chain-add 'jabber-iq-chain #'jabber-process-iq)) (defun jabber-process-iq (jc xml-data) "Process an incoming iq stanza. JC is the Jabber Connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((id (jabber-xml-get-attribute xml-data 'id)) (type (jabber-xml-get-attribute xml-data 'type)) (from (jabber-xml-get-attribute xml-data 'from)) (query (jabber-iq-query xml-data)) (callback (assoc id *jabber-open-info-queries*))) (cond ;; if type is "result" or "error", this is a response to a query we sent. ((or (string= type "result") (string= type "error")) (let ((callback-cons (nth (cdr (assoc type '(("result" . 0) ("error" . 1)))) (cdr callback)))) (when (and (consp callback-cons) (car callback-cons)) (funcall (car callback-cons) jc xml-data (cdr callback-cons)))) (setq *jabber-open-info-queries* (delq callback *jabber-open-info-queries*))) ;; if type is "get" or "set", correct action depends on namespace of request. ((and (listp query) (or (string= type "get") (string= type "set"))) (let* ((which-alist (pcase type ("get" jabber-iq-get-xmlns-alist) ("set" jabber-iq-set-xmlns-alist))) (handler (cdr (assoc (jabber-xml-get-attribute query 'xmlns) which-alist)))) (if handler (condition-case error-var (funcall handler jc xml-data) (jabber-error (apply #'jabber-send-iq-error jc from id query (cdr error-var))) (error (jabber-send-iq-error jc from id query "wait" 'internal-server-error (error-message-string error-var)))) (jabber-send-iq-error jc from id query "cancel" 'feature-not-implemented))))))) (defun jabber-send-iq (jc to type query success-callback success-closure-data error-callback error-closure-data &optional result-id) "Send an iq stanza to the specified entity, and optionally set up a callback. JC is the Jabber connection. TO is the addressee. TYPE is one of \"get\", \"set\", \"result\" or \"error\". QUERY is a list containing the child of the iq node in the format `jabber-sexp2xml' accepts. SUCCESS-CALLBACK is the function to be called when a successful result arrives. SUCCESS-CLOSURE-DATA is an extra argument to SUCCESS-CALLBACK. ERROR-CALLBACK is the function to be called when an error arrives. ERROR-CLOSURE-DATA is an extra argument to ERROR-CALLBACK. RESULT-ID is the id to be used for a response to a received iq message. `jabber-report-success' and `jabber-process-data' are common callbacks. The callback functions are called like this: \(funcall CALLBACK JC XML-DATA CLOSURE-DATA) with XML-DATA being the IQ stanza received in response. " (let ((id (or result-id (format "emacs-iq-%d" (cl-incf jabber--iq-counter))))) (if (or success-callback error-callback) (setq *jabber-open-info-queries* (cons (list id (cons success-callback success-closure-data) (cons error-callback error-closure-data)) *jabber-open-info-queries*))) (jabber-send-sexp jc (list 'iq (append (if to (list (cons 'to to))) (list (cons 'type type)) (list (cons 'id id))) query)))) (defun jabber-send-iq-error (jc to id original-query error-type condition &optional text app-specific) "Send an error iq stanza in response to a previously sent iq stanza. Send an error iq stanza to the specified entity in response to a previously sent iq stanza. TO is the addressee. ID is the id of the iq stanza that caused the error. ORIGINAL-QUERY is the original query, which should be included in the error, or nil. ERROR-TYPE is one of \"cancel\", \"continue\", \"modify\", \"auth\" and \"wait\". CONDITION is a symbol denoting a defined XMPP condition. TEXT is a string to be sent in the error message, or nil for no text. APP-SPECIFIC is a list of extra XML tags. JC is the Jabber connection. See section 9.3 of XMPP Core." (jabber-send-sexp jc `(iq (,@(when to `((to . ,to))) (type . "error") (id . ,(or id ""))) ,original-query (error ((type . ,error-type)) (,condition ((xmlns . ,jabber-stanzas-xmlns))) ,(if text `(text ((xmlns . ,jabber-stanzas-xmlns)) ,text)) ,@app-specific)))) (defun jabber-browse--buffer (jid) "Return the browse buffer for JID, creating it if needed. When newly created, insert a JID header line." (let* ((name (format-spec jabber-browse-buffer-format (list (cons ?n jid)))) (buf (get-buffer-create name))) (with-current-buffer buf (unless (derived-mode-p 'jabber-browse-mode) (jabber-browse-mode) (let ((inhibit-read-only t)) (insert (propertize jid 'face 'jabber-title) "\n\n")))) buf)) (defun jabber-browse--insert (jc xml-data closure-data) "Render CLOSURE-DATA into the current buffer at point-max. CLOSURE-DATA is a function (called with JC and XML-DATA), an error string, or nil (dumps raw XML)." (let ((inhibit-read-only t)) (goto-char (point-max)) (save-excursion (cond ((functionp closure-data) (let ((result (funcall closure-data jc xml-data))) (when (stringp result) (insert result "\n\n")))) ((stringp closure-data) (insert closure-data ": " (jabber-parse-error (jabber-iq-error xml-data)) "\n\n")) (t (insert (format "%S\n\n" xml-data))))))) (defun jabber-process-data (jc xml-data closure-data) "Process random results from various requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((from (or (jabber-xml-get-attribute xml-data 'from) (plist-get (fsm-get-state-data jc) :server))) (buf (jabber-browse--buffer from))) (with-current-buffer buf (jabber-browse--insert jc xml-data closure-data) (dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks)) (run-hook-with-args hook 'browse buf (funcall jabber-alert-info-message-function 'browse buf)))))) (defun jabber-silent-process-data (jc xml-data closure-data) "Process random results from various requests to only alert hooks. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((text (cond ((functionp closure-data) (funcall closure-data jc xml-data)) ((stringp closure-data) (concat closure-data ": " (jabber-parse-error (jabber-iq-error xml-data)))) (t (format "%S" xml-data))))) (dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks)) (run-hook-with-args hook 'browse (current-buffer) text)))) (provide 'jabber-iq) ;;; jabber-iq.el ends here. emacs-jabber/lisp/jabber-keepalive.el000066400000000000000000000160361516610113500200570ustar00rootroot00000000000000;; jabber-keepalive.el - try to detect lost connection -*- lexical-binding: t; -*- ;; Copyright (C) 2004, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2007 - Detlev Zundel - dzu@gnu.org ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;; Keepalive - send something to the server and see if it answers. ;; These keepalive functions send a urn:xmpp:ping request to the ;; server every X minutes, and considers the connection broken if ;; they get no answer within Y seconds. ;;; Code: (require 'jabber-ping) ;;;###autoload (defgroup jabber-keepalive nil "Keepalive functions try to detect lost connection" :group 'jabber) (defcustom jabber-keepalive-interval 600 "Interval in seconds between connection checks." :type 'integer) (defcustom jabber-keepalive-timeout 20 "Seconds to wait for response from server." :type 'integer) (defvar jabber-keepalive-timer nil "Timer object for keepalive function.") (defvar jabber-keepalive-timeout-timer nil "Timer object for keepalive timeout function.") (defvar jabber-keepalive-pending nil "List of outstanding keepalive connections.") (defvar jabber-keepalive-debug nil "Log keepalive traffic when non-nil.") ;; Global reference declarations (declare-function jabber-send-string "jabber-core.el" (jc string)) (declare-function jabber-disconnect-one "jabber-core.el" (jc &optional dont-redisplay interactivep)) (declare-function fsm-get-state-data "fsm" (fsm)) (declare-function fsm-send "fsm" (fsm event &optional callback)) (defvar jabber-connections) ; jabber-core.el ;; ;;;###autoload (defun jabber-keepalive-start (&optional _jc) "Activate keepalive. That is, regularly send a ping request to the server, and disconnect it if it doesn't answer. See variable `jabber-keepalive-interval' and variable `jabber-keepalive-timeout'. The JC argument makes it possible to add this function to `jabber-post-connect-hooks'; it is ignored. Keepalive is activated for all accounts regardless of the argument." (interactive) (when jabber-keepalive-timer (jabber-keepalive-stop)) (setq jabber-keepalive-timer (run-with-timer jabber-keepalive-interval jabber-keepalive-interval #'jabber-keepalive-do)) (add-hook 'jabber-post-disconnect-hook #'jabber-keepalive-stop)) (defun jabber-keepalive-stop () "Deactivate keepalive." (interactive) (when jabber-keepalive-timer (cancel-timer jabber-keepalive-timer) (setq jabber-keepalive-timer nil))) (defun jabber-keepalive-do () (when jabber-keepalive-debug (message "%s: sending keepalive packet(s)" (current-time-string))) (setq jabber-keepalive-timeout-timer (run-with-timer jabber-keepalive-timeout nil #'jabber-keepalive-timeout)) (setq jabber-keepalive-pending jabber-connections) (dolist (c jabber-connections) ;; Whether we get an error or not is not interesting. ;; Getting a response at all is. (jabber-ping-send c nil 'jabber-keepalive-got-response nil nil))) (defun jabber-keepalive-got-response (jc &rest _args) (when jabber-keepalive-debug (message "%s: got keepalive response from %s" (current-time-string) (plist-get (fsm-get-state-data jc) :server))) (setq jabber-keepalive-pending (remq jc jabber-keepalive-pending)) (when (and (null jabber-keepalive-pending) (timerp jabber-keepalive-timeout-timer)) (cancel-timer jabber-keepalive-timeout-timer) (setq jabber-keepalive-timeout-timer nil))) (defun jabber-keepalive-timeout () (cancel-timer jabber-keepalive-timer) (setq jabber-keepalive-timer nil) (dolist (c jabber-keepalive-pending) (message "%s: keepalive timeout, connection to %s considered lost" (current-time-string) (plist-get (fsm-get-state-data c) :server)) (run-hook-with-args 'jabber-lost-connection-hooks c) (jabber-disconnect-one c nil))) ;;;; Whitespace pings - less traffic, no error checking on our side ;;; ;;; Openfire needs something like this, but I couldn't bring myself to ;;; enable keepalive by default... Whitespace pings are light and ;;; unobtrusive. (defcustom jabber-whitespace-ping-interval 30 "Send a space character to the server with this interval, in seconds. This is a traditional remedy for a number of problems: to keep NAT boxes from considering the connection dead, to have the OS discover earlier that the connection is lost, and to placate servers which rely on the client doing this, e.g. Openfire. If you want to verify that the server is able to answer, see `jabber-keepalive-start' for another mechanism." :type '(integer :tag "Interval in seconds") :group 'jabber-core) (defvar jabber-whitespace-ping-timer nil "Timer object for whitespace pings.") ;;;###autoload (defun jabber-whitespace-ping-start (&optional _jc) "Start sending whitespace pings at regular intervals. See `jabber-whitespace-ping-interval'. The JC argument is ignored; whitespace pings are enabled for all accounts." (interactive) (when jabber-whitespace-ping-timer (jabber-whitespace-ping-stop)) ;; Send one ping immediately to prevent servers with aggressive ;; idle timeouts from dropping the connection before the first ;; timer fires. (jabber-whitespace-ping-do) (setq jabber-whitespace-ping-timer (run-with-timer jabber-whitespace-ping-interval jabber-whitespace-ping-interval #'jabber-whitespace-ping-do)) (add-hook 'jabber-post-disconnect-hook #'jabber-whitespace-ping-stop)) (defun jabber-whitespace-ping-stop () "Deactivate whitespace pings." (interactive) (when jabber-whitespace-ping-timer (cancel-timer jabber-whitespace-ping-timer) (setq jabber-whitespace-ping-timer nil))) (defun jabber-whitespace-ping-do () (dolist (c jabber-connections) (let* ((state-data (fsm-get-state-data c)) (connection (plist-get state-data :connection))) (if (and connection (process-live-p connection)) (condition-case err (jabber-send-string c " ") (error (message "jabber-keepalive: whitespace ping failed: %s" err) (fsm-send c :connection-dead))) ;; Connection process is dead but FSM didn't transition. ;; Only act when stuck in :session-established; other states ;; are transient and will resolve on their own. (when (eq (get c :state) :session-established) (fsm-send c :connection-dead)))))) (provide 'jabber-keepalive) ;;; jabber-keepalive.el ends hereemacs-jabber/lisp/jabber-mam.el000066400000000000000000001077741516610113500166760ustar00rootroot00000000000000;;; jabber-mam.el --- XEP-0313 Message Archive Management -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Author: Thanos Apollo ;; Maintainer: Thanos Apollo ;; This file is part of emacs-jabber. ;; emacs-jabber 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 3 of the License, or ;; (at your option) any later version. ;; emacs-jabber 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 emacs-jabber. If not, see . ;;; Commentary: ;; XEP-0313 (Message Archive Management) support. ;; Queries the server's message archive on connect to sync missed ;; messages across devices. Results are stored in the local database ;; and displayed in open chat buffers. ;; ;; Pagination uses XEP-0059 (Result Set Management). ;; Deduplication uses XEP-0359 stanza-id / server-id. ;;; Code: (require 'jabber-xml) (require 'jabber-util) (eval-when-compile (require 'cl-lib)) (declare-function jabber-chain-add "jabber-core" (chain-var handler &optional depth)) (declare-function jabber-connection-bare-jid "jabber-util" (jc)) (declare-function jabber-jid-user "jabber-util" (jid)) (declare-function jabber-jid-resource "jabber-util" (jid)) (declare-function jabber-send-iq "jabber-iq" (jc to type query success-callback success-closure-data error-callback error-closure-data &optional result-id)) (declare-function jabber-iq-query "jabber-util" (xml-data)) (declare-function jabber-disco-get-info "jabber-disco" (jc jid node callback closure-data &optional force)) (declare-function jabber-disco-advertise-feature "jabber-disco" (feature)) (declare-function jabber-db-store-message "jabber-db" (account peer direction type body timestamp &optional resource stanza-id server-id occupant-id oob-entries encrypted)) (declare-function jabber-db--extract-occupant-id "jabber-db" (xml-data)) (declare-function jabber-db--extract-oob-entries "jabber-db" (xml-data)) (declare-function jabber-db-last-server-id "jabber-db" (account &optional peer)) (declare-function jabber-db-ensure-open "jabber-db" ()) (declare-function jabber-chat--decrypt-if-needed "jabber-chat" (jc xml-data)) (declare-function jabber-parse-time "jabber-util" (raw-time)) (declare-function jabber-message-correct--replace-id "jabber-message-correct" (xml-data)) (declare-function jabber-db-correct-message "jabber-db" (stanza-id new-body)) (declare-function jabber-sexp2xml "jabber-xml" (sexp)) (defvar jabber-message-chain) ; jabber-core.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-chatting-with) ; jabber-chat.el (defvar jabber-group) ; jabber-muc.el ;;; Constants (defconst jabber-mam-xmlns "urn:xmpp:mam:2" "Namespace for XEP-0313 MAM.") (defconst jabber-mam-rsm-xmlns "http://jabber.org/protocol/rsm" "Namespace for XEP-0059 Result Set Management.") (defconst jabber-mam-forward-xmlns "urn:xmpp:forward:0" "Namespace for XEP-0297 Stanza Forwarding.") (defconst jabber-mam-delay-xmlns "urn:xmpp:delay" "Namespace for XEP-0203 Delayed Delivery.") (defconst jabber-mam-sid-xmlns "urn:xmpp:sid:0" "Namespace for XEP-0359 Stanza IDs.") ;;; Customization (defcustom jabber-mam-enable t "Whether to sync messages via MAM on connect." :type 'boolean :group 'jabber) (defcustom jabber-mam-page-size 50 "Number of messages to request per MAM page." :type 'integer :group 'jabber) (defcustom jabber-mam-catch-up-days 3 "Limit initial MAM catch-up to this many days back. Only used when no previous sync point exists (first sync). Set to nil to fetch the entire archive." :type '(choice integer (const :tag "Fetch all" nil)) :group 'jabber) ;;; Hooks (defvar jabber-mam-peer-syncing-functions nil "Hook run when a peer's MAM sync state changes. Each function receives three arguments: PEER (bare JID), TYPE \(\"groupchat\" or \"chat\"), and SYNCING-P (non-nil when sync starts, nil when it ends).") (defvar jabber-mam-sync-complete-functions nil "Hook run after MAM stores messages for one or more peers. Each function receives one argument: a list of (PEER . TYPE) pairs.") ;;; Internal state (defvar jabber-mam--syncing nil "Non-nil while a MAM sync is in progress. Alist of (JC . QUERYID) for active queries.") (defvar jabber-mam--dirty-peers nil "Peers that received MAM messages during sync. Alist of (PEER . TYPE) where TYPE is the message type string. Accumulated during sync, drained after COMMIT.") (defvar jabber-mam--tx-depth 0 "Reference count for the shared MAM transaction. BEGIN when 0->1, COMMIT when 1->0. Allows concurrent MAM queries to share one SQLite transaction.") (defvar jabber-mam--completion-callbacks nil "Alist of (QUERYID . CALLBACK) for per-query completion hooks. CALLBACK is called with no arguments when the query finishes.") (defvar jabber-mam--sync-received nil "Alist of (QUERYID . PLIST) for sync-buffer reconciliation. PLIST keys: :ids (hash-table), :min-ts, :max-ts, :account, :peer. Populated during sync; consumed by `jabber-mam--reconcile-sync'.") (defvar jabber-mam--query-targets nil "Alist of (QUERYID . TARGET) for active MAM queries. TARGET is a room JID for MUC MAM, or nil for 1:1 MAM.") ;;; Public predicates (defun jabber-mam-syncing-p () "Return non-nil if any MAM sync is in progress." (not (null jabber-mam--syncing))) ;;; Query building (defvar jabber-mam--queryid-counter 0 "Monotonic counter for unique MAM query IDs.") (defun jabber-mam--make-queryid () "Generate a unique query ID for MAM." (format "mam-%d-%d" (cl-incf jabber-mam--queryid-counter) (floor (float-time)))) (defun jabber-mam--build-query (queryid &optional with start after-id max before-id) "Build a MAM sexp. QUERYID is echoed in results for correlation. WITH filters by JID, START is an XEP-0082 datetime string. AFTER-ID is an RSM cursor for forward pagination. MAX is the page size. BEFORE-ID is an RSM cursor for backward pagination; when t, emit an empty element (meaning \"last page\")." (let ((form-fields nil) (rsm-children nil)) ;; Data form fields (when (or with start) (push `(field ((var . "FORM_TYPE") (type . "hidden")) (value () ,jabber-mam-xmlns)) form-fields) (when with (push `(field ((var . "with")) (value () ,with)) form-fields)) (when start (push `(field ((var . "start")) (value () ,start)) form-fields)) (setq form-fields (nreverse form-fields))) ;; RSM (when max (push `(max () ,(number-to-string max)) rsm-children)) (when after-id (push `(after () ,after-id) rsm-children)) (when before-id (if (eq before-id t) (push '(before ()) rsm-children) (push `(before () ,before-id) rsm-children))) (setq rsm-children (nreverse rsm-children)) ;; Build query `(query ((xmlns . ,jabber-mam-xmlns) (queryid . ,queryid)) ,@(when form-fields (list `(x ((xmlns . "jabber:x:data") (type . "submit")) ,@form-fields))) ,@(when rsm-children (list `(set ((xmlns . ,jabber-mam-rsm-xmlns)) ,@rsm-children)))))) ;;; Result parsing (defun jabber-mam--parse-result (xml-data) "Extract MAM result from a stanza. Returns (ARCHIVE-ID DELAY-STAMP INNER-MESSAGE) or nil." (when-let* ((result-el (jabber-xml-child-with-xmlns xml-data jabber-mam-xmlns))) (let* ((archive-id (jabber-xml-get-attribute result-el 'id)) (fwd-el (car (jabber-xml-get-children result-el 'forwarded))) (delay-el (and fwd-el (car (jabber-xml-get-children fwd-el 'delay)))) (stamp (and delay-el (jabber-xml-get-attribute delay-el 'stamp))) (inner-msg (and fwd-el (car (jabber-xml-get-children fwd-el 'message))))) (when inner-msg (list archive-id stamp inner-msg))))) (defun jabber-mam--parse-fin (xml-data) "Parse a MAM IQ result. Returns plist (:complete BOOL :first ID :last ID)." (let* ((fin-el (jabber-xml-child-with-xmlns xml-data jabber-mam-xmlns)) (complete (string= (or (jabber-xml-get-attribute fin-el 'complete) "") "true")) (set-el (and fin-el (car (jabber-xml-get-children fin-el 'set)))) (first-el (and set-el (car (jabber-xml-get-children set-el 'first)))) (last-el (and set-el (car (jabber-xml-get-children set-el 'last)))) (first-id (and first-el (car (jabber-xml-node-children first-el)))) (last-id (and last-el (car (jabber-xml-node-children last-el))))) (list :complete complete :first first-id :last last-id))) ;;; Message chain handler (defun jabber-mam--unwrap-into (outer inner) "Replace OUTER stanza's attributes and children with INNER's. Marks the stanza as MAM-origin so downstream handlers can suppress outgoing receipts. Mutates OUTER in place." (setcar (cdr outer) (append (jabber-xml-node-attributes inner) '((jabber-mam--origin . "t")))) (setcdr (cdr outer) (cddr inner))) (defun jabber-mam--active-query-p (queryid) "Return non-nil if QUERYID is an active MAM query." (cl-find queryid jabber-mam--syncing :key #'cdr :test #'string=)) (defun jabber-mam--valid-sender-p (jc from queryid) "Return non-nil if FROM is a valid MAM result sender for JC. Valid senders are our own bare JID (1:1 archive) or a joined MUC room (room archive). A nil FROM is accepted only for own-archive queries (no MUC target) because some servers omit the attribute when the message originates from the user's own archive. QUERYID identifies the active query for target lookup." (if (null from) ;; Accept nil from only for own-archive queries. ;; MUC queries always have a room JID in query-targets. (let ((target (cdr (assoc queryid jabber-mam--query-targets #'string=)))) (or (null target) (eq target 'one-shot))) (let ((bare (jabber-jid-user from)) (our-jid (jabber-connection-bare-jid jc))) (or (string= bare our-jid) (jabber-muc-nickname bare))))) (defun jabber-mam--classify-direction (jc from to type) "Classify message direction and peer from MAM result fields. JC is the connection, FROM/TO are stanza JIDs, TYPE is message type. Return (DIRECTION . PEER) where DIRECTION is \"in\" or \"out\"." (let* ((our-jid (jabber-connection-bare-jid jc)) (groupchat-p (string= type "groupchat")) (direction (if groupchat-p (let ((nick (jabber-jid-resource from)) (room (jabber-jid-user from))) (if (and nick (jabber-mam--our-muc-nick-p room nick jc)) "out" "in")) (if (string= (jabber-jid-user from) our-jid) "out" "in"))) (peer (if groupchat-p (jabber-jid-user from) (jabber-jid-user (if (string= direction "out") to from))))) (cons direction peer))) (defun jabber-mam--extract-fields (jc inner-msg stamp) "Extract message fields from INNER-MSG for storage. JC is the connection. STAMP is the MAM delay timestamp string. Returns a plist with :from :to :type :body :stanza-id :our-jid :direction :peer :timestamp :oob-entries, or nil if direction cannot be determined." (let* ((from (jabber-xml-get-attribute inner-msg 'from)) (to (jabber-xml-get-attribute inner-msg 'to)) (type (or (jabber-xml-get-attribute inner-msg 'type) "chat")) (body-el (car (jabber-xml-get-children inner-msg 'body))) (body (and body-el (car (jabber-xml-node-children body-el)))) (stanza-id (jabber-xml-get-attribute inner-msg 'id)) (our-jid (jabber-connection-bare-jid jc)) (dir-peer (jabber-mam--classify-direction jc from to type)) (direction (car dir-peer)) (peer (cdr dir-peer)) (timestamp (and stamp (jabber-parse-time stamp))) (oob-entries (jabber-db--extract-oob-entries inner-msg))) (list :from from :to to :type type :body body :stanza-id stanza-id :our-jid our-jid :direction direction :peer peer :timestamp timestamp :oob-entries oob-entries))) (defun jabber-mam--track-sync-ids (qid archive-id stanza-id ts) "Update sync-received tracking for query QID. ARCHIVE-ID and STANZA-ID are recorded as seen. TS updates the min/max timestamp range." (when-let* ((sync-data (cdr (assoc qid jabber-mam--sync-received #'string=))) (ids (plist-get sync-data :ids))) (when archive-id (puthash archive-id t ids)) (when stanza-id (puthash stanza-id t ids)) (when (or (null (plist-get sync-data :min-ts)) (< ts (plist-get sync-data :min-ts))) (plist-put sync-data :min-ts ts)) (when (or (null (plist-get sync-data :max-ts)) (> ts (plist-get sync-data :max-ts))) (plist-put sync-data :max-ts ts)))) (defun jabber-mam--process-message (jc xml-data) "Handle a MAM result from the message chain. JC is the Jabber connection. XML-DATA is the stanza." (when-let* ((result-el (jabber-xml-child-with-xmlns xml-data jabber-mam-xmlns)) (qid (jabber-xml-get-attribute result-el 'queryid)) ((jabber-mam--active-query-p qid)) (parsed (jabber-mam--parse-result xml-data)) ((jabber-mam--valid-sender-p jc (jabber-xml-get-attribute xml-data 'from) qid))) (let* ((archive-id (nth 0 parsed)) (stamp (nth 1 parsed)) (inner-msg (nth 2 parsed)) (encrypted (jabber-xml-encrypted-p inner-msg)) (inner-msg (jabber-chat--decrypt-if-needed jc inner-msg)) (fields (jabber-mam--extract-fields jc inner-msg stamp)) (peer (plist-get fields :peer)) (body (plist-get fields :body))) (if (and peer body) (let* ((ts (floor (float-time (or (plist-get fields :timestamp) (current-time))))) (replace-id (jabber-message-correct--replace-id inner-msg))) (if replace-id (jabber-db-correct-message replace-id body) (jabber-db-store-message (plist-get fields :our-jid) peer (plist-get fields :direction) (plist-get fields :type) body ts (jabber-jid-resource (plist-get fields :from)) (plist-get fields :stanza-id) archive-id (jabber-db--extract-occupant-id inner-msg) (plist-get fields :oob-entries) encrypted)) (jabber-mam--track-sync-ids qid archive-id (plist-get fields :stanza-id) ts) (jabber-mam--mark-dirty peer (plist-get fields :type)) (setcdr (cdr xml-data) nil)) (jabber-mam--unwrap-into xml-data inner-msg))))) (defun jabber-mam--our-muc-nick-p (room nick jc) "Return non-nil if NICK in ROOM is us on connection JC. Checks the current room nickname first, then falls back to comparing with the account username to handle nick changes." (require 'jabber-muc) (or (and-let* ((my-nick (jabber-muc-nickname room jc))) (string= nick my-nick)) (string= nick (plist-get (fsm-get-state-data jc) :username)))) (declare-function jabber-muc-nickname "jabber-muc" (group &optional jc)) (defun jabber-mam--mark-dirty (peer type) "Record that PEER's buffer needs redisplay after sync. TYPE is the message type (\"groupchat\" for MUC)." (unless (cl-find peer jabber-mam--dirty-peers :key #'car :test #'string=) (push (cons peer type) jabber-mam--dirty-peers))) (defun jabber-mam--redraw-dirty () "Signal that accumulated dirty peers need display refresh. Drains `jabber-mam--dirty-peers' and runs `jabber-mam-sync-complete-functions'." (let ((peers (prog1 jabber-mam--dirty-peers (setq jabber-mam--dirty-peers nil)))) (when peers (run-hook-with-args 'jabber-mam-sync-complete-functions peers)))) ;;; Shared transaction management (defun jabber-mam--tx-begin () "Increment the MAM transaction ref count. BEGIN a SQLite transaction when transitioning from 0 to 1." (when (zerop jabber-mam--tx-depth) (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "BEGIN"))) (cl-incf jabber-mam--tx-depth)) (defun jabber-mam--tx-end () "Decrement the MAM transaction ref count. COMMIT the SQLite transaction when transitioning from 1 to 0." (when (> jabber-mam--tx-depth 0) (cl-decf jabber-mam--tx-depth)) (when (zerop jabber-mam--tx-depth) (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "COMMIT")))) ;;; Query and pagination (defun jabber-mam--query (jc &optional after-id queryid with start to before-id max) "Send a MAM query via JC, paginating from AFTER-ID. QUERYID correlates results; generated if nil. WITH and START are optional filters. TO is the query target; nil for user archive, a room JID for MUC MAM. BEFORE-ID and MAX support backward pagination (last-page queries). When BEFORE-ID is non-nil, the query is one-shot (no forward pagination)." (let ((queryid (or queryid (jabber-mam--make-queryid))) (page-size (or max jabber-mam-page-size))) (push (cons jc queryid) jabber-mam--syncing) (when to (push (cons queryid to) jabber-mam--query-targets)) ;; Mark one-shot queries so handle-fin skips forward pagination. (when before-id (push (cons queryid 'one-shot) jabber-mam--query-targets)) ;; Open a shared transaction for concurrent MAM queries. ;; COMMIT happens when the last active query finishes. (jabber-mam--tx-begin) (condition-case err (jabber-send-iq jc to "set" (jabber-mam--build-query queryid with start after-id page-size before-id) #'jabber-mam--handle-fin (list queryid with start to) #'jabber-mam--handle-error (list queryid to)) (error (jabber-mam--tx-end) (setq jabber-mam--syncing (cl-remove queryid jabber-mam--syncing :key #'cdr :test #'string=)) (message "MAM: query failed to send: %s" (error-message-string err)))))) (defun jabber-mam--handle-fin (jc xml-data closure) "Handle the IQ result for a MAM query. JC is the connection. XML-DATA is the IQ response. CLOSURE is (QUERYID WITH START TO)." (let* ((queryid (nth 0 closure)) (with (nth 1 closure)) (start (nth 2 closure)) (to (nth 3 closure)) (fin (jabber-mam--parse-fin xml-data)) (complete (plist-get fin :complete)) (last-id (plist-get fin :last))) (jabber-mam--tx-end) ;; Remove from syncing list (setq jabber-mam--syncing (cl-remove queryid jabber-mam--syncing :key #'cdr :test #'string=)) (let ((one-shot-p (assoc queryid jabber-mam--query-targets #'string=))) ;; One-shot queries (before-id based) never paginate forward. (setq one-shot-p (and one-shot-p (eq (cdr one-shot-p) 'one-shot))) (if (or complete (null last-id) one-shot-p) (progn ;; Clean up query target tracking. (setq jabber-mam--query-targets (cl-remove queryid jabber-mam--query-targets :key #'car :test #'string=)) (let ((inhibit-message t)) (message "MAM: sync complete%s" (if to (format " for %s" to) (if with (format " for %s" with) "")))) ;; Fire per-query completion callback if registered. (when-let* ((cb (assoc queryid jabber-mam--completion-callbacks #'string=))) (setq jabber-mam--completion-callbacks (delq cb jabber-mam--completion-callbacks)) (funcall (cdr cb))) ;; Redraw affected buffers from DB. (jabber-mam--redraw-dirty)) ;; More pages: yield to the event loop for redisplay and input, ;; then continue pagination. (run-with-timer 0.1 nil #'jabber-mam--query jc last-id queryid with start to))))) (defun jabber-mam--handle-error (jc xml-data closure) "Handle a MAM query error. JC is the connection. XML-DATA is the IQ error. CLOSURE is (QUERYID TO). On item-not-found (stale sync point), falls back to time-based query." (let ((queryid (car closure)) (to (cadr closure))) (jabber-mam--tx-end) (setq jabber-mam--syncing (cl-remove queryid jabber-mam--syncing :key #'cdr :test #'string=)) (setq jabber-mam--query-targets (cl-remove queryid jabber-mam--query-targets :key #'car :test #'string=)) (let ((error-el (car (jabber-xml-get-children xml-data 'error)))) (if (and error-el (car (jabber-xml-get-children error-el 'item-not-found))) (progn (let ((inhibit-message t)) (message "MAM: sync point expired%s, falling back to time-based query" (if to (format " for %s" to) ""))) ;; Transfer completion callback to the fallback query. (let* ((old-cb (assoc queryid jabber-mam--completion-callbacks #'string=)) (new-queryid (jabber-mam--make-queryid)) (start (when jabber-mam-catch-up-days (format-time-string "%Y-%m-%dT%H:%M:%SZ" (time-subtract (current-time) (* jabber-mam-catch-up-days 86400)) t)))) (when old-cb (setq jabber-mam--completion-callbacks (delq old-cb jabber-mam--completion-callbacks)) (push (cons new-queryid (cdr old-cb)) jabber-mam--completion-callbacks)) (jabber-mam--query jc nil new-queryid nil start to))) ;; Permanent error: fire completion callback so callers aren't stuck. (when-let* ((cb (assoc queryid jabber-mam--completion-callbacks #'string=))) (setq jabber-mam--completion-callbacks (delq cb jabber-mam--completion-callbacks)) (funcall (cdr cb))) (message "MAM: query failed: %s" (jabber-sexp2xml xml-data)))))) ;;; Post-connect catch-up (defun jabber-mam--catch-up (jc) "Sync missed messages for JC via MAM." (let* ((account (jabber-connection-bare-jid jc)) (last-id (jabber-db-last-server-id account))) (if last-id ;; Resume from last known server-id (jabber-mam--query jc last-id) ;; First sync: limit to N days back (let ((start (when jabber-mam-catch-up-days (format-time-string "%Y-%m-%dT%H:%M:%SZ" (time-subtract (current-time) (* jabber-mam-catch-up-days 86400)) t)))) (jabber-mam--query jc nil nil nil start))))) (defun jabber-mam-maybe-catchup (jc) "Post-connect hook: sync messages via MAM if enabled. Added to `jabber-post-connect-hooks'." (when jabber-mam-enable (jabber-disco-get-info jc (jabber-connection-bare-jid jc) nil (lambda (jc _closure-data result) (when (and (listp result) (not (eq (car result) 'error)) (member jabber-mam-xmlns (cadr result))) (jabber-mam--catch-up jc))) nil))) ;;; 1:1 chat MAM catch-up (defun jabber-mam--chat-catch-up (jc peer) "Sync missed messages for PEER via MAM. JC is the Jabber connection. PEER is the bare JID. Registers a completion callback to clear the syncing indicator." (let* ((account (jabber-connection-bare-jid jc)) (last-id (jabber-db-last-server-id account peer)) (queryid (jabber-mam--make-queryid))) (push (cons queryid (lambda () (run-hook-with-args 'jabber-mam-peer-syncing-functions peer "chat" nil))) jabber-mam--completion-callbacks) (if last-id (jabber-mam--query jc last-id queryid peer nil nil) (let ((start (when jabber-mam-catch-up-days (format-time-string "%Y-%m-%dT%H:%M:%SZ" (time-subtract (current-time) (* jabber-mam-catch-up-days 86400)) t)))) (jabber-mam--query jc nil queryid peer start nil))))) (defun jabber-mam-chat-opened (jc peer) "Trigger 1:1 MAM catch-up when opening a chat with PEER. JC is the Jabber connection. Called from `jabber-chat-create-buffer'. Sets the syncing indicator immediately; clears it when the catch-up query completes (or when disco reveals MAM is not supported)." (when jabber-mam-enable (run-hook-with-args 'jabber-mam-peer-syncing-functions peer "chat" t) (jabber-disco-get-info jc (jabber-connection-bare-jid jc) nil (lambda (jc closure-data result) (let ((peer (car closure-data))) (if (and (listp result) (not (eq (car result) 'error)) (member jabber-mam-xmlns (cadr result))) (jabber-mam--chat-catch-up jc peer) (run-hook-with-args 'jabber-mam-peer-syncing-functions peer "chat" nil)))) (list peer)))) ;;; MUC MAM catch-up (defun jabber-mam--muc-catch-up (jc group) "Sync missed messages for GROUP via MUC MAM. JC is the Jabber connection. GROUP is the room bare JID. Registers a completion callback to clear the syncing indicator." (let* ((account (jabber-connection-bare-jid jc)) (last-id (jabber-db-last-server-id account group)) (queryid (jabber-mam--make-queryid))) (push (cons queryid (lambda () (run-hook-with-args 'jabber-mam-peer-syncing-functions group "groupchat" nil))) jabber-mam--completion-callbacks) (if last-id (jabber-mam--query jc last-id queryid nil nil group) (let ((start (when jabber-mam-catch-up-days (format-time-string "%Y-%m-%dT%H:%M:%SZ" (time-subtract (current-time) (* jabber-mam-catch-up-days 86400)) t)))) (jabber-mam--query jc nil queryid nil start group))))) (defun jabber-mam-muc-joined (jc group) "Trigger MUC MAM catch-up after joining GROUP. JC is the Jabber connection. Called from MUC self-presence handler. Sets the syncing indicator immediately; clears it when the catch-up query completes (or when disco reveals MAM is not supported)." (when jabber-mam-enable (run-hook-with-args 'jabber-mam-peer-syncing-functions group "groupchat" t) (jabber-disco-get-info jc group nil (lambda (jc closure-data result) (let ((group (car closure-data))) (if (and (listp result) (not (eq (car result) 'error)) (member jabber-mam-xmlns (cadr result))) (jabber-mam--muc-catch-up jc group) (run-hook-with-args 'jabber-mam-peer-syncing-functions group "groupchat" nil)))) (list group)))) (defun jabber-mam--reconcile-sync (queryid) "Delete local messages not found in the remote archive for QUERYID. Uses the IDs and timestamp range accumulated during sync to find local messages that the server no longer has." (when-let* ((entry (assoc queryid jabber-mam--sync-received #'string=))) (let* ((data (cdr entry)) (ids (plist-get data :ids)) (min-ts (plist-get data :min-ts)) (max-ts (plist-get data :max-ts)) (account (plist-get data :account)) (peer (plist-get data :peer))) (when (and min-ts max-ts (> (hash-table-count ids) 0)) (when-let* ((db (jabber-db-ensure-open))) (let ((local-rows (sqlite-select db "\ SELECT id, stanza_id, server_id FROM message \ WHERE account = ? AND peer = ? AND timestamp BETWEEN ? AND ? \ AND retracted_by IS NULL" (list account peer min-ts max-ts))) (deleted 0)) (dolist (row local-rows) (let ((row-id (nth 0 row)) (sid (nth 1 row)) (svid (nth 2 row))) ;; Only consider messages that have a server-side ID. ;; Messages without IDs can't be compared. (when (and (or sid svid) (not (and svid (gethash svid ids))) (not (and sid (gethash sid ids)))) (sqlite-execute db "DELETE FROM message WHERE id = ?" (list row-id)) (cl-incf deleted)))) (when (> deleted 0) (message "MAM: removed %d messages not found on server" deleted)))))) (setq jabber-mam--sync-received (cl-remove queryid jabber-mam--sync-received :key #'car :test #'string=)))) (declare-function jabber-chat-buffer-msg-count "jabber-chatbuffer" ()) (defun jabber-mam-sync-buffer () "Sync messages from the server archive for this buffer. Uses `jabber-chat-buffer-msg-count' for the number of messages. Fetches recent messages using RSM backward pagination. New messages are decrypted and stored; existing messages are preserved via dedup. Failed-decrypt placeholders are replaced if decryption now succeeds. Local messages in the synced time range whose IDs are not found on the server are deleted. The buffer is refreshed in place after sync." (interactive) (unless (memq jabber-buffer-connection jabber-connections) (user-error "Not connected")) (let* ((jc jabber-buffer-connection) (count (jabber-chat-buffer-msg-count)) (group (bound-and-true-p jabber-group)) (peer (or group (jabber-jid-user (bound-and-true-p jabber-chatting-with)))) (account (jabber-connection-bare-jid jc)) (muc-p (not (null group))) (queryid (jabber-mam--make-queryid))) ;; Register ID tracking for post-sync reconciliation. (push (cons queryid (list :ids (make-hash-table :test #'equal) :min-ts nil :max-ts nil :account account :peer peer)) jabber-mam--sync-received) (let ((type (if group "groupchat" "chat"))) (push (cons queryid (lambda () (jabber-mam--reconcile-sync queryid) (run-hook-with-args 'jabber-mam-peer-syncing-functions peer type nil))) jabber-mam--completion-callbacks) (run-hook-with-args 'jabber-mam-peer-syncing-functions peer type t)) (jabber-mam--mark-dirty peer (if group "groupchat" "chat")) (message "MAM: syncing last %d messages for %s..." count peer) (if muc-p (jabber-mam--query jc nil queryid nil nil peer t count) (jabber-mam--query jc nil queryid peer nil nil t count)))) ;;; On-demand history fetch (defun jabber-mam-fetch-peer-history (jc peer &optional muc-p callback) "Fetch full MAM history for PEER via JC. When MUC-P is non-nil, query the room archive (to=PEER). When CALLBACK is non-nil, call it with no arguments after the query completes (including all pagination)." (let ((queryid (jabber-mam--make-queryid))) (when callback (push (cons queryid callback) jabber-mam--completion-callbacks)) (if muc-p (jabber-mam--query jc nil queryid nil nil peer) (jabber-mam--query jc nil queryid peer nil nil)))) ;;; Disconnect cleanup (defun jabber-mam--cleanup-connection (jc) "Clean up MAM state for connection JC. Called from `jabber-lost-connection-hooks' on involuntary disconnect." (let ((jc-queries (cl-remove-if-not (lambda (entry) (eq (car entry) jc)) jabber-mam--syncing))) (when jc-queries (setq jabber-mam--syncing (cl-set-difference jabber-mam--syncing jc-queries)) (condition-case nil (dotimes (_ (length jc-queries)) (jabber-mam--tx-end)) (error nil)) ;; Fire and remove leaked completion callbacks and query targets. (dolist (entry jc-queries) (let ((qid (cdr entry))) (when-let* ((cb (assoc qid jabber-mam--completion-callbacks #'string=))) (setq jabber-mam--completion-callbacks (delq cb jabber-mam--completion-callbacks)) (condition-case err (funcall (cdr cb)) (error (message "MAM: cleanup callback error: %S" err)))) (setq jabber-mam--query-targets (cl-remove qid jabber-mam--query-targets :key #'car :test #'string=)))) ;; Redraw affected buffers. (jabber-mam--redraw-dirty)))) (defun jabber-mam--cleanup-all () "Clean up all MAM state on voluntary disconnect. Called from `jabber-pre-disconnect-hook'." (condition-case nil (dotimes (_ jabber-mam--tx-depth) (jabber-mam--tx-end)) (error nil)) ;; Fire remaining completion callbacks to clear syncing flags. (dolist (cb jabber-mam--completion-callbacks) (condition-case err (funcall (cdr cb)) (error (message "MAM: cleanup callback error: %S" err)))) (setq jabber-mam--syncing nil jabber-mam--tx-depth 0 jabber-mam--completion-callbacks nil jabber-mam--query-targets nil jabber-mam--sync-received nil) (jabber-mam--redraw-dirty)) ;;; MUC query cancellation (defun jabber-mam--cancel-muc-query (room) "Cancel any active MUC MAM query for ROOM. Removes the query from syncing state and decrements the transaction depth. Called when leaving a room to stop wasting bandwidth." (when-let* ((target-entry (cl-find room jabber-mam--query-targets :key #'cdr :test #'string=))) (let ((qid (car target-entry))) (setq jabber-mam--syncing (cl-remove qid jabber-mam--syncing :key #'cdr :test #'string=)) (setq jabber-mam--query-targets (delq target-entry jabber-mam--query-targets)) (when-let* ((cb (assoc qid jabber-mam--completion-callbacks #'string=))) (setq jabber-mam--completion-callbacks (delq cb jabber-mam--completion-callbacks)) (condition-case err (funcall (cdr cb)) (error (message "MAM: cleanup callback error: %S" err)))) (condition-case nil (jabber-mam--tx-end) (error nil)) (when (zerop jabber-mam--tx-depth) (jabber-mam--redraw-dirty))))) ;;; Registration (jabber-disco-advertise-feature jabber-mam-xmlns) (with-eval-after-load "jabber-core" (jabber-chain-add 'jabber-message-chain #'jabber-mam--process-message -10)) (with-eval-after-load "jabber-core" (add-hook 'jabber-post-connect-hooks #'jabber-mam-maybe-catchup) (add-hook 'jabber-pre-disconnect-hook #'jabber-mam--cleanup-all) (add-hook 'jabber-lost-connection-hooks #'jabber-mam--cleanup-connection)) (provide 'jabber-mam) ;;; jabber-mam.el ends here emacs-jabber/lisp/jabber-menu.el000066400000000000000000000271361516610113500170610ustar00rootroot00000000000000;;; jabber-menu.el --- menu definitions -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (eval-when-compile (require 'cl-lib)) (require 'jabber-util) (require 'transient) (require 'wid-edit) ;;;###autoload (defvar jabber-menu (let ((map (make-sparse-keymap "jabber-menu"))) (define-key-after map [jabber-menu-connect] '("Connect" . jabber-connect-all)) (define-key-after map [jabber-menu-disconnect] '(menu-item "Disconnect" jabber-disconnect :enable (bound-and-true-p jabber-connections))) (define-key-after map [jabber-menu-status] `(menu-item "Set Status" ,(make-sparse-keymap "set-status") :enable (bound-and-true-p jabber-connections))) (define-key map [jabber-menu-status jabber-menu-status-chat] `(menu-item "Chatty" ,(lambda () (interactive) (jabber-send-presence "chat" (jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*) *jabber-current-priority*)) :button (:radio . (and (boundp '*jabber-current-show*) (equal *jabber-current-show* "chat"))))) (define-key map [jabber-menu-status jabber-menu-status-dnd] `(menu-item "Do not Disturb" ,(lambda () (interactive) (jabber-send-presence "dnd" (jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*) *jabber-current-priority*)) :button (:radio . (and (boundp '*jabber-current-show*) (equal *jabber-current-show* "dnd"))))) (define-key map [jabber-menu-status jabber-menu-status-xa] '(menu-item "Extended Away" jabber-send-xa-presence :button (:radio . (and (boundp '*jabber-current-show*) (equal *jabber-current-show* "xa"))))) (define-key map [jabber-menu-status jabber-menu-status-away] '(menu-item "Away" jabber-send-away-presence :button (:radio . (and (boundp '*jabber-current-show*) (equal *jabber-current-show* "away"))))) (define-key map [jabber-menu-status jabber-menu-status-online] '(menu-item "Online" jabber-send-default-presence :button (:radio . (and (boundp '*jabber-current-show*) (equal *jabber-current-show* ""))))) (define-key-after map [separator] '(menu-item "--")) (define-key-after map [jabber-menu-chat-with] '(menu-item "Chat with..." jabber-chat-with :enable (bound-and-true-p jabber-connections))) (define-key-after map [jabber-menu-nextmsg] '(menu-item "Next unread message" jabber-activity-switch-to :enable (bound-and-true-p jabber-activity-jids))) (define-key-after map [jabber-menu-send-subscription-request] '(menu-item "Send subscription request" jabber-send-subscription-request :enable (bound-and-true-p jabber-connections))) (define-key-after map [jabber-menu-roster] '("Switch to roster" . jabber-roster)) (define-key-after map [separator2] '(menu-item "--")) (define-key-after map [jabber-menu-customize] '("Customize" . jabber-customize)) (define-key-after map [jabber-menu-info] '("Help" . jabber-info)) map)) ;;;###autoload (defcustom jabber-display-menu 'maybe "Decide whether the \"Jabber\" menu is displayed in the menu bar. If t, always display. If nil, never display. If maybe, display if jabber.el is installed under `package-user-dir', or if any of `jabber-account-list' or `jabber-connections' is non-nil." :group 'jabber :type '(choice (const :tag "Never" nil) (const :tag "Always" t) (const :tag "When installed by user, or when any accounts have been configured or connected" maybe))) (defun jabber-menu (&optional remove) "Put \"Jabber\" menu on menubar. With prefix argument, remove it." (interactive "P") (setq jabber-display-menu (if remove nil t)) (force-mode-line-update)) (make-obsolete 'jabber-menu "set the variable `jabber-display-menu' instead." "2008") ;;;###autoload (define-key-after (lookup-key global-map [menu-bar]) [jabber-menu] (list 'menu-item "Jabber" jabber-menu :visible '(or (eq jabber-display-menu t) (and (eq jabber-display-menu 'maybe) (or (bound-and-true-p jabber-account-list) (bound-and-true-p jabber-connections)))))) ;; Global reference declarations (declare-function jabber-send-presence "jabber-presence.el" (show status priority &optional jc)) (declare-function jabber-send-xa-presence "jabber-presence.el" (&optional status jc)) (declare-function jabber-send-default-presence "jabber-presence.el" (&optional jc)) (declare-function jabber-send-away-presence "jabber-presence.el" (&optional status jc)) (declare-function jabber-activity-switch-to "jabber-activity.el" (&optional jid-param)) (declare-function jabber-chat-with "jabber-chat.el" (jc jid &optional other-window)) (declare-function jabber-chat-muc-presence-patterns-select "jabber-chat.el" (global)) (declare-function jabber-chat-buffer-switch "jabber-chatbuffer.el" ()) (declare-function jabber-roster "jabber-roster.el" ()) (declare-function jabber-disconnect "jabber-core.el" (&optional arg interactivep)) (declare-function jabber-connect-all "jabber-core.el" (&optional arg)) (declare-function jabber-muc-join "jabber-muc.el" (jc group nickname &optional popup)) (declare-function jabber-compose "jabber-compose.el" (jc &optional recipient)) (declare-function jabber-roster-change "jabber-presence.el" (jc jid name groups)) (declare-function jabber-send-subscription-request "jabber-presence.el" (jc to &optional request)) (declare-function jabber-roster-delete "jabber-presence.el" (jc jid)) (declare-function jabber-get-disco-items "jabber-disco.el" (jc to &optional node)) (declare-function jabber-get-disco-info "jabber-disco.el" (jc to &optional node)) (declare-function jabber-get-browse "jabber-browse.el" (jc to)) (declare-function jabber-get-version "jabber-version.el" (jc to)) (declare-function jabber-ping "jabber-ping.el" (to)) (declare-function jabber-get-info "jabber-info.el" (jc to)) (declare-function jabber-muc-get-info "jabber-info.el" (jc group nickname)) (declare-function jabber-get-time "jabber-time.el" (jc to)) (declare-function jabber-vcard-get "jabber-vcard.el" (jc jid)) (declare-function jabber-muc-create "jabber-muc.el" (jc group nickname)) (declare-function jabber-muc-leave "jabber-muc.el" (jc group)) (declare-function jabber-muc-nick "jabber-muc.el" (jc group nickname)) (declare-function jabber-muc-set-topic "jabber-muc.el" (jc group topic)) (declare-function jabber-muc-invite "jabber-muc.el" (jc jid group reason)) (declare-function jabber-muc-names "jabber-muc.el" ()) (declare-function jabber-muc-get-config "jabber-muc.el" (jc group)) (declare-function jabber-muc-set-role "jabber-muc.el" (jc group nickname role reason)) (declare-function jabber-muc-set-affiliation "jabber-muc.el" (jc group nickname-or-jid nickname-p affiliation reason)) (declare-function jabber-muc-private "jabber-muc.el" (jc group nickname)) (declare-function jabber-muc-vcard-get "jabber-muc.el" (jc group nickname)) (declare-function jabber-get-register "jabber-register.el" (jc to)) (declare-function jabber-get-search "jabber-search.el" (jc to)) (declare-function jabber-ahc-execute-command "jabber-ahc.el" (jc to node)) (declare-function jabber-ahc-get-list "jabber-ahc.el" (jc to)) (declare-function jabber-enable-carbons "jabber-carbons.el" (jc)) ;;;###autoload (transient-define-prefix jabber-chat-menu () "Jabber chat commands." [["Chat" ("c" "Start chat" jabber-chat-with) ("m" "Compose message" jabber-compose)]]) ;;;###autoload (transient-define-prefix jabber-roster-context-menu () "Jabber roster commands." [["Roster" ("a" "Add/modify contact" jabber-roster-change) ("s" "Subscribe" jabber-send-subscription-request) ("d" "Delete roster entry" jabber-roster-delete)]]) ;;;###autoload (transient-define-prefix jabber-info-menu () "Jabber info/discovery commands." [["Discovery" ("I" "Get info" jabber-get-info) ("i" "Disco items" jabber-get-disco-items) ("d" "Disco info" jabber-get-disco-info) ("b" "Browse" jabber-get-browse) ("v" "Client version" jabber-get-version) ("p" "Ping" jabber-ping) ("t" "Request time" jabber-get-time) ("V" "View vCard" jabber-vcard-get)]]) ;;;###autoload (transient-define-prefix jabber-muc-menu () "Jabber MUC commands." [["Room" ("j" "Join" jabber-muc-join) ("J" "Create room" jabber-muc-create) ("l" "Leave" jabber-muc-leave) ("t" "Set topic" jabber-muc-set-topic) ("c" "Configure" jabber-muc-get-config)] ["Participants" ("n" "Change nick" jabber-muc-nick) ("I" "Get info" jabber-muc-get-info) ("i" "Invite" jabber-muc-invite) ("w" "List participants" jabber-muc-names) ("p" "Private chat" jabber-muc-private) ("v" "Request vcard" jabber-muc-vcard-get)] ["Admin" ("r" "Set role" jabber-muc-set-role) ("a" "Set affiliation" jabber-muc-set-affiliation)]]) ;;;###autoload (transient-define-prefix jabber-service-menu () "Jabber service commands." [["Services" ("r" "Register" jabber-get-register) ("s" "Search directory" jabber-get-search) ("c" "Execute command" jabber-ahc-execute-command) ("l" "Command list" jabber-ahc-get-list) ("C" "Enable carbons" jabber-enable-carbons)]]) (define-obsolete-function-alias 'jabber-popup-chat-menu #'jabber-chat-menu "29.1") (define-obsolete-function-alias 'jabber-popup-roster-menu #'jabber-roster-context-menu "29.1") (define-obsolete-function-alias 'jabber-popup-info-menu #'jabber-info-menu "29.1") (define-obsolete-function-alias 'jabber-popup-muc-menu #'jabber-muc-menu "29.1") (define-obsolete-function-alias 'jabber-popup-service-menu #'jabber-service-menu "29.1") (define-obsolete-function-alias 'jabber-popup-combined-menu #'jabber-chat-menu "29.1") ;;;; Keymaps (defvar-keymap jabber-common-keymap :doc "Common keymap shared by jabber chat, roster, console and IQ buffers." "C-c C-c" #'jabber-chat-menu "C-c C-r" #'jabber-roster-context-menu "C-c C-i" #'jabber-info-menu "C-c C-m" #'jabber-muc-menu "C-c C-s" #'jabber-service-menu "TAB" #'forward-button "" #'backward-button) (defvar-keymap jabber-global-keymap :doc "Global Jabber keymap (usually under C-x C-j)." "C-c" #'jabber-connect-all "C-d" #'jabber-disconnect "C-r" #'jabber-roster "C-j" #'jabber-chat-with "C-l" #'jabber-activity-switch-to "C-a" #'jabber-send-away-presence "C-o" #'jabber-send-default-presence "C-y" #'jabber-chat-muc-presence-patterns-select "C-x" #'jabber-send-xa-presence "C-p" #'jabber-send-presence "C-b" #'jabber-chat-buffer-switch "C-m" #'jabber-muc-join) (define-key ctl-x-map "\C-j" jabber-global-keymap) (provide 'jabber-menu) ;;; jabber-menu.el ends here emacs-jabber/lisp/jabber-message-correct.el000066400000000000000000000152521516610113500211740ustar00rootroot00000000000000;;; jabber-message-correct.el --- XEP-0308 Last Message Correction -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; Implements XEP-0308 Last Message Correction. ;; ;; A correction stanza is a normal carrying a ;; child. ;; The receiver finds the original message by that id, replaces its body ;; in-place and marks it as edited. ;; ;; Send: `jabber-correct-last-message' (C-c C-e) re-sends your last ;; message with a child and updates the local buffer entry. ;;; Code: (require 'jabber-xml) (require 'jabber-chatbuffer) (require 'jabber-db) (declare-function jabber-jid-user "jabber-util" (jid)) (declare-function jabber-chat-send "jabber-chat" (jc body &optional extra-elements)) (declare-function jabber-muc-send "jabber-muc" (jc body &optional extra-elements)) (declare-function jabber-muc-find-buffer "jabber-muc" (group)) (declare-function jabber-connection-bare-jid "jabber-util" (jc)) (declare-function jabber-disco-advertise-feature "jabber-disco" (feature)) (declare-function jabber-db-message-sender-by-stanza-id "jabber-db" (stanza-id)) (defconst jabber-message-correct-xmlns "urn:xmpp:message-correct:0" "XML namespace for XEP-0308 Last Message Correction.") ;;; Parsing (defun jabber-message-correct--replace-id (xml-data) "Return the id from the child of XML-DATA, or nil." (when-let* ((el (jabber-xml-child-with-xmlns xml-data jabber-message-correct-xmlns))) (jabber-xml-get-attribute el 'id))) ;;; Sender validation (defun jabber-message-correct--valid-sender-p (original-from new-from muc-p) "Return non-nil if NEW-FROM may correct a message from ORIGINAL-FROM. MUC-P non-nil means full-JID comparison; otherwise bare-JID comparison." (if muc-p (string= original-from new-from) (string= (jabber-jid-user original-from) (jabber-jid-user new-from)))) ;;; Apply correction (defun jabber-message-correct--apply (replace-id new-body new-from muc-p buffer) "Apply correction REPLACE-ID with NEW-BODY sent by NEW-FROM. MUC-P non-nil for groupchat. BUFFER is the chat buffer or nil. Validates sender against the stored original message (via DB lookup) before writing. If the original is not in the DB the correction is dropped. Returns non-nil when the correction was accepted." (let ((original-from (jabber-db-message-sender-by-stanza-id replace-id))) (cond ((null original-from) (message "XEP-0308: correction for unknown message %s dropped" replace-id) nil) ((not (jabber-message-correct--valid-sender-p original-from new-from muc-p)) (message "XEP-0308: rejected correction from %s for message by %s" new-from original-from) nil) (t (jabber-db-correct-message replace-id new-body) (when buffer (with-current-buffer buffer (when-let* ((node (jabber-chat-ewoc-find-by-id replace-id)) (data (ewoc-data node)) (msg (cadr data))) (setq msg (plist-put msg :body new-body)) (setq msg (plist-put msg :edited t)) (setcar (cdr data) msg) (jabber-chat-ewoc-invalidate node)))) t)))) ;;; Inhibit DB storage of correction stanzas (defun jabber-message-correct--inhibit (_jc xml-data) "Return non-nil to prevent logging XML-DATA as a new message." (not (null (jabber-message-correct--replace-id xml-data)))) (add-to-list 'jabber-history-inhibit-received-message-functions #'jabber-message-correct--inhibit) ;;; Disco feature advertisement (jabber-disco-advertise-feature jabber-message-correct-xmlns) ;;; Find last sent message (pure) (defun jabber-message-correct--find-last-sent (ewoc) "Return (NODE ID BODY) for the last sent message in EWOC, or nil." (let (result (node (ewoc-nth ewoc -1))) (while (and node (not result)) (pcase-let ((`(,type ,msg) (ewoc-data node))) (when (and (memq type '(:local :muc-local)) (listp msg) (plist-get msg :id)) (setq result (list node (plist-get msg :id) (or (plist-get msg :body) ""))))) (setq node (ewoc-prev ewoc node))) result)) ;;; Build replace element (pure) (defun jabber-message-correct--replace-element (stanza-id) "Return a XML element referencing STANZA-ID." `(replace ((id . ,stanza-id) (xmlns . ,jabber-message-correct-xmlns)))) ;;; Update ewoc entry in-place (defun jabber-message-correct--update-ewoc (ewoc node new-body) "Update NODE in EWOC with NEW-BODY and mark as edited." (let* ((data (ewoc-data node)) (msg (cadr data))) (setq msg (plist-put msg :body new-body)) (setq msg (plist-put msg :edited t)) (setcar (cdr data) msg) (let ((buffer-undo-list t)) (ewoc-invalidate ewoc node)))) ;;; Interactive command (defun jabber-correct-last-message () "Correct the last sent message in this chat buffer. Prompts with the existing body pre-filled." (interactive) (pcase (jabber-message-correct--find-last-sent jabber-chat-ewoc) ('nil (user-error "No sent message found to correct")) (`(,node ,id ,body) (let ((new-body (read-string "Correction: " body))) (when (string= new-body body) (user-error "No change")) (jabber-message-correct--update-ewoc jabber-chat-ewoc node new-body) (jabber-db-correct-message id new-body) (let ((replace-el (jabber-message-correct--replace-element id)) (muc-p (bound-and-true-p jabber-group))) (if muc-p (jabber-muc-send jabber-buffer-connection new-body (list replace-el)) (jabber-chat-send jabber-buffer-connection new-body (list replace-el)))))))) (provide 'jabber-message-correct) ;;; jabber-message-correct.el ends here emacs-jabber/lisp/jabber-message-reply.el000066400000000000000000000150761516610113500206720ustar00rootroot00000000000000;;; jabber-message-reply.el --- XEP-0461 Message Replies -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; XEP-0461 Message Replies with XEP-0428 Fallback Indication. ;; Adds reply-to-message support in chat buffers. The user positions ;; point on a message, invokes `jabber-chat-reply', a quoted fallback ;; is inserted into the composition area, and on send the and ;; elements are added to the stanza. The fallback text is ;; kept in the displayed body as-is. ;;; Code: (require 'ewoc) (require 'jabber-disco) (require 'jabber-xml) (declare-function jabber-jid-displayname "jabber-util" (jid)) (declare-function jabber-jid-username "jabber-util" (jid)) (declare-function jabber-jid-user "jabber-util" (jid)) (declare-function jabber-jid-resource "jabber-util" (jid)) (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el (defvar jabber-chat-send-hooks) ; jabber-chat.el (defvar jabber-point-insert) ; jabber-chatbuffer.el (defvar jabber-group) ; jabber-muc.el (defconst jabber-message-reply-xmlns "urn:xmpp:reply:0" "XEP-0461 Message Replies namespace.") (defconst jabber-message-reply-fallback-xmlns "urn:xmpp:fallback:0" "XEP-0428 Fallback Indication namespace.") ;;; Buffer-local reply state (defvar-local jabber-message-reply--id nil "Stanza ID of the message being replied to.") (defvar-local jabber-message-reply--jid nil "JID of the original message author.") (defvar-local jabber-message-reply--fallback-length nil "Character count of the fallback prefix in the composition area.") ;;; Pure functions (defun jabber-message-reply--build-fallback-text (author body) "Build a fallback quote string from AUTHOR and BODY. Returns \"> Author:\\n> line1\\n> line2\\n\"." (let ((lines (if (or (null body) (string-empty-p body)) nil (split-string body "\n")))) (concat "> " author ":\n" (mapconcat (lambda (line) (concat "> " line)) lines "\n") "\n"))) (defun jabber-message-reply--select-id (msg muc-p) "Select the appropriate message ID from MSG for a reply. In MUC (when MUC-P is non-nil), prefer :server-id. In 1:1 chat, use :id. Returns nil if unavailable." (if muc-p (or (plist-get msg :server-id) (plist-get msg :id)) (plist-get msg :id))) ;;; Send hook (defun jabber-message-reply--send-hook (body _id) "Add and elements when replying to a message. BODY is the message text. Clears reply state after producing elements." (when jabber-message-reply--id (let ((reply-id jabber-message-reply--id) (reply-jid jabber-message-reply--jid) (fb-len jabber-message-reply--fallback-length)) (setq jabber-message-reply--id nil jabber-message-reply--jid nil jabber-message-reply--fallback-length nil) (let ((elements (list `(reply ((xmlns . ,jabber-message-reply-xmlns) (to . ,reply-jid) (id . ,reply-id)))))) (when (and fb-len (> fb-len 0) (<= fb-len (length body))) (push `(fallback ((xmlns . ,jabber-message-reply-fallback-xmlns) (for . ,jabber-message-reply-xmlns)) (body ((start . "0") (end . ,(number-to-string fb-len))))) elements)) elements)))) (with-eval-after-load "jabber-chat" (add-hook 'jabber-chat-send-hooks #'jabber-message-reply--send-hook)) ;;; Helpers (defun jabber-message-reply--author-name (jid) "Return a short display name for JID. In MUC buffers the resource is the nickname. In 1:1 chat, use the username part of the JID." (if (bound-and-true-p jabber-group) (or (jabber-jid-resource jid) (jabber-jid-displayname jid)) (or (jabber-jid-username jid) (jabber-jid-user jid)))) ;;; Interactive commands ;;;###autoload (defun jabber-chat-reply () "Reply to the message at point in the ewoc. Stores reply state and inserts fallback quote text at point-max." (interactive) (unless (bound-and-true-p jabber-chat-ewoc) (user-error "Not in a chat buffer")) (let* ((ewoc-node (ewoc-locate jabber-chat-ewoc (point))) (data (and ewoc-node (ewoc-data ewoc-node))) (msg (and data (cadr data))) (muc-p (bound-and-true-p jabber-group)) (id (and msg (jabber-message-reply--select-id msg muc-p)))) (unless id (user-error "No message ID at point")) (let* ((from (plist-get msg :from)) (author (if from (jabber-message-reply--author-name from) "me")) (body (or (plist-get msg :body) "")) (jid (or from "")) (fallback (jabber-message-reply--build-fallback-text author body))) (setq jabber-message-reply--id id jabber-message-reply--jid (if (stringp jid) jid (format "%s" jid)) jabber-message-reply--fallback-length (length fallback)) (goto-char (point-max)) (insert fallback) (message "Replying to %s (C-c C-k to cancel)" author)))) ;;;###autoload (defun jabber-chat-cancel-reply () "Cancel the pending reply and remove fallback text." (interactive) (when jabber-message-reply--id (let ((fb-len jabber-message-reply--fallback-length)) (setq jabber-message-reply--id nil jabber-message-reply--jid nil jabber-message-reply--fallback-length nil) (when (and fb-len (> fb-len 0)) (save-excursion (goto-char jabber-point-insert) (delete-char (min fb-len (- (point-max) (point))))))) (message "Reply cancelled"))) ;;; Disco (jabber-disco-advertise-feature jabber-message-reply-xmlns) (provide 'jabber-message-reply) ;;; jabber-message-reply.el ends here emacs-jabber/lisp/jabber-modeline.el000066400000000000000000000177371516610113500177170ustar00rootroot00000000000000;;; jabber-modeline.el --- display jabber status in modeline -*- lexical-binding: t; -*- ;; Copyright (C) 2004 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'jabber-presence) (require 'jabber-alert) (eval-when-compile (require 'cl-lib)) (defgroup jabber-mode-line nil "Display Jabber status in mode line" :group 'jabber) (defcustom jabber-mode-line-compact t "Count contacts in fewer categories for compact view." :type 'boolean) (defcustom jabber-modeline-sections '(activity) "Which sections to show in the mode line. Available sections: `presence', `contacts', `activity'." :type '(set (const presence) (const contacts) (const activity))) (defvar jabber-mode-line-presence "") (defvar jabber-mode-line-contacts "") ;; Global reference declarations (defvar *jabber-current-show*) ; jabber.el (defvar jabber-presence-strings) ; jabber.el ;; Activity variables (defined in jabber-activity.el) (declare-function jabber-activity--init "jabber-activity") (declare-function jabber-activity--teardown "jabber-activity") (declare-function jabber-activity--on-disconnect "jabber-activity") (defvar jabber-activity-mode-string) (defvar jabber-activity-count-in-title) (defvar jabber-activity-count-in-title-format) ;; (defconst jabber-modeline--eval-form '(:eval (jabber-modeline--render)) "The `:eval' form added to `global-mode-string'.") (defun jabber-modeline--render () "Return the string to display in the mode line." (let ((parts nil)) (when (and (memq 'activity jabber-modeline-sections) (not (string-empty-p jabber-activity-mode-string))) (push jabber-activity-mode-string parts)) (when (and (memq 'contacts jabber-modeline-sections) (not (string-empty-p jabber-mode-line-contacts))) (push jabber-mode-line-contacts parts)) (when (and (memq 'presence jabber-modeline-sections) (not (string-empty-p jabber-mode-line-presence))) (push jabber-mode-line-presence parts)) (if parts (concat " " (string-join parts " ")) ""))) (defun jabber-mode-line-presence-update (&rest _) "Update `jabber-mode-line-presence' from current connection state." (setq jabber-mode-line-presence (if (and jabber-connections (not *jabber-disconnecting*)) (cdr (assoc *jabber-current-show* jabber-presence-strings)) "Offline"))) (defvar jabber-mode-line--recount-timer nil "Pending timer for a debounced `jabber-mode-line--do-count-contacts' call.") (defun jabber-mode-line--do-count-contacts () "Perform the actual O(roster) presence recount." (setq jabber-mode-line--recount-timer nil) (let ((count (list (cons "chat" 0) (cons "" 0) (cons "away" 0) (cons "xa" 0) (cons "dnd" 0) (cons nil 0)))) (dolist (jc jabber-connections) (dolist (buddy (plist-get (fsm-get-state-data jc) :roster)) (when-let* ((cell (assoc (get buddy 'show) count))) (cl-incf (cdr cell))))) (setq jabber-mode-line-contacts (if jabber-mode-line-compact (format "(%d/%d/%d)" (+ (cdr (assoc "chat" count)) (cdr (assoc "" count))) (+ (cdr (assoc "away" count)) (cdr (assoc "xa" count)) (cdr (assoc "dnd" count))) (cdr (assoc nil count))) (apply #'format "(%d/%d/%d/%d/%d/%d)" (mapcar #'cdr count)))) (force-mode-line-update t))) (defun jabber-mode-line-count-contacts (&rest _ignore) "Schedule a debounced roster recount (coalesces rapid presence bursts)." (when (timerp jabber-mode-line--recount-timer) (cancel-timer jabber-mode-line--recount-timer)) (setq jabber-mode-line--recount-timer (run-with-timer 0.1 nil #'jabber-mode-line--do-count-contacts))) (defun jabber-modeline--add-to-frame-title () "Add activity count to `frame-title-format' and `icon-title-format'." (dolist (var '(frame-title-format icon-title-format)) (let ((fmt (symbol-value var))) (unless (member jabber-activity-count-in-title-format fmt) (if (equal (car-safe fmt) "") (set var (cons "" (cons jabber-activity-count-in-title-format (cdr fmt)))) (set var (list "" jabber-activity-count-in-title-format fmt))))))) (defun jabber-modeline--remove-from-frame-title () "Remove activity count from `frame-title-format' and `icon-title-format'." (dolist (var '(frame-title-format icon-title-format)) (when (listp (symbol-value var)) (set var (delete jabber-activity-count-in-title-format (symbol-value var)))))) (defun jabber-modeline--on-disconnect () "Clear all modeline state on disconnect." (when (timerp jabber-mode-line--recount-timer) (cancel-timer jabber-mode-line--recount-timer) (setq jabber-mode-line--recount-timer nil)) (jabber-mode-line--do-count-contacts) (jabber-activity--on-disconnect) (jabber-mode-line-presence-update)) ;;;###autoload (define-minor-mode jabber-modeline-mode "Toggle display of Jabber status in mode lines. Which sections are shown is controlled by `jabber-modeline-sections'." :global t (if jabber-modeline-mode (progn (unless global-mode-string (setq global-mode-string '(""))) (jabber-mode-line-presence-update) (jabber-mode-line-count-contacts) (add-hook 'jabber-send-presence #'jabber-mode-line-presence-update) (add-hook 'jabber-post-disconnect-hook #'jabber-mode-line-presence-update) (add-hook 'jabber-presence-hooks #'jabber-mode-line-count-contacts) (add-hook 'jabber-post-disconnect-hook #'jabber-modeline--on-disconnect) (jabber-activity--init) (when jabber-activity-count-in-title (jabber-modeline--add-to-frame-title)) (add-to-list 'global-mode-string jabber-modeline--eval-form t)) (when (timerp jabber-mode-line--recount-timer) (cancel-timer jabber-mode-line--recount-timer) (setq jabber-mode-line--recount-timer nil)) (setq jabber-mode-line-presence "" jabber-mode-line-contacts "") (remove-hook 'jabber-send-presence #'jabber-mode-line-presence-update) (remove-hook 'jabber-post-disconnect-hook #'jabber-mode-line-presence-update) (remove-hook 'jabber-presence-hooks #'jabber-mode-line-count-contacts) (remove-hook 'jabber-post-disconnect-hook #'jabber-modeline--on-disconnect) (jabber-activity--teardown) (jabber-modeline--remove-from-frame-title) (setq global-mode-string (delete jabber-modeline--eval-form global-mode-string)) (force-mode-line-update t))) ;; Backward compatibility (defalias 'jabber-mode-line-mode #'jabber-modeline-mode) (defun jabber-activity-mode (&optional arg) "Toggle the `activity' section in `jabber-modeline-sections'. With a positive ARG, ensure activity is shown. With a zero or negative ARG, remove activity." (interactive "P") (if (if arg (> (prefix-numeric-value arg) 0) (not (memq 'activity jabber-modeline-sections))) (cl-pushnew 'activity jabber-modeline-sections) (setq jabber-modeline-sections (delq 'activity jabber-modeline-sections))) (force-mode-line-update t)) (provide 'jabber-modeline) ;;; jabber-modeline.el ends here emacs-jabber/lisp/jabber-moderation.el000066400000000000000000000217061516610113500202530ustar00rootroot00000000000000;;; jabber-moderation.el --- XEP-0425: Moderated Message Retraction -*- lexical-binding: t; -*- ;; Copyright (C) 2026 - Thanos Apollo ;; Author: Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;; Implements XEP-0425 (Moderated Message Retraction) send/receive and ;; uses the XEP-0424 element on incoming stanzas. When a MUC ;; moderator retracts a message, the original is replaced with a tombstone ;; in the chat buffer. ;;; Code: (require 'ewoc) (require 'jabber-xml) (require 'jabber-disco) (require 'jabber-iq) (declare-function jabber-chain-add "jabber-core" (chain-var handler &optional depth)) (declare-function jabber-jid-user "jabber-util" (jid)) (declare-function jabber-jid-resource "jabber-util" (jid)) (declare-function jabber-muc-find-buffer "jabber-muc" (group)) (declare-function jabber-muc-nickname "jabber-muc" (group &optional jc)) (declare-function jabber-chat-ewoc-find-by-id "jabber-chatbuffer" (stanza-id)) (declare-function jabber-chat-ewoc-invalidate "jabber-chatbuffer" (node)) (declare-function jabber-send-iq "jabber-iq" (jc to type query success-callback success-closure-data error-callback error-closure-data &optional result-id)) (declare-function jabber-report-success "jabber-util" (_jc xml-data context)) (declare-function jabber-db-retract-message "jabber-db" (server-id retracted-by &optional reason)) (declare-function jabber-db-occupant-id-by-server-id "jabber-db" (server-id)) (declare-function jabber-db-server-ids-by-occupant-id "jabber-db" (account peer occupant-id)) (declare-function jabber-connection-bare-jid "jabber-util" (jc)) (defvar jabber-message-chain) ; jabber-core.el (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el (defvar jabber-group) ; jabber-muc.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defconst jabber-moderation-xmlns "urn:xmpp:message-moderate:1" "XML namespace for XEP-0425 Message Moderation.") (defconst jabber-moderation-retract-xmlns "urn:xmpp:message-retract:1" "XML namespace for XEP-0424 Message Retraction.") (defun jabber-moderation--handle-message (_jc xml-data) "Handle moderated message retraction in XML-DATA. If the stanza contains a with a child, look up the original message in the MUC buffer and replace it with a tombstone." (when-let* ((type (jabber-xml-get-attribute xml-data 'type)) ((string= type "groupchat")) (retract (jabber-xml-child-with-xmlns xml-data jabber-moderation-retract-xmlns)) (moderated (car (jabber-xml-get-children retract 'moderated))) (stanza-id (jabber-xml-get-attribute retract 'id)) (from (jabber-xml-get-attribute xml-data 'from)) (room (jabber-jid-user from)) ;; Only accept retractions from the MUC service itself ;; (bare room JID, no resource). ((not (jabber-jid-resource from)))) (let* ((moderator (or (jabber-xml-get-attribute moderated 'by) ;; Prosody sends the v0 / ;; with the moderator JID but omits it from the v1 ;; / element. Fall back to v0. (when-let* ((apply-to (jabber-xml-child-with-xmlns xml-data "urn:xmpp:fasten:0")) (mod-v0 (car (jabber-xml-get-children apply-to 'moderated)))) (jabber-xml-get-attribute mod-v0 'by)))) (reason-el (car (jabber-xml-get-children retract 'reason))) (reason (car (jabber-xml-node-children reason-el))) (buf (jabber-muc-find-buffer room))) (when moderator (jabber-db-retract-message stanza-id moderator reason)) (when buf (with-current-buffer buf (jabber-moderation--mark-ewoc-retracted stanza-id moderator reason)))) t)) (with-eval-after-load "jabber-core" (jabber-chain-add 'jabber-message-chain #'jabber-moderation--handle-message)) ;; XEP-0424: clients SHOULD advertise retract support so senders know we ;; handle tombstones. The moderate namespace is a MUC-service feature ;; and MUST NOT be advertised by clients. (jabber-disco-advertise-feature jabber-moderation-retract-xmlns) (defun jabber-moderation--mark-ewoc-retracted (server-id retracted-by reason) "Mark the ewoc node with SERVER-ID as retracted in the current buffer. RETRACTED-BY and REASON are stored on the message plist." (when-let* ((node (jabber-chat-ewoc-find-by-id server-id)) (data (ewoc-data node)) (msg (cadr data)) ((equal server-id (plist-get msg :server-id)))) (setq msg (plist-put msg :retracted t)) (setq msg (plist-put msg :retracted-by retracted-by)) (setq msg (plist-put msg :retraction-reason reason)) (setcar (cdr data) msg) (jabber-chat-ewoc-invalidate node))) (defun jabber-moderation--send-retract (jc room server-id &optional reason) "Send a moderation IQ to retract SERVER-ID in ROOM on JC. Also marks the message as retracted locally in the DB and ewoc. Optional REASON is a human-readable string." (let ((moderator (concat room "/" (jabber-muc-nickname room jc)))) (jabber-db-retract-message server-id moderator reason) (when-let* ((buf (jabber-muc-find-buffer room))) (with-current-buffer buf (jabber-moderation--mark-ewoc-retracted server-id moderator reason)))) (jabber-send-iq jc room "set" `(moderate ((id . ,server-id) (xmlns . ,jabber-moderation-xmlns)) (retract ((xmlns . ,jabber-moderation-retract-xmlns))) ,@(when (and reason (not (string-empty-p reason))) `((reason () ,reason)))) #'jabber-report-success "Message retraction" #'jabber-report-success "Message retraction")) (defun jabber-moderation-retract () "Retract the MUC message at point via XEP-0425 moderation. Sends a moderation IQ to the room requesting retraction of the message under point. Requires moderator privileges." (interactive) (unless (bound-and-true-p jabber-group) (user-error "Not in a MUC buffer")) (let* ((node (ewoc-locate jabber-chat-ewoc (point))) (data (and node (ewoc-data node))) (msg (and data (listp (cadr data)) (cadr data))) (server-id (and msg (plist-get msg :server-id)))) (unless server-id (user-error "No server-assigned stanza ID on this message")) (let ((reason (read-string "Reason (empty for none): "))) (jabber-moderation--send-retract jabber-buffer-connection jabber-group server-id reason)))) (defun jabber-moderation-retract-by-occupant () "Retract all MUC messages from the occupant at point. Uses XEP-0421 occupant-id to find all messages, sends individual moderation IQs for each." (interactive) (unless (bound-and-true-p jabber-group) (user-error "Not in a MUC buffer")) (let* ((node (ewoc-locate jabber-chat-ewoc (point))) (data (and node (ewoc-data node))) (msg (and data (listp (cadr data)) (cadr data))) (server-id (and msg (plist-get msg :server-id)))) (unless server-id (user-error "No server-assigned stanza ID on this message")) (let ((occupant-id (jabber-db-occupant-id-by-server-id server-id))) (unless occupant-id (user-error "No occupant-id for this message")) (let* ((account (jabber-connection-bare-jid jabber-buffer-connection)) (ids (jabber-db-server-ids-by-occupant-id account jabber-group occupant-id)) (count (length ids))) (unless ids (user-error "No retractable messages for this occupant")) (when (y-or-n-p (format "Retract %d message%s from this occupant? " count (if (= count 1) "" "s"))) (let ((reason (read-string "Reason (empty for none): "))) (dolist (id ids) (jabber-moderation--send-retract jabber-buffer-connection jabber-group id reason)) (message "Sent %d retraction request%s" count (if (= count 1) "" "s")))))))) (provide 'jabber-moderation) ;;; jabber-moderation.el ends here emacs-jabber/lisp/jabber-muc-nick-completion.el000066400000000000000000000167001516610113500217650ustar00rootroot00000000000000;;; jabber-muc-nick-completion.el --- Add nick completion abilyty to emacs-jabber -*- lexical-binding: t; -*- ;; Copyright (C) 2008 - Terechkov Evgenii - evg@altlinux.org ;; Copyright (C) 2007, 2008, 2010 - Kirill A. Korinskiy - catap@catap.ru ;; Copyright (C) 2007 - Serguei Jidkov - jsv@e-mail.ru ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; History: ;; ;;; Code: (require 'cl-lib) (require 'jabber-chatbuffer) ;;; User customizations here: (defcustom jabber-muc-completion-delimiter ": " "String to add to end of completion line." :type 'string :group 'jabber-chat) (defcustom jabber-muc-looks-personaling-symbols '("," ":" ">") "Symbols for personaling messages." :type '(repeat string) :group 'jabber-chat) (defcustom jabber-muc-personal-message-bonus (* 60 20) "Bonus for personal message, in seconds." :type 'integer :group 'jabber-chat) (defcustom jabber-muc-all-string "all" "String meaning all conference members (to insert in completion). Note that \":\" or alike not needed (it appended in other string)" :type 'string :group 'jabber-chat) (defvar *jabber-muc-participant-last-speaking* nil "Global alist in form (group . ((member . time-of-last-speaking) ...) ...).") ;; Global reference declarations (declare-function jabber-muc-nickname "jabber-muc.el" (group &optional jc)) (defvar jabber-group) ; jabber-muc.el (defvar jabber-muc-default-nicknames) ; jabber-muc.el (defvar jabber-muc-participants) ; jabber-muc.el (defvar jabber-chatting-with) ; jabber-chat.el ;; (defun jabber-my-nick (&optional group) "Return my jabber nick in GROUP." (let ((room (or group jabber-group))) (or (jabber-muc-nickname room) (cdr (assoc room jabber-muc-default-nicknames))))) ;;;###autoload (defun jabber-muc-looks-like-personal-p (message &optional group) "Return non-nil if jabber MESSAGE is addresed to me. Optional argument GROUP to look." (if message (string-match (concat "^" (jabber-my-nick group) (regexp-opt jabber-muc-looks-personaling-symbols)) message) nil)) (defun jabber-muc-nicknames () "List of conference participants, excluding self, or nil if we not in conference." (cl-delete-if (lambda (nick) (string= nick (jabber-my-nick))) (append (mapcar #'car (cdr (assoc jabber-group jabber-muc-participants))) (list jabber-muc-all-string)))) (defun jabber-muc-participant-update-activity (group nick time) "Update NICK's time of last speaking in GROUP to TIME." (let* ((room (assoc group *jabber-muc-participant-last-speaking*)) (room-activity (cdr room)) (entry (assoc nick room-activity)) (old-time (or (cdr entry) 0))) (when (> time old-time) ;; don't use put-alist for speed (progn (if entry (setcdr entry time) (setq room-activity (cons (cons nick time) room-activity))) (if room (setcdr room room-activity) (setq *jabber-muc-participant-last-speaking* (cons (cons group room-activity) *jabber-muc-participant-last-speaking*))))))) (defun jabber-muc-track-message-time (nick group _buffer text &optional _title) "Tracks time of NICK's last speaking in GROUP." (when nick (let ((time (float-time))) (jabber-muc-participant-update-activity group nick (if (jabber-muc-looks-like-personal-p text group) (+ time jabber-muc-personal-message-bonus) time))))) (defun jabber-sort-nicks (nicks group) "Return list of NICKS in GROUP, sorted." ;; when completing word at beginning of line each nick, each element of NICKS ;; has a trailing completion-delimiter (usually ": "). (let ((times (cdr (assoc group *jabber-muc-participant-last-speaking*)))) (cl-flet ((fetch-time (nick) (let ((time-entry (assoc (if (string-suffix-p jabber-muc-completion-delimiter nick) (substring nick 0 (- (length nick) 2)) nick) times))) (cons nick (if time-entry (cdr time-entry) 0)))) (cmp (nt1 nt2) (let ((t1 (cdr nt1)) (t2 (cdr nt2))) (if (and (zerop t1) (zerop t2)) (string< (car nt1) (car nt2)) (> t1 t2))))) (mapcar #'car (sort (mapcar #'fetch-time nicks) #'cmp))))) (defun jabber-muc-beginning-of-line () "Return position of line begining." (save-excursion (if (looking-back jabber-muc-completion-delimiter (line-beginning-position)) (backward-char (+ (length jabber-muc-completion-delimiter) 1))) (skip-syntax-backward "^-") (point))) (defun jabber-muc-active-participants (group) "Return nicks for speaking participants." (let ((times (cdr (assoc group *jabber-muc-participant-last-speaking*)))) (cl-remove-if-not (lambda (nick) (assoc nick times)) (jabber-muc-nicknames)))) (defun jabber-muc-nick-completion-at-point () "Nick completion function for `completion-at-point'." (when (bound-and-true-p jabber-group) (let* ((completion-begin (max (line-beginning-position) (or jabber-point-insert (point-min)))) (group jabber-group) (beg (save-excursion (skip-syntax-backward "^ " completion-begin) (point))) (start-of-line-p (= beg completion-begin)) (nicks (jabber-muc-nicknames)) (table (mapcar (lambda (str) (if start-of-line-p (concat str jabber-muc-completion-delimiter) str)) nicks)) (prefix (buffer-substring-no-properties beg (point)))) (when (cl-some (lambda (c) (string-prefix-p prefix c t)) table) (list beg (point) (lambda (str pred action) (if (eq action 'metadata) `(metadata (display-sort-function . ,(lambda (nicks) (jabber-sort-nicks nicks group))) (cycle-sort-function . ,(lambda (nicks) (jabber-sort-nicks nicks group)))) (complete-with-action action table str pred)))))))) (add-hook 'jabber-muc-hooks #'jabber-muc-track-message-time) (provide 'jabber-muc-nick-completion) ;;; jabber-muc-nick-completion.el ends here emacs-jabber/lisp/jabber-muc.el000066400000000000000000002462661516610113500167100ustar00rootroot00000000000000;;; jabber-muc.el --- advanced MUC functions -*- lexical-binding: t; -*- ;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru ;; Copyright (C) 2003, 2004, 2007, 2008, 2009, 2010 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'cl-lib) (require 'jabber-widget) (require 'jabber-disco) ;; we need jabber-bookmarks for jabber-muc-autojoin (via ;; jabber-get-bookmarks and jabber-parse-conference-bookmark): (require 'jabber-bookmarks) (require 'ewoc) (defconst jabber-muc-xmlns "http://jabber.org/protocol/muc" "XEP-0045 MUC namespace.") (defconst jabber-muc-xmlns-user "http://jabber.org/protocol/muc#user" "XEP-0045 MUC user namespace.") (defconst jabber-muc-xmlns-owner "http://jabber.org/protocol/muc#owner" "XEP-0045 MUC owner namespace.") (defconst jabber-muc-xmlns-admin "http://jabber.org/protocol/muc#admin" "XEP-0045 MUC admin namespace.") (defconst jabber-muc-xmlns-direct-invite "jabber:x:conference" "XEP-0249 Direct MUC Invitations namespace.") (defvar jabber-muc--rooms (make-hash-table :test #'equal) "Internal hash table of active MUC rooms. Keys are group JID strings; values are lists of (JC . NICKNAME) cons cells, one per connection that has joined the room. This allows multiple accounts to be in the same room simultaneously.") (defvar jabber-muc--generation 0 "Generation counter for `jabber-muc--rooms'. Incremented on every join/leave, enabling cheap change detection without copying the room list.") (defun jabber-muc-nickname (group &optional jc) "Return our nickname in GROUP, or nil. If JC is given, return the nickname for that specific connection. Otherwise return the nickname from the first entry." (let ((entries (gethash group jabber-muc--rooms))) (if jc (alist-get jc entries) (cdar entries)))) (defun jabber-muc-connection (group) "Return a connection object for GROUP, or nil. When multiple accounts are in the same room, returns the first." (caar (gethash group jabber-muc--rooms))) (defun jabber-muc-joined-p (group &optional jc) "Return non-nil if we are in GROUP. If JC is given, check whether that specific connection is in GROUP." (let ((entries (gethash group jabber-muc--rooms))) (if jc (and (assq jc entries) t) (and entries t)))) (defun jabber-muc-our-nick-p (group nick) "Return non-nil if NICK is our nickname in GROUP on any connection." (let ((entries (gethash group jabber-muc--rooms))) (cl-some (lambda (entry) (string= nick (cdr entry))) entries))) (defun jabber-muc-room-entries (group) "Return list of (JC . NICKNAME) entries for GROUP." (gethash group jabber-muc--rooms)) (defun jabber-muc-active-rooms () "Return list of joined room JIDs." (hash-table-keys jabber-muc--rooms)) (defun jabber-muc-join-set (group jc nickname) "Record that we joined GROUP via JC with NICKNAME." (let ((entries (gethash group jabber-muc--rooms))) (if-let* ((existing (assq jc entries))) (setcdr existing nickname) (push (cons jc nickname) entries)) (puthash group entries jabber-muc--rooms)) (cl-incf jabber-muc--generation)) (defun jabber-muc-leave-remove (group &optional jc) "Remove GROUP from active rooms. If JC is given, only remove that connection's entry; the room stays tracked if other connections remain in it." (if jc (let ((entries (gethash group jabber-muc--rooms))) (setq entries (assq-delete-all jc entries)) (if entries (puthash group entries jabber-muc--rooms) (remhash group jabber-muc--rooms))) (remhash group jabber-muc--rooms)) (cl-incf jabber-muc--generation)) (defun jabber-muc-generation () "Return current generation counter for change detection." jabber-muc--generation) (defvar jabber-pending-groupchats (make-hash-table) "Hash table of groupchats and nicknames. Keys are JID symbols; values are strings. This table records the last nickname used to join the particular chat room. Items are thus never removed.") (defvar jabber-muc-participants nil "Alist of groupchats and participants. Keys are strings, the bare JID of the room. Values are lists of nickname strings.") (defvar jabber-group nil "The groupchat you are participating in.") (defvar jabber-muc-topic "" "The topic of the current MUC room.") (defvar-local jabber-muc--auto-configure nil "When non-nil, automatically open the config form on room creation. Set by `jabber-muc-create' and consumed by `jabber-muc--enter-extra-notices'.") (defvar jabber-role-history () "Keeps track of previously used roles.") (defvar jabber-affiliation-history () "Keeps track of previously used affiliations.") (defvar jabber-muc-nickname-history () "Keeps track of previously referred-to nicknames.") (defvar jabber-muc--rooms-before-disconnect nil "Alist of (ROOM . NICK) saved before disconnect. Used to rejoin non-bookmarked rooms on reconnect.") (defvar jabber-muc--autojoin-queue nil "Alist of (JC . ((COUNT GROUP . NICK) ...)) for prioritized MUC autojoin. Each entry is sorted by COUNT (occupant count from disco#items). Rooms with fewer occupants join first. COUNT is `most-positive-fixnum' for rooms whose disco query failed.") (defvar jabber-muc--autojoin-timer nil "Timer for autojoin timeout fallback. If a self-presence doesn't arrive within the timeout, advance to the next queued room.") (defvar jabber-muc--autojoin-pending nil "Alist of (JC . ((GROUP . NICK) ...)) awaiting disco#items query. Rooms are moved from here into `jabber-muc--autojoin-queue' as disco results arrive. Only `jabber-muc-autojoin-max-disco' queries are in-flight at once to avoid saturating the SM window.") (defvar jabber-muc--autojoin-disco-count nil "Alist of (JC . COUNT) tracking in-flight disco#items queries.") (defcustom jabber-muc-autojoin-max-disco 5 "Maximum concurrent disco#items queries during autojoin. Limits how many disco queries are in-flight simultaneously to avoid saturating the SM back-pressure window." :type 'natnum :group 'jabber-muc) (defcustom jabber-muc-autojoin-timeout 10 "Seconds to wait for a MUC self-presence before joining the next room. During staggered autojoin, if the server doesn't respond within this many seconds, the room is skipped and the next one is tried." :type 'integer :group 'jabber-muc) ;;; MUC status codes (XEP-0045) (defconst jabber-muc-status-self-presence "110") (defconst jabber-muc-status-room-created "201") (defconst jabber-muc-status-nick-modified "210") (defconst jabber-muc-status-banned "301") (defconst jabber-muc-status-nick-changed "303") (defconst jabber-muc-status-kicked "307") (defconst jabber-muc-status-nick-not-allowed "406") (defconst jabber-muc-status-nick-conflict "409") (defcustom jabber-muc-default-nicknames nil "Default nickname for specific MUC rooms." :group 'jabber-chat :type '(repeat (cons :format "%v" (string :tag "JID of room") (string :tag "Nickname")))) (defcustom jabber-muc-autojoin nil "List of MUC rooms to automatically join on connection. This list is saved in your Emacs customizations. You can also store such a list on the Jabber server, where it is available to every client; see `jabber-edit-bookmarks'." :group 'jabber-chat :type '(repeat (string :tag "JID of room"))) (defcustom jabber-muc-disable-disco-check nil "If non-nil, disable checking disco#info of rooms before joining them. Disco information can tell whether the room exists and whether it is password protected, but some servers do not support it. If you want to join chat rooms on such servers, set this variable to t." :group 'jabber-chat :type 'boolean) (defcustom jabber-muc-self-ping-interval 180 "Seconds between periodic MUC self-pings. Set to 0 to disable. When non-zero, all joined rooms are pinged at this interval to detect silent server-side drops. Rooms that fail are automatically rejoined. See XEP-0410." :type 'natnum :group 'jabber-chat) (defvar jabber-muc--self-ping-timer nil "Timer for periodic MUC self-pings.") (defcustom jabber-groupchat-buffer-format "*#%n-%a*" "The format specification for the name of groupchat buffers. These fields are available (all are about the group you are chatting in): %n Roster name of group, or JID if no nickname set %b Name of group from bookmarks or roster name or JID if none set %j Bare JID (without resource) These fields are about your account: %a Your bare JID (account) %u Your username %s Your server" :type 'string :group 'jabber-chat) (defcustom jabber-muc-header-line-format '(" " (:eval (propertize (jabber-jid-displayname jabber-group) 'face 'shadow)) " " (:eval jabber-chat-encryption-message) ;see jabber-chatbuffer.el (:eval (when jabber-chat-mam-syncing (propertize " [syncing]" 'face 'shadow)))) "The specification for the header line of MUC buffers. The format is that of `mode-line-format' and `header-line-format'." :type 'sexp :group 'jabber-chat) (defcustom jabber-muc-private-buffer-format "*%g/%n-%a*" "The format specification for the buffer name for private MUC messages. These fields are available: %g Roster name of group, or JID if no nickname set %n Nickname of the group member you're chatting with These fields are about your account: %a Your bare JID (account) %u Your username %s Your server" :type 'string :group 'jabber-chat) (defcustom jabber-muc-print-names-format " %n %a %j\n" "The format specification for MUC list lines. Fields available: %n Nickname in room %a Affiliation status %j Full JID (room@server/nick)" :type 'string :group 'jabber-chat) (defcustom jabber-muc-private-header-line-format '(" " (:eval (jabber-jid-resource jabber-chatting-with)) " in " (:eval (jabber-jid-displayname (jabber-jid-user jabber-chatting-with))) "\t" (:eval jabber-chatstates-message) " " (:eval jabber-chat-encryption-message)) ;see jabber-chatbuffer.el "The specification for the header line of private MUC chat buffers. The format is that of `mode-line-format' and `header-line-format'." :type 'sexp :group 'jabber-chat) ;; Global reference declarations (declare-function jabber-chain-add "jabber-core" (chain-var handler &optional depth)) (declare-function jabber-presence-children "jabber-presence.el" (jc)) (declare-function jabber-vcard-get "jabber-vcard.el" (jc jid)) (declare-function jabber-get-version "jabber-version.el" (jc to)) (declare-function jabber-get-disco-info "jabber-disco.el" (jc to &optional node)) (declare-function jabber-disco-get-items "jabber-disco.el" (jc jid node callback closure-data &optional force)) (declare-function jabber-ping-send "jabber-ping.el" (jc to process-func on-success on-error)) (declare-function jabber-process-ping "jabber-ping.el" (_jc xml-data)) (declare-function jabber-parse-conference-bookmark "jabber-bookmarks.el" (node)) (declare-function jabber-get-bookmarks-from-cache "jabber-bookmarks" (jc)) (declare-function jabber-send-sexp "jabber-core.el" (jc sexp)) (declare-function jabber-chat--run-send-hooks "jabber-chat.el" (stanza body id)) (declare-function jabber-chat-send "jabber-chat.el" (jc body &optional extra-elements)) (declare-function jabber-send-message "jabber-chat.el" (jc to subject body type)) (declare-function jabber-maybe-print-rare-time "jabber-chat.el" (node)) (declare-function jabber-chat-pp "jabber-chat.el" (data)) (declare-function jabber-chat-mode "jabber-chatbuffer.el" ()) (declare-function jabber-chat-mode-setup "jabber-chatbuffer.el" (jc ewoc-pp)) (declare-function jabber-chat-ewoc-enter "jabber-chatbuffer.el" (data)) (declare-function jabber-chatbuffer--registry-put "jabber-chatbuffer" (type key)) (declare-function jabber-chatbuffer--registry-get "jabber-chatbuffer" (type key)) (declare-function jabber-chat-insert-backlog-entry "jabber-chat.el" (msg-plist)) (declare-function jabber-chat--insert-backlog-chunked "jabber-chat.el" (buffer entries callback &optional generation)) (declare-function jabber-chat-display-buffer-images "jabber-chat.el" ()) (declare-function jabber-chat--msg-plist-from-stanza "jabber-chat.el" (xml-data &optional delayed)) (declare-function jabber-chat--insert-prompt "jabber-chat.el" (timestamp nick face &optional plaintext-face encrypted)) (declare-function jabber-chat--format-time "jabber-chat.el" (timestamp delayed)) (declare-function jabber-omemo--send-muc "jabber-omemo.el" (jc body &optional extra-elements)) (declare-function jabber-omemo--prefetch-sessions "jabber-omemo" (jc jid)) (declare-function jabber-omemo--prefetch-muc-sessions "jabber-omemo" (jc group)) (declare-function jabber-openpgp--send-muc "jabber-openpgp.el" (jc body &optional extra-elements)) (declare-function jabber-openpgp-legacy--send-muc "jabber-openpgp-legacy.el" (jc body &optional extra-elements)) (declare-function jabber-chat--decrypt-if-needed "jabber-chat.el" (jc xml-data)) (declare-function jabber-db-last-timestamp "jabber-db.el" (account peer)) (declare-function jabber-db-get-chat-encryption "jabber-db.el" (account peer)) (declare-function jabber-chat-encryption--update-header "jabber-chatbuffer.el" ()) (declare-function jabber-mam-muc-joined "jabber-mam.el" (jc group)) (declare-function jabber-mam--cancel-muc-query "jabber-mam.el" (room)) (declare-function jabber-bookmarks-auto-add-maybe "jabber-bookmarks.el" (jc jid nick)) (declare-function jabber-db-backlog "jabber-db.el" (account peer &optional count start-time resource msg-type)) (declare-function jabber-message-correct--replace-id "jabber-message-correct" (xml-data)) (declare-function jabber-message-correct--apply "jabber-message-correct" (replace-id new-body new-from muc-p buffer)) (defvar jabber-silent-mode) ; jabber.el (defvar jabber-message-chain) ; jabber-core.el (defvar jabber-alert-muc-function) ; jabber-alert.el (defvar jabber-body-printers) ; jabber-chat.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-chat-delayed-time-format) ; jabber-chat.el (defvar jabber-chat-delayed-time-format) ; jabber-chat.el (defvar jabber-chat-encryption) ; jabber-chatbuffer.el (defvar jabber-chat-send-hooks) ; jabber-chat.el (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el (defvar jabber-chat--backlog-generation) ; jabber-chatbuffer.el (defvar jabber-chat-printers) ; jabber-chat.el (defvar jabber-chat-time-format) ; jabber-chat.el (defvar jabber-connections) ; jabber-core.el (defvar jabber-post-disconnect-hook) ; jabber-core.el (defvar jabber-send-function) ; jabber-console.el (defvar jabber-xdata-xmlns) ; jabber-xml.el (defvar jabber-delay-xmlns) ; jabber-xml.el (defvar jabber-delay-legacy-xmlns) ; jabber-xml.el ;; ;;;###autoload (defvar jabber-muc-printers '() "List of functions that may be able to print part of a MUC message. This gets prepended to `jabber-chat-printers', which see.") ;;;###autoload (defun jabber-muc-get-buffer (group &optional jc) "Return the chat buffer name for chatroom GROUP. When JC is provided, account-specific format specs (%a, %u, %s) are expanded. Either a string or a buffer is returned, so use `get-buffer' or `get-buffer-create'." (format-spec jabber-groupchat-buffer-format (list (cons ?n (jabber-jid-displayname group)) (cons ?b (jabber-jid-bookmarkname group)) (cons ?j (jabber-jid-user group)) (cons ?a (if jc (jabber-connection-bare-jid jc) "")) (cons ?u (if jc (plist-get (fsm-get-state-data jc) :username) "")) (cons ?s (if jc (plist-get (fsm-get-state-data jc) :server) ""))))) (defun jabber-muc-find-buffer (group) "Find an existing MUC buffer for GROUP, or nil." (jabber-chatbuffer--registry-get 'muc group)) (defun jabber-muc-create-buffer (jc group) "Prepare a buffer for chatroom GROUP. This function is idempotent. JC is the Jabber connection." (with-current-buffer (get-buffer-create (jabber-muc-get-buffer group jc)) (unless (eq major-mode 'jabber-chat-mode) (jabber-chat-mode) (setq-local jabber-group group) (setq-local jabber-muc-topic nil) (jabber-chat-mode-setup jc #'jabber-chat-pp) (setq jabber-send-function #'jabber-muc-send) (setq header-line-format jabber-muc-header-line-format) (setq-local jabber-chat-earliest-backlog nil) (when (null jabber-chat-earliest-backlog) (let ((backlog-entries (jabber-db-backlog (jabber-connection-bare-jid jc) (jabber-jid-user group) nil nil nil "groupchat"))) (if (null backlog-entries) (setq jabber-chat-earliest-backlog (float-time)) (setq jabber-chat-earliest-backlog (float-time (plist-get (car (last backlog-entries)) :timestamp))) (cl-incf jabber-chat--backlog-generation) (jabber-chat--insert-backlog-chunked (current-buffer) backlog-entries #'jabber-chat-display-buffer-images jabber-chat--backlog-generation)))) (when-let* ((win (get-buffer-window (current-buffer)))) (with-selected-window win (goto-char jabber-point-insert) (recenter -1)))) ;; Make sure the connection variable is up to date. (setq jabber-buffer-connection jc) (jabber-chatbuffer--registry-put 'muc group) (current-buffer))) ;;;###autoload (defun jabber-muc-private-get-buffer (group nickname &optional jc) "Return the chat buffer name for private chat with NICKNAME in GROUP. When JC is provided, account-specific format specs (%a, %u, %s) are expanded. Either a string or a buffer is returned, so use `get-buffer' or `get-buffer-create'." (format-spec jabber-muc-private-buffer-format (list (cons ?g (jabber-jid-displayname group)) (cons ?n nickname) (cons ?a (if jc (jabber-connection-bare-jid jc) "")) (cons ?u (if jc (plist-get (fsm-get-state-data jc) :username) "")) (cons ?s (if jc (plist-get (fsm-get-state-data jc) :server) ""))))) (defun jabber-muc-private-find-buffer (group nickname) "Find an existing MUC private buffer for GROUP/NICKNAME, or nil." (jabber-chatbuffer--registry-get 'muc-private (format "%s/%s" group nickname))) (defun jabber-muc-private-create-buffer (jc group nickname) "Prepare a buffer for chatting with NICKNAME in GROUP. This function is idempotent. JC is the Jabber connection." (with-current-buffer (get-buffer-create (jabber-muc-private-get-buffer group nickname jc)) (unless (eq major-mode 'jabber-chat-mode) (jabber-chat-mode) ;; Set jabber-chatting-with before mode-setup so the DB peer ;; lookup uses the correct JID. (setq-local jabber-chatting-with (concat group "/" nickname)) (jabber-chat-mode-setup jc #'jabber-chat-pp) ;; MUC private messages are addressed to an occupant JID, not a ;; real bare JID, so OMEMO/OpenPGP session setup cannot work. ;; Default to plaintext like MUC buffers. (unless (jabber-db-get-chat-encryption (jabber-connection-bare-jid jc) (jabber-jid-user jabber-chatting-with)) (setq jabber-chat-encryption 'plaintext) (jabber-chat-encryption--update-header))) (setq-local jabber-chatting-with (concat group "/" nickname)) (jabber-chatbuffer--registry-put 'muc-private (format "%s/%s" group nickname)) (setq jabber-send-function #'jabber-chat-send) (setq header-line-format jabber-muc-private-header-line-format) (setq-local jabber-chat-earliest-backlog nil) (when (null jabber-chat-earliest-backlog) (let ((backlog-entries (jabber-db-backlog (jabber-connection-bare-jid jc) group nil nil nickname))) (if (null backlog-entries) (setq jabber-chat-earliest-backlog (float-time)) (setq jabber-chat-earliest-backlog (float-time (plist-get (car (last backlog-entries)) :timestamp))) (cl-incf jabber-chat--backlog-generation) (jabber-chat--insert-backlog-chunked (current-buffer) backlog-entries #'jabber-chat-display-buffer-images jabber-chat--backlog-generation)))) (current-buffer))) (defun jabber-muc-send (jc body &optional extra-elements) "Send BODY to MUC room in current buffer. JC is the Jabber connection. EXTRA-ELEMENTS, when non-nil, is a list of XML sexp elements to splice into the stanza after the body (e.g. XEP-0308 replace)." ;; There is no need to display the sent message in the buffer, as ;; we will get it back from the MUC server. (pcase jabber-chat-encryption ('omemo (require 'jabber-omemo) (jabber-omemo--send-muc jc body extra-elements)) ('openpgp (require 'jabber-openpgp) (jabber-openpgp--send-muc jc body extra-elements)) ('openpgp-legacy (require 'jabber-openpgp-legacy) (jabber-openpgp-legacy--send-muc jc body extra-elements)) (_ (let* ((id (format "emacs-msg-%.6f" (float-time))) (stanza `(message ((to . ,jabber-group) (type . "groupchat") (id . ,id)) (body () ,body) ,@extra-elements))) (jabber-chat--run-send-hooks stanza body id) (jabber-send-sexp jc stanza))))) (defun jabber-muc-add-groupchat (group nickname &optional jc) "Remember participating in GROUP under NICKNAME via JC." (jabber-muc-join-set group jc nickname)) (defun jabber-muc-remove-groupchat (group &optional jc) "Remove GROUP from internal bookkeeping. If JC is given, only remove that connection's entry." (jabber-muc-leave-remove group jc) (jabber-mam--cancel-muc-query group) ;; Only clear participants when no account remains in the room. (unless (jabber-muc-joined-p group) (let ((whichparticipants (assoc group jabber-muc-participants))) (setq jabber-muc-participants (delq whichparticipants jabber-muc-participants))))) (defun jabber-muc-connection-closed (bare-jid) "Remove MUC data for BARE-JID, saving room list for reconnect. Forget all information about rooms that had been entered with this JID. The room list is saved to `jabber-muc--rooms-before-disconnect' so non-bookmarked rooms can be rejoined on reconnect. When multiple accounts share a room, only the disconnecting account's entry is removed." (let (snapshot) (dolist (room (jabber-muc-active-rooms)) (let* ((entries (jabber-muc-room-entries room)) (match (cl-find bare-jid entries :key (lambda (e) (and (car e) (jabber-connection-bare-jid (car e)))) :test #'string=))) (when match (push (cons room (cdr match)) snapshot) ;; Clear autojoin queue for this connection. (jabber-muc--autojoin-clear (car match)) (jabber-muc-leave-remove room (car match)) ;; Only clear participants when no account remains in the room. (unless (jabber-muc-joined-p room) (let ((whichparticipants (assoc room jabber-muc-participants))) (setq jabber-muc-participants (delq whichparticipants jabber-muc-participants))))))) (setq jabber-muc--rooms-before-disconnect snapshot))) (defun jabber-muc--self-ping-failed (jc xml-data closure-data) "Handle failed MUC self-ping per XEP-0410 error classification. JC is the connection. XML-DATA is the IQ error stanza. CLOSURE-DATA is (ROOM . NICK). Error conditions per XEP-0410: - service-unavailable, feature-not-implemented, item-not-found: still joined (ping target doesn't support XEP-0199) - remote-server-not-found, remote-server-timeout: undecided, treat as transient failure - any other error (e.g. not-acceptable): not joined, rejoin" (let* ((room (car closure-data)) (nick (cdr closure-data)) (error-node (jabber-iq-error xml-data)) (condition (when error-node (jabber-error-condition error-node)))) (pcase condition ((or 'service-unavailable 'feature-not-implemented 'item-not-found) (message "MUC self-ping for %s: still joined (ping unsupported)" room)) ((or 'remote-server-not-found 'remote-server-timeout) (message "MUC self-ping for %s: server unreachable, will retry" room)) (_ (message "MUC self-ping failed for %s (%s), rejoining" room (or condition "unknown")) (jabber-muc-remove-groupchat room jc) (let ((password (jabber-get-conference-data jc room nil :password))) (jabber-muc--send-join-presence jc room nick password nil)))))) (defun jabber-muc--self-ping-one (jc group) "Self-ping GROUP via JC to verify membership. On success, does nothing. On failure, classifies the error per XEP-0410 and auto-rejoins if needed." (let ((nick (jabber-muc-nickname group jc))) (if (not nick) (message "MUC self-ping: no nick for %s, skipping" group) (let ((self-jid (format "%s/%s" group nick)) (closure (cons group nick))) (jabber-send-iq jc self-jid "get" '(ping ((xmlns . "urn:xmpp:ping"))) #'ignore nil #'jabber-muc--self-ping-failed closure))))) (defun jabber-muc-self-ping-rooms (jc) "Ping all joined MUC rooms via JC to verify membership. After SM resume, the MUC server may have kicked us while offline. Rooms that fail the self-ping are rejoined automatically. XEP-0410: MUC Self-Ping (Schroedingers Chat)." (let ((bare-jid (jabber-connection-bare-jid jc))) (dolist (room (jabber-muc-active-rooms)) (let ((room-jc (jabber-muc-connection room))) (when (and room-jc (string= bare-jid (jabber-connection-bare-jid room-jc))) (jabber-muc--self-ping-one jc room)))))) (defun jabber-muc-self-ping-start (&optional _jc) "Start periodic MUC self-ping timer. Pings all joined rooms on all connections every `jabber-muc-self-ping-interval' seconds. Suitable for `jabber-post-connect-hooks'." (jabber-muc-self-ping-stop) (when (> jabber-muc-self-ping-interval 0) (setq jabber-muc--self-ping-timer (run-with-timer jabber-muc-self-ping-interval jabber-muc-self-ping-interval #'jabber-muc--self-ping-all-connections)) (add-hook 'jabber-post-disconnect-hook #'jabber-muc-self-ping-stop))) (defun jabber-muc-self-ping-stop () "Cancel periodic MUC self-ping timer." (when jabber-muc--self-ping-timer (cancel-timer jabber-muc--self-ping-timer) (setq jabber-muc--self-ping-timer nil))) (defun jabber-muc--self-ping-all-connections () "Self-ping rooms on all active connections." (dolist (jc jabber-connections) (when (and jc (plist-get (fsm-get-state-data jc) :ever-session-established)) (jabber-muc-self-ping-rooms jc)))) (defun jabber-muc-participant-plist (group nickname) "Return plist associated with NICKNAME in GROUP. Return nil if nothing known about that combination." (let ((whichparticipants (assoc group jabber-muc-participants))) (when whichparticipants (cdr (assoc nickname whichparticipants))))) (defun jabber-muc--merge-plist (old new) "Merge NEW plist into OLD, returning the result. Keys in NEW overwrite OLD. Keys in OLD not present in NEW are preserved." (let ((result (copy-sequence (or old '())))) (cl-loop for (key val) on new by #'cddr do (setq result (plist-put result key val))) result)) (defun jabber-muc-modify-participant (group nickname new-plist) "Assign properties in NEW-PLIST to NICKNAME in GROUP. Existing properties not present in NEW-PLIST are preserved." (let ((participants (assoc group jabber-muc-participants))) ;; either we have a list of participants already... (if participants (let ((participant (assoc nickname participants))) ;; and maybe this participant is already in the list (if participant ;; if so, merge to preserve keys like jid across updates (setf (cdr participant) (jabber-muc--merge-plist (cdr participant) new-plist)) (push (cons nickname new-plist) (cdr participants)))) ;; or we don't (push (cons group (list (cons nickname new-plist))) jabber-muc-participants)))) (defun jabber-muc--format-affiliation-change (nickname from to actor-reason) "Generate message for affiliation transition of NICKNAME. FROM and TO are the old and new affiliation strings. ACTOR-REASON is the pre-formatted \" by actor: reason\" suffix. Return a string describing the change, or nil if unrecognized." ;; There are many ways to express these transitions in English. ;; This one favors eloquence over regularity and consistency. (cond ;; Higher affiliation ((or (and (member from '("outcast" "none" "member")) (member to '("admin" "owner"))) (and (string= from "admin") (string= to "owner"))) (concat nickname " has been promoted to " to actor-reason)) ;; Lower affiliation ((or (and (member from '("owner" "admin")) (string= to "member")) (and (string= from "owner") (string= to "admin"))) (concat nickname " has been demoted to " to actor-reason)) ;; Become member ((string= to "member") (concat nickname " has been granted membership" actor-reason)) ;; Lose membership ((string= to "none") (concat nickname " has been deprived of membership" actor-reason)))) (defun jabber-muc--format-role-change (nickname from to actor-reason) "Generate message for role transition of NICKNAME. FROM and TO are the old and new role strings. ACTOR-REASON is the pre-formatted \" by actor: reason\" suffix. Return a string describing the change, or nil." ;; Possible roles are "none" (not in room, hence not of interest ;; in this function), "visitor" (no voice), "participant" (has ;; voice), and "moderator". (cond ((string= to "moderator") (concat nickname " has been granted moderator privileges" actor-reason)) ((and (string= from "moderator") (string= to "participant")) (concat nickname " had moderator privileges revoked" actor-reason)) ((string= to "participant") (concat nickname " has been granted voice" actor-reason)) ((string= to "visitor") (concat nickname " has been denied voice" actor-reason)))) (defun jabber-muc-report-delta (nickname old-plist new-plist reason actor) "Compare OLD-PLIST and NEW-PLIST, and return a string explaining the change. Return nil if nothing noteworthy has happened. NICKNAME is the user experiencing the change. REASON and ACTOR, if non-nil, are the corresponding presence fields. This function is only concerned with presence stanzas resulting in the user entering/staying in the room." ;; The keys in the plist are affiliation, role and jid. (let ((display-nick (if (plist-get new-plist 'jid) (concat nickname " <" (jabber-jid-user (plist-get new-plist 'jid)) ">") nickname))) (cond ((null old-plist) (concat display-nick " enters the room (" (plist-get new-plist 'role) (unless (string= (plist-get new-plist 'affiliation) "none") (concat ", " (plist-get new-plist 'affiliation))) ")")) ;; If affiliation changes, the role change is usually the logical ;; one, so don't report it separately. ((not (string= (plist-get old-plist 'affiliation) (plist-get new-plist 'affiliation))) (let ((actor-reason (concat (when actor (concat " by " actor)) (when reason (concat ": " reason))))) (jabber-muc--format-affiliation-change display-nick (plist-get old-plist 'affiliation) (plist-get new-plist 'affiliation) actor-reason))) ;; Role changes ((not (string= (plist-get old-plist 'role) (plist-get new-plist 'role))) (let ((actor-reason (concat (when actor (concat " by " actor)) (when reason (concat ": " reason))))) (jabber-muc--format-role-change display-nick (plist-get old-plist 'role) (plist-get new-plist 'role) actor-reason)))))) (defun jabber-muc-remove-participant (group nickname) "Forget everything about NICKNAME in GROUP." (let ((participants (assoc group jabber-muc-participants))) (when participants (let ((participant (assoc nickname (cdr participants)))) (setf (cdr participants) (delq participant (cdr participants))))))) (defmacro jabber-muc-argument-list (&optional args) "Prepend connection and group name to ARGS. If the current buffer is not an MUC buffer, signal an error. This macro is meant for use as an argument to `interactive'." `(if (null jabber-group) (error "Not in MUC buffer") (nconc (list jabber-buffer-connection jabber-group) ,args))) (defun jabber-muc-read-completing (prompt &optional allow-not-joined) "Read the name of a joined chatroom, or use chatroom of current buffer if any. If ALLOW-NOT-JOINED is provided and non-nil, permit choosing any JID; only provide completion as a guide." (or jabber-group (let ((rooms (jabber-muc-active-rooms))) (jabber-read-jid-completing prompt (if (null rooms) (error "You haven't joined any group") (mapcar #'jabber-jid-symbol rooms)) (not allow-not-joined) jabber-group)))) (defun jabber-muc-read-nickname (group prompt) "Read the nickname of a participant in GROUP." (let ((nicknames (cdr (assoc group jabber-muc-participants)))) (unless nicknames (error "Unknown group: %s" group)) (completing-read prompt nicknames nil nil nil 'jabber-muc-nickname-history))) ;;;###autoload (defun jabber-muc-vcard-get (jc group nickname) "Request vcard from chat with NICKNAME in GROUP. JC is the Jabber connection." (interactive (jabber-muc-argument-list (list (jabber-muc-read-nickname jabber-group "Nickname: ")))) (let ((muc-name (format "%s/%s" group nickname))) (jabber-vcard-get jc muc-name))) ;;;###autoload (defun jabber-muc-get-version (jc group nickname) "Request software version from NICKNAME in GROUP. JC is the Jabber connection." (interactive (jabber-muc-argument-list (list (jabber-muc-read-nickname jabber-group "Nickname: ")))) (jabber-get-version jc (format "%s/%s" group nickname))) ;;;###autoload (defun jabber-muc-get-disco-info (jc group nickname) "Request disco info from NICKNAME in GROUP. JC is the Jabber connection." (interactive (jabber-muc-argument-list (list (jabber-muc-read-nickname jabber-group "Nickname: ")))) (jabber-get-disco-info jc (format "%s/%s" group nickname))) ;;;###autoload (defun jabber-muc-ping (jc group nickname) "Ping NICKNAME in GROUP. JC is the Jabber connection." (interactive (jabber-muc-argument-list (list (jabber-muc-read-nickname jabber-group "Nickname: ")))) (jabber-ping-send jc (format "%s/%s" group nickname) #'jabber-silent-process-data #'jabber-process-ping "Ping is unsupported")) (defun jabber-muc-instant-config (jc group) "Accept default configuration for GROUP. This can be used for a newly created room, as an alternative to filling out the configuration form with `jabber-muc-get-config'. Both of these methods unlock the room, so that other users can enter it. JC is the Jabber connection." (interactive (jabber-muc-argument-list)) (jabber-send-iq jc group "set" `(query ((xmlns . ,jabber-muc-xmlns-owner)) (x ((xmlns . ,jabber-xdata-xmlns) (type . "submit")))) #'jabber-report-success "MUC instant configuration" #'jabber-report-success "MUC instant configuration")) (defun jabber-muc-get-config (jc group) "Ask for MUC configuration form. JC is the Jabber connection." (interactive (jabber-muc-argument-list)) (jabber-send-iq jc group "get" `(query ((xmlns . ,jabber-muc-xmlns-owner))) #'jabber-process-data #'jabber-muc-render-config #'jabber-process-data "MUC configuration request failed")) (defun jabber-muc-render-config (jc xml-data) "Render MUC configuration form. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((query (jabber-iq-query xml-data)) xdata) (dolist (x (jabber-xml-get-children query 'x)) (if (string= (jabber-xml-get-attribute x 'xmlns) jabber-xdata-xmlns) (setq xdata x))) (if (not xdata) (message "No configuration possible.") (save-window-excursion (jabber-widget-init-buffer (jabber-xml-get-attribute xml-data 'from)) (setq jabber-buffer-connection jc) (jabber-widget-render-xdata-form xdata) (widget-create 'push-button :notify #'jabber-muc-submit-config "Submit") (widget-insert "\t") (widget-create 'push-button :notify #'jabber-muc-cancel-config "Cancel") (widget-insert "\n") (widget-setup) (widget-minor-mode 1) (recursive-edit))))) (defun jabber-muc-submit-config (&rest _ignore) "Submit MUC configuration form." (jabber-send-iq jabber-buffer-connection jabber-widget-submit-to "set" `(query ((xmlns . ,jabber-muc-xmlns-owner)) ,(jabber-widget-parse-xdata-form)) #'jabber-report-success "MUC configuration" #'jabber-report-success "MUC configuration") (exit-recursive-edit)) (defun jabber-muc-cancel-config (&rest _ignore) "Cancel MUC configuration form." (jabber-send-iq jabber-buffer-connection jabber-widget-submit-to "set" `(query ((xmlns . ,jabber-muc-xmlns-owner)) (x ((xmlns . ,jabber-xdata-xmlns) (type . "cancel")))) nil nil nil nil) (exit-recursive-edit)) (defun jabber-muc--validate-disco-result (result) "Classify a disco#info RESULT for MUC join. Return a plist describing the outcome: (:status ok :features FEATURES) - valid MUC service (:status not-found) - item-not-found (:status no-disco) - feature-not-implemented (:status not-conference) - not a conference (:status error :error-msg STR) - other error" (let* ((identities (car result)) (features (cadr result)) (condition (when (eq identities 'error) (jabber-error-condition result)))) (cond ((eq condition 'item-not-found) '(:status not-found)) ((eq condition 'feature-not-implemented) (list :status 'no-disco :features features)) (condition (list :status 'error :error-msg (jabber-parse-error result))) ((and (eq identities 'error) (not condition)) (list :status 'error :error-msg "Bad error stanza received")) ((cl-find "conference" (if (sequencep identities) identities nil) :key (lambda (i) (aref i 1)) :test #'string=) (list :status 'ok :features features)) (t '(:status not-conference))))) (defun jabber-muc--room-completions (jc) "Return completion candidates for rooms available to JC. Includes joined rooms and bookmarked rooms for this connection." (let ((rooms (make-hash-table :test #'equal))) ;; Joined rooms for this connection (maphash (lambda (group entries) (when (assq jc entries) (puthash group t rooms))) jabber-muc--rooms) ;; Bookmarked rooms (let ((bookmarks (jabber-get-bookmarks-from-cache jc))) (when (listp bookmarks) (dolist (bm bookmarks) (when-let* ((jid (plist-get bm :jid))) (puthash jid t rooms))))) (hash-table-keys rooms))) (defun jabber-muc-join (jc group nickname &optional popup) "Join a groupchat, or change nick. In interactive calls, or if POPUP is non-nil, switch to the groupchat buffer. JC is the Jabber connection." (interactive (let* ((account (jabber-read-account)) (group (completing-read "Groupchat: " (jabber-muc--room-completions account) nil nil nil nil)) (joined (jabber-muc-joined-p group account))) (list account group (if joined (jabber-muc-nickname group account) (or (jabber-muc-nickname group account) (jabber-muc-read-my-nickname account group))) t))) ;; Remove from autojoin queue to prevent double-join. (jabber-muc--autojoin-dequeue jc group) (cond ;; Already joined: open buffer, sync and verify membership. ((jabber-muc-joined-p group jc) (when popup (switch-to-buffer (jabber-muc-create-buffer jc group))) (jabber-mam-muc-joined jc group) (jabber-muc--self-ping-one jc group)) ;; Skip disco check if configured. (jabber-muc-disable-disco-check (jabber-muc--send-join-presence jc group nickname nil popup)) (t (jabber-disco-get-info jc group nil #'jabber-muc--disco-callback (list group nickname popup))))) ;;;###autoload (defun jabber-muc-create (jc group nickname) "Create a new MUC room and open its configuration form. Send join presence to GROUP with NICKNAME. When the server confirms creation (status 201), the room configuration form opens automatically. JC is the Jabber connection." (interactive (let* ((account (jabber-read-account)) (servers (let (s) (maphash (lambda (room _) (let ((host (jabber-jid-server room))) (unless (member host s) (push host s)))) jabber-muc--rooms) (nreverse s))) (server (completing-read "MUC server: " servers nil nil)) (name (read-string "Room name: ")) (group (concat name "@" server))) (list account group (jabber-muc-read-my-nickname account "")))) (jabber-muc--send-join-presence jc group nickname nil t t) (jabber-bookmarks--publish-one jc group nickname)) ;;;###autoload (defun jabber-muc-switch-to (group) "Switch to an active groupchat buffer. Prompt with completion for joined rooms only." (interactive (list (completing-read "Groupchat: " (jabber-muc-active-rooms) nil t))) (let* ((jc (jabber-muc-connection group)) (buffer (if jc (get-buffer (jabber-muc-get-buffer group jc)) (jabber-muc-find-buffer group)))) (if buffer (switch-to-buffer buffer) ;; Buffer was killed; recreate it. (when (setq jc (or jc (car jabber-connections))) (switch-to-buffer (jabber-muc-create-buffer jc group)))))) (defun jabber-muc--disco-callback (jc closure result) "Disco callback for MUC join. JC is the Jabber connection. CLOSURE is (GROUP NICKNAME POPUP). RESULT is the disco#info result." (pcase-let ((`(,group ,nickname ,popup) closure)) (let* ((v (jabber-muc--validate-disco-result result)) (status (plist-get v :status))) (pcase status ('not-found (unless (or jabber-silent-mode (y-or-n-p (format "%s doesn't exist. Create it? " (jabber-jid-displayname group)))) (error "Non-existent groupchat"))) ('error (message "Couldn't query groupchat: %s" (plist-get v :error-msg))) ('not-conference (message "%s is not a conference service" (jabber-jid-displayname group)))) (unless (eq status 'not-conference) (let ((password (when (member "muc_passwordprotected" (plist-get v :features)) (or (jabber-get-conference-data jc group nil :password) (read-passwd (format "Password for %s: " (jabber-jid-displayname group))))))) (jabber-muc--send-join-presence jc group nickname password popup)))))) (defalias 'jabber-muc-join-2 #'jabber-muc--disco-callback) (defun jabber-muc--send-join-presence (jc group nickname password popup &optional auto-configure) "Send MUC join presence for GROUP with NICKNAME. PASSWORD is the room password, or nil. When POPUP is non-nil, switch to the MUC buffer. When AUTO-CONFIGURE is non-nil, set `jabber-muc--auto-configure' in the buffer so the config form opens on room creation. JC is the Jabber connection." ;; Remember that this is a groupchat _before_ sending the stanza. ;; The response might come quicker than you think. (puthash (jabber-jid-symbol group) nickname jabber-pending-groupchats) (jabber-send-sexp jc `(presence ((to . ,(format "%s/%s" group nickname))) (x ((xmlns . ,jabber-muc-xmlns)) (history ((maxchars . "0"))) ,@(when password `((password () ,password)))) ,@(jabber-presence-children jc))) ;; There, stanza sent. Now we just wait for the MUC service to ;; mirror the stanza. This is handled in ;; `jabber-muc-process-presence', where a buffer will be created for ;; the room. ;; But if the user interactively asked to join, he/she probably ;; wants the buffer to pop up right now. (when popup (let ((buffer (jabber-muc-create-buffer jc group))) (when auto-configure (with-current-buffer buffer (setq jabber-muc--auto-configure t))) (switch-to-buffer buffer)))) (defalias 'jabber-muc-join-3 #'jabber-muc--send-join-presence) (defun jabber-muc-read-my-nickname (jc group &optional default) "Read nickname for joining GROUP. If DEFAULT is non-nil, return default nick without prompting. JC is the Jabber connection." (let ((default-nickname (or (jabber-get-conference-data jc group nil :nick) (cdr (assoc group jabber-muc-default-nicknames)) (plist-get (fsm-get-state-data jc) :username)))) (if default default-nickname (jabber-read-with-input-method (format "Nickname: (default %s) " default-nickname) nil nil default-nickname)))) ;;;###autoload (defun jabber-muc-nick (jc group nickname) "Change nickname in GROUP to NICKNAME. JC is the Jabber connection." (interactive (let* ((group (or (and (eq major-mode 'jabber-chat-mode) (bound-and-true-p jabber-group)) (completing-read "Groupchat: " (jabber-muc-active-rooms) nil t))) (jc (or (jabber-muc-connection group) (jabber-read-account))) (current (jabber-muc-nickname group jc)) (new-nick (read-string (format "New nickname (current: %s): " current) nil nil current))) (list jc group new-nick))) (jabber-send-sexp jc `(presence ((to . ,(format "%s/%s" group nickname)))))) (defun jabber-muc-leave (jc group) "Leave a groupchat. JC is the Jabber connection." (interactive (jabber-muc-argument-list)) (let ((nick (jabber-muc-nickname group jc))) ;; send unavailable presence to our own nick in room (jabber-send-sexp jc `(presence ((to . ,(format "%s/%s" group nick)) (type . "unavailable"))))) (jabber-bookmarks--retract-one jc group)) (defvar-local jabber-muc-names--group nil "Room JID for the current participants buffer.") (define-derived-mode jabber-muc-names-mode tabulated-list-mode "MUC-Names" "Major mode for displaying MUC participant lists." (setq tabulated-list-format [("Nick" 20 t) ("Role" 12 t) ("Affiliation" 12 t) ("JID" 30 t)]) (tabulated-list-init-header)) (defun jabber-muc-names () "Display participants of the current room in a tabulated-list buffer." (interactive) (let* ((group jabber-group) (participants (cdr (assoc group jabber-muc-participants))) (buf (get-buffer-create (format "*MUC Participants: %s*" (jabber-jid-displayname group))))) (with-current-buffer buf (jabber-muc-names-mode) (setq jabber-muc-names--group group) (setq tabulated-list-entries (mapcar (lambda (p) (let ((nick (car p)) (props (cdr p))) (list nick (vector nick (or (plist-get props 'role) "") (or (plist-get props 'affiliation) "") (or (plist-get props 'jid) ""))))) participants)) (tabulated-list-print)) (display-buffer buf))) (defun jabber-muc-set-topic (jc group topic) "Set topic of GROUP to TOPIC. JC is the Jabber connection." (interactive (jabber-muc-argument-list (list (jabber-read-with-input-method "New topic: " jabber-muc-topic)))) (jabber-send-message jc group topic nil "groupchat")) (defun jabber-muc-snarf-topic (xml-data) "Record subject (topic) of the given , if any. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((body (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'body))))) (new-topic (jabber-xml-path xml-data '(subject "")))) (when (and new-topic (not body)) (setq jabber-muc-topic new-topic)))) (defun jabber-muc-set-role (jc group nickname role reason) "Set role of NICKNAME in GROUP to ROLE, specifying REASON. JC is the Jabber connection." (interactive (jabber-muc-argument-list (let ((nickname (jabber-muc-read-nickname jabber-group "Nickname: "))) (list nickname (completing-read "New role: " '(("none") ("visitor") ("participant") ("moderator")) nil t nil 'jabber-role-history) (read-string "Reason: "))))) (unless (or (zerop (length nickname)) (zerop (length role))) (jabber-send-iq jc group "set" `(query ((xmlns . ,jabber-muc-xmlns-admin)) (item ((nick . ,nickname) (role . ,role)) ,(unless (zerop (length reason)) `(reason () ,reason)))) 'jabber-report-success "Role change" 'jabber-report-success "Role change"))) (defun jabber-muc-set-affiliation (jc group nickname-or-jid nickname-p affiliation reason) "Set affiliation of NICKNAME-OR-JID in GROUP to AFFILIATION. If NICKNAME-P is non-nil, NICKNAME-OR-JID is a nickname in the group, else it is a JID. JC is the Jabber connection." (interactive (jabber-muc-argument-list (let ((nickname-p (y-or-n-p "Specify user by room nickname? "))) (list (if nickname-p (jabber-muc-read-nickname jabber-group "Nickname: ") (jabber-read-jid-completing "User: ")) nickname-p (completing-read "New affiliation: " '(("none") ("outcast") ("member") ("admin") ("owner")) nil t nil 'jabber-affiliation-history) (read-string "Reason: "))))) (let ((jid (if nickname-p (let ((participants (cdr (assoc group jabber-muc-participants)))) (unless participants (error "Couldn't find group %s" group)) (let ((participant (cdr (assoc nickname-or-jid participants)))) (unless participant (error "Couldn't find %s in group %s" nickname-or-jid group)) (or (plist-get participant 'jid) (error "JID of %s in group %s is unknown" nickname-or-jid group)))) nickname-or-jid))) (jabber-send-iq jc group "set" `(query ((xmlns . ,jabber-muc-xmlns-admin)) (item ((jid . ,jid) (affiliation . ,affiliation)) ,(unless (zerop (length reason)) `(reason () ,reason)))) 'jabber-report-success "Affiliation change" 'jabber-report-success "Affiliation change"))) (defun jabber-muc-invite (jc jid group reason) "Invite JID to GROUP, stating REASON. Uses XEP-0249 direct invitations. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Invite whom: " ;; The current room is _not_ a good default for whom to invite. (remq (jabber-jid-symbol jabber-group) (jabber-concat-rosters))) (jabber-muc-read-completing "To group: ") (jabber-read-with-input-method "Reason: "))) (jabber-send-sexp jc `(message ((to . ,jid)) (x ((xmlns . ,jabber-muc-xmlns-direct-invite) (jid . ,group) ,@(unless (zerop (length reason)) `((reason . ,reason)))))))) ;; FIXME: If this file is loaded before `jabber-chat', it will prevent ;; `jabber-body-printers' to have its default set of functions, because ;; the var will have been set here already. (add-hook 'jabber-body-printers #'jabber-muc-print-invite) (defun jabber-muc--parse-mediated-invite (xml-data) "Parse XEP-0045 mediated invite from XML-DATA. Return (GROUP INVITER REASON) or nil." (cl-dolist (x (jabber-xml-get-children xml-data 'x)) (when (string= (jabber-xml-get-attribute x 'xmlns) jabber-muc-xmlns-user) (when-let* ((invitation (car (jabber-xml-get-children x 'invite))) (group (jabber-xml-get-attribute xml-data 'from))) (let ((inviter (jabber-xml-get-attribute invitation 'from)) (reason (car (jabber-xml-node-children (car (jabber-xml-get-children invitation 'reason)))))) (cl-return (list group inviter reason))))))) (defun jabber-muc--parse-direct-invite (xml-data) "Parse XEP-0249 direct invite from XML-DATA. Return (GROUP INVITER REASON) or nil." (cl-dolist (x (jabber-xml-get-children xml-data 'x)) (when (string= (jabber-xml-get-attribute x 'xmlns) jabber-muc-xmlns-direct-invite) (let ((group (jabber-xml-get-attribute x 'jid)) (inviter (jabber-xml-get-attribute xml-data 'from)) (reason (jabber-xml-get-attribute x 'reason))) (when (and group (not (jabber-muc-joined-p group))) (cl-return (list group inviter reason))))))) (defun jabber-muc--insert-invite (group inviter reason &optional mediated-p) "Insert MUC invitation UI for GROUP from INVITER with REASON. When MEDIATED-P is non-nil, include a Decline button." ;; XXX: password (insert "You have been invited to MUC room " (jabber-jid-displayname group)) (when inviter (insert " by " (jabber-jid-displayname inviter))) (insert ".") (when (and reason (not (zerop (length reason)))) (insert " Reason: " reason)) (insert "\n\n") (let ((action (lambda (&rest _ignore) (interactive) (jabber-muc-join jabber-buffer-connection group (jabber-muc-read-my-nickname jabber-buffer-connection group))))) (insert-button "Accept" 'action action)) (when mediated-p (insert "\t") (let ((action (lambda (&rest _ignore) (interactive) (let ((reason (jabber-read-with-input-method "Reason: "))) (jabber-send-sexp jabber-buffer-connection `(message ((to . ,group)) (x ((xmlns . ,jabber-muc-xmlns-user)) (decline ((to . ,inviter)) ,(unless (zerop (length reason)) `(reason nil ,reason)))))))))) (insert-button "Decline" 'action action)))) (defun jabber-muc-print-invite (msg _who mode) "Print MUC invitation from message plist MSG. Requires :xml-data key in MSG for raw stanza access." (when-let* ((xml-data (plist-get msg :xml-data))) (or (when-let* ((parsed (jabber-muc--parse-mediated-invite xml-data))) (when (eql mode :insert) (jabber-muc--insert-invite (nth 0 parsed) (nth 1 parsed) (nth 2 parsed) t)) t) (when-let* ((parsed (jabber-muc--parse-direct-invite xml-data))) (when (eql mode :insert) (jabber-muc--insert-invite (nth 0 parsed) (nth 1 parsed) (nth 2 parsed))) t)))) (defun jabber-muc--autojoin-insert (jc count group nick) "Insert (COUNT GROUP . NICK) into the sorted autojoin queue for JC. The queue is kept sorted ascending by COUNT so rooms with fewer occupants are joined first." (let* ((new-entry (cons count (cons group nick))) (cell (assq jc jabber-muc--autojoin-queue))) (if (not cell) (push (cons jc (list new-entry)) jabber-muc--autojoin-queue) (let ((rooms (cdr cell)) (inserted nil) (prev nil)) (while (and rooms (not inserted)) (if (< count (caar rooms)) (progn (if prev (setcdr prev (cons new-entry rooms)) (setcdr cell (cons new-entry rooms))) (setq inserted t)) (setq prev rooms rooms (cdr rooms)))) (unless inserted (if prev (setcdr prev (list new-entry)) (setcdr cell (list new-entry)))))))) (defun jabber-muc--autojoin-cancel-timer () "Cancel the autojoin timeout timer if running." (when (timerp jabber-muc--autojoin-timer) (cancel-timer jabber-muc--autojoin-timer) (setq jabber-muc--autojoin-timer nil))) (defun jabber-muc--autojoin-disco-callback (jc closure-data result) "Disco#items callback for autojoin prioritization. JC is the connection. CLOSURE-DATA is (GROUP . NICK). RESULT is a list of item vectors on success or an error node." (let* ((group (car closure-data)) (nick (cdr closure-data)) (count (if (and (listp result) (eq (car result) 'error)) most-positive-fixnum (length result)))) ;; Decrement in-flight disco counter. (when-let* ((cell (assq jc jabber-muc--autojoin-disco-count))) (cl-decf (cdr cell))) (jabber-muc--autojoin-insert jc count group nick) ;; Fire more disco queries if slots are available. (jabber-muc--autojoin-fire-pending jc) ;; Start draining if no join is currently in-flight. ;; Defer via timer so Emacs can redisplay between joins. (unless jabber-muc--autojoin-timer (run-with-timer 0 nil #'jabber-muc--autojoin-next jc)))) (defun jabber-muc--autojoin-dequeue (jc group) "Remove GROUP from the autojoin queue for JC if present." (when-let* ((cell (assq jc jabber-muc--autojoin-queue))) (let ((rooms (cdr cell))) (setcdr cell (cl-remove-if (lambda (entry) (string= group (cadr entry))) rooms)) (unless (cdr cell) (setq jabber-muc--autojoin-queue (assq-delete-all jc jabber-muc--autojoin-queue)))))) (defun jabber-muc--autojoin-timeout (jc) "Timer callback: advance to the next room when self-presence times out." (setq jabber-muc--autojoin-timer nil) (when (memq jc jabber-connections) (jabber-muc--autojoin-next jc))) (defun jabber-muc--autojoin-next (jc) "Join the next room in the autojoin queue for JC. Pops one entry (COUNT GROUP . NICK) and sends the join presence. Starts a timeout timer so the queue advances even if the server never responds. Does nothing if the queue is empty." (jabber-muc--autojoin-cancel-timer) (when-let* ((entry (assq jc jabber-muc--autojoin-queue)) (rooms (cdr entry))) (let* ((head (pop rooms)) (group (cadr head)) (nick (cddr head)) (password (jabber-get-conference-data jc group nil :password))) (setcdr entry rooms) (unless rooms (setq jabber-muc--autojoin-queue (assq-delete-all jc jabber-muc--autojoin-queue))) (jabber-muc--send-join-presence jc group nick password nil) ;; Start timeout: if no self-presence arrives, try next room. (when (assq jc jabber-muc--autojoin-queue) (setq jabber-muc--autojoin-timer (run-with-timer jabber-muc-autojoin-timeout nil #'jabber-muc--autojoin-timeout jc)))))) (defun jabber-muc--autojoin-queued-p (jc group) "Return non-nil if GROUP is already in the autojoin queue for JC." (when-let* ((entry (assq jc jabber-muc--autojoin-queue))) (cl-find group (cdr entry) :key #'cadr :test #'string=))) (defun jabber-muc--autojoin-clear (jc) "Remove all autojoin queue entries for JC." (jabber-muc--autojoin-cancel-timer) (setq jabber-muc--autojoin-queue (assq-delete-all jc jabber-muc--autojoin-queue)) (setq jabber-muc--autojoin-pending (assq-delete-all jc jabber-muc--autojoin-pending)) (setq jabber-muc--autojoin-disco-count (assq-delete-all jc jabber-muc--autojoin-disco-count))) (defun jabber-muc--rejoin-snapshot (jc) "Rejoin rooms from the pre-disconnect snapshot not already joined. Called after bookmark autojoin to recover non-bookmarked rooms. Rooms are added to the pending disco list for batched querying." (dolist (room-nick jabber-muc--rooms-before-disconnect) (let ((room (car room-nick)) (nick (cdr room-nick))) (unless (or (jabber-muc-joined-p room jc) (jabber-muc--autojoin-queued-p jc room)) (jabber-muc--autojoin-enqueue-pending jc room nick)))) (setq jabber-muc--rooms-before-disconnect nil)) (defun jabber-muc--autojoin-enqueue-pending (jc group nick) "Add (GROUP . NICK) to the pending disco list for JC." (if-let* ((cell (assq jc jabber-muc--autojoin-pending))) (setcdr cell (nconc (cdr cell) (list (cons group nick)))) (push (cons jc (list (cons group nick))) jabber-muc--autojoin-pending))) (defun jabber-muc--autojoin-fire-pending (jc) "Fire disco#items queries for JC up to the concurrency limit. Moves rooms from `jabber-muc--autojoin-pending' into in-flight disco queries, respecting `jabber-muc-autojoin-max-disco'." (let* ((count-cell (or (assq jc jabber-muc--autojoin-disco-count) (car (push (cons jc 0) jabber-muc--autojoin-disco-count)))) (pending-cell (assq jc jabber-muc--autojoin-pending))) (while (and pending-cell (cdr pending-cell) (< (cdr count-cell) jabber-muc-autojoin-max-disco)) (let* ((room-nick (cadr pending-cell)) (group (car room-nick)) (nick (cdr room-nick))) (setcdr pending-cell (cddr pending-cell)) (cl-incf (cdr count-cell)) (jabber-disco-get-items jc group nil #'jabber-muc--autojoin-disco-callback (cons group nick)))) ;; Clean up empty pending entry. (unless (cdr pending-cell) (setq jabber-muc--autojoin-pending (assq-delete-all jc jabber-muc--autojoin-pending))))) (defun jabber-muc-autojoin (jc) "Join rooms specified in account bookmarks and global `jabber-muc-autojoin'. Fires disco#items queries in batches (up to `jabber-muc-autojoin-max-disco' at a time). As results arrive, rooms are inserted into a priority queue ordered by occupant count (fewest first) and drained sequentially. JC is the Jabber connection." (interactive (list (jabber-read-account))) (jabber-muc--autojoin-clear jc) (when (bound-and-true-p jabber-muc-autojoin) (dolist (group jabber-muc-autojoin) (jabber-muc--autojoin-enqueue-pending jc group (or (cdr (assoc group jabber-muc-default-nicknames)) (plist-get (fsm-get-state-data jc) :username))))) (jabber-muc--autojoin-fire-pending jc) (jabber-get-bookmarks jc (lambda (jc bookmarks) (dolist (bookmark bookmarks) (when (plist-get bookmark :autojoin) (let ((group (plist-get bookmark :jid))) (unless (or (jabber-muc-joined-p group jc) (jabber-muc--autojoin-queued-p jc group)) (jabber-muc--autojoin-enqueue-pending jc group (or (plist-get bookmark :nick) (plist-get (fsm-get-state-data jc) :username))))))) (jabber-muc--rejoin-snapshot jc) (jabber-muc--autojoin-fire-pending jc)))) ;;;###autoload (defun jabber-muc-message-p (message) "Return non-nil if MESSAGE is a groupchat message. That does not include private messages in a groupchat, but does include groupchat invites." ;; Public groupchat messages have type "groupchat" and are from ;; room@server/nick. Public groupchat errors have type "error" and ;; are from room@server. (let ((from (jabber-xml-get-attribute message 'from)) (type (jabber-xml-get-attribute message 'type))) (or (string= type "groupchat") (and (string= type "error") (gethash (jabber-jid-symbol from) jabber-pending-groupchats)) (jabber-xml-path message `((,jabber-muc-xmlns-user . "x") invite)) ;; XEP-0249 direct invite (jabber-xml-path message `((,jabber-muc-xmlns-direct-invite . "x")))))) ;;;###autoload (defun jabber-muc-sender-p (jid) "Return non-nil if JID is a full JID of an MUC participant." (and (jabber-muc-joined-p (jabber-jid-user jid)) (jabber-jid-resource jid))) ;;;###autoload (defun jabber-muc-private-message-p (message) "Return non-nil if MESSAGE is a private message in a groupchat." (let ((from (jabber-xml-get-attribute message 'from)) (type (jabber-xml-get-attribute message 'type))) (and (not (string= type "groupchat")) (jabber-muc-sender-p from)))) (defun jabber-muc-private (_jc group nickname) "Open private chat with NICKNAME in GROUP. JC is the Jabber connection." (interactive (jabber-muc-argument-list (list (jabber-muc-read-nickname jabber-group "Nickname: ")))) (switch-to-buffer (jabber-muc-private-create-buffer jabber-buffer-connection group nickname))) (defun jabber-muc-presence-p (presence) "Return non-nil if PRESENCE is presence from groupchat." (let ((from (jabber-xml-get-attribute presence 'from)) (type (jabber-xml-get-attribute presence 'type)) (muc-marker (cl-find-if (lambda (x) (equal (jabber-xml-get-attribute x 'xmlns) jabber-muc-xmlns-user)) (jabber-xml-get-children presence 'x)))) ;; This is MUC presence if it has an MUC-namespaced tag... (or muc-marker ;; ...or if it is error presence from a room we tried to join. (and (string= type "error") (gethash (jabber-jid-symbol from) jabber-pending-groupchats))))) (defun jabber-muc-parse-affiliation (x-muc) "Parse X-MUC in the muc#user namespace and return a plist. Return nil if X-MUC is nil." ;; XXX: parse and tags? or maybe elsewhere? (apply #'nconc (mapcar (lambda (prop) (list (car prop) (cdr prop))) (jabber-xml-node-attributes (car (jabber-xml-get-children x-muc 'item)))))) (defun jabber-muc-print-prompt (msg &optional local dont-print-nick-p) "Print MUC prompt for message plist MSG." (let ((nick (jabber-jid-resource (plist-get msg :from))) (timestamp (plist-get msg :timestamp)) (delayed (plist-get msg :delayed))) (if (stringp nick) (jabber-chat--insert-prompt (jabber-chat--format-time timestamp delayed) (if dont-print-nick-p "" nick) (if local 'jabber-chat-nick-plaintext 'jabber-chat-nick-foreign-plaintext)) (jabber-muc-system-prompt)))) (defun jabber-muc-private-print-prompt (msg) "Print prompt for private MUC message plist MSG." (let* ((from (plist-get msg :from)) (timestamp (plist-get msg :timestamp)) (delayed (plist-get msg :delayed)) (nick (jabber-jid-resource from)) (group (jabber-jid-user from)) (group-name (or (jabber-jid-rostername group) (jabber-jid-username group)))) (jabber-chat--insert-prompt (jabber-chat--format-time timestamp delayed) (concat group-name "/" nick) 'jabber-chat-nick-foreign-plaintext))) (defun jabber-muc-system-prompt (&rest _ignore) "Print system prompt for MUC." (jabber-chat--insert-prompt (jabber-chat--format-time nil nil) "" 'jabber-chat-nick-system)) (defun jabber-muc--classify-message (jc group nick xml-data) "Return message type for a MUC stanza. JC is the connection that received the stanza. GROUP is the room JID, NICK is the sender's room nickname, and XML-DATA is the parsed stanza. Returns `:muc-error' if the stanza contains an error child, `:muc-local' if NICK matches our own nickname in GROUP on JC, or `:muc-foreign' otherwise." (cond ((jabber-xml-get-children xml-data 'error) :muc-error) ((and nick (string= nick (jabber-muc-nickname group jc))) :muc-local) (t :muc-foreign))) (defun jabber-muc--history-message-p (xml-data) "Return non-nil if XML-DATA is a MUC history message per XEP-0045. Per XEP-0045 section 7.2.15, a MUC history message has a element whose `from' attribute is the room JID. Delay elements with other `from' values (bridges, gateways, time corrections) indicate live messages with extra metadata, not history." (when-let* ((delay (or (jabber-xml-child-with-xmlns xml-data jabber-delay-xmlns) (jabber-xml-child-with-xmlns xml-data jabber-delay-legacy-xmlns))) (delay-from (jabber-xml-get-attribute delay 'from)) (msg-from (jabber-xml-get-attribute xml-data 'from))) (string= delay-from (jabber-jid-user msg-from)))) (defun jabber-muc--display-message (_jc xml-data group nick type msg-plist) "Display a MUC message and conditionally run alert hooks. Insert an EWOC entry into the MUC buffer for GROUP. _JC is the Jabber connection, XML-DATA the parsed stanza, NICK the sender nickname, TYPE one of `:muc-local', `:muc-foreign', or `:muc-error', and MSG-PLIST the message property list. Alert hooks are skipped for history messages." (let ((error-p (eq type :muc-error)) (printers (append jabber-muc-printers jabber-chat-printers)) (body-text (plist-get msg-plist :body)) (buffer (jabber-muc-find-buffer group))) ;; Only insert into EWOC when the buffer already exists. ;; Messages are persisted in the DB regardless; backlog loads ;; when the user opens the room. (when buffer (with-current-buffer buffer (jabber-muc-snarf-topic xml-data) ;; Skip ewoc insert for delayed (history) messages when ;; backlog was already loaded from DB, to avoid duplicates. ;; The DB handler stores them; backlog refresh will show them. (when (and (or error-p (cl-some (lambda (f) (funcall f msg-plist type :printp)) printers)) (not (and (jabber-muc--history-message-p xml-data) jabber-chat-earliest-backlog))) (jabber-maybe-print-rare-time (jabber-chat-ewoc-enter (list type msg-plist)))))) ;; Alert hooks run regardless of buffer existence, but not for ;; history messages. (unless (jabber-muc--history-message-p xml-data) (let ((inhibit-message (and buffer (buffer-live-p buffer) (buffer-local-value 'jabber-chat-mam-syncing buffer)))) (dolist (hook '(jabber-muc-hooks jabber-alert-muc-hooks)) (run-hook-with-args hook nick group buffer body-text (funcall jabber-alert-muc-function nick group buffer body-text))))))) (with-eval-after-load "jabber-core" (jabber-chain-add 'jabber-message-chain #'jabber-muc-process-message)) (defun jabber-muc-process-message (jc xml-data) "If XML-DATA is a groupchat message, handle it as such. JC is the Jabber connection." (when (jabber-muc-message-p xml-data) (let* ((xml-data (jabber-chat--decrypt-if-needed jc xml-data)) (from (jabber-xml-get-attribute xml-data 'from)) (group (jabber-jid-user from)) (nick (jabber-jid-resource from)) (type (jabber-muc--classify-message jc group nick xml-data)) (msg-plist (jabber-chat--msg-plist-from-stanza xml-data)) (replace-id (jabber-message-correct--replace-id xml-data))) (if (and replace-id (not (jabber-muc--history-message-p xml-data))) (jabber-message-correct--apply replace-id (plist-get msg-plist :body) from t (jabber-muc-find-buffer group)) (jabber-muc--display-message jc xml-data group nick type msg-plist))))) (defun jabber-muc--format-actor-reason (actor reason) "Format optional \" by ACTOR\" / \" - \\='REASON\\='\" suffix." (concat (when actor (concat " by " actor)) (when reason (concat " - '" reason "'")))) (defun jabber-muc--process-self-leave (jc group type status-codes error-node actor reason) "Handle our own departure from GROUP. TYPE is the presence type (\"unavailable\" or \"error\"). STATUS-CODES, ERROR-NODE, ACTOR and REASON come from the stanza." (let* ((leavingp t) (message (cond ((string= type "error") (cond ;; Nick-change errors don't mean we left the room. ((or (member jabber-muc-status-nick-not-allowed status-codes) (member jabber-muc-status-nick-conflict status-codes)) (setq leavingp nil) (concat "Nickname change not allowed" (when error-node (concat ": " (jabber-parse-error error-node))))) (t (concat "Error entering room" (when error-node (concat ": " (jabber-parse-error error-node))))))) ((member jabber-muc-status-banned status-codes) (concat "You have been banned" (jabber-muc--format-actor-reason actor reason))) ((member jabber-muc-status-kicked status-codes) (concat "You have been kicked" (jabber-muc--format-actor-reason actor reason))) (t "You have left the chatroom")))) (when leavingp (jabber-muc-remove-groupchat group jc)) ;; If there is no buffer for this groupchat, don't bother ;; creating one just to tell that user left the room. (let ((buffer (get-buffer (jabber-muc-get-buffer group jc)))) (if buffer (with-current-buffer buffer (jabber-maybe-print-rare-time (jabber-chat-ewoc-enter (list (if (string= type "error") :muc-error :muc-notice) message :time (current-time))))) (message "%s: %s" (jabber-jid-displayname group) message))) ;; Stagger: skip failed room and try the next one. ;; Defer via timer so Emacs can redisplay between joins. (when (string= type "error") (run-with-timer 0 nil #'jabber-muc--autojoin-next jc)))) (defun jabber-muc--process-other-leave (_jc group nickname status-codes item actor reason) "Handle another participant leaving GROUP. NICKNAME is the departing user. STATUS-CODES, ITEM, ACTOR and REASON come from the stanza." (let* ((plist (jabber-muc-participant-plist group nickname)) (jid (plist-get plist 'jid)) (name (concat nickname (when jid (concat " <" (jabber-jid-user jid) ">"))))) (jabber-muc-remove-participant group nickname) (when-let* ((buffer (jabber-muc-find-buffer group))) (with-current-buffer buffer (jabber-maybe-print-rare-time (jabber-chat-ewoc-enter (list :muc-notice (cond ((member jabber-muc-status-banned status-codes) (concat name " has been banned" (jabber-muc--format-actor-reason actor reason))) ((member jabber-muc-status-kicked status-codes) (concat name " has been kicked" (jabber-muc--format-actor-reason actor reason))) ((member jabber-muc-status-nick-changed status-codes) (concat name " changes nickname to " (jabber-xml-get-attribute item 'nick))) (t (concat name " has left the chatroom"))) :time (current-time)))))))) (defun jabber-muc--room-created-message () "Return a string with buttons for configuring a newly created room." (with-temp-buffer (insert "This room was just created, and is locked to other participants.\n" "To unlock it, ") (insert-text-button "configure the room" 'action (apply-partially 'call-interactively 'jabber-muc-get-config)) (insert " or ") (insert-text-button "accept the default configuration" 'action (apply-partially 'call-interactively 'jabber-muc-instant-config)) (insert ".") (buffer-string))) (defun jabber-muc--enter-extra-notices (nickname status-codes) "Insert extra ewoc notices for STATUS-CODES into the current MUC buffer. NICKNAME is the entering user. Assumes `jabber-chat-ewoc' is current." (when (member jabber-muc-status-nick-modified status-codes) (jabber-chat-ewoc-enter (list :muc-notice (concat "Your nick was changed to " nickname " by the server") :time (current-time)))) (when (member jabber-muc-status-room-created status-codes) (if jabber-muc--auto-configure (progn (setq jabber-muc--auto-configure nil) (jabber-muc-get-config jabber-buffer-connection jabber-group)) (jabber-chat-ewoc-enter (list :muc-notice (jabber-muc--room-created-message) :time (current-time)))))) (defun jabber-muc--process-enter (jc group nickname symbol status-codes x-muc actor reason our-nickname) "Handle a participant entering or updating presence in GROUP. NICKNAME is the user. SYMBOL is their JID symbol. STATUS-CODES, X-MUC, ACTOR, REASON and OUR-NICKNAME come from the stanza." ;; Self-presence: check nickname too since some servers (e.g. ;; ejabberd mod_irc) omit the 110 status code. (when (or (member jabber-muc-status-self-presence status-codes) (string= nickname our-nickname)) (let ((was-joined (jabber-muc-joined-p group jc))) (jabber-muc-add-groupchat group nickname jc) (puthash symbol nickname jabber-pending-groupchats) ;; Trigger MUC MAM catch-up on initial join (not nick change) (unless was-joined (jabber-mam-muc-joined jc group) (jabber-bookmarks-auto-add-maybe jc group nickname) ;; Stagger: join the next queued room now that this one succeeded. ;; Defer via timer so Emacs can redisplay between joins. (run-with-timer 0 nil #'jabber-muc--autojoin-next jc)))) (let* ((self-p (or (member jabber-muc-status-self-presence status-codes) (string= nickname our-nickname))) (old-plist (jabber-muc-participant-plist group nickname)) (new-plist (jabber-muc-parse-affiliation x-muc))) (jabber-muc-modify-participant group nickname new-plist) ;; Prefetch OMEMO sessions for newly-joining non-self participants. (when (and (not self-p) (null old-plist)) (when-let* ((jid (plist-get new-plist 'jid)) (bare (jabber-jid-user jid)) (buf (jabber-muc-find-buffer group))) (with-current-buffer buf (when (and (eq jabber-chat-encryption 'omemo) (fboundp 'jabber-omemo--prefetch-sessions)) (jabber-omemo--prefetch-sessions jc bare))))) (when-let* ((buffer (jabber-muc-find-buffer group))) (let ((report (jabber-muc-report-delta nickname old-plist new-plist reason actor))) (when report (with-current-buffer buffer (jabber-maybe-print-rare-time (jabber-chat-ewoc-enter (list :muc-notice report :time (current-time))))))) ;; Extra notices (status 201/210) fire for self-presence regardless ;; of whether there was an affiliation delta report. (when self-p (with-current-buffer buffer (jabber-muc--enter-extra-notices nickname status-codes) (when (and (eq jabber-chat-encryption 'omemo) (fboundp 'jabber-omemo--prefetch-muc-sessions)) (jabber-omemo--prefetch-muc-sessions jc group))))))) (defun jabber-muc--parse-presence (presence) "Extract fields from a MUC PRESENCE stanza. Return a plist with keys :from, :type, :group, :nickname, :symbol, :our-nickname, :x-muc, :item, :actor, :reason, :error-node, :status-codes. Accesses `jabber-pending-groupchats' to determine our nickname." (let* ((from (jabber-xml-get-attribute presence 'from)) (type (jabber-xml-get-attribute presence 'type)) (x-muc (cl-find-if (lambda (x) (equal (jabber-xml-get-attribute x 'xmlns) jabber-muc-xmlns-user)) (jabber-xml-get-children presence 'x))) (group (jabber-jid-user from)) (nickname (jabber-jid-resource from)) (symbol (jabber-jid-symbol from)) (our-nickname (gethash symbol jabber-pending-groupchats)) (item (car (jabber-xml-get-children x-muc 'item))) (actor (jabber-xml-get-attribute (car (jabber-xml-get-children item 'actor)) 'jid)) (reason (car (jabber-xml-node-children (car (jabber-xml-get-children item 'reason))))) (error-node (car (jabber-xml-get-children presence 'error))) (status-codes (if error-node (list (jabber-xml-get-attribute error-node 'code)) (mapcar (lambda (status-element) (jabber-xml-get-attribute status-element 'code)) (jabber-xml-get-children x-muc 'status))))) (list :from from :type type :group group :nickname nickname :symbol symbol :our-nickname our-nickname :x-muc x-muc :item item :actor actor :reason reason :error-node error-node :status-codes status-codes))) (defun jabber-muc-process-presence (jc presence) "Dispatch a MUC presence stanza to the appropriate handler." (let* ((p (jabber-muc--parse-presence presence)) (type (plist-get p :type)) (group (plist-get p :group)) (nickname (plist-get p :nickname)) (symbol (plist-get p :symbol)) (our-nickname (plist-get p :our-nickname)) (x-muc (plist-get p :x-muc)) (item (plist-get p :item)) (actor (plist-get p :actor)) (reason (plist-get p :reason)) (error-node (plist-get p :error-node)) (status-codes (plist-get p :status-codes))) (cond ((or (string= type "unavailable") (string= type "error")) (if (or (null nickname) (member jabber-muc-status-self-presence status-codes) (string= nickname our-nickname)) (jabber-muc--process-self-leave jc group type status-codes error-node actor reason) (jabber-muc--process-other-leave jc group nickname status-codes item actor reason))) (t (jabber-muc--process-enter jc group nickname symbol status-codes x-muc actor reason our-nickname))))) (jabber-disco-advertise-feature jabber-muc-xmlns-direct-invite) (provide 'jabber-muc) ;;; jabber-muc.el ends here. emacs-jabber/lisp/jabber-notifications.el000066400000000000000000000111311516610113500207520ustar00rootroot00000000000000;;; jabber-notifications.el --- emacs-jabber interface to notifications.el -*- lexical-binding: t; -*- ;; Copyright (C) 2014 - Adam Sjøgren - asjo@koldfront.dk ;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru ;; Copyright (C) 2007 - Rodrigo Lazo - rlazo.paz@gmail.com ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;; Built on jabber-libnotify.el. ;;; Code: (eval-when-compile (require 'jabber-alert)) (require 'notifications) (defcustom jabber-notifications-icon "emacs" "Icon to be used on the notification pop-up. The default \"emacs\" is resolved by the system icon theme." :type 'string :group 'jabber-alerts) (defcustom jabber-notifications-timeout nil "Specifies the timeout of the pop up window in millisecond" :type 'integer :group 'jabber-alerts) (defcustom jabber-notifications-message-header "Jabber message" "Defines the header of the pop up." :type 'string :group 'jabber-alerts) (defcustom jabber-notifications-app "Emacs Jabber" "Defines the app of the pop up." :type 'string :group 'jabber-alerts) (defcustom jabber-notifications-urgency "low" "Urgency of message" :type '(choice (const :tag "Low" "low") (const :tag "Normal" "normal") (const :tag "Critical" "critical")) :group 'jabber-alerts) (defcustom jabber-notifications-muc 'mentions "When to show desktop notifications for MUC messages. `all' shows a notification for every MUC message, `mentions' only when the message looks like it is addressed to you, and nil disables MUC notifications entirely." :type '(choice (const :tag "All messages" all) (const :tag "Mentions only" mentions) (const :tag "Disabled" nil)) :group 'jabber-alerts) ;; Global reference declarations (declare-function jabber-muc-looks-like-personal-p "jabber-muc-nick-completion.el" (message &optional group)) (declare-function jabber-avatar-find-cached "jabber-avatar.el" (sha1-sum)) (declare-function jabber-jid-symbol "jabber-util.el" (jid)) (declare-function jabber-escape-xml "jabber-xml.el" (string)) ;; (defun jabber-message-notifications (from _buffer text title) "Show a message through the notifications.el interface." (let ((body (or (jabber-escape-xml text) " ")) (avatar-hash (get (jabber-jid-symbol from) 'avatar-hash))) (condition-case err (notifications-notify :title title :body body :app-icon (or (and avatar-hash (jabber-avatar-find-cached avatar-hash)) jabber-notifications-icon) :app-name jabber-notifications-app :category "jabber.message" :timeout jabber-notifications-timeout) (dbus-error (message "jabber-notifications: D-Bus error: %s" (error-message-string err)))))) (defun jabber-muc-notifications (nick group buffer text title) "Show MUC message through the notifications.el interface. Controlled by `jabber-notifications-muc': notify for all messages, mentions only, or not at all." (when (pcase jabber-notifications-muc ('all t) ('mentions (jabber-muc-looks-like-personal-p text group)) (_ nil)) (jabber-message-notifications group buffer (if nick (format "%s: %s" nick text) text) title))) ;; jabber-*-notifications* requires "from" argument, so we cant use ;; define-jabber-alert/define-personal-jabber-alert here and do the ;; work by hand: (cl-pushnew 'jabber-message-notifications (get 'jabber-alert-message-hooks 'custom-options)) (cl-pushnew 'jabber-muc-notifications (get 'jabber-alert-muc-hooks 'custom-options)) (define-obsolete-function-alias 'jabber-muc-notifications-personal #'jabber-muc-notifications "0.10.0") (add-hook 'jabber-alert-message-hooks #'jabber-message-notifications) (add-hook 'jabber-alert-muc-hooks #'jabber-muc-notifications) (provide 'jabber-notifications) ;;; jabber-notifications.el ends here emacs-jabber/lisp/jabber-omemo-store.el000066400000000000000000000302661516610113500203610ustar00rootroot00000000000000;;; jabber-omemo-store.el --- OMEMO persistence -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; This file is part of emacs-jabber. ;; emacs-jabber 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 3 of the License, or ;; (at your option) any later version. ;; emacs-jabber 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 emacs-jabber. If not, see . ;;; Commentary: ;; SQLite persistence for OMEMO state. Uses the shared database ;; connection from `jabber-db'. OMEMO tables are created by ;; `jabber-db--migrate' (version 2) when the database is opened. ;;; Code: (require 'jabber-db) (defsubst jabber-omemo-store--as-unibyte (value) "Return VALUE as a unibyte string if it is a string, else VALUE. SQLite returns BLOBs as multibyte strings; this normalizes them for the C module which expects unibyte." (if (and (stringp value) (multibyte-string-p value)) (encode-coding-string value 'raw-text) value)) ;;; Store blob CRUD (defun jabber-omemo-store-save (account blob) "Upsert serialized OMEMO store BLOB for ACCOUNT." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "INSERT OR REPLACE INTO omemo_store (account, store_blob) VALUES (?, ?)" (list account blob)))) (defun jabber-omemo-store-load (account) "Load serialized OMEMO store blob for ACCOUNT, or nil." (when-let* ((db (jabber-db-ensure-open))) (jabber-omemo-store--as-unibyte (caar (sqlite-select db "SELECT store_blob FROM omemo_store WHERE account = ?" (list account)))))) (defun jabber-omemo-store-delete (account) "Delete OMEMO store for ACCOUNT." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "DELETE FROM omemo_store WHERE account = ?" (list account)))) ;;; Device ID CRUD (defun jabber-omemo-store-save-device-id (account device-id) "Upsert DEVICE-ID for ACCOUNT in the omemo_device_id table." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "INSERT OR REPLACE INTO omemo_device_id (account, device_id) VALUES (?, ?)" (list account device-id)))) (defun jabber-omemo-store-load-device-id (account) "Load the device ID for ACCOUNT, or nil if not set." (when-let* ((db (jabber-db-ensure-open))) (caar (sqlite-select db "SELECT device_id FROM omemo_device_id WHERE account = ?" (list account))))) ;;; Trust CRUD (defun jabber-omemo-store-save-trust (account jid device-id identity-key trust) "Upsert trust record for ACCOUNT, JID, DEVICE-ID. IDENTITY-KEY is a unibyte blob. TRUST is 0=undecided, 1=tofu, 2=verified, -1=untrusted. Sets first_seen to current time on initial insert. Rejects the update if the device already has a different identity key." (when-let* ((db (jabber-db-ensure-open))) (let ((existing (jabber-omemo-store--as-unibyte (caar (sqlite-select db "\ SELECT identity_key FROM omemo_trust WHERE account = ? AND jid = ? AND device_id = ?" (list account jid device-id)))))) (if (and existing (not (equal existing identity-key))) (display-warning 'jabber-omemo (format "SECURITY: device %d for %s changed identity key! Rejecting." device-id jid) :warning) (let ((now (truncate (float-time)))) (sqlite-execute db "\ INSERT INTO omemo_trust (account, jid, device_id, identity_key, trust, first_seen) VALUES (?, ?, ?, ?, ?, ?) ON CONFLICT (account, jid, device_id) DO UPDATE SET trust = excluded.trust" (list account jid device-id identity-key trust now))))))) (defun jabber-omemo-store-ensure-trust (account jid device-id identity-key) "Ensure a trust record exists for ACCOUNT, JID, DEVICE-ID. Creates one with trust 0 (undecided) if none exists. If a record already exists, leaves it unchanged. Warns if the stored identity key differs from IDENTITY-KEY." (when-let* ((db (jabber-db-ensure-open)) (identity-key identity-key)) (let ((existing (jabber-omemo-store--as-unibyte (caar (sqlite-select db "\ SELECT identity_key FROM omemo_trust WHERE account = ? AND jid = ? AND device_id = ?" (list account jid device-id)))))) (cond ((and existing (not (equal existing identity-key))) (display-warning 'jabber-omemo (format "SECURITY: device %d for %s changed identity key! Rejecting." device-id jid) :warning)) (existing nil) (t (let ((now (truncate (float-time)))) (sqlite-execute db "\ INSERT INTO omemo_trust (account, jid, device_id, identity_key, trust, first_seen) VALUES (?, ?, ?, ?, 0, ?)" (list account jid device-id identity-key now)))))))) (defun jabber-omemo-store-load-trust (account jid device-id) "Load trust record for ACCOUNT, JID, DEVICE-ID as a plist, or nil. Returns (:identity-key BLOB :trust INT :first-seen INT)." (when-let* ((db (jabber-db-ensure-open))) (when-let* ((row (car (sqlite-select db "\ SELECT identity_key, trust, first_seen FROM omemo_trust WHERE account = ? AND jid = ? AND device_id = ?" (list account jid device-id))))) (list :identity-key (jabber-omemo-store--as-unibyte (nth 0 row)) :trust (nth 1 row) :first-seen (nth 2 row))))) (defun jabber-omemo-store-set-trust (account jid device-id level) "Update trust LEVEL for a known device (ACCOUNT, JID, DEVICE-ID)." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "\ UPDATE omemo_trust SET trust = ? WHERE account = ? AND jid = ? AND device_id = ?" (list level account jid device-id)))) (defun jabber-omemo-store-delete-trust (account jid device-id) "Delete trust record for ACCOUNT, JID, DEVICE-ID." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "\ DELETE FROM omemo_trust WHERE account = ? AND jid = ? AND device_id = ?" (list account jid device-id)))) (defun jabber-omemo-store-all-trust (account jid) "List all trust records for ACCOUNT + JID. Returns a list of plists (:device-id INT :identity-key BLOB :trust INT :first-seen INT)." (when-let* ((db (jabber-db-ensure-open))) (mapcar (lambda (row) (list :device-id (nth 0 row) :identity-key (jabber-omemo-store--as-unibyte (nth 1 row)) :trust (nth 2 row) :first-seen (nth 3 row))) (sqlite-select db "\ SELECT device_id, identity_key, trust, first_seen FROM omemo_trust WHERE account = ? AND jid = ?" (list account jid))))) ;;; Device list CRUD (defun jabber-omemo-store-save-device (account jid device-id &optional active) "Upsert device record for ACCOUNT, JID, DEVICE-ID. ACTIVE defaults to 1 (true). Sets last_seen to current time." (when-let* ((db (jabber-db-ensure-open))) (let ((now (truncate (float-time))) (act (if (or (null active) (eq active t)) 1 active))) (sqlite-execute db "\ INSERT OR REPLACE INTO omemo_devices (account, jid, device_id, active, last_seen) VALUES (?, ?, ?, ?, ?)" (list account jid device-id act now))))) (defun jabber-omemo-store-load-devices (account jid) "Load all device records for ACCOUNT + JID. Returns a list of plists (:device-id INT :active BOOL :last-seen INT)." (when-let* ((db (jabber-db-ensure-open))) (mapcar (lambda (row) (list :device-id (nth 0 row) :active (not (zerop (nth 1 row))) :last-seen (nth 2 row))) (sqlite-select db "\ SELECT device_id, active, last_seen FROM omemo_devices WHERE account = ? AND jid = ?" (list account jid))))) (defun jabber-omemo-store-set-device-active (account jid device-id active) "Mark device DEVICE-ID as ACTIVE (non-nil) or inactive (nil)." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "\ UPDATE omemo_devices SET active = ? WHERE account = ? AND jid = ? AND device_id = ?" (list (if active 1 0) account jid device-id)))) (defun jabber-omemo-store-delete-device (account jid device-id) "Remove a device record for ACCOUNT, JID, DEVICE-ID." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "\ DELETE FROM omemo_devices WHERE account = ? AND jid = ? AND device_id = ?" (list account jid device-id)))) ;;; Session CRUD (defun jabber-omemo-store-save-session (account jid device-id blob) "Upsert session BLOB for ACCOUNT, JID, DEVICE-ID." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "\ INSERT OR REPLACE INTO omemo_sessions (account, jid, device_id, session_blob) VALUES (?, ?, ?, ?)" (list account jid device-id blob)))) (defun jabber-omemo-store-load-session (account jid device-id) "Load session blob for ACCOUNT, JID, DEVICE-ID, or nil." (when-let* ((db (jabber-db-ensure-open))) (jabber-omemo-store--as-unibyte (caar (sqlite-select db "\ SELECT session_blob FROM omemo_sessions WHERE account = ? AND jid = ? AND device_id = ?" (list account jid device-id)))))) (defun jabber-omemo-store-delete-session (account jid device-id) "Delete session for ACCOUNT, JID, DEVICE-ID." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "\ DELETE FROM omemo_sessions WHERE account = ? AND jid = ? AND device_id = ?" (list account jid device-id)))) (defun jabber-omemo-store-all-sessions (account jid) "List all sessions for ACCOUNT + JID. Returns a list of plists (:device-id INT :session-blob BLOB)." (when-let* ((db (jabber-db-ensure-open))) (mapcar (lambda (row) (list :device-id (nth 0 row) :session-blob (jabber-omemo-store--as-unibyte (nth 1 row)))) (sqlite-select db "\ SELECT device_id, session_blob FROM omemo_sessions WHERE account = ? AND jid = ?" (list account jid))))) ;;; Skipped key CRUD (defun jabber-omemo-store-save-skipped-key (account jid device-id dh-key msg-number msg-key) "Store a skipped message key for ACCOUNT, JID, DEVICE-ID. DH-KEY and MSG-KEY are unibyte blobs. MSG-NUMBER is an integer." (when-let* ((db (jabber-db-ensure-open))) (let ((now (truncate (float-time)))) (sqlite-execute db "\ INSERT OR REPLACE INTO omemo_skipped_keys (account, jid, device_id, dh_key, message_number, message_key, created_at) VALUES (?, ?, ?, ?, ?, ?, ?)" (list account jid device-id dh-key msg-number msg-key now))))) (defun jabber-omemo-store-load-skipped-key (account jid device-id dh-key msg-number) "Load a skipped message key, or nil." (when-let* ((db (jabber-db-ensure-open))) (jabber-omemo-store--as-unibyte (caar (sqlite-select db "\ SELECT message_key FROM omemo_skipped_keys WHERE account = ? AND jid = ? AND device_id = ? AND dh_key = ? AND message_number = ?" (list account jid device-id dh-key msg-number)))))) (defun jabber-omemo-store-delete-skipped-key (account jid device-id dh-key msg-number) "Delete a skipped message key after use." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "\ DELETE FROM omemo_skipped_keys WHERE account = ? AND jid = ? AND device_id = ? AND dh_key = ? AND message_number = ?" (list account jid device-id dh-key msg-number)))) (defun jabber-omemo-store-delete-old-skipped-keys (account max-age) "Delete skipped keys for ACCOUNT older than MAX-AGE seconds." (when-let* ((db (jabber-db-ensure-open))) (let ((cutoff (- (truncate (float-time)) max-age))) (sqlite-execute db "\ DELETE FROM omemo_skipped_keys WHERE account = ? AND created_at < ?" (list account cutoff))))) (provide 'jabber-omemo-store) ;;; jabber-omemo-store.el ends here emacs-jabber/lisp/jabber-omemo-trust.el000066400000000000000000000410001516610113500203720ustar00rootroot00000000000000;;; jabber-omemo-trust.el --- OMEMO trust management UI -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; This file is part of emacs-jabber. ;; emacs-jabber 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 3 of the License, or ;; (at your option) any later version. ;; emacs-jabber 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 emacs-jabber. If not, see . ;;; Commentary: ;; Tabulated-list-mode interface for managing OMEMO device trust. ;; Shows all known keys for a peer with interactive trust toggling ;; and key deletion. ;;; Code: (require 'cl-lib) (require 'jabber-omemo-store) (require 'transient) (declare-function jabber-omemo--format-fingerprint "jabber-omemo") (declare-function jabber-omemo--trust-label "jabber-omemo") (declare-function jabber-omemo--get-device-id "jabber-omemo") (declare-function jabber-omemo--get-store "jabber-omemo") (declare-function jabber-omemo-get-bundle "jabber-omemo") (declare-function jabber-omemo--fetch-device-list "jabber-omemo" (jc jid callback)) (declare-function jabber-omemo--fetch-bundle "jabber-omemo" (jc jid device-id callback)) (declare-function jabber-omemo--remove-device "jabber-omemo" (jc device-id &optional callback)) (declare-function jabber-omemo--device-list-key "jabber-omemo" (account jid)) (declare-function jabber-omemo--prefetch-sessions "jabber-omemo" (jc jid)) (declare-function jabber-connection-bare-jid "jabber-util") (declare-function jabber-jid-user "jabber-util") (declare-function jabber-read-account "jabber-util") (defvar jabber-chatting-with) (defvar jabber-buffer-connection) (defvar jabber-omemo--device-lists) (defun jabber-omemo-trust--strip-key-type (identity-key) "Strip the 0x05 Curve25519 type prefix from IDENTITY-KEY. Returns the key without the first byte, or as-is if shorter than 2 bytes." (if (and (> (length identity-key) 1) (= (aref identity-key 0) #x05)) (substring identity-key 1) identity-key)) (defvar-local jabber-omemo-trust--account nil "Bare JID of the account for this trust buffer.") (defvar-local jabber-omemo-trust--jc nil "Jabber connection for this trust buffer.") (defvar-local jabber-omemo-trust--peer nil "Bare JID of the peer for this trust buffer.") (defvar-local jabber-omemo-trust--fetched nil "List of entries fetched from server bundles.") ;;; Mode (defvar-keymap jabber-omemo-trust-mode-map :doc "Keymap for `jabber-omemo-trust-mode'." "t" #'jabber-omemo-trust-set-verified "u" #'jabber-omemo-trust-set-untrusted "d" #'jabber-omemo-trust-delete "w" #'jabber-omemo-trust-copy-fingerprint "G" #'jabber-omemo-trust-refresh "h" #'jabber-omemo-trust-menu "?" #'jabber-omemo-trust-menu) (defun jabber-omemo--list-format () (let ((list-format `[("Device ID" ,(/ (window-width) 10)) ("Trust" ,(/ (window-width) 10)) ("Fingerprint" ,(/ (window-width) 3)) ("First Seen" ,(/ (window-width) 10))])) list-format)) (define-derived-mode jabber-omemo-trust-mode tabulated-list-mode "OMEMO-Trust" "Major mode for managing OMEMO device trust. \\ \\[jabber-omemo-trust-set-verified] Set trust to verified. \\[jabber-omemo-trust-set-untrusted] Set trust to untrusted. \\[jabber-omemo-trust-delete] Delete key and session." (setq tabulated-list-format (jabber-omemo--list-format)) (setq tabulated-list-padding 2) (tabulated-list-init-header) (setq tabulated-list-entries #'jabber-omemo-trust--entries) (add-hook 'tabulated-list-revert-hook #'jabber-omemo-trust--revert nil t)) (defun jabber-omemo-trust--revert () "Recalculate column widths before revert." (setq tabulated-list-format (jabber-omemo--list-format)) (tabulated-list-init-header)) ;;; Entries (defun jabber-omemo-trust--format-entry (rec) "Format a single trust record REC as a tabulated-list entry." (let ((did (plist-get rec :device-id)) (ik (plist-get rec :identity-key)) (trust (plist-get rec :trust)) (first-seen (plist-get rec :first-seen))) (list did (vector (number-to-string did) (jabber-omemo--trust-label trust) (jabber-omemo--format-fingerprint (jabber-omemo-trust--strip-key-type ik)) (if first-seen (format-time-string "%Y-%m-%d %H:%M" first-seen) ""))))) (defun jabber-omemo-trust--own-device-entry () "Return an entry for the current device from the OMEMO store, or nil." (when-let* ((jc jabber-omemo-trust--jc) (own-jid (jabber-connection-bare-jid jc)) ((string= jabber-omemo-trust--peer own-jid)) (store (jabber-omemo--get-store jc)) (bundle (jabber-omemo-get-bundle store)) (did (jabber-omemo--get-device-id jc)) (ik (plist-get bundle :identity-key))) (let* ((entry (jabber-omemo-trust--format-entry (list :device-id did :identity-key ik :trust nil :first-seen nil))) (cols (cadr entry))) (aset cols 0 (propertize (aref cols 0) 'face 'jabber-chat-nick-encrypted)) (aset cols 1 "self") entry))) (defun jabber-omemo-trust--entries () "Build tabulated-list entries from trust records and fetched bundles." (let ((records (jabber-omemo-store-all-trust jabber-omemo-trust--account jabber-omemo-trust--peer)) (seen (make-hash-table :test #'eql))) (append (when-let* ((own (jabber-omemo-trust--own-device-entry))) (puthash (car own) t seen) (list own)) (mapcar (lambda (rec) (puthash (plist-get rec :device-id) t seen) (jabber-omemo-trust--format-entry rec)) records) ;; Deduplicate fetched entries: skip any device already seen ;; from local trust records or from a previous fetched entry. (let ((unique nil)) (dolist (entry jabber-omemo-trust--fetched) (unless (gethash (car entry) seen) (puthash (car entry) t seen) (push entry unique))) (nreverse unique))))) ;;; Entry point ;;;###autoload (defun jabber-omemo-show-trust (jc jid) "Display OMEMO trust management for JID via connection JC." (interactive (let* ((jc (if (and (bound-and-true-p jabber-buffer-connection) (bound-and-true-p jabber-chatting-with)) jabber-buffer-connection (jabber-read-account))) (jid (if (bound-and-true-p jabber-chatting-with) (jabber-jid-user jabber-chatting-with) (read-string "JID: ")))) (list jc jid))) (unless (bound-and-true-p jabber-omemo--available) (user-error "OMEMO encryption requires the jabber-omemo-core native module")) (let* ((account (jabber-connection-bare-jid jc)) (peer (jabber-jid-user jid)) (buf-name (format "*OMEMO trust: %s*" peer))) (with-current-buffer (get-buffer-create buf-name) (jabber-omemo-trust-mode) (setq jabber-omemo-trust--jc jc jabber-omemo-trust--account account jabber-omemo-trust--peer peer jabber-omemo-trust--fetched nil) (tabulated-list-print t) (switch-to-buffer (current-buffer))) (jabber-omemo--fetch-device-list jc peer (lambda (device-ids) (dolist (did device-ids) (jabber-omemo--fetch-bundle jc peer did (let ((did did)) (lambda (bundle) (when-let* ((ik (and bundle (plist-get bundle :identity-key))) (buf (get-buffer buf-name))) (jabber-omemo-store-ensure-trust account peer did ik) (with-current-buffer buf (push (jabber-omemo-trust--format-entry (list :device-id did :identity-key ik :trust nil :first-seen nil)) jabber-omemo-trust--fetched) (tabulated-list-print t))))))))))) ;;;###autoload (defun jabber-omemo-show-fingerprints (jc) "Display own OMEMO fingerprints across all devices for JC. Fetches the device list and bundles from the server." (interactive (list (jabber-read-account))) (unless (bound-and-true-p jabber-omemo--available) (user-error "OMEMO encryption requires the jabber-omemo-core native module")) (let* ((own-jid (jabber-connection-bare-jid jc)) (buf-name (format "*OMEMO fingerprints: %s*" own-jid)) (our-did (jabber-omemo--get-device-id jc))) (with-current-buffer (get-buffer-create buf-name) (jabber-omemo-trust-mode) (setq jabber-omemo-trust--jc jc jabber-omemo-trust--account own-jid jabber-omemo-trust--peer own-jid jabber-omemo-trust--fetched nil) (tabulated-list-print t) (switch-to-buffer (current-buffer))) (jabber-omemo--fetch-device-list jc own-jid (lambda (device-ids) (dolist (did device-ids) (unless (= did our-did) (jabber-omemo--fetch-bundle jc own-jid did (let ((did did)) (lambda (bundle) (when-let* ((ik (and bundle (plist-get bundle :identity-key))) (buf (get-buffer buf-name))) (jabber-omemo-store-ensure-trust own-jid own-jid did ik) (with-current-buffer buf (let* ((entry (jabber-omemo-trust--format-entry (list :device-id did :identity-key ik :trust nil :first-seen nil))) (cols (cadr entry))) (aset cols 0 (propertize (aref cols 0) 'face 'jabber-chat-nick-foreign-encrypted)) (push entry jabber-omemo-trust--fetched)) (tabulated-list-print t)))))))))))) ;;; Actions (defun jabber-omemo-trust--device-at-point () "Return the device ID at point as an integer, or signal an error." (or (tabulated-list-get-id) (user-error "No device at point"))) (defun jabber-omemo-trust-set-verified () "Mark the device at point as verified." (interactive) (let ((did (jabber-omemo-trust--device-at-point))) (jabber-omemo-store-set-trust jabber-omemo-trust--account jabber-omemo-trust--peer did 2) (tabulated-list-print t) (message "Device %d marked as verified" did))) (defun jabber-omemo-trust-set-untrusted () "Mark the device at point as untrusted." (interactive) (let ((did (jabber-omemo-trust--device-at-point))) (jabber-omemo-store-set-trust jabber-omemo-trust--account jabber-omemo-trust--peer did -1) (jabber-omemo-store-delete-session jabber-omemo-trust--account jabber-omemo-trust--peer did) (tabulated-list-print t) (message "Device %d marked as untrusted" did))) (defun jabber-omemo-trust--own-peer-p () "Return non-nil if viewing our own fingerprints." (and jabber-omemo-trust--jc (string= jabber-omemo-trust--peer (jabber-connection-bare-jid jabber-omemo-trust--jc)))) (defun jabber-omemo-trust-delete () "Delete the device key and session at point. When viewing own fingerprints, also remove the device from the server-side device list and delete its bundle PubSub node." (interactive) (let ((did (jabber-omemo-trust--device-at-point))) (if (jabber-omemo-trust--own-peer-p) (let ((our-did (jabber-omemo--get-device-id jabber-omemo-trust--jc))) (when (= did our-did) (user-error "Cannot delete the current device")) (when (y-or-n-p (format "Remove device %d from server and delete local data? " did)) (jabber-omemo-store-delete-trust jabber-omemo-trust--account jabber-omemo-trust--peer did) (jabber-omemo-store-delete-session jabber-omemo-trust--account jabber-omemo-trust--peer did) (setq jabber-omemo-trust--fetched (cl-remove-if (lambda (entry) (= (car entry) did)) jabber-omemo-trust--fetched)) (jabber-omemo--remove-device jabber-omemo-trust--jc did (let ((buf (current-buffer))) (lambda () (when (buffer-live-p buf) (with-current-buffer buf (tabulated-list-print t)))))) (tabulated-list-print t) (message "Device %d removed" did))) (when (y-or-n-p (format "Delete key and session for device %d? " did)) (jabber-omemo-store-delete-trust jabber-omemo-trust--account jabber-omemo-trust--peer did) (jabber-omemo-store-delete-session jabber-omemo-trust--account jabber-omemo-trust--peer did) (tabulated-list-print t) (message "Device %d deleted" did))))) (defun jabber-omemo-trust-copy-fingerprint () "Copy the fingerprint of the device at point to the kill ring." (interactive) (jabber-omemo-trust--device-at-point) (let ((fingerprint (aref (tabulated-list-get-entry) 2))) (kill-new fingerprint) (message "Copied: %s" fingerprint))) (defun jabber-omemo-trust-refresh () "Re-fetch device list and bundles from the server. Clears the cached device list for the peer, then fetches fresh data from PubSub and updates the buffer." (interactive) (let ((jc jabber-omemo-trust--jc) (peer jabber-omemo-trust--peer) (account jabber-omemo-trust--account) (buf (current-buffer))) (remhash (jabber-omemo--device-list-key account peer) jabber-omemo--device-lists) (setq jabber-omemo-trust--fetched nil) (tabulated-list-print t) (jabber-omemo--fetch-device-list jc peer (lambda (device-ids) (dolist (did device-ids) (jabber-omemo--fetch-bundle jc peer did (let ((did did)) (lambda (bundle) (when-let* ((ik (and bundle (plist-get bundle :identity-key))) ((buffer-live-p buf))) (jabber-omemo-store-ensure-trust account peer did ik) (with-current-buffer buf (push (jabber-omemo-trust--format-entry (list :device-id did :identity-key ik :trust nil :first-seen nil)) jabber-omemo-trust--fetched) (tabulated-list-print t))))))) (jabber-omemo--prefetch-sessions jc peer))) (message "Fetching devices for %s..." peer))) ;;; Transient (defun jabber-omemo-trust--menu-description () "Return description string for the transient menu." (let ((lines (list (format "Peer: %s Account: %s" (propertize jabber-omemo-trust--peer 'face 'jabber-chat-nick-foreign-encrypted) (propertize jabber-omemo-trust--account 'face 'jabber-chat-nick-encrypted))))) (string-join (nreverse lines) "\n"))) (transient-define-prefix jabber-omemo-trust-menu () "OMEMO trust commands." [:description jabber-omemo-trust--menu-description [("t" "Verify" jabber-omemo-trust-set-verified) ("u" "Untrust" jabber-omemo-trust-set-untrusted) ("d" "Delete" jabber-omemo-trust-delete) ("w" "Copy fingerprint" jabber-omemo-trust-copy-fingerprint) ("g" "Refresh" revert-buffer) ("G" "Re-fetch from server" jabber-omemo-trust-refresh)]]) ;;; Cleanup on disconnect (defun jabber-omemo-trust--kill-buffers () "Kill all OMEMO trust/fingerprint buffers." (dolist (buf (buffer-list)) (when (eq (buffer-local-value 'major-mode buf) 'jabber-omemo-trust-mode) (kill-buffer buf)))) (with-eval-after-load "jabber-core" (add-hook 'jabber-post-disconnect-hook #'jabber-omemo-trust--kill-buffers)) (provide 'jabber-omemo-trust) ;;; jabber-omemo-trust.el ends here emacs-jabber/lisp/jabber-omemo.el000066400000000000000000002006031516610113500172210ustar00rootroot00000000000000;;; jabber-omemo.el --- OMEMO encryption for jabber.el -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Author: Thanos Apollo ;; Maintainer: Thanos Apollo ;; This file is part of emacs-jabber. ;; emacs-jabber 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 3 of the License, or ;; (at your option) any later version. ;; emacs-jabber 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 emacs-jabber. If not, see . ;;; Commentary: ;; Public Elisp API for OMEMO 0.3 (eu.siacs.conversations.axolotl). ;; Wraps the jabber-omemo-core dynamic module (picomemo). ;; ;; This file handles loading the native module, building it on demand ;; if missing, and re-exports the core functions under the public ;; jabber-omemo- namespace. ;;; Code: (require 'cl-lib) (require 'hex-util) (require 'jabber-omemo-store) (require 'jabber-pubsub) (require 'jabber-xml) (require 'jabber-hints) (require 'jabber-eme) (require 'jabber-omemo-trust) (declare-function jabber-connection-bare-jid "jabber-util") (declare-function jabber-jid-user "jabber-util") (declare-function jabber-iq-error "jabber-util") (declare-function jabber-parse-error "jabber-util") (declare-function jabber-error-condition "jabber-util") (declare-function jabber-disco-advertise-feature "jabber-disco") (declare-function jabber-send-iq "jabber-iq") (declare-function jabber-send-sexp "jabber-core") (declare-function jabber-chat--run-send-hooks "jabber-chat" (stanza body id)) (declare-function jabber-chat--msg-plist-from-stanza "jabber-chat") (declare-function jabber-maybe-print-rare-time "jabber-chat") (declare-function jabber-chat-ewoc-enter "jabber-chatbuffer") (declare-function jabber-chat-ewoc-invalidate "jabber-chatbuffer" (node)) (declare-function jabber-httpupload--upload "jabber-httpupload") (declare-function jabber-httpupload--send-url "jabber-httpupload") (declare-function jabber-db--outgoing-handler "jabber-db" (body id)) (declare-function jabber-chat-register-decrypt-handler "jabber-chat" (id &rest props)) (declare-function jabber-chat--set-body "jabber-chat" (xml-data text)) (declare-function ewoc-data "ewoc" (node)) (defcustom jabber-omemo-enable t "Whether to enable OMEMO encryption support. When nil, the native module is not loaded and OMEMO features are disabled. Set to nil if you do not have the build toolchain to compile jabber-omemo-core." :type 'boolean :group 'jabber) (defcustom jabber-omemo-skipped-key-max-age (* 30 86400) "Maximum age in seconds for OMEMO skipped message keys. Keys older than this are deleted on connect." :type 'integer :group 'jabber) (defvar jabber-omemo--reconfigured-nodes (make-hash-table :test 'equal) "Nodes already reconfigured this session to prevent retry loops.") (defvar jabber-post-connect-hooks) (defvar jabber-pre-disconnect-hook) (defvar jabber-pubsub-node-handlers) (defvar jabber-chat-send-hooks) (defvar jabber-chat-ewoc) (defvar jabber-chatting-with) (defvar jabber-chat-encryption) (defvar jabber-chat-printers) (defvar jabber-group) (defvar jabber-muc-participants) (defvar jabber-httpupload-pre-upload-transform) (defvar jabber-httpupload-send-url-function) (defvar jabber-message-reply--id) ; jabber-message-reply.el (defvar jabber-message-reply--jid) ; jabber-message-reply.el (defvar jabber-omemo-build-command (cond ((eq system-type 'darwin) "make module CC=clang") ((eq system-type 'berkeley-unix) "gmake module CC=clang") (t "make module")) "Shell command to build the jabber-omemo-core dynamic module. Run from the emacs-jabber project root.") (defun jabber-omemo--build-module (project-root) "Build the native module synchronously from PROJECT-ROOT. Compiles picomemo via `jabber-omemo-build-command', then loads the resulting module. Signals an error on build failure." (let ((default-directory project-root) (buf (get-buffer-create "*jabber-omemo-build*"))) (message "Building jabber-omemo-core module...") (unless (zerop (call-process-shell-command jabber-omemo-build-command nil buf t)) (pop-to-buffer buf) (error "Failed to build jabber-omemo-core module. See *jabber-omemo-build*")) (require 'jabber-omemo-core) (message "jabber-omemo-core module built and loaded."))) (defvar jabber-omemo--available nil "Non-nil when the jabber-omemo-core native module is loaded.") ;; Module availability check. Runs once at load time; `defvar' above ;; preserves `jabber-omemo--available' across repeated loads so the ;; prompt cannot fire more than once per session. (unless (or jabber-omemo--available (not jabber-omemo-enable) (not module-file-suffix)) (if (require 'jabber-omemo-core nil t) (setq jabber-omemo--available t) (let* ((this-file (or load-file-name buffer-file-name)) (this-dir (and this-file (file-name-directory this-file))) (src-candidate (and this-dir (expand-file-name "src" this-dir))) (src-dir (if (and src-candidate (file-directory-p src-candidate)) src-candidate (and this-dir (expand-file-name "../src" this-dir))))) (if (and (not noninteractive) src-dir (file-exists-p (expand-file-name "jabber-omemo-core.c" src-dir)) (yes-or-no-p (concat "jabber-omemo-core module not found. " "Fetch picomemo from github.com and build it now? "))) (progn (jabber-omemo--build-module (file-name-directory (directory-file-name src-dir))) (setq jabber-omemo--available t)) (message (concat "OMEMO: native module not found, encryption disabled. " "Clone https://git.thanosapollo.org/emacs-jabber, " "run `make module', and place the resulting " "jabber-omemo-core%s on your `load-path'.") module-file-suffix))))) ;; Declare internal C functions from the dynamic module for the byte-compiler. ;; "ext:" prefix tells check-declare to skip file verification. (declare-function jabber-omemo--setup-store "ext:jabber-omemo-core") (declare-function jabber-omemo--deserialize-store "ext:jabber-omemo-core") (declare-function jabber-omemo--serialize-store "ext:jabber-omemo-core") (declare-function jabber-omemo--get-bundle "ext:jabber-omemo-core") (declare-function jabber-omemo--rotate-signed-pre-key "ext:jabber-omemo-core") (declare-function jabber-omemo--refill-pre-keys "ext:jabber-omemo-core") (declare-function jabber-omemo--encrypt-message "ext:jabber-omemo-core") (declare-function jabber-omemo--decrypt-message "ext:jabber-omemo-core") (declare-function jabber-omemo--make-session "ext:jabber-omemo-core") (declare-function jabber-omemo--initiate-session "ext:jabber-omemo-core") (declare-function jabber-omemo--serialize-session "ext:jabber-omemo-core") (declare-function jabber-omemo--deserialize-session "ext:jabber-omemo-core") (declare-function jabber-omemo--encrypt-key "ext:jabber-omemo-core") (declare-function jabber-omemo--decrypt-key "ext:jabber-omemo-core") (declare-function jabber-omemo--heartbeat "ext:jabber-omemo-core") (declare-function jabber-omemo--aesgcm-decrypt "ext:jabber-omemo-core") (declare-function jabber-omemo--aesgcm-encrypt "ext:jabber-omemo-core") ;;; Errors ;; ;; The C module defines `jabber-omemo-error' as the parent condition ;; on init. We redefine it here so subtype declarations work even ;; when the native module is not available. (define-error 'jabber-omemo-error "OMEMO error") (define-error 'jabber-omemo-not-for-us "OMEMO message not encrypted for this device" 'jabber-omemo-error) (define-error 'jabber-omemo-no-session "No OMEMO session with sender device" 'jabber-omemo-error) (define-error 'jabber-omemo-prekey-failed "OMEMO pre-key decryption failed" 'jabber-omemo-error) ;; Public API (defun jabber-omemo-setup-store () "Generate a new OMEMO device store. Returns a serialized store as a unibyte string." (jabber-omemo--setup-store)) (defun jabber-omemo-deserialize-store (blob) "Deserialize BLOB into an OMEMO store object. Returns a user-ptr; freed automatically by GC." (jabber-omemo--deserialize-store blob)) (defun jabber-omemo-serialize-store (store-ptr) "Serialize STORE-PTR back to a unibyte string." (jabber-omemo--serialize-store store-ptr)) (defun jabber-omemo-get-bundle (store-ptr) "Extract the public bundle from STORE-PTR. Returns a plist with keys :identity-key, :signed-pre-key, :signed-pre-key-id, :signature, :pre-keys." (jabber-omemo--get-bundle store-ptr)) (defun jabber-omemo-rotate-signed-pre-key (store-ptr) "Rotate the signed pre-key in STORE-PTR. Mutates the store; caller must re-serialize." (jabber-omemo--rotate-signed-pre-key store-ptr)) (defun jabber-omemo-refill-pre-keys (store-ptr) "Refill removed pre-keys in STORE-PTR. Mutates the store; caller must re-serialize." (jabber-omemo--refill-pre-keys store-ptr)) (defun jabber-omemo-encrypt-message (plaintext) "Encrypt PLAINTEXT (a unibyte string) with OMEMO 0.3. Returns a plist (:key KEY :iv IV :ciphertext CT), all unibyte strings." (jabber-omemo--encrypt-message plaintext)) (defun jabber-omemo-decrypt-message (key iv ciphertext) "Decrypt an OMEMO 0.3 message. KEY is a unibyte string (>= 32 bytes: 16 AES key + auth tag). IV is a 12-byte unibyte string. CIPHERTEXT is the encrypted payload. Returns the plaintext as a unibyte string." (jabber-omemo--decrypt-message key iv ciphertext)) (defun jabber-omemo-make-session () "Allocate an empty OMEMO session. Returns a session user-ptr; freed automatically by GC. Use for the receiving side of a pre-key message." (jabber-omemo--make-session)) (defun jabber-omemo-initiate-session (store-ptr sig spk ik pk spk-id pk-id) "Initiate an OMEMO session with a remote device's bundle. STORE-PTR is the local OMEMO store. SIG is a 64-byte signature, SPK/IK/PK are 33-byte serialized keys. SPK-ID and PK-ID are integer key IDs. Returns a session user-ptr; freed automatically by GC." (jabber-omemo--initiate-session store-ptr sig spk ik pk spk-id pk-id)) (defun jabber-omemo-serialize-session (session-ptr) "Serialize SESSION-PTR to a unibyte string." (jabber-omemo--serialize-session session-ptr)) (defun jabber-omemo-deserialize-session (blob) "Deserialize BLOB into an OMEMO session object. Returns a session user-ptr; freed automatically by GC." (jabber-omemo--deserialize-session blob)) (defun jabber-omemo-encrypt-key (session-ptr key) "Encrypt KEY for a recipient using SESSION-PTR. KEY is a unibyte string (the message encryption key). Returns a plist (:data BYTES :pre-key-p BOOL)." (jabber-omemo--encrypt-key session-ptr key)) (defun jabber-omemo-decrypt-key (session-ptr store-ptr pre-key-p msg) "Decrypt an encrypted key message. SESSION-PTR is the session with the sender. STORE-PTR is the local OMEMO store. PRE-KEY-P is non-nil if this is a pre-key message. MSG is the encrypted key message as a unibyte string. Returns the decrypted key as a unibyte string." (jabber-omemo--decrypt-key session-ptr store-ptr pre-key-p msg)) (defun jabber-omemo-heartbeat (session-ptr store-ptr) "Check if a heartbeat message is needed after decryption. SESSION-PTR is the session to check. STORE-PTR is the local OMEMO store. Returns heartbeat message bytes or nil." (jabber-omemo--heartbeat session-ptr store-ptr)) (defun jabber-omemo-aesgcm-decrypt (key iv ciphertext-with-tag) "Decrypt CIPHERTEXT-WITH-TAG using AES-256-GCM. KEY is a 32-byte unibyte string, IV is a 12-byte unibyte string. The last 16 bytes of CIPHERTEXT-WITH-TAG are the GCM auth tag." (jabber-omemo--aesgcm-decrypt key iv ciphertext-with-tag)) (defun jabber-omemo-aesgcm-encrypt (plaintext) "Encrypt PLAINTEXT using AES-256-GCM for aesgcm:// media sharing. PLAINTEXT is a unibyte string. Returns a plist \(:key KEY :iv IV :ciphertext CIPHERTEXT-WITH-TAG)." (jabber-omemo--aesgcm-encrypt plaintext)) (defun jabber-omemo--build-aesgcm-url (https-url iv key) "Build an aesgcm:// URL from HTTPS-URL, IV, and KEY. IV is a 12-byte unibyte string, KEY is a 32-byte unibyte string. Returns a string like aesgcm://HOST/PATH#IVHEX_KEYHEX." (unless (string-prefix-p "https://" https-url) (error "Expected https:// URL, got: %s" (substring https-url 0 (min 40 (length https-url))))) (let ((fragment (concat (encode-hex-string iv) (encode-hex-string key)))) (concat "aesgcm://" (substring https-url (length "https://")) "#" fragment))) ;;; Protocol constants (defconst jabber-omemo-xmlns "eu.siacs.conversations.axolotl" "OMEMO 0.3 XML namespace.") (defconst jabber-omemo-devicelist-node "eu.siacs.conversations.axolotl.devicelist" "PubSub node for OMEMO device lists.") (defconst jabber-omemo-bundles-node-prefix "eu.siacs.conversations.axolotl.bundles:" "PubSub node prefix for OMEMO bundles (append device ID).") (defconst jabber-omemo--devicelist-publish-options '(("pubsub#access_model" . "open")) "Publish-options for the OMEMO device list PubSub node.") (defconst jabber-omemo--bundle-publish-options '(("pubsub#persist_items" . "true") ("pubsub#max_items" . "max") ("pubsub#access_model" . "open")) "Publish-options for OMEMO bundle PubSub nodes.") (defconst jabber-omemo-fallback-body "This message is encrypted with OMEMO and could not be displayed." "Plaintext fallback body for non-OMEMO clients.") ;;; In-memory state (defvar jabber-omemo--device-ids (make-hash-table :test 'equal) "Cache of account -> device ID (integer).") (defvar jabber-omemo--stores (make-hash-table :test 'equal) "Cache of account -> deserialized store user-ptr.") (defvar jabber-omemo--device-lists (make-hash-table :test 'equal) "Cache of \"account\\0jid\" -> list of device ID integers.") (defvar jabber-omemo--sessions (make-hash-table :test 'equal) "Cache of \"account\\0jid\\0device-id\" -> deserialized session user-ptr.") (defvar jabber-omemo--bundle-publishes-in-flight (make-hash-table :test 'equal) "Set of bundle publish requests currently in flight. Keyed by \"BARE-JID:DEVICE-ID\". Mirrors Dino's `active_bundle_requests' to dedup concurrent self-bundle fetches.") (defconst jabber-omemo--prekey-min-count 100 "Minimum number of pre-keys our published bundle should advertise. Below this we refill locally and republish. Matches picomemo's `OMEMO_NUMPREKEYS' refill target and Dino's `NUM_KEYS_TO_PUBLISH', so any drift between local and published state triggers a republish.") ;;; Internal helpers (defun jabber-omemo--device-list-key (account jid) "Return hash key for ACCOUNT and JID device list cache." (concat account "\0" jid)) (defun jabber-omemo--session-key (account jid device-id) "Return hash key for ACCOUNT, JID, DEVICE-ID session cache." (concat account "\0" jid "\0" (number-to-string device-id))) (defun jabber-omemo--generate-device-id () "Generate a random OMEMO device ID (1 to 2^31 - 1)." (1+ (random (1- (ash 1 31))))) (defun jabber-omemo--get-store (jc) "Load or create the OMEMO store for connection JC. Returns a deserialized store user-ptr, cached for future calls." (let ((account (jabber-connection-bare-jid jc))) (or (gethash account jabber-omemo--stores) (let* ((blob (jabber-omemo-store-load account)) (store-ptr (if blob (jabber-omemo-deserialize-store blob) (let ((new-blob (jabber-omemo-setup-store))) (jabber-omemo-store-save account new-blob) (jabber-omemo-deserialize-store new-blob))))) (puthash account store-ptr jabber-omemo--stores) store-ptr)))) (defun jabber-omemo--get-device-id (jc) "Load or generate the OMEMO device ID for connection JC. Returns an integer, cached for future calls." (let ((account (jabber-connection-bare-jid jc))) (or (gethash account jabber-omemo--device-ids) (let ((id (or (jabber-omemo-store-load-device-id account) (let ((new-id (jabber-omemo--generate-device-id))) (jabber-omemo-store-save-device-id account new-id) new-id)))) (puthash account id jabber-omemo--device-ids) id)))) (defun jabber-omemo--get-session (jc jid device-id) "Load session for JID's DEVICE-ID via connection JC. Returns a deserialized session user-ptr, or nil." (let* ((account (jabber-connection-bare-jid jc)) (key (jabber-omemo--session-key account jid device-id))) (or (gethash key jabber-omemo--sessions) (when-let* ((blob (jabber-omemo-store-load-session account jid device-id))) (let ((session-ptr (jabber-omemo-deserialize-session blob))) (puthash key session-ptr jabber-omemo--sessions) session-ptr))))) (defun jabber-omemo--save-session (jc jid device-id session-ptr) "Serialize and persist SESSION-PTR for JID's DEVICE-ID via JC. Updates both the database and in-memory cache." (let* ((account (jabber-connection-bare-jid jc)) (key (jabber-omemo--session-key account jid device-id)) (blob (jabber-omemo-serialize-session session-ptr))) (jabber-omemo-store-save-session account jid device-id blob) (puthash key session-ptr jabber-omemo--sessions))) ;;; Device list XML helpers (defun jabber-omemo--parse-device-list (items) "Parse PubSub ITEMS into a list of device ID integers. ITEMS is a list of child elements from the PubSub node. Extracts from the element." (let (ids) (dolist (item items) (when (eq (jabber-xml-node-name item) 'item) (let ((list-el (car (jabber-xml-get-children item 'list)))) (when list-el (dolist (dev (jabber-xml-get-children list-el 'device)) (let ((id-str (jabber-xml-get-attribute dev 'id))) (when id-str (push (string-to-number id-str) ids)))))))) (nreverse ids))) (defun jabber-omemo--build-device-list-xml (device-ids) "Build XML sexp for a device list containing DEVICE-IDS." `(list ((xmlns . ,jabber-omemo-xmlns)) ,@(mapcar (lambda (id) `(device ((id . ,(number-to-string id))))) device-ids))) ;;; Device list management (defun jabber-omemo--deactivate-stale-devices (account jid current-ids) "Mark devices for ACCOUNT+JID not in CURRENT-IDS as inactive." (dolist (rec (jabber-omemo-store-load-devices account jid)) (let ((did (plist-get rec :device-id))) (when (and (plist-get rec :active) (not (memq did current-ids))) (jabber-omemo-store-set-device-active account jid did nil))))) (defun jabber-omemo--fetch-device-list (jc jid callback) "Fetch the OMEMO device list for JID via connection JC. On success, parse and call (funcall CALLBACK device-id-list). Updates the in-memory cache and database." (jabber-pubsub-request jc jid jabber-omemo-devicelist-node (lambda (jc xml-data _closure) (let* ((pubsub (car (jabber-xml-get-children xml-data 'pubsub))) (items-node (car (jabber-xml-get-children pubsub 'items))) (items (jabber-xml-node-children items-node)) (ids (jabber-omemo--parse-device-list items)) (account (jabber-connection-bare-jid jc)) (bare-jid (jabber-jid-user jid))) (puthash (jabber-omemo--device-list-key account bare-jid) ids jabber-omemo--device-lists) (dolist (id ids) (jabber-omemo-store-save-device account bare-jid id)) (jabber-omemo--deactivate-stale-devices account bare-jid ids) (when callback (funcall callback ids)))) (lambda (_jc xml-data _closure) (message "jabber-omemo: failed to fetch device list for %s: %s" jid (jabber-parse-error (jabber-iq-error xml-data))) (when callback (funcall callback nil))))) (defun jabber-omemo--handle-publish-conflict (jc node item-id payload options xml-data label) "Handle a PubSub publish error for LABEL. If the error is a publish-options conflict, retry without options and reconfigure the node. Otherwise just warn. JC is the connection, NODE and ITEM-ID identify the item, PAYLOAD is the XML to publish, OPTIONS is the original publish-options alist, and XML-DATA is the error IQ stanza." (let* ((err (jabber-iq-error xml-data)) (condition (and err (jabber-error-condition err)))) (if (eq condition 'conflict) (if (gethash node jabber-omemo--reconfigured-nodes) (warn "jabber-omemo: giving up on %s (already reconfigured)" label) (puthash node t jabber-omemo--reconfigured-nodes) (message "OMEMO: publish-options conflict for %s, retrying" label) (jabber-pubsub-publish jc nil node item-id payload nil #'ignore (lambda (_jc xml-data2 _closure) (warn "jabber-omemo: failed to publish %s (retry): %s" label (jabber-parse-error (jabber-iq-error xml-data2))))) (jabber-pubsub-configure-node jc nil node options nil (lambda (_jc xml-data2 _closure) (warn "jabber-omemo: failed to reconfigure %s node: %s" label (jabber-parse-error (jabber-iq-error xml-data2)))))) (warn "jabber-omemo: failed to publish %s: %s" label (if err (jabber-parse-error err) "unknown error"))))) (defun jabber-omemo--publish-device-list (jc device-ids) "Publish DEVICE-IDS as our OMEMO device list via JC." (let ((payload (jabber-omemo--build-device-list-xml device-ids)) (node jabber-omemo-devicelist-node)) (jabber-pubsub-publish jc nil node "current" payload jabber-omemo--devicelist-publish-options #'ignore (lambda (_jc xml-data _closure) (jabber-omemo--handle-publish-conflict jc node "current" payload jabber-omemo--devicelist-publish-options xml-data "device list"))))) (defun jabber-omemo--ensure-device-listed (jc) "Ensure our device ID is on our published device list via JC. Fetches the current list, adds our ID if missing, re-publishes. When our ID was missing (new installation), also checks other listed devices for stale copies sharing our identity key and removes them." (let ((our-id (jabber-omemo--get-device-id jc))) (jabber-omemo--fetch-device-list jc (jabber-connection-bare-jid jc) (lambda (ids) (if (memq our-id ids) ;; Already listed, nothing to do. nil (jabber-omemo--publish-device-list jc (cons our-id (or ids '()))) ;; New installation: check for stale devices with our key. (jabber-omemo--cleanup-stale-devices jc ids)))))) (defun jabber-omemo--cleanup-stale-devices (jc other-ids) "Remove devices from OTHER-IDS that share our identity key. JC is the Jabber connection. Fetches the bundle for each device in OTHER-IDS, collects stale device IDs, then removes them all in a single device list republish to avoid race conditions." (let* ((store (jabber-omemo--get-store jc)) (our-bundle (jabber-omemo-get-bundle store)) (our-ik (plist-get our-bundle :identity-key)) (own-jid (jabber-connection-bare-jid jc)) (remaining (length other-ids)) (stale nil)) (if (zerop remaining) nil (dolist (did other-ids) (jabber-omemo--fetch-bundle jc own-jid did (let ((did did)) (lambda (bundle) (when-let* ((ik (and bundle (plist-get bundle :identity-key))) ((string= ik our-ik))) (push did stale)) (cl-decf remaining) (when (zerop remaining) (jabber-omemo--remove-stale-devices jc stale))))))))) (defun jabber-omemo--remove-stale-devices (jc stale-ids) "Remove STALE-IDS from the device list and delete their bundles. JC is the Jabber connection. Does a single fetch-filter-republish for all stale devices, then deletes each bundle node." (when stale-ids (message "OMEMO: removing %d stale device(s): %s" (length stale-ids) stale-ids) (jabber-omemo--fetch-device-list jc (jabber-connection-bare-jid jc) (lambda (ids) (let ((new-ids (cl-remove-if (lambda (id) (memq id stale-ids)) ids))) (jabber-omemo--publish-device-list jc new-ids) (dolist (did stale-ids) (jabber-omemo--delete-bundle-node jc did))))))) (defun jabber-omemo--delete-bundle-node (jc device-id) "Delete the bundle PubSub node for DEVICE-ID via JC." (jabber-pubsub-delete-node jc nil (concat jabber-omemo-bundles-node-prefix (number-to-string device-id)) nil (lambda (_jc xml _closure) (message "OMEMO: failed to delete bundle for %d: %s" device-id (jabber-xml-path xml '(error)))))) (defun jabber-omemo--remove-device (jc device-id &optional callback) "Remove DEVICE-ID from our published device list and delete its bundle. Fetches the current list, filters out DEVICE-ID, re-publishes, then deletes the bundle PubSub node. Calls CALLBACK when done." (jabber-omemo--fetch-device-list jc (jabber-connection-bare-jid jc) (lambda (ids) (let ((new-ids (cl-remove device-id ids))) (jabber-omemo--publish-device-list jc new-ids) (message "OMEMO: republished device list without %d (%d -> %d devices)" device-id (length ids) (length new-ids))) (jabber-pubsub-delete-node jc nil (concat jabber-omemo-bundles-node-prefix (number-to-string device-id)) (when callback (lambda (_jc _xml _closure) (funcall callback))) (lambda (_jc xml _closure) (message "OMEMO: failed to delete bundle for %d: %s" device-id (jabber-xml-path xml '(error)))))))) (defun jabber-omemo--handle-device-list (jc from _node items) "Handle incoming PubSub device list notification. JC is the connection, FROM is the sender JID, ITEMS is the list of child elements from the event. When our own device is missing from our device list, re-add and re-publish." (let* ((account (jabber-connection-bare-jid jc)) (bare-jid (jabber-jid-user from)) (ids (jabber-omemo--parse-device-list items))) (when (string= bare-jid account) (let ((our-id (jabber-omemo--get-device-id jc))) (unless (memq our-id ids) (message "OMEMO: own device %d dropped from device list, re-adding" our-id) (setq ids (cons our-id ids)) (jabber-omemo--publish-device-list jc ids)))) (when (string= bare-jid account) (jabber-omemo--publish-bundle-if-needed jc)) (puthash (jabber-omemo--device-list-key account bare-jid) ids jabber-omemo--device-lists) (dolist (id ids) (jabber-omemo-store-save-device account bare-jid id)) (jabber-omemo--deactivate-stale-devices account bare-jid ids))) ;;; Bundle XML helpers (defun jabber-omemo--build-bundle-xml (store-ptr) "Build XML sexp from STORE-PTR's bundle data. Calls `jabber-omemo-get-bundle' and base64-encodes all keys." (let* ((bundle (jabber-omemo-get-bundle store-ptr)) (ik (plist-get bundle :identity-key)) (spk (plist-get bundle :signed-pre-key)) (spk-id (plist-get bundle :signed-pre-key-id)) (sig (plist-get bundle :signature)) (pre-keys (plist-get bundle :pre-keys))) `(bundle ((xmlns . ,jabber-omemo-xmlns)) (signedPreKeyPublic ((signedPreKeyId . ,(number-to-string spk-id))) ,(base64-encode-string spk t)) (signedPreKeySignature () ,(base64-encode-string sig t)) (identityKey () ,(base64-encode-string ik t)) (prekeys () ,@(mapcar (lambda (pk) `(preKeyPublic ((preKeyId . ,(number-to-string (car pk)))) ,(base64-encode-string (cdr pk) t))) pre-keys))))) (defun jabber-omemo--parse-bundle-xml (xml) "Parse bundle XML into a plist for session initiation. XML is a element sexp. Returns (:signature BYTES :signed-pre-key BYTES :identity-key BYTES :signed-pre-key-id INT :pre-keys ((ID . BYTES) ...)) All key material is base64-decoded to unibyte strings. Returns nil if any required element is missing or empty." (let* ((spk-el (car (jabber-xml-get-children xml 'signedPreKeyPublic))) (sig-el (car (jabber-xml-get-children xml 'signedPreKeySignature))) (ik-el (car (jabber-xml-get-children xml 'identityKey))) (pks-el (car (jabber-xml-get-children xml 'prekeys))) (spk-text (car (jabber-xml-node-children spk-el))) (sig-text (car (jabber-xml-node-children sig-el))) (ik-text (car (jabber-xml-node-children ik-el)))) (if (not (and (stringp spk-text) (stringp sig-text) (stringp ik-text))) (progn (message "jabber-omemo: malformed bundle XML (missing key data)") nil) (let ((spk-id (string-to-number (or (jabber-xml-get-attribute spk-el 'signedPreKeyId) "0"))) (spk-data (base64-decode-string spk-text)) (sig-data (base64-decode-string sig-text)) (ik-data (base64-decode-string ik-text)) pre-keys) (dolist (pk (jabber-xml-get-children pks-el 'preKeyPublic)) (let ((pk-text (car (jabber-xml-node-children pk)))) (when (stringp pk-text) (let ((pk-id (string-to-number (or (jabber-xml-get-attribute pk 'preKeyId) "0"))) (pk-data (base64-decode-string pk-text))) (push (cons pk-id pk-data) pre-keys))))) (list :signature sig-data :signed-pre-key spk-data :identity-key ik-data :signed-pre-key-id spk-id :pre-keys (nreverse pre-keys)))))) ;;; Bundle management (defun jabber-omemo--publish-bundle (jc) "Publish our OMEMO bundle to PubSub via JC." (let* ((store-ptr (jabber-omemo--get-store jc)) (device-id (jabber-omemo--get-device-id jc)) (node (concat jabber-omemo-bundles-node-prefix (number-to-string device-id)))) (let ((payload (jabber-omemo--build-bundle-xml store-ptr)) (item-id (number-to-string device-id))) (jabber-pubsub-publish jc nil node item-id payload jabber-omemo--bundle-publish-options #'ignore (lambda (_jc xml-data _closure) (jabber-omemo--handle-publish-conflict jc node item-id payload jabber-omemo--bundle-publish-options xml-data (format "bundle for device %d" device-id))))))) (defun jabber-omemo--fetch-bundle (jc jid device-id callback) "Fetch OMEMO bundle for JID's DEVICE-ID via JC. On success, parse and call (funcall CALLBACK bundle-plist) where bundle-plist has keys from `jabber-omemo--parse-bundle-xml'. On error, calls (funcall CALLBACK nil)." (let ((node (concat jabber-omemo-bundles-node-prefix (number-to-string device-id)))) (jabber-pubsub-request jc jid node (lambda (_jc xml-data _closure) (let* ((pubsub (car (jabber-xml-get-children xml-data 'pubsub))) (items-node (car (jabber-xml-get-children pubsub 'items))) (item (car (jabber-xml-get-children items-node 'item))) (bundle-el (car (jabber-xml-get-children item 'bundle))) (parsed (when bundle-el (jabber-omemo--parse-bundle-xml bundle-el)))) (funcall callback parsed))) (lambda (_jc xml-data _closure) (warn "jabber-omemo: failed to fetch bundle for %s device %d: %s" jid device-id (jabber-parse-error (jabber-iq-error xml-data))) (funcall callback nil))))) (defun jabber-omemo--bundle-needs-republish-p (local published) "Return non-nil if PUBLISHED bundle is out of date vs LOCAL. Both arguments are bundle plists (see `jabber-omemo-get-bundle' and `jabber-omemo--parse-bundle-xml'). PUBLISHED may be nil when no bundle is published yet. The pre-key drift check assumes the server prunes consumed pre-keys from the published bundle per XEP-0384 Section 4.3; Prosody, ejabberd, MongooseIM, Tigase and Openfire all do. Against a non-compliant server that never prunes, rotation of pre-key ids without a size drop will be silently missed. Dino's structural intersection in `stream_module.vala:254-273' catches that edge case; matching it would require plumbing the local pre-key set into this predicate." (or (null published) (not (equal (plist-get local :identity-key) (plist-get published :identity-key))) (not (equal (plist-get local :signed-pre-key-id) (plist-get published :signed-pre-key-id))) (not (equal (plist-get local :signed-pre-key) (plist-get published :signed-pre-key))) (< (length (plist-get published :pre-keys)) jabber-omemo--prekey-min-count))) (defun jabber-omemo--publish-bundle-if-needed (jc) "Fetch our published bundle and republish only if out of date. Dedups concurrent calls per JC via `jabber-omemo--bundle-publishes-in-flight'." (let* ((bare-jid (jabber-connection-bare-jid jc)) (device-id (jabber-omemo--get-device-id jc)) (key (format "%s:%d" bare-jid device-id))) (unless (gethash key jabber-omemo--bundle-publishes-in-flight) (puthash key t jabber-omemo--bundle-publishes-in-flight) (jabber-omemo--fetch-bundle jc bare-jid device-id (lambda (published) (unwind-protect (let* ((store-ptr (jabber-omemo--get-store jc)) (local (jabber-omemo-get-bundle store-ptr))) (when (jabber-omemo--bundle-needs-republish-p local published) (message "OMEMO: republishing bundle (out of date)") (jabber-omemo-refill-pre-keys store-ptr) (jabber-omemo--persist-store jc) (jabber-omemo--publish-bundle jc))) (remhash key jabber-omemo--bundle-publishes-in-flight))))))) ;;; Session establishment (defun jabber-omemo--establish-session (jc jid device-id bundle) "Establish an OMEMO session with JID's DEVICE-ID using BUNDLE. BUNDLE is a plist from `jabber-omemo--parse-bundle-xml'. Selects a random pre-key, initiates the session, saves to DB and cache, and stores an undecided trust record (TOFU)." (let* ((store-ptr (jabber-omemo--get-store jc)) (pre-keys (plist-get bundle :pre-keys)) (signed-pre-key (plist-get bundle :signed-pre-key)) (identity-key (plist-get bundle :identity-key)) (signed-pre-key-id (plist-get bundle :signed-pre-key-id))) (unless (and pre-keys signed-pre-key identity-key signed-pre-key-id) (user-error "OMEMO: incomplete bundle for %s device %d (missing %s)" jid device-id (string-join (delq nil (list (unless pre-keys "pre-keys") (unless signed-pre-key "signed-pre-key") (unless identity-key "identity-key") (unless signed-pre-key-id "signed-pre-key-id"))) ", "))) (let* ((pk (nth (random (length pre-keys)) pre-keys)) (session-ptr (jabber-omemo-initiate-session store-ptr (plist-get bundle :signature) signed-pre-key identity-key (cdr pk) signed-pre-key-id (car pk))) (account (jabber-connection-bare-jid jc))) (jabber-omemo--save-session jc jid device-id session-ptr) (jabber-omemo-store-save-trust account jid device-id identity-key 0) session-ptr))) (defun jabber-omemo--load-device-list-from-db (account jid) "Load cached device IDs for ACCOUNT + JID from the database. Returns a list of active device ID integers, or nil." (let ((records (jabber-omemo-store-load-devices account jid))) (mapcar (lambda (r) (plist-get r :device-id)) (cl-remove-if-not (lambda (r) (plist-get r :active)) records)))) (defun jabber-omemo--ensure-sessions (jc jid callback) "Ensure sessions exist for all active devices of JID via JC. Checks in-memory cache, then DB, then PubSub for the device list. For each device lacking a session, fetches the bundle and establishes one. Calls (funcall CALLBACK sessions) when done, where sessions is a list of (DEVICE-ID . SESSION-PTR) for all active devices." (let* ((account (jabber-connection-bare-jid jc)) (bare-jid (jabber-jid-user jid)) (cache-key (jabber-omemo--device-list-key account bare-jid)) (cached-ids (or (gethash cache-key jabber-omemo--device-lists) (let ((db-ids (jabber-omemo--load-device-list-from-db account bare-jid))) (when db-ids (puthash cache-key db-ids jabber-omemo--device-lists)) db-ids)))) (if cached-ids (jabber-omemo--ensure-sessions-for-ids jc bare-jid cached-ids callback) (jabber-omemo--fetch-device-list jc bare-jid (lambda (ids) (if ids (jabber-omemo--ensure-sessions-for-ids jc bare-jid ids callback) (funcall callback nil))))))) (defun jabber-omemo--ensure-sessions-for-ids (jc jid device-ids callback) "Ensure sessions for DEVICE-IDS of JID via JC, then call CALLBACK. CALLBACK receives a list of (DEVICE-ID . SESSION-PTR)." (let ((our-id (jabber-omemo--get-device-id jc)) (pending 0) (results nil)) (dolist (did device-ids) (unless (= did our-id) (let ((existing (jabber-omemo--get-session jc jid did))) (if existing (push (cons did existing) results) (cl-incf pending) (jabber-omemo--fetch-bundle jc jid did (lambda (bundle) (when bundle (let ((session (jabber-omemo--establish-session jc jid did bundle))) (push (cons did session) results))) (cl-decf pending) (when (zerop pending) (funcall callback results)))))))) (when (zerop pending) (funcall callback results)))) ;;; Message encryption XML (defun jabber-omemo--trusted-sessions (jc sessions) "Filter SESSIONS to exclude devices marked untrusted via JC. SESSIONS is a list of (DEVICE-ID . SESSION-PTR). Returns the filtered list, dropping any device with trust = -1." (let ((account (jabber-connection-bare-jid jc))) (cl-remove-if (lambda (entry) (let* ((did (car entry)) (jid (jabber-omemo--session-jid-for-did jc did)) (trust-rec (and jid (jabber-omemo-store-load-trust account jid did)))) (and trust-rec (= (plist-get trust-rec :trust) -1)))) sessions))) (defun jabber-omemo--build-encrypted-xml (jc sessions enc-result) "Build XML sexp for an OMEMO 0.3 message. JC is the Jabber connection (for our device ID). SESSIONS is a list of (DEVICE-ID . SESSION-PTR) for all recipients \(including our own other devices). ENC-RESULT is the plist from `jabber-omemo-encrypt-message'." (setq sessions (jabber-omemo--trusted-sessions jc sessions)) (unless sessions (user-error "OMEMO: no trusted devices for any recipient")) (let* ((our-sid (jabber-omemo--get-device-id jc)) (key (plist-get enc-result :key)) (iv (plist-get enc-result :iv)) (ciphertext (plist-get enc-result :ciphertext)) key-elements) (dolist (entry sessions) (let* ((did (car entry)) (session-ptr (cdr entry)) (encrypted-key (jabber-omemo-encrypt-key session-ptr key)) (data (plist-get encrypted-key :data)) (pre-key-p (plist-get encrypted-key :pre-key-p))) (push `(key ((rid . ,(number-to-string did)) ,@(when pre-key-p '((prekey . "true")))) ,(base64-encode-string data t)) key-elements) (jabber-omemo--save-session jc (jabber-jid-user (jabber-omemo--session-jid-for-did jc did)) did session-ptr))) (jabber-omemo--persist-store jc) `(encrypted ((xmlns . ,jabber-omemo-xmlns)) (header ((sid . ,(number-to-string our-sid))) ,@(nreverse key-elements) (iv () ,(base64-encode-string iv t))) (payload () ,(base64-encode-string ciphertext t))))) (defun jabber-omemo--session-jid-for-did (jc device-id) "Look up the JID associated with DEVICE-ID in the session cache for JC. Searches through `jabber-omemo--sessions' hash keys." (let ((account (jabber-connection-bare-jid jc)) result) (maphash (lambda (key _val) (unless result (let* ((parts (split-string key "\0")) (acct (nth 0 parts)) (jid (nth 1 parts)) (did (string-to-number (nth 2 parts)))) (when (and (string= acct account) (= did device-id)) (setq result jid))))) jabber-omemo--sessions) result)) ;;; Message decryption XML (defun jabber-omemo--parse-encrypted (xml-data) "Parse OMEMO element from XML-DATA. Returns plist (:sid INT :iv BYTES :payload BYTES :keys ALIST) where :keys is ((DEVICE-ID :data BYTES :pre-key-p BOOL) ...). Returns nil if no element." (when-let* ((encrypted (jabber-xml-child-with-xmlns xml-data jabber-omemo-xmlns))) (let* ((header (car (jabber-xml-get-children encrypted 'header))) (sid (string-to-number (or (jabber-xml-get-attribute header 'sid) "0"))) (iv-el (car (jabber-xml-get-children header 'iv))) (iv (base64-decode-string (car (jabber-xml-node-children iv-el)))) (payload-el (car (jabber-xml-get-children encrypted 'payload))) (payload (when payload-el (let ((text (car (jabber-xml-node-children payload-el)))) (when (and text (not (string-empty-p text))) (base64-decode-string text))))) keys) (dolist (key-el (jabber-xml-get-children header 'key)) (let ((rid (string-to-number (or (jabber-xml-get-attribute key-el 'rid) "0"))) (pre-key-p (equal (jabber-xml-get-attribute key-el 'prekey) "true")) (data (base64-decode-string (car (jabber-xml-node-children key-el))))) (push (list rid :data data :pre-key-p pre-key-p) keys))) (list :sid sid :iv iv :payload payload :keys (nreverse keys))))) (defun jabber-omemo--persist-store (jc) "Serialize and save the OMEMO store for JC to the database." (let* ((account (jabber-connection-bare-jid jc)) (store-ptr (gethash account jabber-omemo--stores))) (when store-ptr (jabber-omemo-store-save account (jabber-omemo-serialize-store store-ptr))))) ;;; Receive path (defun jabber-omemo--decrypt-stanza (jc xml-data parsed) "Decrypt OMEMO message in XML-DATA using PARSED data. Returns modified XML-DATA with decrypted body. Signals structured errors that callers can dispatch on: - `jabber-omemo-not-for-us' when the stanza has no key entry for our device (heartbeat or message addressed to a different device). - `jabber-omemo-no-session' for a non-prekey message when we have no local session with the sender's device. - `jabber-omemo-prekey-failed' when the C decrypt fails on a pre-key message (usually a stale local pre-key). - `jabber-omemo-error' (the parent) for all other crypto failures." (let* ((our-did (jabber-omemo--get-device-id jc)) (account (jabber-connection-bare-jid jc)) (from (jabber-xml-get-attribute xml-data 'from)) (sender-jid (and from (jabber-jid-user from)))) (if (not sender-jid) (warn "OMEMO: ignoring encrypted message with no 'from' attribute") (let* ((sender-did (plist-get parsed :sid)) (iv (plist-get parsed :iv)) (payload (plist-get parsed :payload)) (keys (plist-get parsed :keys)) (our-key-entry (cl-find our-did keys :key #'car))) (unless our-key-entry (signal 'jabber-omemo-not-for-us (list our-did))) (let* ((key-data (plist-get (cdr our-key-entry) :data)) (pre-key-p (plist-get (cdr our-key-entry) :pre-key-p)) (store-ptr (jabber-omemo--get-store jc)) (session-ptr (if pre-key-p (jabber-omemo-make-session) (or (jabber-omemo--get-session jc sender-jid sender-did) (signal 'jabber-omemo-no-session (list sender-jid sender-did))))) (decrypted-key (condition-case err (jabber-omemo-decrypt-key session-ptr store-ptr pre-key-p key-data) (jabber-omemo-error (if pre-key-p (signal 'jabber-omemo-prekey-failed (list sender-jid sender-did (error-message-string err))) (signal (car err) (cdr err))))))) (jabber-omemo--save-session jc sender-jid sender-did session-ptr) (jabber-omemo--persist-store jc) (let ((trust (jabber-omemo-store-load-trust account sender-jid sender-did))) (when (and trust (zerop (plist-get trust :trust))) (jabber-omemo-store-set-trust account sender-jid sender-did 1) (message "%s auto-trusted device %d for %s (TOFU)" (propertize "OMEMO:" 'face 'warning) sender-did sender-jid))) (when-let* ((hb (jabber-omemo-heartbeat session-ptr store-ptr))) (jabber-omemo--send-heartbeat jc sender-jid sender-did hb)) (if payload (let* ((plaintext (jabber-omemo-decrypt-message decrypted-key iv payload)) (text (decode-coding-string plaintext 'utf-8))) (jabber-chat--set-body xml-data text)) xml-data)))))) (defvar jabber-omemo--sent-muc-plaintexts (make-hash-table :test #'equal) "Cache of recently-sent OMEMO MUC message plaintexts. Keyed by message ID string. Entries are consumed when the MUC server echo is received, so the cache is normally near-empty.") (defun jabber-omemo--detect-encrypted (xml-data) "Detect OMEMO encryption in XML-DATA. Returns a detection plist or nil. Checks MUC echo cache first, then looks for element." (let* ((msg-id (jabber-xml-get-attribute xml-data 'id)) (cached (and msg-id (gethash msg-id jabber-omemo--sent-muc-plaintexts)))) (cond (cached (remhash msg-id jabber-omemo--sent-muc-plaintexts) (list :type 'muc-echo :cached cached)) (t (when-let* ((parsed (jabber-omemo--parse-encrypted xml-data))) (list :type 'omemo :parsed parsed)))))) (defun jabber-omemo--decrypt-handler (jc xml-data detected) "Decrypt OMEMO message. DETECTED is the plist from detect. Catches structured OMEMO errors: - `jabber-omemo-not-for-us': silently return XML-DATA unchanged (the stanza is for a different device on the same JID, or a heartbeat that doesn't concern us). - `jabber-omemo-prekey-failed': log and re-signal so the dispatcher reports the failure to the user. Bundle repair happens via the lifecycle-driven `--publish-bundle-if-needed' trigger, not from the decrypt path. Other OMEMO errors propagate unchanged so the dispatcher can replace the body with a generic decrypt-failed placeholder." (pcase (plist-get detected :type) ('muc-echo (jabber-chat--set-body xml-data (plist-get detected :cached))) ('omemo (condition-case err (jabber-omemo--decrypt-stanza jc xml-data (plist-get detected :parsed)) (jabber-omemo-not-for-us xml-data) (jabber-omemo-prekey-failed (message "OMEMO: pre-key decrypt failed: %s" (error-message-string err)) (signal (car err) (cdr err))))) (_ xml-data))) (defun jabber-omemo--send-heartbeat (jc to device-id heartbeat-bytes) "Send OMEMO heartbeat (empty encrypted message, no payload). JC is the connection. TO is the recipient bare JID. DEVICE-ID is the recipient's device. HEARTBEAT-BYTES is the encrypted key material to send." (let* ((our-sid (jabber-omemo--get-device-id jc)) (iv (make-string 12 0)) (stanza `(message ((to . ,to) (type . "chat")) (encrypted ((xmlns . ,jabber-omemo-xmlns)) (header ((sid . ,(number-to-string our-sid))) (key ((rid . ,(number-to-string device-id))) ,(base64-encode-string heartbeat-bytes t)) (iv () ,(base64-encode-string iv t)))) ,(jabber-hints-store)))) (jabber-send-sexp jc stanza))) ;;; MUC helpers (defun jabber-omemo--muc-participant-jids (_group participants) "Return deduplicated list of bare JIDs for PARTICIPANTS. PARTICIPANTS is the alist from `jabber-muc-participants'. Entries without a real JID are excluded." (let (jids) (dolist (entry participants) (when-let* ((full-jid (plist-get (cdr entry) 'jid)) (bare (jabber-jid-user full-jid))) (unless (member bare jids) (push bare jids)))) (nreverse jids))) (defun jabber-omemo--ensure-sessions-multi (jc jids callback) "Ensure OMEMO sessions for all JIDS via JC. Calls (funcall CALLBACK all-sessions) when done, where all-sessions is a list of (DEVICE-ID . SESSION-PTR)." (if (null jids) (funcall callback nil) (let ((pending (length jids)) (all-sessions nil)) (dolist (jid jids) (jabber-omemo--ensure-sessions jc jid (lambda (sessions) (setq all-sessions (append sessions all-sessions)) (cl-decf pending) (when (zerop pending) (funcall callback all-sessions)))))))) ;;; Send path (defun jabber-omemo--display-pending (buffer body id) "Display BODY in BUFFER as a message with :sending status. ID is the stanza id. Persists to DB immediately. Returns the ewoc node, or nil if BUFFER is dead." (when (buffer-live-p buffer) (with-current-buffer buffer (let* ((reply-id (bound-and-true-p jabber-message-reply--id)) (reply-jid (bound-and-true-p jabber-message-reply--jid)) (msg-plist (list :id id :body body :timestamp (current-time) :status :sending :encrypted t))) (when reply-id (plist-put msg-plist :reply-to-id reply-id) (plist-put msg-plist :reply-to-jid reply-jid)) (jabber-db--outgoing-handler body id) (when (run-hook-with-args-until-success 'jabber-chat-printers msg-plist :local :printp) (let ((node (jabber-chat-ewoc-enter (list :local msg-plist)))) (jabber-maybe-print-rare-time node) node)))))) (defun jabber-omemo--send-failed (buffer node body reason) "Mark NODE as :undelivered and restore BODY to input area. BUFFER is the chat buffer. REASON is shown via `message'." (when (buffer-live-p buffer) (with-current-buffer buffer (when node (plist-put (cadr (ewoc-data node)) :status :undelivered) (jabber-chat-ewoc-invalidate node)) (goto-char (point-max)) (insert body))) (message "%s" reason)) (defun jabber-omemo--send-chat (jc body &optional extra-elements) "Send BODY as OMEMO-encrypted message via JC. Must be called from a chat buffer with `jabber-chatting-with' set. EXTRA-ELEMENTS are spliced into the stanza outside the encryption envelope (e.g. XEP-0308 replace)." (let* ((recipient (jabber-jid-user jabber-chatting-with)) (chat-with jabber-chatting-with) (is-correction (assq 'replace extra-elements)) (buffer (if is-correction nil (current-buffer))) (id (format "emacs-msg-%.6f" (float-time))) (node (unless is-correction (jabber-omemo--display-pending (current-buffer) body id)))) (jabber-omemo--ensure-sessions jc recipient (lambda (recipient-sessions) (if (null recipient-sessions) (jabber-omemo--send-failed buffer node body (format "OMEMO: no sessions for %s, cannot send" recipient)) (jabber-omemo--ensure-sessions jc (jabber-connection-bare-jid jc) (lambda (own-sessions) (jabber-omemo--send-encrypted jc body chat-with (append recipient-sessions own-sessions) buffer node id extra-elements)))))))) (defun jabber-omemo--send-encrypted (jc body chat-with all-sessions &optional buffer node id extra-elements) "Build and send an OMEMO-encrypted stanza. JC is the connection. BODY is the plaintext. CHAT-WITH is the recipient full/bare JID for addressing. ALL-SESSIONS is a list of (DEVICE-ID . SESSION-PTR) for recipient + own other devices. Optional BUFFER, NODE, ID support immediate display: when NODE is non-nil, update its status from :sending to :sent instead of inserting a new ewoc entry. EXTRA-ELEMENTS are spliced into the stanza outside the encryption envelope." (let* ((chat-with (or chat-with jabber-chatting-with)) (id (or id (format "emacs-msg-%.6f" (float-time)))) (is-correction (assq 'replace extra-elements)) (buffer (or buffer (unless is-correction (current-buffer)))) (plaintext (encode-coding-string body 'utf-8)) (enc-result (jabber-omemo-encrypt-message plaintext)) (encrypted-xml (jabber-omemo--build-encrypted-xml jc all-sessions enc-result)) (stanza `(message ((to . ,chat-with) (type . "chat") (id . ,id)) (body () ,jabber-omemo-fallback-body) ,encrypted-xml ,(jabber-hints-store) ,(jabber-eme-encryption jabber-omemo-xmlns "OMEMO") ,@extra-elements))) (when (buffer-live-p buffer) (with-current-buffer buffer ;; Inline hook loop instead of jabber-chat--run-send-hooks: ;; this runs from an async IQ callback where current buffer ;; is not the chat buffer, so we need with-current-buffer. (dolist (hook jabber-chat-send-hooks) (if (eq hook t) (when (local-variable-p 'jabber-chat-send-hooks) (dolist (global-hook (default-value 'jabber-chat-send-hooks)) (nconc stanza (funcall global-hook body id)))) (nconc stanza (funcall hook body id)))) (if node (progn (plist-put (cadr (ewoc-data node)) :status :sent) (jabber-chat-ewoc-invalidate node)) (let ((msg-plist (jabber-chat--msg-plist-from-stanza stanza))) (plist-put msg-plist :body body) (plist-put msg-plist :status :sent) (when (run-hook-with-args-until-success 'jabber-chat-printers msg-plist :local :printp) (jabber-maybe-print-rare-time (jabber-chat-ewoc-enter (list :local msg-plist)))))))) (jabber-send-sexp jc stanza))) (defun jabber-omemo--send-muc (jc body &optional extra-elements) "Send BODY as OMEMO-encrypted groupchat message via JC. Must be called from a MUC buffer with `jabber-group' set. EXTRA-ELEMENTS are spliced into the stanza outside the encryption envelope." (let* ((group jabber-group) (buffer (current-buffer)) (participants (cdr (assoc group jabber-muc-participants))) (bare-jids (jabber-omemo--muc-participant-jids group participants))) (if (null bare-jids) (progn (jabber-omemo--send-failed buffer nil body "OMEMO: no participant JIDs available (room may be anonymous)") (user-error "OMEMO: no participant JIDs available (room may be anonymous)")) (jabber-omemo--ensure-sessions-multi jc bare-jids (lambda (all-sessions) (if (null all-sessions) (jabber-omemo--send-failed buffer nil body "OMEMO: no sessions for MUC participants, cannot send") (jabber-omemo--ensure-sessions jc (jabber-connection-bare-jid jc) (lambda (own-sessions) (jabber-omemo--send-encrypted-muc jc body group (append all-sessions own-sessions) extra-elements))))))))) (defun jabber-omemo--send-encrypted-muc (jc body group all-sessions &optional extra-elements) "Build and send an OMEMO-encrypted MUC stanza. JC is the connection. BODY is the plaintext. GROUP is the room JID. ALL-SESSIONS is a list of (DEVICE-ID . SESSION-PTR) for all participants plus own other devices. EXTRA-ELEMENTS are spliced into the stanza outside the encryption envelope. No local echo: the MUC server mirrors the message back." (let* ((plaintext (encode-coding-string body 'utf-8)) (enc-result (jabber-omemo-encrypt-message plaintext)) (encrypted-xml (jabber-omemo--build-encrypted-xml jc all-sessions enc-result)) (id (format "emacs-msg-%.6f" (float-time))) (_ (puthash id body jabber-omemo--sent-muc-plaintexts)) (stanza `(message ((to . ,group) (type . "groupchat") (id . ,id)) (body () ,jabber-omemo-fallback-body) ,encrypted-xml ,(jabber-hints-store) ,(jabber-eme-encryption jabber-omemo-xmlns "OMEMO") ,@extra-elements))) (jabber-chat--run-send-hooks stanza body id) (jabber-send-sexp jc stanza))) (defun jabber-omemo--prefetch-sessions (jc jid) "Pre-fetch OMEMO sessions for JID via JC in the background. Called when OMEMO is enabled in a chat buffer." (jabber-omemo--ensure-sessions jc jid #'ignore)) (defun jabber-omemo--prefetch-muc-sessions (jc group) "Pre-fetch OMEMO sessions for all participants in GROUP via JC. Called when OMEMO is enabled in a MUC buffer." (let* ((participants (cdr (assoc group jabber-muc-participants))) (bare-jids (jabber-omemo--muc-participant-jids group participants))) (when bare-jids (jabber-omemo--ensure-sessions-multi jc bare-jids #'ignore)))) ;;; Trust and fingerprints (defun jabber-omemo--format-fingerprint (identity-key) "Format IDENTITY-KEY as space-separated hex pairs." (mapconcat (lambda (byte) (format "%02X" byte)) identity-key " ")) (defun jabber-omemo--trust-label (level) "Return a human-readable label for trust LEVEL." (pcase level ('nil "new") (0 "undecided") (1 "TOFU") (2 "verified") (-1 "UNTRUSTED") (_ (format "unknown(%d)" level)))) (defun jabber-omemo-fingerprints () "Display OMEMO trust management for the current chat peer. Opens a tabulated-list buffer with interactive trust controls." (interactive) (unless (bound-and-true-p jabber-chatting-with) (user-error "Not in a chat buffer")) (jabber-omemo-show-trust jabber-buffer-connection jabber-chatting-with)) (defalias 'jabber-omemo-trust-device #'jabber-omemo-fingerprints) (defalias 'jabber-omemo-untrust-device #'jabber-omemo-fingerprints) ;;; Connect/disconnect hooks ;;;###autoload (defun jabber-omemo-on-connect (jc) "Post-connect hook for OMEMO initialization. Loads or creates the store, ensures our device is listed, republishes our bundle if it's out of date, and pre-fetches sessions for open chat buffers." (jabber-omemo--get-store jc) (jabber-omemo--get-device-id jc) (jabber-omemo--ensure-device-listed jc) (jabber-omemo--publish-bundle-if-needed jc) (jabber-omemo--prefetch-open-chats jc) (jabber-omemo-store-delete-old-skipped-keys (jabber-connection-bare-jid jc) jabber-omemo-skipped-key-max-age)) (defun jabber-omemo--prefetch-open-chats (jc) "Pre-fetch OMEMO sessions for all open OMEMO chat buffers on JC." (dolist (buf (buffer-list)) (with-current-buffer buf (when (and (eq major-mode 'jabber-chat-mode) (eq jabber-buffer-connection jc) (eq jabber-chat-encryption 'omemo) (bound-and-true-p jabber-chatting-with)) (jabber-omemo--prefetch-sessions jc (jabber-jid-user jabber-chatting-with)))))) ;;;###autoload (defun jabber-omemo--on-disconnect () "Pre-disconnect hook. Clear OMEMO in-memory caches." (clrhash jabber-omemo--device-ids) (clrhash jabber-omemo--stores) (clrhash jabber-omemo--device-lists) (clrhash jabber-omemo--sessions) (clrhash jabber-omemo--reconfigured-nodes) (clrhash jabber-omemo--bundle-publishes-in-flight)) ;;; XEP-0454: aesgcm file upload (defun jabber-omemo--httpupload-transform (filepath callback) "Encrypt FILEPATH for aesgcm upload when OMEMO is active. Returns (ENCRYPTED-PATH . WRAPPED-CALLBACK) or nil." (when (eq jabber-chat-encryption 'omemo) (condition-case err (let* ((plaintext (with-temp-buffer (set-buffer-multibyte nil) (insert-file-contents-literally filepath) (buffer-string))) (enc (jabber-omemo-aesgcm-encrypt plaintext)) (key (plist-get enc :key)) (iv (plist-get enc :iv)) (ciphertext (plist-get enc :ciphertext)) (tmp (make-temp-file "jabber-aesgcm-" nil (file-name-extension filepath t)))) (with-temp-file tmp (set-buffer-multibyte nil) (insert ciphertext)) (cons tmp (lambda (get-url) (ignore-errors (delete-file tmp)) (funcall callback (jabber-omemo--build-aesgcm-url get-url iv key))))) (error (message "aesgcm: file encryption failed: %s" (error-message-string err)) nil)))) (defun jabber-omemo--httpupload-send-url (jc jid get-url) "Send aesgcm:// URL as OMEMO-encrypted message. Returns non-nil if handled, nil to fall through to plaintext." (when (string-prefix-p "aesgcm://" get-url) (if (bound-and-true-p jabber-group) (jabber-omemo--send-muc jc get-url) (jabber-omemo--ensure-sessions jc (jabber-jid-user jid) (lambda (recipient-sessions) (jabber-omemo--ensure-sessions jc (jabber-connection-bare-jid jc) (lambda (own-sessions) (jabber-omemo--send-encrypted jc get-url jid (append recipient-sessions own-sessions))))))) t)) ;;; Disco and PubSub registration (when jabber-omemo--available (jabber-disco-advertise-feature jabber-omemo-xmlns) (jabber-disco-advertise-feature (concat jabber-omemo-devicelist-node "+notify")) (with-eval-after-load "jabber-pubsub" (setf (alist-get jabber-omemo-devicelist-node jabber-pubsub-node-handlers nil nil #'equal) #'jabber-omemo--handle-device-list)) (with-eval-after-load "jabber-core" (add-hook 'jabber-post-connect-hooks #'jabber-omemo-on-connect) (add-hook 'jabber-pre-disconnect-hook #'jabber-omemo--on-disconnect)) (with-eval-after-load "jabber-httpupload" (setq jabber-httpupload-pre-upload-transform #'jabber-omemo--httpupload-transform) (setq jabber-httpupload-send-url-function #'jabber-omemo--httpupload-send-url))) (when jabber-omemo--available (jabber-chat-register-decrypt-handler 'omemo :detect #'jabber-omemo--detect-encrypted :decrypt #'jabber-omemo--decrypt-handler :priority 10 :error-label "OMEMO")) (provide 'jabber-omemo) ;;; jabber-omemo.el ends here emacs-jabber/lisp/jabber-openpgp-legacy.el000066400000000000000000000376511516610113500210320ustar00rootroot00000000000000;;; jabber-openpgp-legacy.el --- XEP-0027 Legacy OpenPGP for jabber.el -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Author: Thanos Apollo ;; Maintainer: Thanos Apollo ;; This file is part of emacs-jabber. ;; emacs-jabber 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 3 of the License, or ;; (at your option) any later version. ;; emacs-jabber 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 emacs-jabber. If not, see . ;;; Commentary: ;; XEP-0027 (Current Jabber OpenPGP Usage) support. ;; Used by Conversations (Android) and other legacy XMPP clients. ;; ;; Protocol summary: ;; - Signed presence: sign text, send as ;; - Encrypted message: encrypt , send as ;; - Armor headers are stripped per XEP-0027; only base64 body is transmitted ;; ;; Uses Emacs's built-in EasyPG (epg.el) for GPG operations. ;; Reuses key lookup from jabber-openpgp.el (XEP-0373). ;;; Code: (require 'epg) (require 'jabber-xml) (require 'jabber-hints) (eval-when-compile (require 'cl-lib)) (declare-function jabber-openpgp--our-key "jabber-openpgp" (jc)) (declare-function jabber-openpgp--our-key-safe "jabber-openpgp" (jc)) (declare-function jabber-openpgp--recipient-key "jabber-openpgp" (jid)) (declare-function jabber-connection-bare-jid "jabber-util" (jc)) (declare-function jabber-jid-user "jabber-util" (jid)) (declare-function jabber-send-sexp "jabber-core" (jc sexp)) (declare-function jabber-chat--run-send-hooks "jabber-chat" (stanza body id)) (declare-function jabber-chat--msg-plist-from-stanza "jabber-chat" (xml-data &optional delayed)) (declare-function jabber-maybe-print-rare-time "jabber-chat" (node)) (declare-function jabber-chat-ewoc-enter "jabber-chatbuffer" (data)) (declare-function jabber-disco-advertise-feature "jabber-disco" (feature)) (declare-function jabber-chain-add "jabber-core" (chain-var handler &optional depth)) (declare-function jabber-chat-register-decrypt-handler "jabber-chat" (id &rest props)) (declare-function jabber-chat--set-body "jabber-chat" (xml-data text)) (defvar jabber-chatting-with) ; jabber-chat.el (defvar jabber-group) ; jabber-muc.el (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el (defvar jabber-chat-send-hooks) ; jabber-chat.el (defvar jabber-chat-printers) ; jabber-chat.el (defvar jabber-muc-participants) ; jabber-muc.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-presence-element-functions) ; jabber-presence.el (defvar jabber-presence-chain) ; jabber-core.el (defvar *jabber-current-status*) ; jabber.el (defvar jabber-jid-obarray) ; jabber-util.el ;;; Constants (defconst jabber-openpgp-legacy-signed-xmlns "jabber:x:signed" "Namespace for XEP-0027 signed presence.") (defconst jabber-openpgp-legacy-encrypted-xmlns "jabber:x:encrypted" "Namespace for XEP-0027 encrypted messages.") (defconst jabber-openpgp-legacy-fallback-body "This message is encrypted with OpenPGP." "Fallback body for clients that don't support XEP-0027.") ;;; Customization (defcustom jabber-openpgp-legacy-sign-presence t "Whether to sign outgoing presence with OpenPGP. Only active when a GPG key is configured." :type 'boolean :group 'jabber) (defcustom jabber-openpgp-legacy-auto-fetch-keys t "Whether to automatically fetch GPG keys from keyservers. When a signed presence reveals a key ID not in the local keyring, attempt to fetch it via `gpg --recv-keys'." :type 'boolean :group 'jabber) ;;; Armor helpers (defun jabber-openpgp-legacy--strip-armor (armored-text) "Strip PGP armor headers and footers from ARMORED-TEXT. Returns only the base64 body and checksum, as required by XEP-0027." (with-temp-buffer (insert armored-text) (goto-char (point-min)) ;; Skip the -----BEGIN PGP ... ----- line (when (re-search-forward "^-----BEGIN PGP [^-]+-----\n" nil t) (delete-region (point-min) (point))) ;; Skip header lines (Version:, Hash:, Comment:, etc.) and blank line (goto-char (point-min)) (while (looking-at "^[A-Za-z]+: .*\n") (delete-region (line-beginning-position) (1+ (line-end-position)))) ;; Skip blank line after headers (when (looking-at "^\n") (delete-region (point) (1+ (point)))) ;; Remove the -----END PGP ... ----- line (goto-char (point-max)) (when (re-search-backward "^-----END PGP [^-]+-----" nil t) (delete-region (line-beginning-position) (point-max))) ;; Trim trailing whitespace (goto-char (point-max)) (skip-chars-backward " \t\n") (delete-region (point) (point-max)) (buffer-string))) (defun jabber-openpgp-legacy--rearmor-signature (stripped) "Wrap STRIPPED base64 back into a PGP SIGNATURE armor block." (concat "-----BEGIN PGP SIGNATURE-----\n\n" stripped "\n" "-----END PGP SIGNATURE-----\n")) (defun jabber-openpgp-legacy--rearmor-message (stripped) "Wrap STRIPPED base64 back into a PGP MESSAGE armor block." (concat "-----BEGIN PGP MESSAGE-----\n\n" stripped "\n" "-----END PGP MESSAGE-----\n")) ;;; Signed presence (outgoing) (defvar jabber-openpgp-legacy--sign-cache nil "Cache for presence signature: (STATUS KEY ELEMENTS). Avoids redundant GPG calls when signing the same status text.") (defvar jabber-openpgp-legacy--signing-in-progress nil "Non-nil when GPG signing is in progress. `epg-wait-for-status' processes pending timers while waiting for GPG, which can trigger MUC joins that call this function again. This guard prevents the re-entrant nesting that causes `excessive-lisp-nesting'.") (defun jabber-openpgp-legacy--sign-presence (jc) "Return signed presence elements for JC. Added to `jabber-presence-element-functions'. Signs the current status text (or empty string) with our GPG key. Caches the result and guards against re-entrant GPG calls." (when jabber-openpgp-legacy-sign-presence (require 'jabber-openpgp) (when-let* ((key (jabber-openpgp--our-key-safe jc))) (let ((status (or (bound-and-true-p *jabber-current-status*) ""))) (cond ;; Cache hit: same status and key, return cached elements. ((and jabber-openpgp-legacy--sign-cache (equal status (nth 0 jabber-openpgp-legacy--sign-cache)) (eq key (nth 1 jabber-openpgp-legacy--sign-cache))) (nth 2 jabber-openpgp-legacy--sign-cache)) ;; Re-entrance: GPG is already running, skip signing. ;; The MUC join presence will lack the signature this time; ;; subsequent presence updates will use the cached result. (jabber-openpgp-legacy--signing-in-progress nil) ;; Normal case: sign, cache, and return. (t (condition-case err (let ((jabber-openpgp-legacy--signing-in-progress t)) (let* ((ctx (epg-make-context 'OpenPGP)) (_ (setf (epg-context-armor ctx) t)) (_ (setf (epg-context-signers ctx) (list key))) (sig (epg-sign-string ctx (encode-coding-string status 'utf-8) 'detached)) (stripped (jabber-openpgp-legacy--strip-armor sig)) (elements (list `(x ((xmlns . ,jabber-openpgp-legacy-signed-xmlns)) ,stripped)))) (setq jabber-openpgp-legacy--sign-cache (list status key elements)) elements)) (error (message "XEP-0027: signing presence failed: %s" (error-message-string err)) nil)))))))) ;;; Signed presence (incoming) (defun jabber-openpgp-legacy--process-presence (_jc xml-data) "Process incoming presence for XEP-0027 signed element. JC is the connection. XML-DATA is the presence stanza. Verifies the signature and optionally fetches missing keys." (when-let* ((x-el (jabber-xml-child-with-xmlns xml-data jabber-openpgp-legacy-signed-xmlns)) (stripped (car (jabber-xml-node-children x-el))) ((stringp stripped))) (let* ((from (jabber-xml-get-attribute xml-data 'from)) (status-el (car (jabber-xml-get-children xml-data 'status))) (status (or (and status-el (car (jabber-xml-node-children status-el))) "")) (armored (jabber-openpgp-legacy--rearmor-signature stripped)) (ctx (epg-make-context 'OpenPGP))) (condition-case err (progn (epg-verify-string ctx armored (encode-coding-string status 'utf-8)) (let ((result (epg-context-result-for ctx 'verify))) (when result (let* ((sig (car result)) (fpr (epg-signature-fingerprint sig))) (when fpr (let ((bare (jabber-jid-user from))) (put (intern bare jabber-jid-obarray) 'pgp-key-id fpr))))))) (error (let ((msg (error-message-string err))) (when (and jabber-openpgp-legacy-auto-fetch-keys (string-match-p "No public key" msg)) (jabber-openpgp-legacy--try-fetch-key-from-error msg from)))))))) (defun jabber-openpgp-legacy--try-fetch-key-from-error (msg from) "Try to fetch a GPG key based on error MSG. FROM is the JID that sent the signed presence." (when (string-match "\\([0-9A-Fa-f]\\{8,\\}\\)" msg) (let ((key-id (match-string 1 msg))) (message "XEP-0027: fetching key %s for %s..." key-id from) (let ((status (call-process "gpg" nil nil nil "--recv-keys" key-id))) (if (zerop status) (message "XEP-0027: fetched key %s for %s" key-id from) (message "XEP-0027: failed to fetch key %s for %s" key-id from)))))) ;;; Message encryption (send) - 1:1 chat (defun jabber-openpgp-legacy--send-chat (jc body &optional extra-elements) "Send BODY as XEP-0027 encrypted message via JC. Must be called from a chat buffer with `jabber-chatting-with' set. EXTRA-ELEMENTS are spliced into the stanza outside the encryption envelope." (require 'jabber-openpgp) (let* ((recipient (jabber-jid-user jabber-chatting-with)) (key (jabber-openpgp--recipient-key recipient)) (our-key (jabber-openpgp--our-key jc))) (unless key (user-error "XEP-0027: no public key for %s" recipient)) (let* ((ctx (epg-make-context 'OpenPGP)) (_ (setf (epg-context-armor ctx) t)) (encrypted (epg-encrypt-string ctx (encode-coding-string body 'utf-8) (list our-key key) nil)) (stripped (jabber-openpgp-legacy--strip-armor encrypted)) (id (format "emacs-msg-%d" (floor (* 1000 (float-time))))) (stanza `(message ((to . ,jabber-chatting-with) (type . "chat") (id . ,id)) (body () ,jabber-openpgp-legacy-fallback-body) (x ((xmlns . ,jabber-openpgp-legacy-encrypted-xmlns)) ,stripped) ,(jabber-hints-store) ,@extra-elements))) (jabber-chat--run-send-hooks stanza body id) (unless (assq 'replace extra-elements) (let ((msg-plist (jabber-chat--msg-plist-from-stanza stanza))) (plist-put msg-plist :body body) (plist-put msg-plist :status :sent) (when (run-hook-with-args-until-success 'jabber-chat-printers msg-plist :local :printp) (jabber-maybe-print-rare-time (jabber-chat-ewoc-enter (list :local msg-plist)))))) (jabber-send-sexp jc stanza)))) ;;; Message encryption (send) - MUC (defun jabber-openpgp-legacy--muc-participant-jids (group) "Return bare JIDs for participants in GROUP. Excludes entries without a real JID." (let ((participants (cdr (assoc group jabber-muc-participants))) jids) (dolist (entry participants) (when-let* ((plist (cdr entry)) (full-jid (plist-get plist 'jid)) (bare (jabber-jid-user full-jid))) (unless (member bare jids) (push bare jids)))) (nreverse jids))) (defun jabber-openpgp-legacy--send-muc (jc body &optional extra-elements) "Send BODY as XEP-0027 encrypted groupchat message via JC. Must be called from a MUC buffer with `jabber-group' set. EXTRA-ELEMENTS are spliced into the stanza outside the encryption envelope." (require 'jabber-openpgp) (let* ((group jabber-group) (recipient-jids (jabber-openpgp-legacy--muc-participant-jids group))) (when (null recipient-jids) (user-error "XEP-0027: no participant JIDs available (room may be anonymous)")) (let* ((our-key (jabber-openpgp--our-key jc)) (keys (mapcar (lambda (jid) (or (jabber-openpgp--recipient-key jid) (user-error "XEP-0027: no public key for %s" jid))) recipient-jids)) (all-keys (cons our-key keys)) (ctx (epg-make-context 'OpenPGP)) (_ (setf (epg-context-armor ctx) t)) (encrypted (epg-encrypt-string ctx (encode-coding-string body 'utf-8) all-keys nil)) (stripped (jabber-openpgp-legacy--strip-armor encrypted)) (stanza `(message ((to . ,group) (type . "groupchat")) (body () ,jabber-openpgp-legacy-fallback-body) (x ((xmlns . ,jabber-openpgp-legacy-encrypted-xmlns)) ,stripped) ,(jabber-hints-store) ,@extra-elements))) (jabber-send-sexp jc stanza)))) ;;; Message decryption (receive) (defun jabber-openpgp-legacy--detect-encrypted (xml-data) "Return stripped armor text from , or nil." (when-let* ((x-el (jabber-xml-child-with-xmlns xml-data jabber-openpgp-legacy-encrypted-xmlns)) (stripped (car (jabber-xml-node-children x-el)))) (and (stringp stripped) stripped))) (defun jabber-openpgp-legacy--decrypt-handler (_jc xml-data stripped) "Decrypt XEP-0027 message. STRIPPED is the base64-armored ciphertext." (let* ((armored (jabber-openpgp-legacy--rearmor-message stripped)) (ctx (epg-make-context 'OpenPGP)) (plaintext (decode-coding-string (epg-decrypt-string ctx armored) 'utf-8))) (jabber-chat--set-body xml-data plaintext) xml-data)) ;;; Registration (jabber-disco-advertise-feature jabber-openpgp-legacy-signed-xmlns) (jabber-chat-register-decrypt-handler 'openpgp-legacy :detect #'jabber-openpgp-legacy--detect-encrypted :decrypt #'jabber-openpgp-legacy--decrypt-handler :priority 30 :error-label "PGP") (add-to-list 'jabber-presence-element-functions #'jabber-openpgp-legacy--sign-presence) (with-eval-after-load "jabber-core" (jabber-chain-add 'jabber-presence-chain #'jabber-openpgp-legacy--process-presence 30)) (provide 'jabber-openpgp-legacy) ;;; jabber-openpgp-legacy.el ends here emacs-jabber/lisp/jabber-openpgp.el000066400000000000000000000523121516610113500175570ustar00rootroot00000000000000;;; jabber-openpgp.el --- XEP-0373 OpenPGP encryption for jabber.el -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; This file is part of emacs-jabber. ;; emacs-jabber 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 3 of the License, or ;; (at your option) any later version. ;; emacs-jabber 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 emacs-jabber. If not, see . ;;; Commentary: ;; XEP-0373 (OpenPGP for XMPP) encryption support. ;; Uses Emacs's built-in EasyPG (epg.el) for GPG operations. ;; Key management via PubSub (jabber-pubsub.el). ;;; Code: (require 'cl-lib) (require 'epg) (require 'jabber-pubsub) (require 'jabber-xml) (require 'jabber-hints) (require 'jabber-eme) (eval-when-compile (require 'pcase)) (declare-function jabber-connection-bare-jid "jabber-util" (jc)) (declare-function jabber-jid-user "jabber-util" (jid)) (declare-function jabber-disco-advertise-feature "jabber-disco" (feature)) (declare-function jabber-send-sexp "jabber-core" (jc sexp)) (declare-function jabber-chat--run-send-hooks "jabber-chat" (stanza body id)) (declare-function jabber-chat--msg-plist-from-stanza "jabber-chat" (xml-data &optional delayed)) (declare-function jabber-maybe-print-rare-time "jabber-chat" (node)) (declare-function jabber-chat-ewoc-enter "jabber-chatbuffer" (data)) (declare-function jabber-chat-register-decrypt-handler "jabber-chat" (id &rest props)) (declare-function jabber-chat--set-body "jabber-chat" (xml-data text)) (defvar jabber-chatting-with) ; jabber-chat.el (defvar jabber-group) ; jabber-muc.el (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el (defvar jabber-chat-send-hooks) ; jabber-chat.el (defvar jabber-chat-printers) ; jabber-chat.el (defvar jabber-muc-participants) ; jabber-muc.el (defvar jabber-chat-encryption) ; jabber-chatbuffer.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el ;;; Constants (defconst jabber-openpgp-xmlns "urn:xmpp:openpgp:0" "Namespace for XEP-0373 OpenPGP elements.") (defconst jabber-openpgp-pubkeys-node "urn:xmpp:openpgp:0:public-keys" "PubSub node for OpenPGP public key metadata.") (defconst jabber-openpgp-fallback-body "This message is encrypted with OpenPGP and could not be displayed." "Fallback body for clients that don't support OpenPGP.") ;;; Customization (defcustom jabber-openpgp-key-alist nil "Alist mapping account bare JIDs to GPG key fingerprints. Each entry is (JID . FINGERPRINT). When nil, falls back to searching the keyring for a key with User ID \"xmpp:JID\"." :type '(alist :key-type string :value-type string) :group 'jabber-chat) ;;; Key lookup (defun jabber-openpgp--our-key (jc) "Return the EPG key for JC's account. Lookup order: 1. `jabber-openpgp-key-alist' (per-account fingerprint) 2. `mml-secure-openpgp-signers' (Gnus/message signing key) 3. Keyring search for \"xmpp:BARE-JID\" User ID" (let* ((bare-jid (jabber-connection-bare-jid jc)) (ctx (epg-make-context 'OpenPGP)) (fingerprint (or (cdr (assoc bare-jid jabber-openpgp-key-alist)) (car (bound-and-true-p mml-secure-openpgp-signers))))) (if fingerprint (let ((keys (epg-list-keys ctx fingerprint 'secret))) (or (car keys) (error "OpenPGP: no secret key for fingerprint %s" fingerprint))) (or (car (epg-list-keys ctx (concat "xmpp:" bare-jid) 'secret)) (car (epg-list-keys ctx bare-jid 'secret)) (error "OpenPGP: no key for %s; configure `jabber-openpgp-key-alist' or `mml-secure-openpgp-signers'" bare-jid))))) (defun jabber-openpgp--our-key-safe (jc) "Return the EPG key for JC, or nil if not configured." (condition-case nil (jabber-openpgp--our-key jc) (error nil))) (defun jabber-openpgp--key-fingerprint (key) "Return uppercase hex fingerprint of KEY." (upcase (epg-sub-key-fingerprint (car (epg-key-sub-key-list key))))) (defun jabber-openpgp--recipient-key (jid) "Return EPG key for JID from the local keyring, or nil. Lookup order: 1. `jabber-openpgp-key-alist' (explicit fingerprint) 2. Keyring search for \"xmpp:JID\" 3. Keyring search for bare JID as-is (email-style UID)" (let* ((ctx (epg-make-context 'OpenPGP)) (fingerprint (cdr (assoc jid jabber-openpgp-key-alist)))) (if fingerprint (car (epg-list-keys ctx fingerprint)) (or (car (epg-list-keys ctx (concat "xmpp:" jid))) (car (epg-list-keys ctx jid)))))) (defun jabber-openpgp--ensure-recipient-keys (jc jids callback) "Ensure public keys for all JIDS are available, then call CALLBACK. For any JID whose key is missing locally, fetch it via PubSub. CALLBACK is called with no arguments once all keys are resolved. Signals an error (via `message') if any key remains unavailable." (let* ((missing (cl-remove-if #'jabber-openpgp--recipient-key jids)) (remaining (length missing)) (failed nil)) (if (zerop remaining) (funcall callback) (message "OpenPGP: fetching %d key(s)..." remaining) (dolist (jid missing) (jabber-openpgp--fetch-key jc jid (lambda (key) (unless key (push jid failed)) (cl-decf remaining) (when (zerop remaining) (if failed (message "OpenPGP: could not fetch keys for: %s" (string-join failed ", ")) (funcall callback))))))))) ;;; EPG encrypt/decrypt (defun jabber-openpgp--random-padding () "Return a random padding string for rpad element." (let ((len (+ 1 (random 200))) (chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")) (apply #'string (cl-loop repeat len collect (aref chars (random (length chars))))))) (defun jabber-openpgp--encrypt (jc plaintext-xml recipient-jids &optional sign) "Encrypt PLAINTEXT-XML for RECIPIENT-JIDS via JC. When SIGN is non-nil, also sign with JC's key. Returns raw (non-armored) OpenPGP message bytes. All recipient keys must already be in the local keyring." (let* ((context (epg-make-context 'OpenPGP)) (our-key (jabber-openpgp--our-key jc)) (recipients (mapcar (lambda (jid) (or (jabber-openpgp--recipient-key jid) (error "OpenPGP: no public key for %s" jid))) recipient-jids))) (setf (epg-context-armor context) nil) (when sign (setf (epg-context-signers context) (list our-key))) (epg-encrypt-string context (encode-coding-string plaintext-xml 'utf-8) (cons our-key recipients) sign))) (defun jabber-openpgp--decrypt (ciphertext) "Decrypt CIPHERTEXT (raw OpenPGP bytes). Returns the decrypted string." (let ((context (epg-make-context 'OpenPGP))) (decode-coding-string (epg-decrypt-string context ciphertext) 'utf-8))) ;;; Key publishing (defun jabber-openpgp--publish-key (jc) "Publish our OpenPGP public key to PubSub via JC." (let* ((key (jabber-openpgp--our-key jc)) (fingerprint (jabber-openpgp--key-fingerprint key)) (context (epg-make-context 'OpenPGP)) (_ (setf (epg-context-armor context) nil)) (key-data (epg-export-keys-to-string context (list key))) (node (concat jabber-openpgp-pubkeys-node ":" fingerprint))) (jabber-pubsub-publish jc nil node fingerprint `(pubkey ((xmlns . ,jabber-openpgp-xmlns)) (data () ,(base64-encode-string key-data t))) '(("pubsub#persist_items" . "true") ("pubsub#access_model" . "open"))))) (defun jabber-openpgp--publish-metadata (jc) "Publish key fingerprint list to the metadata node via JC." (let* ((key (jabber-openpgp--our-key jc)) (fingerprint (jabber-openpgp--key-fingerprint key)) (date (format-time-string "%Y-%m-%dT%H:%M:%SZ" nil t))) (jabber-pubsub-publish jc nil jabber-openpgp-pubkeys-node fingerprint `(public-keys-list ((xmlns . ,jabber-openpgp-xmlns)) (pubkey-metadata ((v4-fingerprint . ,fingerprint) (date . ,date)))) '(("pubsub#persist_items" . "true") ("pubsub#access_model" . "open"))))) (defun jabber-openpgp-on-connect (jc) "Post-connect hook: publish key if configured. Added to `jabber-post-connect-hooks'." (when (jabber-openpgp--our-key-safe jc) (jabber-openpgp--publish-key jc) (jabber-openpgp--publish-metadata jc))) ;;; Key fetching (defun jabber-openpgp--fetch-key (jc jid callback) "Fetch OpenPGP key for JID via PubSub through JC. 1. Query metadata node for fingerprint. 2. Fetch key data from per-fingerprint node. 3. Import into GPG keyring. 4. Call (funcall CALLBACK epg-key-or-nil)." (jabber-pubsub-request jc jid jabber-openpgp-pubkeys-node (lambda (_jc xml-data _closure) (jabber-openpgp--handle-metadata-response jc jid xml-data callback)) (lambda (_jc xml-data _closure) (message "OpenPGP: failed to fetch metadata for %s: %s" jid (jabber-sexp2xml xml-data)) (funcall callback nil)))) (defun jabber-openpgp--handle-metadata-response (jc jid xml-data callback) "Handle PubSub metadata response for JID. JC is the connection. XML-DATA is the IQ result. CALLBACK receives the imported key or nil." (let* ((pubsub-el (jabber-xml-path xml-data '(pubsub))) (items-el (and pubsub-el (car (jabber-xml-get-children pubsub-el 'items)))) (item-el (and items-el (car (jabber-xml-get-children items-el 'item)))) (keys-list (and item-el (car (jabber-xml-get-children item-el 'public-keys-list)))) (meta (and keys-list (car (jabber-xml-get-children keys-list 'pubkey-metadata)))) (fingerprint (and meta (jabber-xml-get-attribute meta 'v4-fingerprint)))) (if (null fingerprint) (progn (message "OpenPGP: no key metadata for %s" jid) (funcall callback nil)) (let ((node (concat jabber-openpgp-pubkeys-node ":" fingerprint))) (jabber-pubsub-request jc jid node (lambda (_jc xml-data2 _closure) (jabber-openpgp--handle-key-response xml-data2 fingerprint callback)) (lambda (_jc _xml-data2 _closure) (message "OpenPGP: failed to fetch key %s for %s" fingerprint jid) (funcall callback nil))))))) (defun jabber-openpgp--handle-key-response (xml-data fingerprint callback) "Handle PubSub key data response. XML-DATA is the IQ result. FINGERPRINT identifies the expected key. CALLBACK receives the imported key or nil." (let* ((pubsub-el (jabber-xml-path xml-data '(pubsub))) (items-el (and pubsub-el (car (jabber-xml-get-children pubsub-el 'items)))) (item-el (and items-el (car (jabber-xml-get-children items-el 'item)))) (pubkey-el (and item-el (car (jabber-xml-get-children item-el 'pubkey)))) (data-el (and pubkey-el (car (jabber-xml-get-children pubkey-el 'data)))) (b64 (and data-el (car (jabber-xml-node-children data-el))))) (if (null b64) (progn (message "OpenPGP: empty key data for %s" fingerprint) (funcall callback nil)) (let* ((key-data (base64-decode-string b64)) (context (epg-make-context 'OpenPGP))) (condition-case err (progn (epg-import-keys-from-string context key-data) (let ((keys (epg-list-keys context fingerprint))) (funcall callback (car keys)))) (error (message "OpenPGP: key import failed: %s" (error-message-string err)) (funcall callback nil))))))) ;;; Signcrypt XML building (defun jabber-openpgp--build-signcrypt-xml (recipient-jids body) "Build XML string for RECIPIENT-JIDS containing BODY." (jabber-sexp2xml `(signcrypt ((xmlns . ,jabber-openpgp-xmlns)) ,@(mapcar (lambda (jid) `(to ((jid . ,jid)))) recipient-jids) (time ((stamp . ,(format-time-string "%Y-%m-%dT%H:%M:%SZ" nil t)))) (rpad () ,(jabber-openpgp--random-padding)) (payload () (body ((xmlns . "jabber:client")) ,body))))) (defun jabber-openpgp--build-crypt-xml (recipient-jids body) "Build XML string for RECIPIENT-JIDS containing BODY. Used for MUC where signing is optional." (jabber-sexp2xml `(crypt ((xmlns . ,jabber-openpgp-xmlns)) ,@(mapcar (lambda (jid) `(to ((jid . ,jid)))) recipient-jids) (time ((stamp . ,(format-time-string "%Y-%m-%dT%H:%M:%SZ" nil t)))) (rpad () ,(jabber-openpgp--random-padding)) (payload () (body ((xmlns . "jabber:client")) ,body))))) ;;; Send path: 1:1 chat (defun jabber-openpgp--send-chat (jc body &optional extra-elements) "Send BODY as OpenPGP-encrypted chat message via JC. Must be called from a chat buffer with `jabber-chatting-with' set. Fetches missing recipient keys via PubSub before encrypting. EXTRA-ELEMENTS are spliced into the stanza outside the encryption envelope." (let ((recipient (jabber-jid-user jabber-chatting-with)) (buffer (current-buffer))) (jabber-openpgp--ensure-recipient-keys jc (list recipient) (lambda () (with-current-buffer buffer (jabber-openpgp--send-chat-1 jc body recipient extra-elements)))))) (defun jabber-openpgp--send-chat-1 (jc body recipient &optional extra-elements) "Internal: encrypt and send BODY to RECIPIENT via JC. EXTRA-ELEMENTS are spliced into the stanza outside the encryption envelope." (let* ((inner-xml (jabber-openpgp--build-signcrypt-xml (list recipient) body)) (encrypted (jabber-openpgp--encrypt jc inner-xml (list recipient) t)) (id (format "emacs-msg-%.6f" (float-time))) (stanza `(message ((to . ,jabber-chatting-with) (type . "chat") (id . ,id)) (openpgp ((xmlns . ,jabber-openpgp-xmlns)) ,(base64-encode-string encrypted t)) (body () ,jabber-openpgp-fallback-body) ,(jabber-hints-store) ,(jabber-eme-encryption jabber-openpgp-xmlns "OpenPGP") ,@extra-elements))) (jabber-chat--run-send-hooks stanza body id) (unless (assq 'replace extra-elements) (let ((msg-plist (jabber-chat--msg-plist-from-stanza stanza))) (plist-put msg-plist :body body) (plist-put msg-plist :status :sent) (when (run-hook-with-args-until-success 'jabber-chat-printers msg-plist :local :printp) (jabber-maybe-print-rare-time (jabber-chat-ewoc-enter (list :local msg-plist)))))) (jabber-send-sexp jc stanza))) ;;; Send path: MUC (defun jabber-openpgp--muc-participant-jids (group) "Return bare JIDs for participants in GROUP. Excludes entries without a real JID." (let ((participants (cdr (assoc group jabber-muc-participants))) jids) (dolist (entry participants) (when-let* ((plist (cdr entry)) (full-jid (plist-get plist 'jid)) (bare (jabber-jid-user full-jid))) (unless (member bare jids) (push bare jids)))) (nreverse jids))) (defun jabber-openpgp--send-muc (jc body &optional extra-elements) "Send BODY as OpenPGP-encrypted groupchat message via JC. Must be called from a MUC buffer with `jabber-group' set. Fetches missing recipient keys via PubSub before encrypting. EXTRA-ELEMENTS are spliced into the stanza outside the encryption envelope." (let* ((group jabber-group) (recipient-jids (jabber-openpgp--muc-participant-jids group)) (our-jid (jabber-jid-user (jabber-connection-bare-jid jc))) (all-jids (if (member our-jid recipient-jids) recipient-jids (cons our-jid recipient-jids))) (buffer (current-buffer))) (when (null recipient-jids) (user-error "OpenPGP: no participant JIDs available (room may be anonymous)")) (jabber-openpgp--ensure-recipient-keys jc all-jids (lambda () (with-current-buffer buffer (let* ((inner-xml (jabber-openpgp--build-crypt-xml all-jids body)) (encrypted (jabber-openpgp--encrypt jc inner-xml all-jids)) (stanza `(message ((to . ,group) (type . "groupchat")) (openpgp ((xmlns . ,jabber-openpgp-xmlns)) ,(base64-encode-string encrypted t)) (body () ,jabber-openpgp-fallback-body) ,(jabber-hints-store) ,(jabber-eme-encryption jabber-openpgp-xmlns "OpenPGP") ,@extra-elements))) (jabber-send-sexp jc stanza))))))) ;;; Receive path (defun jabber-openpgp--parse-openpgp-element (xml-data) "Return the child element from XML-DATA, or nil." (jabber-xml-child-with-xmlns xml-data jabber-openpgp-xmlns)) (defun jabber-openpgp--decrypt-stanza (_jc xml-data openpgp-el) "Decrypt the element and replace body in XML-DATA. OPENPGP-EL is the child element." (let* ((b64 (car (jabber-xml-node-children openpgp-el))) (ciphertext (base64-decode-string b64)) (inner-xml-str (jabber-openpgp--decrypt ciphertext)) (inner-xml (with-temp-buffer (insert inner-xml-str) (car (xml-parse-region (point-min) (point-max))))) (inner-name (and inner-xml (jabber-xml-node-name inner-xml))) (_ (unless (memq inner-name '(signcrypt crypt)) (error "OpenPGP: unexpected inner element <%s>" inner-name))) (payload (car (jabber-xml-get-children inner-xml 'payload))) (inner-body (and payload (car (jabber-xml-get-children payload 'body)))) (body-text (and inner-body (car (jabber-xml-node-children inner-body))))) (jabber-chat--set-body xml-data (or body-text "[OpenPGP: empty payload]")))) ;;; Disco, PubSub registration, and hooks (jabber-disco-advertise-feature jabber-openpgp-xmlns) (jabber-disco-advertise-feature (concat jabber-openpgp-pubkeys-node "+notify")) (defun jabber-openpgp--handle-keys-event (jc from _node items) "Handle PubSub event for OpenPGP public key updates. JC is the connection, FROM is the sender JID, ITEMS is the list of child elements from the event. Fetches updated key into the local GPG keyring." (let* ((item-el (car items)) (keys-list (and (listp item-el) (car (jabber-xml-get-children item-el 'public-keys-list)))) (meta (and keys-list (car (jabber-xml-get-children keys-list 'pubkey-metadata)))) (fingerprint (and meta (jabber-xml-get-attribute meta 'v4-fingerprint))) (jid (jabber-jid-user from))) (cond ((null fingerprint) (message "OpenPGP: key update from %s but no fingerprint in metadata" jid)) ;; Skip fetch if we already have this key locally. ((car (epg-list-keys (epg-make-context 'OpenPGP) fingerprint)) nil) (t (message "OpenPGP: %s updated key %s, fetching..." jid fingerprint) (let ((node (concat jabber-openpgp-pubkeys-node ":" fingerprint))) (jabber-pubsub-request jc jid node (lambda (_jc xml-data _closure) (jabber-openpgp--handle-key-response xml-data fingerprint (lambda (key) (if key (message "OpenPGP: imported updated key for %s" jid) (message "OpenPGP: failed to import key for %s" jid))))) (lambda (_jc _xml-data _closure) (message "OpenPGP: failed to fetch key %s for %s" fingerprint jid)))))))) (with-eval-after-load "jabber-pubsub" (setf (alist-get jabber-openpgp-pubkeys-node jabber-pubsub-node-handlers nil nil #'equal) #'jabber-openpgp--handle-keys-event)) (jabber-chat-register-decrypt-handler 'openpgp :detect #'jabber-openpgp--parse-openpgp-element :decrypt #'jabber-openpgp--decrypt-stanza :priority 20 :error-label "OpenPGP") (with-eval-after-load "jabber-core" (add-hook 'jabber-post-connect-hooks #'jabber-openpgp-on-connect)) (provide 'jabber-openpgp) ;;; jabber-openpgp.el ends here emacs-jabber/lisp/jabber-ping.el000066400000000000000000000056461516610113500170540ustar00rootroot00000000000000;;; jabber-ping.el --- XMPP "Ping" by XEP-0199 -*- lexical-binding: t; -*- ;; Copyright (C) 2009 - Evgenii Terechkov - evg@altlinux.org ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'jabber-iq) (require 'jabber-util) (require 'jabber-menu) (require 'jabber-disco) ;; Global reference declarations (defvar jabber-connections) ; jabber-core.el (defconst jabber-ping-xmlns "urn:xmpp:ping" "XML namespace for XEP-0199 XMPP Ping.") ;; (defun jabber-ping-send (jc to process-func on-success on-error) "Send XEP-0199 ping IQ stanza. JC is connection to use, TO is full JID, PROCESS-FUNC is fucntion to call to process result, ON-SUCCESS and ON-ERROR is arg for this function depending on result." (jabber-send-iq jc to "get" `(ping ((xmlns . ,jabber-ping-xmlns))) process-func on-success process-func on-error)) (defun jabber-ping (to) "Ping XMPP entity. TO is full JID. All connected JIDs is used." (interactive (list (jabber-read-jid-completing "Send ping to: " nil nil nil 'full))) (dolist (jc jabber-connections) (jabber-ping-send jc to 'jabber-silent-process-data 'jabber-process-ping "Ping is unsupported"))) ;; called by jabber-process-data (defun jabber-process-ping (_jc xml-data) "Handle results from ping requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((to (jabber-xml-get-attribute xml-data 'from))) (format "%s is alive" to))) (add-to-list 'jabber-iq-get-xmlns-alist (cons jabber-ping-xmlns 'jabber-pong)) (jabber-disco-advertise-feature jabber-ping-xmlns) (defun jabber-pong (jc xml-data) "Return pong as defined in XEP-0199. Sender and Id are determined from the incoming packet passed in XML-DATA. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((to (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id))) (jabber-send-iq jc to "result" nil nil nil nil nil id))) (provide 'jabber-ping) ;;; jabber-ping.el ends here emacs-jabber/lisp/jabber-presence.el000066400000000000000000000656421516610113500177250ustar00rootroot00000000000000;; jabber-presence.el - roster and presence bookkeeping -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'jabber-core) (require 'jabber-iq) (require 'jabber-alert) (require 'jabber-util) (require 'jabber-menu) (require 'ewoc) (defconst jabber-presence-show-alist '(("Online" . "") ("Away" . "away") ("Extended Away" . "xa") ("Do Not Disturb" . "dnd") ("Free to Chat" . "chat")) "Alist mapping human-readable labels to XMPP presence show values.") (defvar jabber-presence-element-functions nil "List of functions returning extra elements for stanzas. Each function takes one argument, the connection, and returns a possibly empty list of extra child element of the stanza.") (defvar jabber-presence-history () "Keeps track of previously used presence status types.") (defvar jabber-presence-sent-hooks nil "List of functions called after presence messages are sent.") ;; Global reference declarations (declare-function jabber-roster--refresh "jabber-roster.el" ()) (declare-function jabber-roster-update "jabber-roster.el" (jc new-items changed-items deleted-items)) (declare-function jabber-chat-create-buffer "jabber-chat.el" (jc chat-with)) (declare-function jabber-chat-ewoc-enter "jabber-chatbuffer.el" (data)) (declare-function jabber-chat-ewoc-delete "jabber-chatbuffer" (node)) (declare-function jabber-chat-get-buffer "jabber-chat.el" (chat-with &optional jc)) (declare-function jabber-muc-get-buffer "jabber-muc.el" (group &optional jc)) (declare-function jabber-muc-process-presence "jabber-muc.el" (jc presence)) (declare-function jabber-muc-presence-p "jabber-muc.el" (presence)) (declare-function jabber-muc-active-rooms "jabber-muc.el" ()) (declare-function jabber-muc-connection "jabber-muc.el" (group)) (declare-function jabber-muc-nickname "jabber-muc.el" (group &optional jc)) (declare-function jabber-muc-room-entries "jabber-muc.el" (group)) (defvar jabber-chatting-with) ; jabber-chat.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el (defvar *jabber-current-show*) ; jabber.el (defvar *jabber-current-status*) ; jabber.el (defvar *jabber-current-priority*) ; jabber.el (defvar jabber-default-show) ; jabber.el (defvar jabber-default-status) ; jabber.el (defvar jabber-default-priority) ; jabber.el (defvar jabber-silent-mode) ; jabber.el (defvar jabber-roster-xmlns) ; jabber-xml.el ;; (defun jabber--roster-valid-push-p (from state-data) "Return non-nil if FROM is a valid roster push sender. Valid senders are: nil (absent), the bare server, or our own full/bare JID." (let ((username (plist-get state-data :username)) (server (plist-get state-data :server)) (resource (plist-get state-data :resource))) (or (null from) (string= from server) (string= from (concat username "@" server)) (string= from (concat username "@" server "/" resource))))) (defun jabber--roster-process-item (item roster initialp) "Process a single roster ITEM element. ROSTER is the current roster list. INITIALP non-nil means initial fetch. Return (CATEGORY . JID-SYMBOL) where CATEGORY is `new', `changed', or `deleted'." (let* ((jid (jabber-jid-symbol (jabber-xml-get-attribute item 'jid))) (existing (car (memq jid roster)))) (if (string= (jabber-xml-get-attribute item 'subscription) "remove") (progn (if (jabber-jid-rostername jid) (message "%s (%s) removed from roster" (jabber-jid-rostername jid) jid) (message "%s removed from roster" jid)) (cons 'deleted jid)) (let ((roster-item (or existing jid))) (when (and (not existing) (not initialp)) (if (jabber-xml-get-attribute item 'name) (message "%s (%s) added to roster" (jabber-xml-get-attribute item 'name) jid) (message "%s added to roster" jid))) (when initialp (setplist roster-item nil)) (put roster-item 'name (jabber-xml-get-attribute item 'name)) (put roster-item 'subscription (jabber-xml-get-attribute item 'subscription)) (put roster-item 'ask (jabber-xml-get-attribute item 'ask)) (put roster-item 'xml item) (put roster-item 'groups (mapcar (lambda (g) (nth 2 g)) (jabber-xml-get-children item 'group))) (cons (if existing 'changed 'new) roster-item))))) (add-to-list 'jabber-iq-set-xmlns-alist (cons jabber-roster-xmlns (function (lambda (jc x) (jabber-process-roster jc x nil))))) (defun jabber-process-roster (jc xml-data closure-data) "Process an incoming roster infoquery result. CLOSURE-DATA should be `initial' if initial roster push, nil otherwise. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((state-data (fsm-get-state-data jc)) (roster (plist-get state-data :roster)) (from (jabber-xml-get-attribute xml-data 'from)) (type (jabber-xml-get-attribute xml-data 'type)) (id (jabber-xml-get-attribute xml-data 'id)) (initialp (eq closure-data 'initial)) new-items changed-items deleted-items) (if (not (jabber--roster-valid-push-p from state-data)) (message "Roster push with invalid \"from\": \"%s\"" from) (dolist (item (jabber-xml-get-children (car (jabber-xml-get-children xml-data 'query)) 'item)) (pcase (jabber--roster-process-item item roster initialp) (`(new . ,sym) (push sym new-items)) (`(changed . ,sym) (push sym changed-items)) (`(deleted . ,sym) (push sym deleted-items)))) (jabber-roster-update jc new-items changed-items deleted-items) (when (and id (string= type "set")) (jabber-send-iq jc nil "result" nil nil nil nil nil id))) (when initialp (run-hook-with-args 'jabber-post-connect-hooks jc)))) (defun jabber-initial-roster-failure (jc xml-data _closure-data) "Report the initial roster failure. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." ;; If the initial roster request fails, let's report it, but run ;; `jabber-post-connect-hooks' anyway. According to the spec, there is ;; nothing exceptional about the server not returning a roster. (jabber-report-success jc xml-data "Initial roster retrieval") (run-hook-with-args 'jabber-post-connect-hooks jc)) (defun jabber-presence--extract-metadata (xml-data) "Parse presence metadata from XML-DATA. Return a plist (:show :status :priority :error)." (list :show (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'show)))) :status (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'status)))) :priority (string-to-number (or (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'priority)))) "0")) :error (car (jabber-xml-get-children xml-data 'error)))) (defun jabber-presence--update-resource (buddy type resource metadata) "Update BUDDY presence for RESOURCE given TYPE and METADATA. METADATA is a plist from `jabber-presence--extract-metadata'. Modifies BUDDY symbol properties as a side effect. Return (NEWSTATUS . RESOURCE-PLIST)." (let ((resource-plist (cdr (assoc resource (get buddy 'resources)))) (presence-show (plist-get metadata :show)) (presence-status (plist-get metadata :status)) (error-xml (plist-get metadata :error)) (priority (plist-get metadata :priority)) newstatus) (cond ((and (string= resource "") (member type '("unavailable" "error"))) ;; 'unavailable' or 'error' from bare JID means that all resources ;; are offline. (setq resource-plist nil) (setq newstatus (if (string= type "error") "error" nil)) (let ((new-message (if error-xml (jabber-parse-error error-xml) presence-status))) ;; erase any previous information (put buddy 'resources nil) (put buddy 'connected nil) (put buddy 'show newstatus) (put buddy 'status new-message))) ((string= type "unavailable") (setq resource-plist (plist-put resource-plist 'connected nil)) (setq resource-plist (plist-put resource-plist 'show nil)) (setq resource-plist (plist-put resource-plist 'status presence-status))) ((string= type "error") (setq newstatus "error") (setq resource-plist (plist-put resource-plist 'connected nil)) (setq resource-plist (plist-put resource-plist 'show "error")) (setq resource-plist (plist-put resource-plist 'status (if error-xml (jabber-parse-error error-xml) presence-status)))) ((or (string= type "unsubscribe") (string= type "subscribed") (string= type "unsubscribed")) ;; Do nothing, except letting the user know. The Jabber protocol ;; places all this complexity on the server. (setq newstatus type)) (t (setq resource-plist (plist-put resource-plist 'connected t)) (setq resource-plist (plist-put resource-plist 'show (or presence-show ""))) (setq resource-plist (plist-put resource-plist 'status presence-status)) (setq resource-plist (plist-put resource-plist 'priority priority)) (setq newstatus (or presence-show "")))) (cons newstatus resource-plist))) (defun jabber-presence--run-hooks (buddy oldstatus newstatus status-message) "Fire presence hooks for BUDDY with OLDSTATUS, NEWSTATUS, and STATUS-MESSAGE. Runs `jabber-presence-hooks' and `jabber-alert-presence-hooks'." (dolist (hook '(jabber-presence-hooks jabber-alert-presence-hooks)) (run-hook-with-args hook buddy oldstatus newstatus status-message (funcall jabber-alert-presence-message-function buddy oldstatus newstatus status-message)))) (jabber-chain-add 'jabber-presence-chain #'jabber-process-presence) (defun jabber-process-presence (jc xml-data) "Process incoming presence tags. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." ;; XXX: use JC argument (let* ((roster (plist-get (fsm-get-state-data jc) :roster)) (from (jabber-xml-get-attribute xml-data 'from)) (type (jabber-xml-get-attribute xml-data 'type)) (metadata (jabber-presence--extract-metadata xml-data))) (cond ((string= type "subscribe") (run-with-idle-timer 0.01 nil #'jabber-process-subscription-request jc from (plist-get metadata :status))) ((jabber-muc-presence-p xml-data) (jabber-muc-process-presence jc xml-data)) (t ;; Clean up any stale subscription request prompts for this JID. (jabber-subscription--remove-stale jc from) ;; XXX: Think about what to do about out-of-roster presences. (let ((buddy (jabber-jid-symbol from))) (when (memq buddy roster) (let* ((oldstatus (get buddy 'show)) (resource (or (jabber-jid-resource from) "")) (result (jabber-presence--update-resource buddy type resource metadata)) (newstatus (car result)) (resource-plist (cdr result))) (when resource-plist ;; this is for `assoc-set!' in guile (if (assoc resource (get buddy 'resources)) (setcdr (assoc resource (get buddy 'resources)) resource-plist) (put buddy 'resources (cons (cons resource resource-plist) (get buddy 'resources)))) (jabber-prioritize-resources buddy)) (fsm-send jc (cons :roster-update buddy)) (jabber-presence--run-hooks buddy oldstatus newstatus (plist-get resource-plist 'status))))))))) (defun jabber-process-subscription-request (jc from presence-status) "Process an incoming subscription request. JC is the Jabber connection." (with-current-buffer (jabber-chat-create-buffer jc from) (jabber-chat-ewoc-enter (list :subscription-request presence-status :time (current-time))) (dolist (hook '(jabber-presence-hooks jabber-alert-presence-hooks)) (run-hook-with-args hook (jabber-jid-symbol from) nil "subscribe" presence-status (funcall jabber-alert-presence-message-function (jabber-jid-symbol from) nil "subscribe" presence-status))))) (defun jabber-subscription-accept-mutual (&rest _ignored) (message "Subscription accepted; reciprocal subscription request sent") (jabber-subscription-reply "subscribed" "subscribe")) (defun jabber-subscription-accept-one-way (&rest _ignored) (message "Subscription accepted") (jabber-subscription-reply "subscribed")) (defun jabber-subscription-decline (&rest _ignored) (message "Subscription declined") (jabber-subscription-reply "unsubscribed")) (defun jabber-subscription--remove-prompt () "Remove the subscription request EWOC node at point." (when (bound-and-true-p jabber-chat-ewoc) (let ((node (ewoc-locate jabber-chat-ewoc))) (when (and node (eq :subscription-request (car (ewoc-data node)))) (jabber-chat-ewoc-delete node))))) (defun jabber-subscription--remove-stale (jc from) "Remove all subscription request nodes from FROM's chat buffer. JC is the Jabber connection." (when-let* ((buf (get-buffer (jabber-chat-get-buffer from jc)))) (with-current-buffer buf (when (bound-and-true-p jabber-chat-ewoc) (let ((node (ewoc-nth jabber-chat-ewoc 0)) to-delete) (while node (when (eq :subscription-request (car (ewoc-data node))) (push node to-delete)) (setq node (ewoc-next jabber-chat-ewoc node))) (dolist (n to-delete) (jabber-chat-ewoc-delete n))))))) (defun jabber-subscription-reply (&rest types) (let ((to (jabber-jid-user jabber-chatting-with))) (dolist (type types) (jabber-send-sexp jabber-buffer-connection `(presence ((to . ,to) (type . ,type)))))) (jabber-subscription--remove-prompt)) (defun jabber-prioritize-resources (buddy) "Set connected, show and status properties for BUDDY. Show status properties from highest-priority resource." (let ((resource-alist (get buddy 'resources)) (highest-priority nil)) ;; Reset to nil at first, for cases (a) resource-alist is nil ;; and (b) all resources are disconnected. (put buddy 'connected nil) (put buddy 'show nil) (put buddy 'status nil) (mapc #'(lambda (resource) (let* ((resource-plist (cdr resource)) (priority (plist-get resource-plist 'priority))) (if (plist-get resource-plist 'connected) (when (or (null highest-priority) (and priority (> priority highest-priority))) ;; if no priority specified, interpret as zero (setq highest-priority (or priority 0)) (put buddy 'connected (plist-get resource-plist 'connected)) (put buddy 'show (plist-get resource-plist 'show)) (put buddy 'status (plist-get resource-plist 'status)) (put buddy 'resource (car resource))) ;; if we have not found a connected resource yet, but this ;; disconnected resource has a status message, display it. (when (not (get buddy 'connected)) (if (plist-get resource-plist 'status) (put buddy 'status (plist-get resource-plist 'status))) (if (plist-get resource-plist 'show) (put buddy 'show (plist-get resource-plist 'show))))))) resource-alist))) (defun jabber-count-connected-resources (buddy) "Return the number of connected resources for BUDDY." (let ((resource-alist (get buddy 'resources)) (count 0)) (dolist (resource resource-alist) (if (plist-get (cdr resource) 'connected) (setq count (1+ count)))) count)) ;;;###autoload (defun jabber-send-presence (show status priority &optional jc) "Set presence. When called interactively, prompt for which account to use. With prefix argument, send to all accounts. When JC is non-nil, send only for that connection. When JC is nil, send for all connections." (interactive (let* ((jc (unless current-prefix-arg (jabber-read-account))) (label (completing-read "Status: " (mapcar #'car jabber-presence-show-alist) nil t nil 'jabber-presence-history)) (show (cdr (assoc label jabber-presence-show-alist)))) (list show (jabber-read-with-input-method "Status message: " *jabber-current-status* '*jabber-status-history*) (read-string "Priority: " (int-to-string (if *jabber-current-priority* *jabber-current-priority* jabber-default-priority))) jc))) (setq *jabber-current-show* show *jabber-current-status* status) (setq *jabber-current-priority* (if (numberp priority) priority (string-to-number priority))) (let ((connections (if jc (list jc) jabber-connections)) subelements-map) ;; For each connection, we use a different set of subelements. We ;; cache them, to only generate them once. ;; Ordinary presence, with no specified recipient (dolist (c connections) (let ((subelements (jabber-presence-children c))) (push (cons c subelements) subelements-map) (jabber-send-sexp-if-connected c `(presence () ,@subelements)))) ;; Then send presence to groupchats. A room may have entries for ;; multiple accounts, so iterate all (JC . NICK) pairs. (dolist (room (jabber-muc-active-rooms)) (dolist (entry (jabber-muc-room-entries room)) (let* ((room-jc (car entry)) (nick (cdr entry)) (subelements (cdr (assq room-jc subelements-map)))) (when (and room-jc (or (null jc) (eq room-jc jc))) (jabber-send-sexp-if-connected room-jc `(presence ((to . ,(concat room "/" nick))) ,@subelements))))))) (jabber-roster--refresh) (run-hooks 'jabber-presence-sent-hooks)) (defun jabber-presence-children (jc) "Return the children for a stanza. JC is the Jabber connection." `(,(when (> (length *jabber-current-status*) 0) `(status () ,*jabber-current-status*)) ,(when (> (length *jabber-current-show*) 0) `(show () ,*jabber-current-show*)) ,(when *jabber-current-priority* `(priority () ,(number-to-string *jabber-current-priority*))) ,@(apply #'append (mapcar (lambda (f) (funcall f jc)) jabber-presence-element-functions)))) (defun jabber-send-directed-presence (jc jid type) "Send a directed presence stanza to JID. TYPE is one of: \"online\", \"away\", \"xa\", \"dnd\", \"chatty\": Appear as present with the given status. \"unavailable\": Appear as offline. \"probe\": Ask the contact's server for updated presence. \"subscribe\": Ask for subscription to contact's presence. (see also `jabber-send-subscription-request') \"unsubscribe\": Cancel your subscription to contact's presence. \"subscribed\": Accept contact's request for presence subscription. (this is usually done within a chat buffer) \"unsubscribed\": Cancel contact's subscription to your presence. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Send directed presence to: ") (completing-read "Type (default is online): " '(("online") ("away") ("xa") ("dnd") ("chatty") ("probe") ("unavailable") ("subscribe") ("unsubscribe") ("subscribed") ("unsubscribed")) nil t nil 'jabber-presence-history "online"))) (cond ((member type '("probe" "unavailable" "subscribe" "unsubscribe" "subscribed" "unsubscribed")) (jabber-send-sexp jc `(presence ((to . ,jid) (type . ,type))))) (t (let ((*jabber-current-show* (if (string= type "online") "" type)) (*jabber-current-status* nil)) (jabber-send-sexp jc `(presence ((to . ,jid)) ,@(jabber-presence-children jc))))))) (defun jabber-send-away-presence (&optional status jc) "Set status to away. With prefix argument, ask for status message. If JC is non-nil, send only for that connection." (interactive (list (when current-prefix-arg (jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*)))) (jabber-send-presence "away" (if status status *jabber-current-status*) *jabber-current-priority* jc)) ;; XXX code duplication! (defun jabber-send-xa-presence (&optional status jc) "Send extended away presence. With prefix argument, ask for status message. If JC is non-nil, send only for that connection." (interactive (list (when current-prefix-arg (jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*)))) (jabber-send-presence "xa" (if status status *jabber-current-status*) *jabber-current-priority* jc)) ;;;###autoload (defun jabber-send-default-presence (&optional jc) "Send default presence. Default presence is specified by `jabber-default-show', `jabber-default-status', and `jabber-default-priority'. If JC is non-nil, send only for that connection." (interactive) (jabber-send-presence jabber-default-show jabber-default-status jabber-default-priority jc)) (defun jabber-send-current-presence (&optional jc) "(Re-)send current presence. That is, if presence has already been sent, use current settings, otherwise send defaults (see `jabber-send-default-presence'). If JC is non-nil, send only for that connection." (interactive) (if *jabber-current-show* (jabber-send-presence *jabber-current-show* *jabber-current-status* *jabber-current-priority* jc) (jabber-send-default-presence jc))) (defun jabber-send-subscription-request (jc to &optional request) "Send a subscription request to jid. Show him your request text, if specified. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "to: ") (jabber-read-with-input-method "request: "))) (jabber-send-sexp jc `(presence ((to . ,to) (type . "subscribe")) ,@(when (and request (> (length request) 0)) (list `(status () ,request)))))) (defvar jabber-roster-group-history nil "History of entered roster groups.") (defun jabber-roster-change (jc jid name groups) "Add or change a roster item. JC is the Jabber connection." (interactive (let* ((jid (jabber-jid-symbol (jabber-read-jid-completing "Add/change JID: "))) (account (jabber-read-account)) (name (get jid 'name)) (groups (get jid 'groups)) (all-groups (apply #'append (mapcar (lambda (j) (get j 'groups)) (plist-get (fsm-get-state-data account) :roster))))) (list account jid (jabber-read-with-input-method (format "Name: (default `%s') " name) nil nil name) (delete "" (completing-read-multiple (format "Groups, comma-separated: (default %s) " (if groups (mapconcat #'identity groups ",") "none")) all-groups nil nil nil 'jabber-roster-group-history (mapconcat #'identity groups ",") t))))) ;; If new fields are added to the roster XML structure in a future standard, ;; they will be clobbered by this function. ;; XXX: specify account (jabber-send-iq jc nil "set" (list 'query (list (cons 'xmlns jabber-roster-xmlns)) (append (list 'item (append (list (cons 'jid (symbol-name jid))) (if (and name (> (length name) 0)) (list (cons 'name name))))) (mapcar #'(lambda (x) `(group () ,x)) groups))) #'jabber-report-success "Roster item change" #'jabber-report-success "Roster item change")) (defun jabber-roster-delete (jc jid) (interactive (list (jabber-read-account) (jabber-read-jid-completing "Delete from roster: "))) (jabber-send-iq jc nil "set" `(query ((xmlns . ,jabber-roster-xmlns)) (item ((jid . ,jid) (subscription . "remove")))) #'jabber-report-success "Roster item removal" #'jabber-report-success "Roster item removal")) (defun jabber-roster-delete-jid-at-point () "Delete JID at point from roster. Signal an error if there is no JID at point." (interactive) (let ((jid-at-point (get-text-property (point) 'jabber-jid)) (account (get-text-property (point) 'jabber-account))) (if (and jid-at-point account (or jabber-silent-mode (yes-or-no-p (format "Really delete %s from roster? " jid-at-point)))) (jabber-roster-delete account jid-at-point) (error "No contact at point")))) (defun jabber-roster-delete-group-from-jids (jc jids group) "Delete group `group' from all JIDs. JC is the Jabber connection." (interactive) (dolist (jid jids) (jabber-roster-change jc jid (get jid 'name) (cl-remove-if-not (lambda (g) (not (string= g group))) (get jid 'groups))))) (defun jabber-roster-edit-group-from-jids (jc jids group) "Edit group `group' from all JIDs. JC is the Jabber connection." (interactive) (let ((new-group (jabber-read-with-input-method (format "New group: (default `%s') " group) nil nil group))) (dolist (jid jids) (jabber-roster-change jc jid (get jid 'name) (cl-remove-duplicates (mapcar (lambda (g) (if (string= g group) new-group g)) (get jid 'groups)) :test #'string=))))) (provide 'jabber-presence) ;;; jabber-presence.el ends hereemacs-jabber/lisp/jabber-private.el000066400000000000000000000050011516610113500175520ustar00rootroot00000000000000;;; jabber-private.el --- jabber:iq:private API by JEP-0049 -*- lexical-binding: t; -*- ;; Copyright (C) 2005 Magnus Henoch ;; Copyright (C) 2026 Thanos Apollo ;; Author: Magnus Henoch ;; Maintainer: Thanos Apollo ;; This file 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, or (at your option) ;; any later version. ;; This file 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 GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: ;; ;;; Code: (require 'jabber-util) (require 'jabber-xml) (require 'jabber-iq) (defconst jabber-private-xmlns "jabber:iq:private" "XEP-0049 Private XML Storage namespace.") ;;;###autoload (defun jabber-private-get (jc node-name namespace success-callback error-callback) "Retrieve an item from private XML storage. The item to retrieve is identified by NODE-NAME (a symbol) and NAMESPACE (a string). On success, SUCCESS-CALLBACK is called with JC and the retrieved XML fragment. On error, ERROR-CALLBACK is called with JC and the entire IQ result." (jabber-send-iq jc nil "get" `(query ((xmlns . ,jabber-private-xmlns)) (,node-name ((xmlns . ,namespace)))) #'jabber-private-get-1 success-callback #'(lambda (jc xml-data error-callback) (funcall error-callback jc xml-data)) error-callback)) (defun jabber-private-get-1 (jc xml-data success-callback) (funcall success-callback jc (car (jabber-xml-node-children (jabber-iq-query xml-data))))) ;;;###autoload (defun jabber-private-set (jc fragment &optional success-callback success-closure-data error-callback error-closure-data) "Store FRAGMENT in private XML storage. SUCCESS-CALLBACK, SUCCESS-CLOSURE-DATA, ERROR-CALLBACK and ERROR-CLOSURE-DATA are used as in `jabber-send-iq'. JC is the Jabber connection." (jabber-send-iq jc nil "set" `(query ((xmlns . ,jabber-private-xmlns)) ,fragment) success-callback success-closure-data error-callback error-closure-data)) (provide 'jabber-private) ;;; jabber-private.el ends here emacs-jabber/lisp/jabber-pubsub.el000066400000000000000000000162271516610113500174140ustar00rootroot00000000000000;;; jabber-pubsub.el --- XEP-0060: Publish-Subscribe -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Author: Thanos Apollo ;; Maintainer: Thanos Apollo ;; Keywords: extensions ;; 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 3 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, see . ;;; Commentary: ;; ;; Implementation of XEP-0060 (Publish-Subscribe) core operations: ;; publish, retract, request items, delete node, configure node, and ;; event notification dispatch. Used by OMEMO (key distribution) and ;; bookmarks sync (XEP-0402). ;;; Code: (require 'jabber-iq) (require 'jabber-xml) (require 'jabber-util) (require 'jabber-disco) ;; Global reference declarations (declare-function jabber-chain-add "jabber-core" (chain-var handler &optional depth)) (defvar jabber-message-chain) ; jabber-core.el ;;; xmlns constants (defconst jabber-pubsub-xmlns "http://jabber.org/protocol/pubsub" "XEP-0060: Publish-Subscribe.") (defconst jabber-pubsub-owner-xmlns "http://jabber.org/protocol/pubsub#owner" "XEP-0060: Publish-Subscribe (owner operations).") (defconst jabber-pubsub-event-xmlns "http://jabber.org/protocol/pubsub#event" "XEP-0060: Publish-Subscribe (event notifications).") ;;; Publish-options helper (defun jabber-pubsub--publish-options (options) "Build a XML sexp from OPTIONS alist. Each element is (VAR . VALUE)." `(publish-options () (x ((xmlns . ,jabber-xdata-xmlns) (type . "submit")) (field ((var . "FORM_TYPE") (type . "hidden")) (value () "http://jabber.org/protocol/pubsub#publish-options")) ,@(mapcar (lambda (opt) `(field ((var . ,(car opt))) (value () ,(cdr opt)))) options)))) ;;; Core operations (defun jabber-pubsub-publish (jc jid node item-id payload &optional options callback error-callback) "Publish PAYLOAD to NODE on JID via JC. ITEM-ID is the item identifier. OPTIONS, if non-nil, is an alist of publish-options (VAR . VALUE). CALLBACK and ERROR-CALLBACK are called as (funcall cb JC XML-DATA CLOSURE-DATA)." (let ((query `(pubsub ((xmlns . ,jabber-pubsub-xmlns)) (publish ((node . ,node)) (item ((id . ,item-id)) ,payload)) ,@(when options (list (jabber-pubsub--publish-options options)))))) (jabber-send-iq jc jid "set" query callback "pubsub publish" error-callback "pubsub publish"))) (defun jabber-pubsub-retract (jc jid node item-id &optional notify callback error-callback) "Retract ITEM-ID from NODE on JID via JC. When NOTIFY is non-nil, add notify=\"true\" to the retract element. CALLBACK and ERROR-CALLBACK follow `jabber-send-iq' conventions." (jabber-send-iq jc jid "set" `(pubsub ((xmlns . ,jabber-pubsub-xmlns)) (retract ((node . ,node) ,@(when notify '((notify . "true")))) (item ((id . ,item-id))))) callback "pubsub retract" error-callback "pubsub retract")) (defun jabber-pubsub-request (jc jid node callback &optional error-callback) "Request items from NODE on JID via JC. CALLBACK receives the full IQ result; caller extracts items." (jabber-send-iq jc jid "get" `(pubsub ((xmlns . ,jabber-pubsub-xmlns)) (items ((node . ,node)))) callback "pubsub request" error-callback "pubsub request")) (defun jabber-pubsub-delete-node (jc jid node &optional callback error-callback) "Delete NODE on JID via JC (owner operation). CALLBACK and ERROR-CALLBACK follow `jabber-send-iq' conventions." (jabber-send-iq jc jid "set" `(pubsub ((xmlns . ,jabber-pubsub-owner-xmlns)) (delete ((node . ,node)))) callback "pubsub delete-node" error-callback "pubsub delete-node")) (defun jabber-pubsub-configure-node (jc jid node options &optional callback error-callback) "Configure NODE on JID via JC (owner operation). OPTIONS is an alist of (VAR . VALUE) for the node configuration form." (jabber-send-iq jc jid "set" `(pubsub ((xmlns . ,jabber-pubsub-owner-xmlns)) (configure ((node . ,node)) (x ((xmlns . ,jabber-xdata-xmlns) (type . "submit")) (field ((var . "FORM_TYPE") (type . "hidden")) (value () "http://jabber.org/protocol/pubsub#node_config")) ,@(mapcar (lambda (opt) `(field ((var . ,(car opt))) (value () ,(cdr opt)))) options)))) callback "pubsub configure-node" error-callback "pubsub configure-node")) ;;; Event notification handler (defvar jabber-pubsub-node-handlers nil "Alist of (NODE-NAME . HANDLER) for PubSub event dispatch. HANDLER is called as (funcall HANDLER JC FROM NODE ITEMS) where ITEMS is the list of child elements (item or retract).") (defun jabber-pubsub--process-event (jc xml-data) "Process incoming PubSub event notifications. JC is the Jabber connection. XML-DATA is the message stanza. Per XEP-0163 s4.3, PEP events MUST come from bare JIDs." (let* ((event (jabber-xml-child-with-xmlns xml-data jabber-pubsub-event-xmlns)) (from (and event (jabber-xml-get-attribute xml-data 'from)))) (when (and event from) (if (jabber-jid-resource from) (message "PubSub: ignoring event from full JID %s" from) (let* ((items-or-purge (or (car (jabber-xml-get-children event 'items)) (car (jabber-xml-get-children event 'purge)))) (node (and items-or-purge (jabber-xml-get-attribute items-or-purge 'node))) (handler (and node (cdr (assoc node jabber-pubsub-node-handlers))))) (when handler (funcall handler jc from node (jabber-xml-node-children items-or-purge)))))))) (with-eval-after-load "jabber-core" (jabber-chain-add 'jabber-message-chain #'jabber-pubsub--process-event)) ;;; Disco advertisement (jabber-disco-advertise-feature jabber-pubsub-xmlns) (provide 'jabber-pubsub) ;;; jabber-pubsub.el ends here emacs-jabber/lisp/jabber-receipts.el000066400000000000000000000301541516610113500177250ustar00rootroot00000000000000;;; jabber-receipts.el --- Delivery receipts and chat markers -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; XEP-0184 Message Delivery Receipts and XEP-0333 Chat Markers for ;; 1:1 chats. Outgoing messages get and ;; elements. Incoming receipts update the DB and header-line. ;; Optionally sends and back. ;;; Code: (require 'jabber-xml) (require 'jabber-core) (require 'jabber-chat) (require 'jabber-db) (require 'jabber-disco) (declare-function jabber-chat-ewoc-find-by-id "jabber-chatbuffer" (stanza-id)) (declare-function jabber-chat-ewoc-invalidate "jabber-chatbuffer" (node)) (declare-function jabber-jid-user "jabber-util" (jid)) (declare-function jabber-jid-resource "jabber-util" (jid)) (declare-function jabber-muc-joined-p "jabber-muc" (group &optional jc)) (declare-function jabber-muc-private-get-buffer "jabber-muc" (group nickname &optional jc)) (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el (defgroup jabber-receipts nil "Message delivery receipts (XEP-0184) and chat markers (XEP-0333)." :group 'jabber-chat) (defconst jabber-receipts-xmlns "urn:xmpp:receipts" "XML namespace for XEP-0184 Message Delivery Receipts.") (defconst jabber-chat-markers-xmlns "urn:xmpp:chat-markers:0" "XML namespace for XEP-0333 Chat Markers.") (defcustom jabber-chat-send-receipts t "Send delivery receipts and read markers to peers. When non-nil, send on message delivery and when a chat buffer becomes visible. Incoming receipts are always processed regardless of this setting." :type 'boolean) (defface jabber-chat-delivered '((t :inherit shadow :slant italic)) "Face for delivery receipt status in header-line.") (defface jabber-chat-seen '((t :inherit success :slant italic)) "Face for seen/displayed status in header-line.") (defvar-local jabber-chat-receipt-message "" "Header-line string showing receipt status for current chat.") (defvar-local jabber-receipts--pending-displayed-id nil "Stanza ID of latest unread markable message in this buffer.") ;;; Send hook (defun jabber-receipts--send-hook (_body _id) "Add receipt request and markable elements to outgoing messages. Added to `jabber-chat-send-hooks'. Per XEP-0184, receipt requests are NOT RECOMMENDED in MUC groupchat because every occupant would respond. Chat markers \(XEP-0333) are fine in MUC." (if (bound-and-true-p jabber-group) ;; MUC groupchat: markable only, no receipt request. `((markable ((xmlns . ,jabber-chat-markers-xmlns)))) `((request ((xmlns . ,jabber-receipts-xmlns))) (markable ((xmlns . ,jabber-chat-markers-xmlns)))))) (add-hook 'jabber-chat-send-hooks #'jabber-receipts--send-hook) ;;; Receive handler (defun jabber-receipts--find-buffer (from jc) "Find the chat buffer for FROM on connection JC. For MUC participant JIDs, look up the MUC private buffer. For regular JIDs, look up the 1:1 chat buffer." (if (and (jabber-jid-resource from) (jabber-muc-joined-p (jabber-jid-user from))) (get-buffer (jabber-muc-private-get-buffer (jabber-jid-user from) (jabber-jid-resource from) jc)) (get-buffer (jabber-chat-get-buffer from jc)))) (defun jabber-receipts--handle-message (jc xml-data) "Process incoming delivery receipts and chat markers in XML-DATA. JC is the connection. Added to `jabber-message-chain'." (let* ((from (jabber-xml-get-attribute xml-data 'from)) (type (jabber-xml-get-attribute xml-data 'type)) (groupchat-p (equal type "groupchat"))) ;; Skip stanzas without a from attribute or groupchat stanzas. ;; MUC markers require XEP-0359 stanza-id matching and per-occupant ;; tracking that we don't yet support; processing them could corrupt ;; 1:1 receipt state via ID collisions. (unless (or (null from) groupchat-p) ;; XEP-0184: (when-let* ((received (jabber-xml-child-with-xmlns xml-data jabber-receipts-xmlns)) ((eq (jabber-xml-node-name received) 'received)) (ref-id (jabber-xml-get-attribute received 'id))) (jabber-receipts--update-status jc from ref-id "delivered_at")) ;; XEP-0333: ;; Some clients send XEP-0333 received instead of XEP-0184. (when-let* ((marker (jabber-xml-child-with-xmlns xml-data jabber-chat-markers-xmlns)) ((eq (jabber-xml-node-name marker) 'received)) (ref-id (jabber-xml-get-attribute marker 'id))) (jabber-receipts--update-status jc from ref-id "delivered_at")) ;; XEP-0333: (when-let* ((marker (jabber-xml-child-with-xmlns xml-data jabber-chat-markers-xmlns)) ((eq (jabber-xml-node-name marker) 'displayed)) (ref-id (jabber-xml-get-attribute marker 'id))) (jabber-receipts--update-status jc from ref-id "displayed_at"))) ;; Send back if the message requests it. ;; Skip MAM-replayed messages and groupchat (per XEP-0184). (let ((id (jabber-xml-get-attribute xml-data 'id))) (when (and jabber-chat-send-receipts id (not groupchat-p) (not (jabber-xml-get-attribute xml-data 'jabber-mam--origin)) (jabber-xml-get-children xml-data 'body) (let ((req (jabber-xml-child-with-xmlns xml-data jabber-receipts-xmlns))) (and req (eq (jabber-xml-node-name req) 'request)))) (jabber-send-sexp-if-connected jc `(message ((to . ,from) (type . "chat")) (received ((xmlns . ,jabber-receipts-xmlns) (id . ,id))))))) ;; Track pending markable message for on visibility. ;; If the buffer is already visible, send immediately. ;; Skip MAM-replayed messages and groupchat. (when-let* ((id (jabber-xml-get-attribute xml-data 'id)) ((not groupchat-p)) ((not (jabber-xml-get-attribute xml-data 'jabber-mam--origin))) ((jabber-xml-get-children xml-data 'body)) ((jabber-xml-child-with-xmlns xml-data jabber-chat-markers-xmlns))) (when-let* ((buffer (jabber-receipts--find-buffer from jc))) (with-current-buffer buffer (when jabber-chat-send-receipts (if (get-buffer-window buffer 'visible) (progn (jabber-send-sexp-if-connected jc `(message ((to . ,from) (type . "chat")) (displayed ((xmlns . ,jabber-chat-markers-xmlns) (id . ,id))))) (setq jabber-receipts--pending-displayed-id nil)) (setq jabber-receipts--pending-displayed-id id)))))))) (defvar-local jabber-receipts--latest-displayed-ts 0 "Timestamp of the most recently displayed outgoing message. Used to enforce XEP-0333 forward-only rule: displayed markers referencing older messages are redundant and MUST be ignored.") (defun jabber-receipts--update-status (jc from ref-id column) "Update receipt status for message REF-ID from FROM on JC. COLUMN is \"delivered_at\" or \"displayed_at\"." (let ((timestamp (floor (float-time))) (account (jabber-connection-bare-jid jc)) (peer (jabber-jid-user from)) (status (if (string= column "displayed_at") :displayed :delivered))) (jabber-db-update-receipt account peer ref-id column timestamp) (when-let* ((buffer (jabber-receipts--find-buffer from jc))) (with-current-buffer buffer (when-let* ((node (jabber-chat-ewoc-find-by-id ref-id))) (let* ((msg (cadr (ewoc-data node))) (msg-ts (plist-get msg :timestamp)) (msg-epoch (and msg-ts (floor (float-time msg-ts)))) (inhibit-read-only t)) ;; XEP-0333: displayed markers for older messages MUST be ;; ignored (forward-only rule). (when (or (not (string= column "displayed_at")) (not msg-epoch) (> msg-epoch jabber-receipts--latest-displayed-ts)) (plist-put msg :status status) (jabber-chat-ewoc-invalidate node) (jabber-receipts--update-header-line column timestamp) (when (string= column "displayed_at") (when msg-epoch (setq jabber-receipts--latest-displayed-ts msg-epoch)) (jabber-receipts--cascade-displayed node) (when msg-epoch (jabber-db-cascade-displayed account peer timestamp msg-epoch)))))))))) (defun jabber-receipts--cascade-displayed (node) "Walk backward from NODE, promoting :delivered nodes to :displayed. Per XEP-0333, a marker implies all prior messages were also seen. Only promotes :local nodes whose :status is :delivered." (let ((prev (ewoc-prev jabber-chat-ewoc node)) (inhibit-read-only t)) (while prev (let* ((data (ewoc-data prev)) (type (car data)) (msg (cadr data))) (cond ((and (eq type :local) (eq (plist-get msg :status) :delivered)) (plist-put msg :status :displayed) (jabber-chat-ewoc-invalidate prev)) ((and (eq type :local) (eq (plist-get msg :status) :displayed)) (setq prev nil)))) ; stop, already cascaded (when prev (setq prev (ewoc-prev jabber-chat-ewoc prev)))))) (defun jabber-receipts--update-header-line (column timestamp) "Update `jabber-chat-receipt-message' for COLUMN at TIMESTAMP. Does not downgrade from \"seen\" to \"delivered\"." (let* ((time-str (format-time-string "%H:%M" timestamp)) (is-seen (string= column "displayed_at")) (label (if is-seen "seen" "delivered")) (face (if is-seen 'jabber-chat-seen 'jabber-chat-delivered))) (unless (and (not is-seen) (string-match-p "seen" jabber-chat-receipt-message)) (setq jabber-chat-receipt-message (propertize (format " %s %s" label time-str) 'face face)) (force-mode-line-update)))) (jabber-chain-add 'jabber-message-chain #'jabber-receipts--handle-message 50) ;;; Display marker on buffer visibility (defun jabber-receipts--on-window-change () "Send displayed marker when chat buffer becomes visible." (when (and jabber-chat-send-receipts (derived-mode-p 'jabber-chat-mode) jabber-receipts--pending-displayed-id jabber-chatting-with (get-buffer-window (current-buffer) 'visible)) (jabber-send-sexp-if-connected jabber-buffer-connection `(message ((to . ,jabber-chatting-with) (type . "chat")) (displayed ((xmlns . ,jabber-chat-markers-xmlns) (id . ,jabber-receipts--pending-displayed-id))))) (setq jabber-receipts--pending-displayed-id nil))) (add-hook 'window-configuration-change-hook #'jabber-receipts--on-window-change) ;;; Disco feature advertisement (jabber-disco-advertise-feature jabber-receipts-xmlns) (jabber-disco-advertise-feature jabber-chat-markers-xmlns) (provide 'jabber-receipts) ;;; jabber-receipts.el ends here emacs-jabber/lisp/jabber-register.el000066400000000000000000000144131516610113500177330ustar00rootroot00000000000000;;; jabber-register.el --- registration according to JEP-0077 -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2007 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'jabber-iq) (require 'jabber-widget) ;; Global reference declarations (declare-function jabber-disconnect-one "jabber-core.el" (jc &optional dont-redisplay interactivep)) (declare-function jabber-submit-search "jabber-search.el" (&rest _ignore)) (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-silent-mode) ; jabber.el (defvar jabber-xdata-xmlns) ; jabber-xml.el (defvar jabber-search-xmlns) ; jabber-search.el ;; Namespace constants (defconst jabber-register-xmlns "jabber:iq:register" "XEP-0077 In-Band Registration namespace.") ;; (defun jabber-get-register (jc to) "Send IQ get request in namespace \"jabber:iq:register\". JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Register with: "))) (jabber-send-iq jc to "get" `(query ((xmlns . ,jabber-register-xmlns))) #'jabber-process-data #'jabber-process-register-or-search #'jabber-report-success "Registration")) (defun jabber-process-register-or-search (jc xml-data) "Display results from jabber:iq:{register,search} query as a form. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((query (jabber-iq-query xml-data)) (have-xdata nil) (type (cond ((string= (jabber-iq-xmlns xml-data) jabber-register-xmlns) 'register) ((string= (jabber-iq-xmlns xml-data) jabber-search-xmlns) 'search) (t (error "Namespace %s not handled by jabber-process-register-or-search" (jabber-iq-xmlns xml-data))))) (register-account (plist-get (fsm-get-state-data jc) :registerp)) (username (plist-get (fsm-get-state-data jc) :username)) (server (plist-get (fsm-get-state-data jc) :server))) (cond ((eq type 'register) ;; If there is no `from' attribute, we are registering with the server (jabber-widget-init-buffer (or (jabber-xml-get-attribute xml-data 'from) server))) ((eq type 'search) ;; no such thing here (jabber-widget-init-buffer (jabber-xml-get-attribute xml-data 'from)))) (setq jabber-buffer-connection jc) (widget-insert (if (eq type 'register) "Register with " "Search ") jabber-widget-submit-to "\n\n") (dolist (x (jabber-xml-get-children query 'x)) (when (string= (jabber-xml-get-attribute x 'xmlns) jabber-xdata-xmlns) (setq have-xdata t) ;; If the registration form obeys XEP-0068, we know ;; for sure how to put a default username in it. (jabber-widget-render-xdata-form x (if (and register-account (string= (jabber-widget-xdata-formtype x) jabber-register-xmlns)) (list (cons "username" username)) nil)))) (if (not have-xdata) (jabber-widget-render-register-form query (when register-account username))) (widget-create 'push-button :notify (if (eq type 'register) #'jabber-submit-register #'jabber-submit-search) "Submit") (when (eq type 'register) (widget-insert "\t") (widget-create 'push-button :notify #'jabber-remove-register "Cancel registration")) (widget-insert "\n") (widget-setup) (widget-minor-mode 1))) (defun jabber-submit-register (&rest _ignore) "Submit registration input. See `jabber-process-register-or-search'." (let* ((registerp (plist-get (fsm-get-state-data jabber-buffer-connection) :registerp)) (handler (if registerp #'jabber-process-register-secondtime #'jabber-report-success)) (text (concat "Registration with " jabber-widget-submit-to))) (jabber-send-iq jabber-buffer-connection jabber-widget-submit-to "set" (cond ((eq jabber-widget-form-type 'register) `(query ((xmlns . ,jabber-register-xmlns)) ,@(jabber-widget-parse-register-form))) ((eq jabber-widget-form-type 'xdata) `(query ((xmlns . ,jabber-register-xmlns)) ,(jabber-widget-parse-xdata-form))) (t (error "Unknown form type: %s" jabber-widget-form-type))) handler (if registerp 'success text) handler (if registerp 'failure text))) (message "Registration sent")) (defun jabber-process-register-secondtime (jc xml-data closure-data) "Receive registration success or failure. CLOSURE-DATA is either `success' or `error'. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (cond ((eq closure-data 'success) (message "Registration successful. You may now connect to the server.")) (t (jabber-report-success jc xml-data "Account registration"))) (sit-for 3) (jabber-disconnect-one jc)) (defun jabber-remove-register (&rest _ignore) "Cancel registration. See `jabber-process-register-or-search'." (if (or jabber-silent-mode (yes-or-no-p (concat "Are you sure that you want to cancel your registration to " jabber-widget-submit-to "? "))) (jabber-send-iq jabber-buffer-connection jabber-widget-submit-to "set" `(query ((xmlns . ,jabber-register-xmlns)) (remove)) #'jabber-report-success "Unregistration" #'jabber-report-success "Unregistration"))) (provide 'jabber-register) ;;; jabber-register.el ends hereemacs-jabber/lisp/jabber-roster.el000066400000000000000000001071611516610113500174300ustar00rootroot00000000000000;;; jabber-roster.el --- displaying the roster -*- coding: utf-8; lexical-binding: t; -*- ;; Copyright (C) 2009 - Kirill A. Korinskiy - catap@catap.ru ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'cl-lib) (require 'jabber-util) (require 'jabber-alert) (require 'jabber-menu) (require 'jabber-private) (require 'jabber-presence) (require 'jabber-carbons) (require 'format-spec) (require 'ewoc) (require 'transient) (defgroup jabber-roster nil "roster display options" :group 'jabber) (defcustom jabber-resource-line-format " %r - %s (%S)" "The format specification of resource lines in the roster display. These are displayed when `jabber-show-resources' permits it. These fields are available: %c \"*\" if the contact is connected, or \" \" if not %n Nickname of contact, or JID if no nickname %j Bare JID of contact (without resource) %p Priority of this resource %r Name of this resource %s Availability of resource as string (\"Online\", \"Away\" etc) %S Status string specified by resource." :type 'string) (defcustom jabber-roster-sort-functions '(jabber-roster-sort-by-status jabber-roster-sort-by-displayname) "Sort roster according to these criteria. These functions should take two roster items A and B, and return: <0 if A < B 0 if A = B >0 if A > B." :type 'hook :options '(jabber-roster-sort-by-status jabber-roster-sort-by-displayname jabber-roster-sort-by-group)) (defcustom jabber-sort-order '("chat" "" "away" "dnd" "xa") "Sort by status in this order. Anything not in list goes last. Offline is represented as nil." :type '(repeat (restricted-sexp :match-alternatives (stringp nil)))) (defcustom jabber-show-resources 'sometimes "Show contacts' resources in roster? This can be one of the following symbols: nil Never show resources sometimes Show resources when there are more than one always Always show resources." :type '(radio (const :tag "Never" nil) (const :tag "When more than one connected resource" sometimes) (const :tag "Always" always))) (defcustom jabber-show-offline-contacts t "Show offline contacts in roster when non-nil." :type 'boolean) (defcustom jabber-remove-newlines t "Remove newlines in status messages? Newlines in status messages mess up the roster display. However, they are essential to status message poets. Therefore, you get to choose the behaviour. Trailing newlines are always removed, regardless of this variable." :type 'boolean) (defcustom jabber-roster-mode-hook nil "Hook run when entering Roster mode." :type 'hook) (defcustom jabber-roster-default-group-name "Ungrouped" "Default group name for buddies without groups." :type 'string :get (lambda (var) (let ((val (symbol-value var))) (when (stringp val) (set-text-properties 0 (length val) nil val)) val)) :set (lambda (var val) (when (stringp val) (set-text-properties 0 (length val) nil val)) (custom-set-default var val))) (defcustom jabber-roster-show-empty-group nil "Show empty groups in roster?" :type 'boolean) (defface jabber-roster-user-online '((t :inherit success :weight bold)) "Face for displaying online users.") (defface jabber-roster-user-xa '((t :inherit shadow :slant italic)) "Face for displaying extended away users.") (defface jabber-roster-user-dnd '((t :inherit error :weight bold)) "Face for displaying do not disturb users.") (defface jabber-roster-user-away '((t :inherit warning :slant italic)) "Face for displaying away users.") (defface jabber-roster-user-chatty '((t :inherit success :weight bold :slant italic)) "Face for displaying chatty users.") (defface jabber-roster-user-error '((t :inherit error :slant italic)) "Face for displaying users sending presence errors.") (defface jabber-roster-user-offline '((t :inherit shadow :slant italic)) "Face for displaying offline users.") (defface jabber-roster-groupchat '((t :inherit font-lock-type-face)) "Face for groupchat room names in the roster buffer.") (defface jabber-roster-groupchat-nick '((t :inherit shadow)) "Face for the user's nickname in groupchat roster entries.") (defface jabber-roster-unread '((t :inherit font-lock-warning-face :weight bold)) "Face for roster entries with unread messages.") (defun jabber-roster-separator () "Return a propertized separator string for the roster buffer." (propertize (jabber-separator) 'cursor-intangible t)) (defvar jabber-roster-debug nil "Debug roster draw.") (defvar-keymap jabber-roster-mode-map :parent (make-composed-keymap jabber-common-keymap special-mode-map) "TAB" #'jabber-go-to-next-roster-item "S-TAB" #'jabber-go-to-previous-roster-item "M-TAB" #'jabber-go-to-previous-roster-item "" #'jabber-go-to-previous-roster-item "RET" #'jabber-roster-ret-action-at-point "C-k" #'jabber-roster-delete-at-point "d" #'jabber-roster-delete-at-point "D" #'jabber-roster-delete-at-point "e" #'jabber-roster-edit-action-at-point "s" #'jabber-send-subscription-request "q" #'bury-buffer "i" #'jabber-get-disco-items "j" #'jabber-muc-join "I" #'jabber-get-disco-info "b" #'jabber-get-browse "v" #'jabber-get-version "a" #'jabber-send-presence "g" #'jabber-roster "h" #'jabber-roster-menu "o" #'jabber-roster-toggle-offline-display "H" #'jabber-roster-menu "?" #'jabber-roster-menu "f" #'jabber-omemo-show-fingerprints) ;; Global reference declarations (declare-function jabber-omemo-show-fingerprints "jabber-omemo-trust.el" (jc)) (declare-function jabber-muc-read-my-nickname "jabber-muc.el" (jc group &optional default)) (declare-function jabber-muc-join "jabber-muc.el" (jc group nickname &optional popup)) (declare-function jabber-chat-with "jabber-chat.el" (jc jid &optional other-window)) (declare-function jabber-disco-get-info "jabber-disco.el" (jc jid node callback closure-data &optional force)) (declare-function jabber-get-version "jabber-version.el" (jc to)) (declare-function jabber-get-browse "jabber-browse.el" (jc to)) (declare-function jabber-get-disco-items "jabber-disco.el" (jc to &optional node)) (declare-function jabber-get-disco-info "jabber-disco.el" (jc to &optional node)) (declare-function jabber-send-presence "jabber-presence.el" (show status priority &optional jc)) (declare-function jabber-muc-switch-to "jabber-muc.el" (group)) (declare-function jabber-muc-get-buffer "jabber-muc.el" (group &optional jc)) (declare-function jabber-send-subscription-request "jabber-presence.el" (jc to &optional request)) (declare-function jabber-roster-delete-jid-at-point "jabber-presence.el" ()) (declare-function jabber-roster-delete-group-from-jids "jabber-presence.el" (jc jids group)) (declare-function jabber-roster-edit-group-from-jids "jabber-presence.el" (jc jids group)) (declare-function jabber-roster-change "jabber-presence.el" (jc jid name groups)) (declare-function jabber-edit-bookmarks "jabber-bookmarks.el" (jc)) (declare-function jabber-muc-joined-p "jabber-muc.el" (group &optional jc)) (declare-function jabber-muc-active-rooms "jabber-muc.el" ()) (declare-function jabber-muc-nickname "jabber-muc.el" (group &optional jc)) (declare-function jabber-muc-connection "jabber-muc.el" (group)) (declare-function jabber-muc-generation "jabber-muc.el" ()) (defvar jabber-connections) ; jabber-core.el (defvar jabber-roster-buffer) ; jabber-core.el (defvar *jabber-current-show*) ; jabber.el (defvar jabber-presence-strings) ; jabber.el (defvar *jabber-current-status*) ; jabber.el (defvar jabber-presence-faces) ; jabber.el (defvar jabber-activity-jids) ; jabber-activity.el (transient-define-prefix jabber-roster-menu () "Jabber roster commands." [["Chat" ("RET" "Open chat buffer" jabber-roster-ret-action-at-point) ("e" "Edit item" jabber-roster-edit-action-at-point) ("s" "Subscribe" jabber-send-subscription-request)] ["Roster" ("d" "Delete item" jabber-roster-delete-at-point) ("g" "Refresh" jabber-roster) ("m" "Jump to item" imenu) ("o" "Toggle offline" jabber-roster-toggle-offline-display)] ["MUC & Presence" ("B" "Bookmarks" jabber-edit-bookmarks) ("a" "Send presence" jabber-send-presence)] ["Discovery" ("i" "Disco items" jabber-get-disco-items) ("I" "Disco info" jabber-get-disco-info) ("b" "Browse" jabber-get-browse) ("v" "Client version" jabber-get-version)] ["OMEMO" ("f" "Fingerprints" jabber-omemo-show-fingerprints)]]) ;; (defun jabber-roster--accounts-for-jid (jid) "Return list of connections that have JID in their roster." (let ((sym (jabber-jid-symbol jid))) (cl-remove-if-not (lambda (jc) (memq sym (plist-get (fsm-get-state-data jc) :roster))) jabber-connections))) (defun jabber-roster--choose-account (jid account-at-point) "Choose which account to use for JID. If JID appears in more than one account's roster, prompt. Otherwise return ACCOUNT-AT-POINT." (let ((accounts (jabber-roster--accounts-for-jid jid))) (if (cdr accounts) ;; Multiple accounts have this contact; prompt. (let* ((completions (mapcar (lambda (jc) (cons (jabber-connection-bare-jid jc) jc)) accounts)) (default (when account-at-point (jabber-connection-bare-jid account-at-point))) (input (completing-read (format "Account for %s (default %s): " (jabber-jid-user jid) default) completions nil t nil 'jabber-account-history default))) (cdr (assoc input completions))) account-at-point))) (defun jabber-roster-ret-action-at-point () "Action for RET. Before try to roll up/down group. Eval `chat-with-jid-at-point' is no group at point." (interactive) (let ((group-at-point (get-text-property (point) 'jabber-group)) (account-at-point (get-text-property (point) 'jabber-account)) (jid-at-point (get-text-property (point) 'jabber-jid))) (cond ((and group-at-point account-at-point) (jabber-roster-roll-group account-at-point group-at-point)) ;; Already-joined groupchat: switch directly to buffer. ((jabber-muc-joined-p jid-at-point) (jabber-muc-switch-to jid-at-point)) ;; Contact or other JID: disco-check to decide chat vs MUC join. ((and jid-at-point account-at-point) (let ((jc (jabber-roster--choose-account jid-at-point account-at-point))) (jabber-disco-get-info jc (jabber-jid-user jid-at-point) nil #'jabber-roster-ret-action-at-point-1 jid-at-point)))))) (defun jabber-roster-ret-action-at-point-1 (jc jid result) ;; If we get an error, assume it's a normal contact. (if (eq (car result) 'error) (jabber-chat-with jc jid) ;; Otherwise, let's check whether it has a groupchat identity. (let ((identities (car result))) (if (cl-find "conference" (if (sequencep identities) identities nil) :key (lambda (i) (aref i 1)) :test #'string=) ;; Yes! Let's join it. (jabber-muc-join jc jid (jabber-muc-read-my-nickname jc jid t) t) ;; No. Let's open a normal chat buffer. (jabber-chat-with jc jid))))) (defun jabber-roster-mouse-2-action-at-point (e) "Action for mouse 2. Before try to roll up/down group. Eval `chat-with-jid-at-point' is no group at point." (interactive "e") (mouse-set-point e) (let ((group-at-point (get-text-property (point) 'jabber-group)) (account-at-point (get-text-property (point) 'jabber-account))) (if (and group-at-point account-at-point) (jabber-roster-roll-group account-at-point group-at-point) (call-interactively #'jabber-roster-menu)))) (defun jabber-roster-delete-at-point () "Delete at point from roster. Try to delete the group from all contacts. Delete a jid if there is no group at point." (interactive) (let ((group-at-point (get-text-property (point) 'jabber-group)) (account-at-point (get-text-property (point) 'jabber-account))) (if (and group-at-point account-at-point) (let ((jids-with-group (gethash group-at-point (plist-get (fsm-get-state-data account-at-point) :roster-hash)))) (jabber-roster-delete-group-from-jids account-at-point jids-with-group group-at-point)) (jabber-roster-delete-jid-at-point)))) (defun jabber-roster-edit-action-at-point () "Action for e. Before try to edit group name. Eval `jabber-roster-change' is no group at point." (interactive) (let ((group-at-point (get-text-property (point) 'jabber-group)) (account-at-point (get-text-property (point) 'jabber-account))) (if (and group-at-point account-at-point) (let ((jids-with-group (gethash group-at-point (plist-get (fsm-get-state-data account-at-point) :roster-hash)))) (jabber-roster-edit-group-from-jids account-at-point jids-with-group group-at-point)) (call-interactively 'jabber-roster-change)))) (defun jabber-roster-roll-group (jc group-name &optional set) "Roll up/down group in roster. If optional SET is t, roll up group. If SET is non-nil and not t, roll down group. If SET is nil, toggle." (let* ((state-data (fsm-get-state-data jc)) (roll-groups (plist-get state-data :roster-roll-groups)) (rolled-p (cl-find group-name roll-groups :test #'string=)) (new-roll-groups (cond ;; Currently rolled up: unroll unless SET forces roll-up ((and rolled-p (not (eq set t))) (cl-remove group-name roll-groups :test #'string=)) ;; Currently unrolled: roll up on toggle or explicit roll-up ((and (not rolled-p) (or (not set) (eq set t))) (cons group-name roll-groups)) ;; No change needed (t roll-groups)))) (unless (equal roll-groups new-roll-groups) (plist-put state-data :roster-roll-groups new-roll-groups) (jabber-roster--refresh)))) (defun jabber-roster-imenu-create-index () "Create an imenu index for the roster buffer." (let (contacts-index groupchats-index) (save-excursion (goto-char (point-min)) (while (not (eobp)) (let ((group (get-text-property (point) 'jabber-group)) (jid (get-text-property (point) 'jabber-jid))) (cond (group (push (cons group (point)) (if (string= group "Groupchats") groupchats-index contacts-index))) (jid (let ((entry (cons jid (point)))) (if (jabber-muc-joined-p jid) (push entry groupchats-index) (push entry contacts-index)))))) (forward-line 1))) (let (index) (when groupchats-index (push (cons "Groupchats" (nreverse groupchats-index)) index)) (when contacts-index (push (cons "Contacts" (nreverse contacts-index)) index)) index))) (define-derived-mode jabber-roster-mode special-mode "jabber-roster" "Major mode for Jabber roster display. Use the keybindings (mnemonic as Chat, Roster, Info, MUC, Service) to bring up menus of actions. \\{jabber-roster-mode-map}" :keymap jabber-roster-mode-map (setq display-line-numbers nil) (setq left-margin-width 1) (setq line-spacing 0.15) (cursor-intangible-mode 1) (setq left-fringe-width 0 right-fringe-width 0) (setq imenu-create-index-function #'jabber-roster-imenu-create-index) ;; Re-apply buffer to window so margin/fringe changes take effect. (let ((win (get-buffer-window (current-buffer)))) (when win (set-window-buffer win (current-buffer))))) (defun jabber-sort-roster (jc) "Sort roster according to online status. JC is the Jabber connection." (let ((state-data (fsm-get-state-data jc))) (dolist (group (plist-get state-data :roster-groups)) (let ((group-name (car group))) (puthash group-name (sort (gethash group-name (plist-get state-data :roster-hash)) #'jabber-roster-sort-items) (plist-get state-data :roster-hash)))))) (defun jabber-roster-prepare-roster (jc) "Make a hash based roster. JC is the Jabber connection." (let* ((state-data (fsm-get-state-data jc)) (hash (make-hash-table :test 'equal)) (buddies (plist-get state-data :roster)) (all-groups '())) (dolist (buddy buddies) (let ((groups (or (get buddy 'groups) (list jabber-roster-default-group-name)))) (dolist (group groups) (push group all-groups) (puthash group (cons buddy (gethash group hash)) hash)))) ;; Reverse hash values to restore buddy order within each group (maphash (lambda (key val) (puthash key (nreverse val) hash)) hash) ;; remove duplicates name of group (setq all-groups (sort (cl-remove-duplicates all-groups :test #'string=) #'string<)) ;; put to state-data all-groups as list of list (plist-put state-data :roster-groups (mapcar #'list all-groups)) ;; put to state-data hash-roster (plist-put state-data :roster-hash hash))) (defun jabber-roster-sort-items (a b) "Sort roster items A and B according to `jabber-roster-sort-functions'. Return t if A is less than B." (cl-dolist (fn jabber-roster-sort-functions) (let ((comparison (funcall fn a b))) (cond ((< comparison 0) (cl-return t)) ((> comparison 0) (cl-return nil)))))) (defun jabber-roster-sort-by-status (a b) "Sort roster items by online status. See `jabber-sort-order' for order used." (cl-flet ((order (item) (length (member (get item 'show) jabber-sort-order)))) (let ((a-order (order a)) (b-order (order b))) ;; Note reversed test. Items with longer X-order go first. (cond ((< a-order b-order) 1) ((> a-order b-order) -1) (t 0))))) (defun jabber-roster-sort-by-displayname (a b) "Sort roster items by displayed name." (let ((a-name (jabber-jid-displayname a)) (b-name (jabber-jid-displayname b))) (cond ((string-lessp a-name b-name) -1) ((string= a-name b-name) 0) (t 1)))) (defun jabber-roster-sort-by-group (a b) "Sort roster items by group membership." (cl-flet ((first-group (item) (or (car (get item 'groups)) ""))) (let ((a-group (first-group a)) (b-group (first-group b))) (cond ((string-lessp a-group b-group) -1) ((string= a-group b-group) 0) (t 1))))) (defun jabber-fix-status (status) "Make status strings more readable." (when status (when (string-match "\n+$" status) (setq status (replace-match "" t t status))) (when jabber-remove-newlines (while (string-match "\n" status) (setq status (replace-match " " t t status)))) status)) (defvar jabber-roster-ewoc nil "Ewoc displaying the roster. There is only one; we don't rely on buffer-local variables or such.") (defun jabber-roster-filter-display (buddies) "Filter BUDDIES for items to be displayed in the roster." (cl-remove-if-not (lambda (buddy) (or jabber-show-offline-contacts (get buddy 'connected))) buddies)) (defun jabber-roster-toggle-offline-display () "Toggle display of offline contacts. To change this permanently, customize the `jabber-show-offline-contacts'." (interactive) (setq jabber-show-offline-contacts (not jabber-show-offline-contacts)) (jabber-roster--refresh)) (defun jabber-roster--insert-status () "Insert the connection status header into the current buffer." (if (null jabber-connections) (insert "\nNot connected\n") (let ((show (cdr (assoc *jabber-current-show* jabber-presence-strings))) (accounts (mapconcat (lambda (jc) (concat (plist-get (fsm-get-state-data jc) :username) "@" (plist-get (fsm-get-state-data jc) :server))) jabber-connections ", "))) (insert (propertize (concat "Connected" (unless (string= show "Online") (format " [%s]" show)) ": " accounts) 'face 'shadow) "\n" (jabber-roster-separator) "\n")))) (defun jabber-roster--merged-groups () "Return a sorted list of unique group names across all connections." (sort (cl-remove-duplicates (cl-mapcan (lambda (jc) (mapcar #'car (plist-get (fsm-get-state-data jc) :roster-groups))) jabber-connections) :test #'string=) #'string<)) (defun jabber-roster--group-buddies (group-name) "Collect buddies for GROUP-NAME across all connections. Return (BUDDIES . BUDDY-JC-MAP) where BUDDIES is a filtered, sorted list and BUDDY-JC-MAP maps buddy names to connections." (let ((buddies '()) (buddy-jc-map (make-hash-table :test 'equal))) (dolist (jc jabber-connections) (let ((hash (plist-get (fsm-get-state-data jc) :roster-hash))) (when hash (dolist (buddy (gethash group-name hash)) (unless (gethash (symbol-name buddy) buddy-jc-map) (puthash (symbol-name buddy) jc buddy-jc-map) (push buddy buddies)))))) (cons (jabber-roster-filter-display (sort (nreverse buddies) #'jabber-roster-sort-items)) buddy-jc-map))) (defun jabber-roster--group-rolled-p (group-name) "Return non-nil if GROUP-NAME is rolled up in any connection." (cl-some (lambda (jc) (cl-find group-name (plist-get (fsm-get-state-data jc) :roster-roll-groups) :test #'string=)) jabber-connections)) (defun jabber-roster--insert-contacts () "Insert the contact roster using an ewoc." (dolist (jc jabber-connections) (unless (plist-get (fsm-get-state-data jc) :roster-hash) (jabber-roster-prepare-roster jc)) (jabber-sort-roster jc)) (let* ((first-jc (car jabber-connections)) (ewoc (ewoc-create (lambda (data) (let* ((group (car data)) (group-name (car group)) (buddy (cadr data)) (jc (nth 2 data))) (jabber-roster--display-entry (or jc first-jc) group-name buddy))) "" (jabber-roster-separator)))) (dolist (jc jabber-connections) (plist-put (fsm-get-state-data jc) :roster-ewoc ewoc)) (insert (propertize "Contacts" 'face 'jabber-title) "\n") (dolist (group-name (jabber-roster--merged-groups)) (let* ((result (jabber-roster--group-buddies group-name)) (buddies (car result)) (buddy-jc-map (cdr result))) (when (or jabber-roster-show-empty-group (> (length buddies) 0)) (let ((group (list group-name)) (rolled (jabber-roster--group-rolled-p group-name))) (let ((group-node (ewoc-enter-last ewoc (list group nil first-jc)))) (unless rolled (dolist (buddy (reverse buddies)) (ewoc-enter-after ewoc group-node (list group buddy (gethash (symbol-name buddy) buddy-jc-map)))))))))) (goto-char (point-max)) (insert "\n"))) (defun jabber-roster--insert-groupchats () "Insert the active groupchats section." (let ((rooms (sort (jabber-muc-active-rooms) #'string<))) (when rooms (insert (propertize "Groupchats" 'face 'jabber-title 'jabber-group "Groupchats") "\n") (dolist (room-jid rooms) (let* ((nick (jabber-muc-nickname room-jid)) (room-name (or (jabber-jid-user room-jid) room-jid)) (gc-jc (or (jabber-muc-connection room-jid) (car jabber-connections))) (unread (member room-jid (bound-and-true-p jabber-activity-jids))) (room-part (propertize (format " %s" room-name) 'face (if unread 'jabber-roster-unread 'jabber-roster-groupchat))) (nick-part (propertize (format " (%s)" nick) 'face 'jabber-roster-groupchat-nick)) (line (concat room-part nick-part))) (add-text-properties 0 (length line) (list 'jabber-jid room-jid 'jabber-account gc-jc) line) (insert line "\n")))))) (defun jabber-roster--restore-point (line column window window-line) "Restore cursor to LINE and COLUMN, and WINDOW scroll to WINDOW-LINE." (goto-char (point-min)) (forward-line (1- line)) (move-to-column column) (when window (set-window-point window (point)) (when window-line (set-window-start window (save-excursion (forward-line (- window-line)) (point)) t)))) (defun jabber-roster--refresh () "Refresh the roster buffer contents without switching to it." (let ((buffer (get-buffer-create jabber-roster-buffer))) (with-current-buffer buffer (unless (eq major-mode 'jabber-roster-mode) (jabber-roster-mode)) (let* ((inhibit-read-only t) (current-line (line-number-at-pos)) (current-column (current-column)) (window (get-buffer-window buffer)) (window-line (when window (count-lines (min (window-start window) (point)) (max (window-start window) (point)))))) (erase-buffer) (setq jabber-roster-ewoc nil) (setq header-line-format (propertize " Jabber roster" 'face '(:weight bold))) (jabber-roster--insert-status) (when jabber-connections (jabber-roster--insert-contacts)) (jabber-roster--insert-groupchats) (jabber-roster--restore-point current-line current-column window window-line))))) ;;;###autoload (defun jabber-roster () "Switch to the roster buffer and refresh it." (interactive) (jabber-roster--refresh) (pop-to-buffer-same-window jabber-roster-buffer) (when (called-interactively-p 'interactive) (message "Press %s for commands" (propertize "h" 'face 'help-key-binding)))) (defun jabber-roster--format-resource (buddy resource jc) "Return a propertized string for RESOURCE of BUDDY. JC is the Jabber connection." (let* ((res-name (car resource)) (res-data (cdr resource)) (resource-str (format-spec jabber-resource-line-format (list (cons ?c "*") (cons ?n (if (> (length (get buddy 'name)) 0) (get buddy 'name) (symbol-name buddy))) (cons ?j (symbol-name buddy)) (cons ?r (if (> (length res-name) 0) res-name "empty")) (cons ?s (or (cdr (assoc (plist-get res-data 'show) jabber-presence-strings)) (plist-get res-data 'show))) (cons ?S (if (plist-get res-data 'status) (jabber-fix-status (plist-get res-data 'status)) "")) (cons ?p (number-to-string (plist-get res-data 'priority))))))) (add-text-properties 0 (length resource-str) (list 'face (or (cdr (assoc (plist-get res-data 'show) jabber-presence-faces)) 'jabber-roster-user-online) 'jabber-jid (format "%s/%s" (symbol-name buddy) res-name) 'jabber-account jc) resource-str) resource-str)) (defun jabber-roster--display-entry (jc group-name buddy) "Format and insert a roster entry for BUDDY at point. BUDDY is a JID symbol. JC is the Jabber connection." (if buddy (let* ((bare-jid (symbol-name buddy)) (nick (get buddy 'name)) (show (or (cdr (assoc (get buddy 'show) jabber-presence-strings)) (get buddy 'show))) (unread (member bare-jid (bound-and-true-p jabber-activity-jids))) (face (if unread 'jabber-roster-unread (or (cdr (assoc (get buddy 'show) jabber-presence-faces)) 'jabber-roster-user-online))) (props (list 'jabber-jid bare-jid 'jabber-account jc))) (insert (apply #'propertize (concat " " bare-jid) 'face face props)) (when (and nick (> (length nick) 0)) (insert (propertize (format " (%s)" nick) 'face 'shadow))) (when show (insert (propertize (concat " " show) 'face 'shadow))) (when (or (eq jabber-show-resources 'always) (and (eq jabber-show-resources 'sometimes) (> (jabber-count-connected-resources buddy) 1))) (dolist (resource (get buddy 'resources)) (when (plist-get (cdr resource) 'connected) (insert "\n" (jabber-roster--format-resource buddy resource jc)))))) (let* ((group-name (or group-name jabber-roster-default-group-name)) (line (concat " " group-name))) (add-text-properties 0 (length line) (list 'face 'jabber-title 'jabber-group group-name 'jabber-account jc) line) (insert line)))) ;;;###autoload (defun jabber-roster-update (jc new-items changed-items deleted-items) "Update roster, in memory and on display. Add NEW-ITEMS, update CHANGED-ITEMS and remove DELETED-ITEMS, all three being lists of JID symbols. JC is the Jabber connection." (let* ((roster (plist-get (fsm-get-state-data jc) :roster)) (hash (plist-get (fsm-get-state-data jc) :roster-hash)) (all-groups (plist-get (fsm-get-state-data jc) :roster-groups))) ;; fix a old-roster (dolist (delete-this deleted-items) (setq roster (delq delete-this roster))) (setq roster (append new-items roster)) (plist-put (fsm-get-state-data jc) :roster roster) ;; update a hash-roster (if (not hash) (jabber-roster-prepare-roster jc) (when jabber-roster-debug (message "update hash-based roster")) ;; delete items (dolist (delete-this (append deleted-items changed-items)) (when jabber-roster-debug (message "delete jid: %s" (symbol-name delete-this))) (dolist (group (mapcar #'car all-groups)) (when jabber-roster-debug (message "try to delete jid: %s from group %s" (symbol-name delete-this) group)) (puthash group (delq delete-this (gethash group hash)) hash))) ;; insert changed-items (dolist (insert-this (append changed-items new-items)) (when jabber-roster-debug (message "insert jid: %s" (symbol-name insert-this))) (dolist (group (or (get insert-this 'groups) (list jabber-roster-default-group-name))) (when jabber-roster-debug (message "insert jid: %s to group %s" (symbol-name insert-this) group)) (puthash group (cons insert-this (gethash group hash)) hash) (push (list group) all-groups))) (when jabber-roster-debug (message "remove duplicates from new group")) (setq all-groups (sort (cl-remove-duplicates all-groups :key #'car :test #'string=) (lambda (a b) (string< (car a) (car b))))) (plist-put (fsm-get-state-data jc) :roster-groups all-groups)) (when jabber-roster-debug (message "re display roster")) ;; recreate roster buffer (jabber-roster--refresh))) (defun jabber-next-property (&optional prev) "Return position of next property appearence or nil if there is none. If optional PREV is non-nil, return position of previous property appearence." (let ((pos (point)) (found nil) (nextprev (if prev 'previous-single-property-change 'next-single-property-change))) (while (not found) (setq pos (let ((jid (funcall nextprev pos 'jabber-jid)) (group (funcall nextprev pos 'jabber-group))) (cond ((not jid) group) ((not group) jid) (t (funcall (if prev 'max 'min) jid group))))) (if (not pos) (setq found t) (setq found (or (get-text-property pos 'jabber-jid) (get-text-property pos 'jabber-group))))) pos)) (defun jabber-go-to-next-roster-item () "Move the cursor to the next jid/group in the buffer." (interactive) (let* ((next (jabber-next-property)) (next (if (not next) (progn (goto-char (point-min)) (jabber-next-property)) next))) (if next (goto-char next) (goto-char (point-min))))) (defun jabber-go-to-previous-roster-item () "Move the cursor to the previous jid/group in the buffer." (interactive) (let* ((previous (jabber-next-property 'prev)) (previous (if (not previous) (progn (goto-char (point-max)) (jabber-next-property 'prev)) previous))) (if previous (goto-char previous) (goto-char (point-max))))) (defun jabber-roster-restore-groups (jc) "Restore roster's groups rolling state from private storage. JC is the Jabber connection." (interactive (list (jabber-read-account))) (jabber-private-get jc 'roster "emacs-jabber" 'jabber-roster-restore-groups-1 'ignore)) (defun jabber-roster-restore-groups-1 (jc xml-data) "Parse roster groups and restore rolling state. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (when (string= (jabber-xml-get-xmlns xml-data) "emacs-jabber") (let* ((data (car (last xml-data))) (groups (if (stringp data) (split-string data "\n") nil))) (dolist (group groups) (jabber-roster-roll-group jc group t))))) (defun jabber-roster-save-groups () "Save roster's groups rolling state in private storage." (interactive) (dolist (jc jabber-connections) (let* ((groups (plist-get (fsm-get-state-data jc) :roster-roll-groups)) (roll-groups (if groups (mapconcat (lambda (a) (substring-no-properties a)) groups "\n") ""))) (jabber-private-set jc `(roster ((xmlns . "emacs-jabber")) ,roll-groups) 'jabber-report-success "Roster groups saved" 'jabber-report-success "Failed to save roster groups")))) (defvar jabber-roster--last-muc-generation 0 "Last seen `jabber-muc--generation' value.") (defvar jabber-roster--needs-refresh nil "Non-nil when the roster buffer needs a redraw.") (defun jabber-roster--refresh-if-visible () "Refresh roster only if its buffer is visible, otherwise defer." (let ((buf (get-buffer jabber-roster-buffer))) (when buf (if (get-buffer-window buf 'visible) (progn (jabber-roster--refresh) (setq jabber-roster--needs-refresh nil)) (setq jabber-roster--needs-refresh t))))) (defun jabber-roster--on-window-state-change (&rest _) "Refresh roster when it becomes visible and needs it." (when (and jabber-roster--needs-refresh (let ((buf (get-buffer jabber-roster-buffer))) (and buf (get-buffer-window buf 'visible)))) (setq jabber-roster--needs-refresh nil) (jabber-roster--refresh))) (add-hook 'window-state-change-hook #'jabber-roster--on-window-state-change) (defun jabber-roster--maybe-refresh-on-muc (_jc _xml-data) "Refresh roster when groupchat list changes." (unless (= (jabber-muc-generation) jabber-roster--last-muc-generation) (setq jabber-roster--last-muc-generation (jabber-muc-generation)) (jabber-roster--refresh-if-visible))) (with-eval-after-load 'jabber-activity (add-hook 'jabber-activity-update-hook #'jabber-roster--refresh-if-visible)) ;; MUC join/leave is signaled via presence stanzas, so we hook into ;; the presence chain. The handler short-circuits via `equal' check ;; and only triggers a refresh when the groupchat list actually changes. (with-eval-after-load "jabber-core" (jabber-chain-add 'jabber-presence-chain #'jabber-roster--maybe-refresh-on-muc 10)) (provide 'jabber-roster) ;;; jabber-roster.el ends here emacs-jabber/lisp/jabber-rtt.el000066400000000000000000000271431516610113500167240ustar00rootroot00000000000000;;; jabber-rtt.el --- XEP-0301: In-Band Real Time Text -*- lexical-binding: t; -*- ;; Copyright (C) 2013 Magnus Henoch ;; Copyright (C) 2026 Thanos Apollo ;; Author: Magnus Henoch ;; Maintainer: Thanos Apollo ;; 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 3 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, see . ;;; Commentary: ;; ;;; Code: (eval-when-compile (require 'cl-lib)) (require 'jabber-disco) (require 'jabber-core) (require 'ewoc) ;; Global reference declarations (declare-function jabber-chat-get-buffer "jabber-chat.el" (chat-with &optional jc)) (declare-function jabber-muc-message-p "jabber-muc.el"(message)) (declare-function jabber-chat-ewoc-enter "jabber-chatbuffer.el" (data)) (declare-function jabber-chat-ewoc-invalidate "jabber-chatbuffer" (node)) (declare-function jabber-chat-ewoc-delete "jabber-chatbuffer" (node)) (defvar jabber-message-chain) ; jabber-core.el (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-chatting-with) ; jabber-chat.el (defvar jabber-point-insert) ; jabber-console.el (defconst jabber-rtt-xmlns "urn:xmpp:rtt:0" "XML namespace for XEP-0301 In-Band Real Time Text.") ;;;; Handling incoming events (with-eval-after-load "jabber-disco" (jabber-disco-advertise-feature jabber-rtt-xmlns)) (defvar-local jabber-rtt-ewoc-node nil) (defvar-local jabber-rtt-last-seq nil) (defvar-local jabber-rtt-message nil) (defvar-local jabber-rtt-pending-events nil) (defvar-local jabber-rtt-timer nil) ;;;###autoload (with-eval-after-load "jabber-core" (jabber-chain-add 'jabber-message-chain #'jabber-rtt-handle-message 50)) ;;;###autoload (defun jabber-rtt-handle-message (jc xml-data) ;; We could support this for MUC as well, if useful. (when-let* (((not (jabber-muc-message-p xml-data))) (from (jabber-xml-get-attribute xml-data 'from)) (buffer (get-buffer (jabber-chat-get-buffer from jc)))) (with-current-buffer buffer (let* ((rtt (jabber-xml-path xml-data `((,jabber-rtt-xmlns . "rtt")))) (body (jabber-xml-path xml-data '(body))) (seq (when rtt (jabber-xml-get-attribute rtt 'seq))) (event (when rtt (or (jabber-xml-get-attribute rtt 'event) "edit"))) (actions (when rtt (jabber-xml-node-children rtt))) (inhibit-read-only t)) (cond ((or body (string= event "cancel")) ;; A element supersedes real time text. (jabber-rtt--reset)) ((member event '("new" "reset")) (jabber-rtt--reset) (setq jabber-rtt-ewoc-node (jabber-chat-ewoc-enter (list :notice "[typing...]")) jabber-rtt-last-seq (string-to-number seq) jabber-rtt-message "" jabber-rtt-pending-events nil) (jabber-rtt--enqueue-actions actions)) ((string= event "edit") ;; TODO: check whether this works properly in 32-bit Emacs (cond ((and jabber-rtt-last-seq (equal (1+ jabber-rtt-last-seq) (string-to-number seq))) ;; We are in sync. (setq jabber-rtt-last-seq (string-to-number seq)) (jabber-rtt--enqueue-actions actions)) (t ;; TODO: show warning when not in sync (message "out of sync! %s vs %s" seq jabber-rtt-last-seq)))) ;; TODO: handle event="init" ))))) (defun jabber-rtt--reset () (when jabber-rtt-ewoc-node (jabber-chat-ewoc-delete jabber-rtt-ewoc-node)) (when (timerp jabber-rtt-timer) (cancel-timer jabber-rtt-timer)) (setq jabber-rtt-ewoc-node nil jabber-rtt-last-seq nil jabber-rtt-message nil jabber-rtt-pending-events nil jabber-rtt-timer nil)) (defun jabber-rtt--enqueue-actions (new-actions) (setq jabber-rtt-pending-events ;; Ensure that the queue never contains more than 700 ms worth ;; of wait events. (jabber-rtt--fix-waits (append jabber-rtt-pending-events new-actions))) (unless jabber-rtt-timer (jabber-rtt--process-actions (current-buffer)))) (defun jabber-rtt--process-actions (buffer) (with-current-buffer buffer (setq jabber-rtt-timer nil) (catch 'wait (while jabber-rtt-pending-events (let ((action (pop jabber-rtt-pending-events))) (pcase (jabber-xml-node-name action) ('t ;; insert text (let* ((p (jabber-xml-get-attribute action 'p)) (position (if p (string-to-number p) (length jabber-rtt-message)))) (setq position (max position 0)) (setq position (min position (length jabber-rtt-message))) (setf (substring jabber-rtt-message position position) (car (jabber-xml-node-children action))) (ewoc-set-data jabber-rtt-ewoc-node (list :notice (concat "[typing...] " jabber-rtt-message))) (jabber-chat-ewoc-invalidate jabber-rtt-ewoc-node))) ('e ;; erase text (let* ((p (jabber-xml-get-attribute action 'p)) (position (if p (string-to-number p) (length jabber-rtt-message))) (n (jabber-xml-get-attribute action 'n)) (number (if n (string-to-number n) 1))) (setq position (max position 0)) (setq position (min position (length jabber-rtt-message))) (setq number (max number 0)) (setq number (min number position)) ;; Now erase the NUMBER characters before POSITION. (setf (substring jabber-rtt-message (- position number) position) "") (ewoc-set-data jabber-rtt-ewoc-node (list :notice (concat "[typing...] " jabber-rtt-message))) (jabber-chat-ewoc-invalidate jabber-rtt-ewoc-node))) ('w (setq jabber-rtt-timer (run-with-timer (/ (string-to-number (jabber-xml-get-attribute action 'n)) 1000.0) nil #'jabber-rtt--process-actions buffer)) (throw 'wait nil)))))))) (defun jabber-rtt--fix-waits (actions) ;; Ensure that the sum of all wait events is no more than 700 ms. (let ((sum 0)) (dolist (action actions) (when (eq (jabber-xml-node-name action) 'w) (let ((n (jabber-xml-get-attribute action 'n))) (setq n (string-to-number n)) (when (>= n 0) (setq sum (+ sum n)))))) (if (<= sum 700) actions (let ((scale (/ 700.0 sum))) (mapcar (lambda (action) (if (eq (jabber-xml-node-name action) 'w) (let ((n (jabber-xml-get-attribute action 'n))) (setq n (string-to-number n)) (setq n (max n 0)) `(w ((n . ,(number-to-string (* scale n)))) nil)) action)) actions))))) ;;;; Sending events (defvar-local jabber-rtt-send-timer nil) (defvar-local jabber-rtt-send-seq nil) (defvar-local jabber-rtt-outgoing-events nil) (defvar-local jabber-rtt-send-last-timestamp nil) ;;;###autoload (define-minor-mode jabber-rtt-send-mode "Show text to recipient as it is being typed. This lets the recipient see every change made to the message up until it's sent. The recipient's client needs to implement XEP-0301, In-Band Real Time Text." :lighter " Real-Time" (if (null jabber-rtt-send-mode) (progn (remove-hook 'after-change-functions #'jabber-rtt--queue-update t) (remove-hook 'jabber-chat-send-hooks #'jabber-rtt--message-sent t) (jabber-rtt--cancel-send)) (unless (derived-mode-p 'jabber-chat-mode) (error "Real Time Text only makes sense in chat buffers")) (when (timerp jabber-rtt-send-timer) (cancel-timer jabber-rtt-send-timer)) (setq jabber-rtt-send-timer nil jabber-rtt-send-seq nil jabber-rtt-outgoing-events nil jabber-rtt-send-last-timestamp nil) (jabber-rtt--send-current-text nil) (add-hook 'after-change-functions #'jabber-rtt--queue-update nil t) (add-hook 'jabber-chat-send-hooks #'jabber-rtt--message-sent nil t))) (defun jabber-rtt--cancel-send () (when (timerp jabber-rtt-send-timer) (cancel-timer jabber-rtt-send-timer)) (setq jabber-rtt-send-seq (1+ jabber-rtt-send-seq)) (jabber-send-sexp jabber-buffer-connection `(message ((to . ,jabber-chatting-with) (type . "chat")) (rtt ((xmlns . ,jabber-rtt-xmlns) (seq . ,(number-to-string jabber-rtt-send-seq)) (event . "cancel")) nil))) (setq jabber-rtt-send-timer nil jabber-rtt-send-seq nil jabber-rtt-outgoing-events nil jabber-rtt-send-last-timestamp nil)) (defun jabber-rtt--send-current-text (resetp) (let ((text (buffer-substring-no-properties jabber-point-insert (point-max)))) ;; This should give us enough room to avoid wrap-arounds, even ;; with just 28 bits... (setq jabber-rtt-send-seq (random 100000)) (jabber-send-sexp jabber-buffer-connection `(message ((to . ,jabber-chatting-with) (type . "chat")) (rtt ((xmlns . ,jabber-rtt-xmlns) (seq . ,(number-to-string jabber-rtt-send-seq)) (event . ,(if resetp "reset" "new"))) (t () ,text)))))) (defun jabber-rtt--queue-update (beg end pre-change-length) (unless (or (< beg jabber-point-insert) (< end jabber-point-insert)) (let ((timestamp (current-time))) (when jabber-rtt-send-last-timestamp (let* ((time-difference (time-subtract timestamp jabber-rtt-send-last-timestamp)) (interval (truncate (* 1000 (float-time time-difference))))) (when (and (> interval 0) ;; Don't send too long intervals - this should have ;; been sent by our timer already. (< interval 1000)) (push `(w ((n . ,(number-to-string interval))) nil) jabber-rtt-outgoing-events)))) (setq jabber-rtt-send-last-timestamp timestamp)) (when (> pre-change-length 0) ;; Some text was deleted. Let's check if we can use a shorter ;; tag: (let ((at-end (= end (point-max))) (erase-one (= pre-change-length 1))) (push `(e ( ,@(unless at-end `((p . ,(number-to-string (+ beg (- jabber-point-insert) pre-change-length))))) ,@(unless erase-one `((n . ,(number-to-string pre-change-length)))))) jabber-rtt-outgoing-events))) (when (/= beg end) ;; Some text was inserted. (let ((text (buffer-substring-no-properties beg end)) (at-end (= end (point-max)))) (push `(t ( ,@(unless at-end `((p . ,(number-to-string (- beg jabber-point-insert)))))) ,text) jabber-rtt-outgoing-events))) (when (null jabber-rtt-send-timer) (setq jabber-rtt-send-timer (run-with-timer 0.7 nil #'jabber-rtt--send-queued-events (current-buffer)))))) (defun jabber-rtt--send-queued-events (buffer) (with-current-buffer buffer (setq jabber-rtt-send-timer nil) (when jabber-rtt-outgoing-events (let ((event (if jabber-rtt-send-seq "edit" "new"))) (setq jabber-rtt-send-seq (if jabber-rtt-send-seq (1+ jabber-rtt-send-seq) (random 100000))) (jabber-send-sexp jabber-buffer-connection `(message ((to . ,jabber-chatting-with) (type . "chat")) (rtt ((xmlns . ,jabber-rtt-xmlns) (seq . ,(number-to-string jabber-rtt-send-seq)) (event . ,event)) ,@(nreverse jabber-rtt-outgoing-events)))) (setq jabber-rtt-outgoing-events nil))))) (defun jabber-rtt--message-sent (_text _id) ;; We're sending a element; reset our state (when (timerp jabber-rtt-send-timer) (cancel-timer jabber-rtt-send-timer)) (setq jabber-rtt-send-timer nil jabber-rtt-send-seq nil jabber-rtt-outgoing-events nil jabber-rtt-send-last-timestamp nil)) (provide 'jabber-rtt) ;;; jabber-rtt.el ends here emacs-jabber/lisp/jabber-sasl.el000066400000000000000000000156021516610113500170520ustar00rootroot00000000000000;;; jabber-sasl.el --- SASL authentication -*- lexical-binding: t; -*- ;; Copyright (C) 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'cl-lib) (require 'fsm) (require 'jabber-util) ;; This file uses sasl.el from FLIM or Gnus. If it can't be found, ;; jabber-core.el won't use the SASL functions. (eval-and-compile (condition-case nil (require 'sasl) (error nil))) ;; Alternatives to FLIM would be the command line utility of GNU SASL, ;; or anything the Gnus people decide to use. ;; See XMPP-CORE and XMPP-IM for details about the protocol. (require 'jabber-xml) (defconst jabber-sasl-xmlns "urn:ietf:params:xml:ns:xmpp-sasl" "RFC 6120 XMPP SASL namespace.") ;; Global reference declarations (declare-function jabber-send-sexp "jabber-core.el" (jc sexp)) (defvar jabber-tls-xmlns) ; jabber-conn.el (defvar jabber-silent-mode) ; jabber.el ;; (defun jabber-sasl-start-auth (jc stream-features) "Start the SASL authentication mechanism. JC is The Jabber Connection. STREAM-FEATURES the XML parsed \"stream features\" answer (it is used with `jabber-xml-get-chidlren')." ;; Find a suitable common mechanism. (let* ((mechanism-elements (car (jabber-xml-get-children stream-features 'mechanisms))) (mechanisms (mapcar (lambda (tag) (car (jabber-xml-node-children tag))) (jabber-xml-get-children mechanism-elements 'mechanism))) (mechanism (if (and (member "ANONYMOUS" mechanisms) (or jabber-silent-mode (yes-or-no-p "Use anonymous authentication? "))) (sasl-find-mechanism '("ANONYMOUS")) (sasl-find-mechanism mechanisms)))) ;; No suitable mechanism? (if (null mechanism) ;; Maybe we can use legacy authentication (let ((iq-auth (cl-find "http://jabber.org/features/iq-auth" (jabber-xml-get-children stream-features 'auth) :key #'jabber-xml-get-xmlns :test #'string=)) ;; Or maybe we have to use STARTTLS, but can't (starttls (cl-find jabber-tls-xmlns (jabber-xml-get-children stream-features 'starttls) :key #'jabber-xml-get-xmlns :test #'string=))) (cond (iq-auth (fsm-send jc :use-legacy-auth-instead)) (starttls (message "STARTTLS encryption required, but disabled/non-functional at our end") (fsm-send jc :authentication-failure)) (t (message "Authentication failure: no suitable SASL mechanism found") (fsm-send jc :authentication-failure)))) ;; Watch for plaintext logins over unencrypted connections (if (and (not (plist-get (fsm-get-state-data jc) :encrypted)) (member (sasl-mechanism-name mechanism) '("PLAIN" "LOGIN")) (not (yes-or-no-p "Jabber server only allows cleartext password transmission! Continue? "))) (fsm-send jc :authentication-failure) ;; Start authentication. (let* (passphrase (client (sasl-make-client mechanism (plist-get (fsm-get-state-data jc) :username) "xmpp" (plist-get (fsm-get-state-data jc) :server))) (sasl-read-passphrase (jabber-sasl-read-passphrase-closure jc (lambda (p) (setq passphrase (copy-sequence p)) p))) (step (sasl-next-step client nil))) (jabber-send-sexp jc `(auth ((xmlns . ,jabber-sasl-xmlns) (mechanism . ,(sasl-mechanism-name mechanism))) ,(when (sasl-step-data step) (base64-encode-string (sasl-step-data step) t)))) (list client step passphrase)))))) (defun jabber-sasl-read-passphrase-closure (jc remember) "Return a lambda function suitable for `sasl-read-passphrase' for JC. Call REMEMBER with the password. REMEMBER is expected to return it as well." (let ((password (plist-get (fsm-get-state-data jc) :password)) (bare-jid (jabber-connection-bare-jid jc))) (if password (lambda (_prompt) (funcall remember (copy-sequence password))) (lambda (_prompt) (funcall remember (jabber-read-password bare-jid)))))) (defun jabber-sasl-process-input (jc xml-data sasl-data) "SASL protocol input processing. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((client (car sasl-data)) (step (nth 1 sasl-data)) (passphrase (nth 2 sasl-data)) (sasl-read-passphrase (jabber-sasl-read-passphrase-closure jc (lambda (p) (setq passphrase (copy-sequence p)) p)))) (cond ((eq (car xml-data) 'challenge) (sasl-step-set-data step (base64-decode-string (car (jabber-xml-node-children xml-data)))) (setq step (sasl-next-step client step)) (jabber-send-sexp jc `(response ((xmlns . ,jabber-sasl-xmlns)) ,(when (sasl-step-data step) (base64-encode-string (sasl-step-data step) t))))) ((eq (car xml-data) 'failure) (message "%s: authentication failure: %s" (jabber-connection-bare-jid jc) (jabber-xml-node-name (car (jabber-xml-node-children xml-data)))) (fsm-send jc :authentication-failure)) ((eq (car xml-data) 'success) ;; The server might, depending on the mechanism, send ;; "additional data" (see RFC 4422) with the element. ;; Since some SASL mechanisms perform mutual authentication, we ;; need to pass this data to sasl.el - we're not necessarily ;; done just because the server says we're done. (let* ((data (car (jabber-xml-node-children xml-data))) (decoded (if data (base64-decode-string data) ""))) (sasl-step-set-data step decoded) (condition-case e (progn ;; Check that sasl-next-step doesn't signal an error. ;; TODO: once sasl.el allows it, check that all steps have ;; been completed. (sasl-next-step client step) (message "Authentication succeeded for %s" (jabber-connection-bare-jid jc)) (fsm-send jc (cons :authentication-success passphrase))) (sasl-error (message "%s: authentication failure: %s" (jabber-connection-bare-jid jc) (error-message-string e)) (fsm-send jc :authentication-failure)))))) (list client step passphrase))) (provide 'jabber-sasl) ;;; jabber-sasl.el ends hereemacs-jabber/lisp/jabber-search.el000066400000000000000000000111751516610113500173560ustar00rootroot00000000000000;;; jabber-search.el --- searching by JEP-0055, with x:data support -*- lexical-binding: t; -*- ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2003, 2004 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'jabber-register) ;; Global reference declarations (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-xdata-xmlns) ; jabber-xml.el ;; Namespace constants (defconst jabber-search-xmlns "jabber:iq:search" "XEP-0055 Jabber Search namespace.") ;; (defun jabber-get-search (jc to) "Send IQ get request in namespace \"jabber:iq:search\". JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Search what database: "))) (jabber-send-iq jc to "get" `(query ((xmlns . ,jabber-search-xmlns))) #'jabber-process-data #'jabber-process-register-or-search #'jabber-report-success "Search field retrieval")) ;; `jabber-process-register-or-search' logically comes here, rendering the ;; search form, but since register and search are so similar, having ;; two functions would be serious code duplication. See ;; `jabber-register.el'. ;; jabber-submit-search is called when the "submit" button of the ;; search form is activated. (defun jabber-submit-search (&rest _ignore) "Submit search. See `jabber-process-register-or-search'." (let ((text (concat "Search at " jabber-widget-submit-to))) (jabber-send-iq jabber-buffer-connection jabber-widget-submit-to "set" (cond ((eq jabber-widget-form-type 'register) `(query ((xmlns . ,jabber-search-xmlns)) ,@(jabber-widget-parse-register-form))) ((eq jabber-widget-form-type 'xdata) `(query ((xmlns . ,jabber-search-xmlns)) ,(jabber-widget-parse-xdata-form))) (t (error "Unknown form type: %s" jabber-widget-form-type))) #'jabber-process-data #'jabber-process-search-result #'jabber-report-success text)) (message "Search sent")) (defun jabber-process-search-result (_jc xml-data) "Receive and display search results. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." ;; This function assumes that all search results come in one packet, ;; which is not necessarily the case. (let ((query (jabber-iq-query xml-data)) (have-xdata nil) xdata fields) ;; First, check for results in jabber:x:data form. (dolist (x (jabber-xml-get-children query 'x)) (when (string= (jabber-xml-get-attribute x 'xmlns) jabber-xdata-xmlns) (setq have-xdata t) (setq xdata x))) (if have-xdata (jabber-widget-render-xdata-search-results xdata) (insert (propertize "Search results" 'face 'jabber-title) "\n") (setq fields '((first . (label "First name" column 0)) (last . (label "Last name" column 15)) (nick . (label "Nickname" column 30)) (jid . (label "JID" column 45)) (email . (label "E-mail" column 65)))) (dolist (field-cons fields) (indent-to (plist-get (cdr field-cons) 'column) 1) (insert (propertize (plist-get (cdr field-cons) 'label) 'face 'bold))) (insert "\n\n") ;; Now, the items (dolist (item (jabber-xml-get-children query 'item)) (let ((start-of-line (point)) jid) (dolist (field-cons fields) (let ((field-plist (cdr field-cons)) (value (if (eq (car field-cons) 'jid) (setq jid (jabber-xml-get-attribute item 'jid)) (car (jabber-xml-node-children (car (jabber-xml-get-children item (car field-cons)))))))) (indent-to (plist-get field-plist 'column) 1) (if value (insert value)))) (if jid (put-text-property start-of-line (point) 'jabber-jid jid)) (insert "\n")))))) (provide 'jabber-search) ;;; jabber-search.el ends hereemacs-jabber/lisp/jabber-sm.el000066400000000000000000000355511516610113500165340ustar00rootroot00000000000000;;; jabber-sm.el --- XEP-0198 Stream Management -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; XEP-0198 Stream Management provides two features: ;; ;; 1. Stanza acknowledgement: counters tracking what each side received, ;; so undelivered stanzas can be detected and retransmitted. ;; ;; 2. Stream resumption: fast reconnect that skips SASL auth and ;; preserves the server-side session. ;; ;; SM state is stored on the FSM state-data plist. All functions in this ;; file are pure (take state-data, return values) except for the timer ;; management and the send helpers that call `jabber-send-string'. ;;; Code: (require 'cl-lib) (declare-function fsm-get-state-data "fsm" (fsm)) (declare-function jabber-send-string "jabber-core.el" (jc string)) (declare-function jabber-xml-node-name "jabber-xml.el" (node)) (declare-function jabber-xml-get-attribute "jabber-xml.el" (node attribute)) (declare-function jabber-xml-get-xmlns "jabber-xml.el" (node)) (declare-function jabber-xml-get-children "jabber-xml.el" (node child-name)) (declare-function jabber-xml-child-with-xmlns "jabber-xml.el" (node xmlns)) (declare-function jabber-sexp2xml "jabber-xml.el" (sexp)) (defvar jabber-debug-log-xml) (defvar jabber-connections) (defconst jabber-sm-xmlns "urn:xmpp:sm:3" "XEP-0198 Stream Management namespace (version 3).") (defgroup jabber-sm nil "XEP-0198 Stream Management." :group 'jabber) (defcustom jabber-sm-enable t "If non-nil, negotiate Stream Management when the server supports it." :type 'boolean) (defcustom jabber-sm-request-interval 30 "Seconds between periodic ack requests." :type 'integer) (defcustom jabber-sm-ack-interval 50 "Send a proactive ack every this many inbound stanzas. When nil, only send acks in response to server requests." :type '(choice (integer :tag "Stanzas between acks") (const :tag "Only on request" nil))) (defcustom jabber-sm-max-in-flight 40 "Maximum number of unacknowledged outbound stanzas before queuing. When the in-flight count reaches this limit, further stanzas are queued and drained as the server acknowledges previous ones. Set to nil to disable back-pressure (send everything immediately)." :type '(choice (integer :tag "Max unacked stanzas") (const :tag "No limit" nil))) ;;; Counter arithmetic (handles 2^32 wraparound per XEP-0198 section 5) (defconst jabber-sm--counter-max (expt 2 32) "Stanza counters wrap at 2^32.") (defun jabber-sm--inc-counter (n) "Increment counter N, wrapping at 2^32." (mod (1+ n) jabber-sm--counter-max)) (defun jabber-sm--counter-delta (a b) "Return the forward distance from counter B to counter A. Both values are mod 2^32. Result is in [0, 2^32)." (mod (- a b) jabber-sm--counter-max)) (defun jabber-sm--counter-<= (a b) "Return non-nil if counter A is at or behind counter B. Uses forward-distance heuristic: if delta(B,A) < 2^31, A <= B." (< (jabber-sm--counter-delta b a) (/ jabber-sm--counter-max 2))) ;;; Predicates for SM XML elements (defun jabber-sm--r-p (stanza) "Return non-nil if STANZA is an SM request." (and (eq (jabber-xml-node-name stanza) 'r) (equal (jabber-xml-get-xmlns stanza) jabber-sm-xmlns))) (defun jabber-sm--a-p (stanza) "Return non-nil if STANZA is an SM acknowledgement." (and (eq (jabber-xml-node-name stanza) 'a) (equal (jabber-xml-get-xmlns stanza) jabber-sm-xmlns))) (defun jabber-sm--enabled-p (stanza) "Return non-nil if STANZA is an SM response." (and (eq (jabber-xml-node-name stanza) 'enabled) (equal (jabber-xml-get-xmlns stanza) jabber-sm-xmlns))) (defun jabber-sm--resumed-p (stanza) "Return non-nil if STANZA is an SM response." (and (eq (jabber-xml-node-name stanza) 'resumed) (equal (jabber-xml-get-xmlns stanza) jabber-sm-xmlns))) (defun jabber-sm--failed-p (stanza) "Return non-nil if STANZA is an SM response." (and (eq (jabber-xml-node-name stanza) 'failed) (equal (jabber-xml-get-xmlns stanza) jabber-sm-xmlns))) ;;; State-data management (defconst jabber-sm--initial-keys '(:sm-enabled nil :sm-id nil :sm-resume-max nil :sm-outbound-count 0 :sm-inbound-count 0 :sm-outbound-queue nil :sm-pending-queue nil :sm-last-acked 0 :sm-resuming nil :sm-resumed nil :sm-r-timer nil) "Initial SM keys for the FSM state-data plist.") (defun jabber-sm--reset (state-data) "Return STATE-DATA with all SM keys reset to initial values." (let ((keys jabber-sm--initial-keys)) (while keys (setq state-data (plist-put state-data (car keys) (cadr keys))) (setq keys (cddr keys)))) state-data) ;;; Stream features check (defun jabber-sm--features-have-sm-p (state-data) "Return non-nil if stream features in STATE-DATA include SM." (let ((features (plist-get state-data :stream-features))) (when features (jabber-xml-child-with-xmlns features jabber-sm-xmlns)))) ;;; Stanza counting (defun jabber-sm--stanza-p (sexp) "Return non-nil if SEXP is a countable stanza (message, presence, or iq)." (memq (jabber-xml-node-name sexp) '(message presence iq))) (defun jabber-sm--count-outbound (state-data sexp) "Increment outbound counter and queue SEXP if SM is enabled. Return updated STATE-DATA." (when (and (plist-get state-data :sm-enabled) (jabber-sm--stanza-p sexp)) (let ((count (jabber-sm--inc-counter (plist-get state-data :sm-outbound-count)))) (setq state-data (plist-put state-data :sm-outbound-count count)) (setq state-data (plist-put state-data :sm-outbound-queue (nconc (plist-get state-data :sm-outbound-queue) (list (cons count sexp))))))) state-data) (defun jabber-sm--count-inbound (jc state-data stanza) "Increment inbound counter if SM is enabled and STANZA is countable. When `jabber-sm-ack-interval' is set, send a proactive every that many stanzas. JC is the Jabber connection. Return updated STATE-DATA." (when (and (plist-get state-data :sm-enabled) (jabber-sm--stanza-p stanza)) (let ((count (jabber-sm--inc-counter (plist-get state-data :sm-inbound-count)))) (setq state-data (plist-put state-data :sm-inbound-count count)) (when (and jabber-sm-ack-interval (zerop (mod count jabber-sm-ack-interval))) (jabber-sm--send-ack jc state-data)))) state-data) ;;; Back-pressure helpers (defun jabber-sm--in-flight-count (state-data) "Return the number of unacknowledged outbound stanzas in STATE-DATA." (jabber-sm--counter-delta (plist-get state-data :sm-outbound-count) (plist-get state-data :sm-last-acked))) (defun jabber-sm--should-queue-p (state-data sexp) "Return non-nil if SEXP should be queued instead of sent immediately. True when SM is enabled, SEXP is a countable stanza, back-pressure is enabled, and the in-flight count has reached the cap." (and jabber-sm-max-in-flight (plist-get state-data :sm-enabled) (jabber-sm--stanza-p sexp) (>= (jabber-sm--in-flight-count state-data) jabber-sm-max-in-flight))) (defun jabber-sm--stanza-priority (sexp) "Return priority for SEXP: 0 for message, 1 for iq, 2 for presence." (pcase (jabber-xml-node-name sexp) ('message 0) ('iq 1) (_ 2))) (defun jabber-sm--enqueue-pending (state-data sexp) "Append SEXP to the pending queue in STATE-DATA. Each entry is stored as (PRIORITY . SEXP) for priority-based drain. Return updated STATE-DATA." (plist-put state-data :sm-pending-queue (nconc (plist-get state-data :sm-pending-queue) (list (cons (jabber-sm--stanza-priority sexp) sexp))))) (defun jabber-sm--drain-pending (jc state-data send-fn) "Send queued stanzas from pending queue up to the in-flight cap. JC is the connection. STATE-DATA is the FSM plist. SEND-FN is called with (JC SEXP) for each drained stanza and must bypass the back-pressure gate to avoid re-queuing. The queue is stable-sorted by priority before draining so messages go first, then IQs, then presence. FIFO order is preserved within each priority class. Return updated STATE-DATA." (let ((queue (sort (plist-get state-data :sm-pending-queue) (lambda (a b) (< (car a) (car b)))))) (while (and queue (or (null jabber-sm-max-in-flight) (< (jabber-sm--in-flight-count state-data) jabber-sm-max-in-flight))) (let ((sexp (cdr (pop queue)))) (funcall send-fn jc sexp) (setq state-data (jabber-sm--count-outbound state-data sexp)))) (plist-put state-data :sm-pending-queue queue))) ;;; Ack send/receive (defun jabber-sm--make-ack-xml (h) "Return the XML string for ." (format "" jabber-sm-xmlns h)) (defun jabber-sm--make-request-xml () "Return the XML string for ." (format "" jabber-sm-xmlns)) (defun jabber-sm--send-ack (jc state-data) "Send an ack to JC with inbound count from STATE-DATA." (jabber-send-string jc (jabber-sm--make-ack-xml (plist-get state-data :sm-inbound-count)))) (defun jabber-sm--request-ack (jc) "Send an request to JC." (jabber-send-string jc (jabber-sm--make-request-xml))) (defun jabber-sm--prune-queue (queue h) "Return QUEUE with entries whose count is <= H removed." (cl-remove-if (lambda (entry) (jabber-sm--counter-<= (car entry) h)) queue)) (defun jabber-sm--process-ack (state-data stanza) "Process an incoming ack STANZA, pruning the outbound queue. Return updated STATE-DATA." (let* ((h (string-to-number (or (jabber-xml-get-attribute stanza 'h) "0"))) (sent (plist-get state-data :sm-outbound-count)) (queue (plist-get state-data :sm-outbound-queue)) (pruned (jabber-sm--prune-queue queue h))) (when (not (jabber-sm--counter-<= h sent)) (message "SM warning: server acked more stanzas than sent (h=%d, sent=%d)" h sent)) (setq state-data (plist-put state-data :sm-last-acked h)) (setq state-data (plist-put state-data :sm-outbound-queue pruned)) state-data)) ;;; Enable/resume XML generation (defun jabber-sm--make-enable-xml () "Return the XML string for ." (format "" jabber-sm-xmlns)) (defun jabber-sm--make-resume-xml (h previd) "Return the XML string for ." (format "" jabber-sm-xmlns h previd)) (defun jabber-sm--parse-enabled (stanza) "Parse an STANZA. Return a plist (:id ID :resume RESUME :max MAX)." (list :id (jabber-xml-get-attribute stanza 'id) :resume (member (jabber-xml-get-attribute stanza 'resume) '("true" "1")) :max (let ((max-str (jabber-xml-get-attribute stanza 'max))) (when max-str (string-to-number max-str))))) (defun jabber-sm--apply-enabled (state-data enabled-info) "Apply parsed ENABLED-INFO to STATE-DATA, enabling SM. Return updated STATE-DATA." (setq state-data (plist-put state-data :sm-enabled t)) ;; Only store session ID when the server actually granted resumption. ;; Without this, an unexpected disconnect would attempt resume against ;; a server that only supports acking, skipping MUC cleanup. (when (plist-get enabled-info :resume) (setq state-data (plist-put state-data :sm-id (plist-get enabled-info :id)))) (when (plist-get enabled-info :max) (setq state-data (plist-put state-data :sm-resume-max (plist-get enabled-info :max)))) state-data) ;;; Resume handling (defun jabber-sm--handle-resumed (state-data stanza) "Process STANZA against STATE-DATA after stream resumption. Prune the outbound queue per the server's h value. Return (UPDATED-STATE-DATA . STANZAS-TO-RESEND)." (let* ((h (string-to-number (or (jabber-xml-get-attribute stanza 'h) "0"))) (queue (plist-get state-data :sm-outbound-queue)) (pruned (jabber-sm--prune-queue queue h)) (to-resend (mapcar #'cdr pruned))) (setq state-data (plist-put state-data :sm-last-acked h)) (setq state-data (plist-put state-data :sm-outbound-count h)) (setq state-data (plist-put state-data :sm-outbound-queue nil)) (setq state-data (plist-put state-data :sm-resumed t)) (setq state-data (plist-put state-data :sm-resuming nil)) (cons state-data to-resend))) ;;; Periodic ack request timer (defun jabber-sm--r-timer-function (jc) "Timer callback: send if JC is still connected." (when (memq jc jabber-connections) (condition-case nil (jabber-sm--request-ack jc) (error nil)))) (defun jabber-sm--start-r-timer (jc state-data) "Start a periodic timer for connection JC. Return updated STATE-DATA with the timer stored." (jabber-sm--stop-r-timer state-data) (let ((timer (run-with-timer jabber-sm-request-interval jabber-sm-request-interval #'jabber-sm--r-timer-function jc))) (plist-put state-data :sm-r-timer timer))) (defun jabber-sm--stop-r-timer (state-data) "Cancel the periodic timer if running. Return updated STATE-DATA." (let ((timer (plist-get state-data :sm-r-timer))) (when (timerp timer) (cancel-timer timer))) (plist-put state-data :sm-r-timer nil)) ;;; FSM routing helper (defun jabber-sm--maybe-enable-or-establish (state-data) "Return FSM transition for STATE-DATA to :sm-enable or :session-established. Checks `jabber-sm-enable' and whether stream features include SM." (if (and jabber-sm-enable (jabber-sm--features-have-sm-p state-data)) (list :sm-enable state-data) (list :session-established state-data))) ;;; Post-connect hook entry point (defun jabber-sm-maybe-start (jc) "Start SM ack timer if SM was successfully enabled on JC. Intended for `jabber-post-connect-hooks'." (let ((state-data (fsm-get-state-data jc))) (when (plist-get state-data :sm-enabled) (jabber-sm--start-r-timer jc state-data)))) (provide 'jabber-sm) ;;; jabber-sm.el ends here emacs-jabber/lisp/jabber-srv.el000066400000000000000000000163441516610113500167260ustar00rootroot00000000000000;;; jabber-srv.el --- SRV DNS lookups for XMPP -*- lexical-binding: t; -*- ;; Copyright (C) 2005, 2007, 2018 Magnus Henoch ;; Author: Magnus Henoch ;; 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 GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: ;; ;; RFC 2782 SRV record lookups. Originally a separate package (srv.el), ;; now inlined into jabber.el. ;;; Code: (require 'cl-lib) (require 'dns) (defun jabber-srv--dns-query (target) "Perform DNS SRV query for TARGET. Uses `dns-query' on systems with UDP support, falls back to nslookup on Windows." (if (featurep 'make-network-process '(:type datagram)) (dns-query target 'SRV t) (jabber-srv--nslookup target))) (defun jabber-srv--nslookup (target) "Call nslookup to perform an SRV query for TARGET. Fallback for systems without UDP socket support (Windows)." (with-temp-buffer (call-process "nslookup" nil t nil "-type=srv" target) (goto-char (point-min)) (let (results) (while (re-search-forward (concat "[ \t]*priority += \\(.*\\)\r?\n" "[ \t]*weight += \\(.*\\)\r?\n" "[ \t]*port += \\(.*\\)\r?\n" "[ \t]*svr hostname += \\(.*\\)\r?\n") nil t) (push (list (list 'data (list (list 'priority (string-to-number (match-string 1))) (list 'weight (string-to-number (match-string 2))) (list 'port (string-to-number (match-string 3))) (list 'target (match-string 4))))) results)) (list (list 'answers results))))) (defun jabber-srv--group-by-priority (answers) "Group ANSWERS by priority, sorted lowest first. Returns an alist of (PRIORITY . ENTRIES)." (let (groups) (dolist (a answers) (let* ((priority (cadr (assq 'priority a))) (entry (assq priority groups))) (if entry (push a (cdr entry)) (push (cons priority (list a)) groups)))) (sort groups (lambda (a b) (< (car a) (car b)))))) (defun jabber-srv--weighted-select (entries) "Select ENTRIES in weighted random order per RFC 2782. Returns the entries reordered by weighted random selection." (let ((weight-acc 0) weight-order result) (dolist (a entries) (cl-incf weight-acc (cadr (assq 'weight a))) (push (cons weight-acc a) weight-order)) (setq weight-order (nreverse weight-order)) (while weight-order (let* ((r (random (1+ weight-acc))) (next (cl-dolist (a weight-order) (when (>= (car a) r) (cl-return a))))) (push (cdr next) result) (setq weight-order (delq next weight-order)))) (nreverse result))) (defun jabber-srv--fetch-answers (target) "Perform DNS SRV query for TARGET and return parsed answer records. Returns a list of alists, each containing priority, weight, port, and target entries. Returns nil if no records found, or `:dot' if the single-dot target (\"service not available\") was returned." (let* ((result (jabber-srv--dns-query target)) (answers (mapcar (lambda (a) (cadr (assq 'data a))) (cadr (assq 'answers result))))) (cond ((null answers) nil) ((and (length= answers 1) (string= (cadr (assq 'target (car answers))) ".")) :dot) (t answers)))) (defun jabber-srv--sort-answers (answers) "Sort ANSWERS by priority with weighted randomization per RFC 2782. ANSWERS is a list of alists as returned by `jabber-srv--fetch-answers'. Returns the entries in connection-attempt order." (let (ordered) (dolist (group (jabber-srv--group-by-priority answers)) (setq ordered (nconc ordered (jabber-srv--weighted-select (cdr group))))) ordered)) (defun jabber-srv--tag-answers (answers directtls-p) "Tag each record in ANSWERS with DIRECTTLS-P flag. Adds a (directtls DIRECTTLS-P) entry to each alist so the flag survives the priority/weight sort pipeline." (mapcar (lambda (a) (cons (list 'directtls directtls-p) a)) answers)) (defun jabber-srv--has-fallback-p (targets server) "Return non-nil if TARGETS already includes SERVER on port 5222 via STARTTLS." (cl-some (lambda (t_) (and (string= (nth 0 t_) server) (= (nth 1 t_) 5222) (not (nth 2 t_)))) targets)) ;;;###autoload (defun jabber-srv-lookup-mixed (server) "Query both _xmpps-client and _xmpp-client SRV records for SERVER. Merges results by priority and weight per RFC 2782. Returns a list of (HOST PORT DIRECTTLS-P) where DIRECTTLS-P is non-nil for targets from _xmpps-client._tcp (XEP-0368 direct TLS). Always appends SERVER:5222 STARTTLS as a lowest-priority fallback unless the SRV results already include it." (let ((xmpps (condition-case nil (jabber-srv--fetch-answers (concat "_xmpps-client._tcp." server)) (error nil))) (xmpp (condition-case nil (jabber-srv--fetch-answers (concat "_xmpp-client._tcp." server)) (error nil)))) ;; :dot means "service explicitly unavailable" (when (eq xmpps :dot) (setq xmpps nil)) (when (eq xmpp :dot) (setq xmpp nil)) (let ((merged (nconc (jabber-srv--tag-answers xmpps t) (jabber-srv--tag-answers xmpp nil)))) (when merged (let ((result (mapcar (lambda (a) (list (cadr (assq 'target a)) (cadr (assq 'port a)) (cadr (assq 'directtls a)))) (jabber-srv--sort-answers merged)))) ;; Append domain:5222 STARTTLS fallback if not already present. (unless (jabber-srv--has-fallback-p result server) (setq result (nconc result (list (list server 5222 nil))))) result))))) ;;;###autoload (defun jabber-srv-lookup (target) "Perform SRV lookup of TARGET and return connection candidates. TARGET is a string of the form \"_Service._Proto.Name\". Returns a list of (HOST . PORT) pairs sorted by priority with weighted randomization per RFC 2782. The caller should attempt connections in order. Returns nil if no SRV records were found." (let ((answers (jabber-srv--fetch-answers target))) (when (and answers (not (eq answers :dot))) (mapcar (lambda (a) (cons (cadr (assq 'target a)) (cadr (assq 'port a)))) (jabber-srv--sort-answers answers))))) (provide 'jabber-srv) ;;; jabber-srv.el ends here emacs-jabber/lisp/jabber-styling.el000066400000000000000000000300201516610113500175700ustar00rootroot00000000000000;;; jabber-styling.el --- XEP-0393 Message Styling -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; XEP-0393 Message Styling (v1.1.1). ;; Applies formatted text styling to chat message bodies: *bold*, ;; _italic_, ~strikethrough~, `preformatted`, ```code blocks```, and ;; > block quotes. ;; ;; Message display area: a body-printer replacement applies styling ;; after `jabber-chat-normal-body' inserts the text. ;; ;; Composition area: jit-lock provides live styling preview as the ;; user types, following the same approach as markdown-mode's ;; font-lock integration. ;;; Code: (require 'jabber-disco) (require 'jit-lock) (eval-when-compile (require 'cl-lib)) (defgroup jabber-styling nil "XEP-0393 Message Styling options." :group 'jabber-chat) (defcustom jabber-styling-enable t "Whether to render XEP-0393 Message Styling in chat buffers." :type 'boolean) (defconst jabber-styling-xmlns "urn:xmpp:styling:0" "XEP-0393 Message Styling namespace.") ;;; Faces (defface jabber-styling-bold '((t :inherit bold)) "Face for *bold* spans.") (defface jabber-styling-italic '((t :inherit italic)) "Face for _italic_ spans.") (defface jabber-styling-strike '((t :strike-through t)) "Face for ~strikethrough~ spans.") (defface jabber-styling-pre '((t :inherit font-lock-constant-face)) "Face for `preformatted` inline spans.") (defface jabber-styling-pre-block '((t :inherit font-lock-constant-face)) "Face for ```preformatted code blocks```.") (defface jabber-styling-quote '((t :inherit shadow)) "Face for > block quotes.") ;;; Pure parsing functions (defun jabber-styling--find-closing (line ch pos len) "Find the closing directive CH in LINE starting after POS. LEN is the length of LINE. Returns the position of the closing directive, or nil. The closing directive must not be preceded by whitespace, and there must be at least one char between open and close. Matching is lazy (first valid close wins)." (let ((search (1+ pos))) (catch 'found (while (< search len) (when (and (eq (aref line search) ch) (> search (1+ pos)) (not (memq (aref line (1- search)) '(?\s ?\t ?\n)))) (throw 'found search)) (setq search (1+ search))) nil))) (defun jabber-styling--valid-opening-p (line pos directives) "Check if POS in LINE is a valid opening directive position. DIRECTIVES is the alist of directive chars. Opening must be at start, after whitespace, or after another opening directive." (or (= pos 0) (let ((before (aref line (1- pos)))) (or (memq before '(?\s ?\t ?\n)) (assq before directives))))) (defun jabber-styling--parse-spans (line) "Parse XEP-0393 span directives in LINE. Return a list of (START END FACE) triples for styled regions. Matching is lazy (left-to-right, first valid close wins). Preformatted spans suppress inner directives; other spans may contain child spans." (let ((spans nil) (pos 0) (len (length line)) (directives '((?* . jabber-styling-bold) (?_ . jabber-styling-italic) (?~ . jabber-styling-strike) (?` . jabber-styling-pre)))) (while (< pos len) (let* ((ch (aref line pos)) (face (cdr (assq ch directives)))) (if (or (not face) (not (jabber-styling--valid-opening-p line pos directives))) (setq pos (1+ pos)) ;; Opening must not be followed by whitespace (if (or (>= (1+ pos) len) (memq (aref line (1+ pos)) '(?\s ?\t ?\n))) (setq pos (1+ pos)) (let ((close (jabber-styling--find-closing line ch pos len))) (if (not close) (setq pos (1+ pos)) (push (list pos (1+ close) face) spans) (setq pos (1+ close)))))))) (nreverse spans))) (defun jabber-styling--classify-block (line) "Classify LINE as a block type. Return one of: `pre-open', `pre-close', `quote', or `plain'. Pre-open matches lines beginning with ```. Pre-close matches lines containing only ```." (cond ((string-match-p "\\`\n*\\'" line) 'plain) ((string-match-p "\\````\\'" line) 'pre-close) ((string-match-p "\\````" line) 'pre-open) ((string-match-p "\\`>" line) 'quote) (t 'plain))) (defun jabber-styling--parse-blocks (text) "Parse TEXT into XEP-0393 blocks. Return a list of (TYPE START END) triples where TYPE is one of `plain', `quote', or `pre'." (let ((blocks nil) (len (length text)) (offset 0) (in-pre nil) (pre-start nil)) (while (< offset len) (let* ((nl (or (cl-position ?\n text :start offset) len)) (line (substring text offset nl)) (line-end (min (1+ nl) len)) (kind (jabber-styling--classify-block line))) (cond ;; Inside a preformatted block: only exact ``` closes it (in-pre (when (eq kind 'pre-close) (push (list 'pre pre-start line-end) blocks) (setq in-pre nil))) ;; Opening a preformatted block ((memq kind '(pre-open pre-close)) (setq in-pre t pre-start offset)) ;; Block quote line ((eq kind 'quote) (push (list 'quote offset line-end) blocks)) ;; Plain line (t (push (list 'plain offset line-end) blocks))) (setq offset line-end))) ;; Unclosed pre block extends to end (when in-pre (push (list 'pre pre-start len) blocks)) (nreverse blocks))) ;;; Application (defun jabber-styling--apply-spans (start line) "Apply span styling to LINE inserted at buffer position START." (dolist (span (jabber-styling--parse-spans line)) (let ((sstart (+ start (nth 0 span))) (send (+ start (nth 1 span))) (face (nth 2 span))) (font-lock-prepend-text-property sstart send 'face face)))) (defun jabber-styling--strip-quote-prefix (line) "Strip the leading > and first whitespace char from LINE. Per XEP-0393, the first leading whitespace after > MUST be trimmed." (if (and (> (length line) 1) (eq (aref line 0) ?>)) (if (memq (aref line 1) '(?\s ?\t)) (substring line 2) (substring line 1)) (if (and (= (length line) 1) (eq (aref line 0) ?>)) "" line))) (defun jabber-styling--apply-region (start end) "Apply XEP-0393 styling to text between START and END in current buffer." (let ((text (buffer-substring-no-properties start end))) (dolist (block (jabber-styling--parse-blocks text)) (let ((type (nth 0 block)) (bstart (+ start (nth 1 block))) (bend (min (+ start (nth 2 block)) end))) (pcase type ('pre (font-lock-prepend-text-property bstart bend 'face 'jabber-styling-pre-block)) ('quote ;; Apply quote face to the whole line, then parse spans ;; in the content after stripping the > prefix (font-lock-prepend-text-property bstart bend 'face 'jabber-styling-quote) (let* ((line (buffer-substring-no-properties bstart bend)) (stripped (jabber-styling--strip-quote-prefix line)) (prefix-len (- (length line) (length stripped)))) (jabber-styling--apply-spans (+ bstart prefix-len) stripped))) ('plain (let ((line (buffer-substring-no-properties bstart bend))) (jabber-styling--apply-spans bstart line)))))))) ;;; Live styling (composition area) (defconst jabber-styling--all-faces '(jabber-styling-bold jabber-styling-italic jabber-styling-strike jabber-styling-pre jabber-styling-pre-block jabber-styling-quote) "All faces applied by XEP-0393 styling.") (defvar jabber-point-insert) ; jabber-chatbuffer.el (defun jabber-styling--remove-faces (beg end) "Remove XEP-0393 styling faces from BEG to END. Preserves all other face properties in the region." (let ((pos beg)) (while (< pos end) (let* ((next (or (next-single-property-change pos 'face nil end) end)) (face (get-text-property pos 'face))) (when face (let ((new-face (if (listp face) (let ((filtered (cl-remove-if (lambda (f) (memq f jabber-styling--all-faces)) face))) (pcase (length filtered) (0 nil) (1 (car filtered)) (_ filtered))) (unless (memq face jabber-styling--all-faces) face)))) (unless (equal face new-face) (put-text-property pos next 'face new-face)))) (setq pos next))))) (defun jabber-styling--fontify-compose (_beg end) "Apply XEP-0393 styling to the composition area. Called by jit-lock for the region _BEG to END. Only operates on text after `jabber-point-insert' (the composition prompt). Always refontifies the entire composition area to handle multi-line constructs like pre blocks correctly." (when (and jabber-styling-enable (bound-and-true-p jabber-point-insert) (markerp jabber-point-insert)) (let ((compose-beg (marker-position jabber-point-insert)) (compose-end (point-max))) (when (and (< compose-beg compose-end) (>= end compose-beg)) (with-silent-modifications (jabber-styling--remove-faces compose-beg compose-end) (jabber-styling--apply-region compose-beg compose-end)))))) (defun jabber-styling--setup-buffer () "Set up live XEP-0393 styling preview in the composition area. Registers a jit-lock fontification function that applies styling as the user types." (when jabber-styling-enable (jit-lock-register #'jabber-styling--fontify-compose t))) (add-hook 'jabber-chat-mode-hook #'jabber-styling--setup-buffer) ;;; Body printer integration (declare-function jabber-chat-normal-body "jabber-chat" (msg who mode)) (defun jabber-styling--body-printer (msg who mode) "Insert body from MSG with XEP-0393 styling applied. WHO indicates the sender, MODE is :insert or :printp. Delegates to `jabber-chat-normal-body' for insertion, then applies styling to the inserted region." (let ((body (plist-get msg :body))) (when body (if (or (not (eq mode :insert)) (not jabber-styling-enable) (plist-get msg :unstyled) (string-prefix-p "/me " body)) ;; No styling needed: delegate to original printer (jabber-chat-normal-body msg who mode) ;; Insert body via original, then apply styling (let ((start (point))) (jabber-chat-normal-body msg who mode) (jabber-styling--apply-region start (point))))))) (with-eval-after-load "jabber-chat" (defvar jabber-body-printers) ;; Replace jabber-chat-normal-body with our styling-aware version ;; FIXME: Yuck! (setq jabber-body-printers (mapcar (lambda (fn) (if (eq fn #'jabber-chat-normal-body) #'jabber-styling--body-printer fn)) jabber-body-printers))) ;;; Disco (jabber-disco-advertise-feature jabber-styling-xmlns) (provide 'jabber-styling) ;;; jabber-styling.el ends here emacs-jabber/lisp/jabber-time.el000066400000000000000000000217241516610113500170500ustar00rootroot00000000000000;;; jabber-time.el --- time reporting by XEP-0012, XEP-0090, XEP-0202 -*- lexical-binding: t; -*- ;; Copyright (C) 2006, 2010 - Kirill A. Kroinskiy - catap@catap.ru ;; Copyright (C) 2006 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; ;;; Code: (require 'jabber-disco) (require 'jabber-iq) (require 'jabber-util) (require 'jabber-autoaway) (require 'time-date) ;; Global reference declarations ;; Namespace constants (defconst jabber-time-xmlns "urn:xmpp:time" "XEP-0202 Entity Time namespace.") (defconst jabber-time-legacy-xmlns "jabber:iq:time" "XEP-0090 Legacy Entity Time namespace.") (defconst jabber-last-xmlns "jabber:iq:last" "XEP-0012 Last Activity namespace.") ;; (defun jabber-get-time (jc to) "Request time. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Request time of: " nil nil nil 'full t))) (jabber-send-iq jc to "get" `(time ((xmlns . ,jabber-time-xmlns))) 'jabber-silent-process-data 'jabber-process-time 'jabber-silent-process-data (lambda (jc xml-data) (let ((from (jabber-xml-get-attribute xml-data 'from))) (jabber-get-legacy-time jc from))))) (defun jabber-get-legacy-time (jc to) "Request legacy time. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Request time of: " nil nil nil 'full t))) (jabber-send-iq jc to "get" `(query ((xmlns . ,jabber-time-legacy-xmlns))) 'jabber-silent-process-data 'jabber-process-legacy-time 'jabber-silent-process-data "Time request failed")) ;; called by jabber-process-data (defun jabber-process-time (_jc xml-data) "Handle results from urn:xmpp:time requests. JC is the Jabber Connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((from (jabber-xml-get-attribute xml-data 'from)) (time (or (car (jabber-xml-get-children xml-data 'time)) ;; adium response of qeury (car (jabber-xml-get-children xml-data 'query)))) (tzo (car (jabber-xml-node-children (car (jabber-xml-get-children time 'tzo))))) (utc (car (jabber-xml-node-children (car (jabber-xml-get-children time 'utc)))))) (when (and utc tzo) (format "%s has time: %s %s" from (format-time-string "%Y-%m-%d %T" (jabber-parse-time utc)) tzo)))) (defun jabber-process-legacy-time (_jc xml-data) "Handle results from jabber:iq:time requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((from (jabber-xml-get-attribute xml-data 'from)) (query (jabber-iq-query xml-data)) (display (car (jabber-xml-node-children (car (jabber-xml-get-children query 'display))))) (utc (car (jabber-xml-node-children (car (jabber-xml-get-children query 'utc))))) (tz (car (jabber-xml-node-children (car (jabber-xml-get-children query 'tz)))))) (format "%s has time: %s" from (cond (display display) (utc (concat (format-time-string "%Y-%m-%d %T" (jabber-parse-legacy-time utc)) (when tz (concat " " tz)))))))) ;; the only difference between these two functions is the ;; `jabber-read-jid-completing' call. (defun jabber-get-last-online (jc to) "Request time since a user was last online, or uptime of a component. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Get last online for: " nil nil nil 'bare-or-muc))) (jabber-send-iq jc to "get" `(query ((xmlns . ,jabber-last-xmlns))) #'jabber-silent-process-data #'jabber-process-last #'jabber-silent-process-data "Last online request failed")) (defun jabber-get-idle-time (jc to) "Request idle time of user. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Get idle time for: " nil nil nil 'full t))) (jabber-send-iq jc to "get" `(query ((xmlns . ,jabber-last-xmlns))) #'jabber-silent-process-data #'jabber-process-last #'jabber-silent-process-data "Idle time request failed")) (defun jabber-process-last (_jc xml-data) "Handle results from jabber:iq:last requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((from (jabber-xml-get-attribute xml-data 'from)) (query (jabber-iq-query xml-data)) (seconds (jabber-xml-get-attribute query 'seconds))) (cond ((jabber-jid-resource from) ;; Full JID: idle time (format "%s idle for %s seconds" from seconds)) ((jabber-jid-username from) ;; Bare JID with username: time since online (concat (format "%s last online %s seconds ago" from seconds) (let ((seconds (condition-case nil (string-to-number seconds) (error nil)))) (when (numberp seconds) (concat " - that is, at " (format-time-string "%Y-%m-%d %T" (time-subtract (current-time) (seconds-to-time seconds))) "\n"))))) (t ;; Only hostname: uptime (format "%s uptime: %s seconds" from seconds))))) (add-to-list 'jabber-iq-get-xmlns-alist (cons jabber-time-legacy-xmlns 'jabber-return-legacy-time)) (jabber-disco-advertise-feature jabber-time-legacy-xmlns) (defun jabber-return-legacy-time (jc xml-data) "Return client time as defined in XEP-0090. Sender and ID are determined from the incoming packet passed in XML-DATA. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((to (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id))) (jabber-send-iq jc to "result" `(query ((xmlns . ,jabber-time-legacy-xmlns)) ;; what is ``human-readable'' format? ;; the same way as formating using by tkabber (display () ,(format-time-string "%a %b %d %H:%M:%S %Z %Y")) (tz () ,(format-time-string "%Z")) (utc () ,(jabber-encode-legacy-time nil))) nil nil nil nil id))) (add-to-list 'jabber-iq-get-xmlns-alist (cons jabber-time-xmlns 'jabber-return-time)) (jabber-disco-advertise-feature jabber-time-xmlns) (defun jabber-return-time (jc xml-data) "Return client time as defined in XEP-0202. Sender and ID are determined from the incoming packet passed in XML-DATA. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((to (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id))) (jabber-send-iq jc to "result" `(time ((xmlns . ,jabber-time-xmlns)) (utc () ,(jabber-encode-time nil)) (tzo () ,(jabber-encode-timezone))) nil nil nil nil id))) (add-to-list 'jabber-iq-get-xmlns-alist (cons jabber-last-xmlns 'jabber-return-last)) (jabber-disco-advertise-feature jabber-last-xmlns) (defun jabber-return-last (jc xml-data) (let ((to (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id))) (jabber-send-iq jc to "result" `(time ((xmlns . ,jabber-last-xmlns) ;; XEP-0012 specifies that this is an integer. (seconds . ,(number-to-string (floor (jabber-autoaway-get-idle-time)))))) nil nil nil nil id))) (provide 'jabber-time) ;;; jabber-time.el ends hereemacs-jabber/lisp/jabber-truncate.el000066400000000000000000000063431516610113500177370ustar00rootroot00000000000000;;; jabber-truncate.el --- cleanup top lines in chatbuffers -*- lexical-binding: t; -*- ;; Copyright (C) 2007 - Kirill A. Korinskiy - catap@catap.ru ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'cl-lib) (require 'jabber-alert) (require 'ewoc) (defvar jabber-log-lines-to-keep 1000 "Maximum number of lines in chat buffer.") ;; Global reference declarations (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el (defvar jabber-chat--msg-nodes) ; jabber-chatbuffer.el ;; (defun jabber-truncate-top (buffer &optional ewoc) "Clean old history from a chat BUFFER. Optional EWOC is ewoc-widget to work. Default is `jabber-chat-ewoc'. `jabber-log-lines-to-keep' specifies the number of lines to keep. Note that this might interfere with `jabber-chat-display-more-backlog': you ask for more history, you get it, and then it just gets deleted." (interactive) (let* ((buffer-undo-list t) (inhibit-read-only t) (work-ewoc (if ewoc ewoc jabber-chat-ewoc)) (delete-before ;; go back one node, to make this function "idempotent" (ewoc-prev work-ewoc (ewoc-locate work-ewoc (with-current-buffer buffer (goto-char (point-max)) (forward-line (- jabber-log-lines-to-keep)) (point)))))) (while delete-before (let* ((data (ewoc-data delete-before)) (msg (and (listp data) (listp (cadr data)) (cadr data))) (id (and msg (plist-get msg :id)))) (when (and id jabber-chat--msg-nodes) (remhash id jabber-chat--msg-nodes))) (setq delete-before (prog1 (ewoc-prev work-ewoc delete-before) (ewoc-delete work-ewoc delete-before)))))) (defun jabber-truncate-muc (_nick _group buffer _text _proposed-alert) "Clean old history from MUC buffers. `jabber-log-lines-to-keep' specifies the number of lines to keep." (jabber-truncate-top buffer)) (defun jabber-truncate-chat (_from buffer _text _proposed-alert) "Clean old history from chat buffers. `jabber-log-lines-to-keep' specifies the number of lines to keep. Note that this might interfer with `jabber-chat-display-more-backlog': you ask for more history, you get it, and then it just gets deleted." (jabber-truncate-top buffer)) (provide 'jabber-truncate) ;;; jabber-truncate.el ends hereemacs-jabber/lisp/jabber-util.el000066400000000000000000001023051516610113500170620ustar00rootroot00000000000000;;; jabber-util.el --- various utility functions -*- coding: utf-8; lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2008, 2010 - Terechkov Evgenii - evg@altlinux.org ;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'cl-lib) (require 'jabber-xml) (require 'fsm) (require 'password-cache) (condition-case nil (require 'auth-source) (error nil)) (defvar jabber-jid-history nil "History of entered JIDs.") ;; Global reference declarations (declare-function auth-source-search "auth-source" (&rest spec)) (declare-function jabber-chat-with "jabber-chat.el" (jc jid &optional other-window)) (declare-function jabber-ahc-execute-command "jabber-ahc.el" (jc to node)) (declare-function jabber-get-register "jabber-register.el" (jc to)) (declare-function jabber-muc-read-my-nickname "jabber-muc.el" (jc group &optional default)) (declare-function jabber-muc-join "jabber-muc.el" (jc group nickname &optional popup)) (defvar jabber-delay-xmlns) ; jabber-xml.el (defvar jabber-delay-legacy-xmlns) ; jabber-xml.el (defvar jabber-stanzas-xmlns) ; jabber-xml.el ;; (defsubst jabber-read-with-input-method (prompt &optional initial-contents history default-value) "Like `read-string', but always inheriting the current input method." ;; Preserve input method when entering a minibuffer. (read-string prompt initial-contents history default-value t)) (defvar jabber-connections) (defun jabber-concat-rosters () "Concatenate the rosters of all connected accounts." (apply #'append (mapcar (lambda (jc) (plist-get (fsm-get-state-data jc) :roster)) jabber-connections))) (defun jabber-concat-rosters-full () "Concatenate the rosters of all connected accounts. Show full JIDs, with resources." (let ((jids (apply #'append (mapcar (lambda (jc) (plist-get (fsm-get-state-data jc) :roster)) jabber-connections)))) (apply #'append (mapcar (lambda (jid) (mapcar (lambda (res) (intern (format "%s/%s" jid (car res)))) (get (jabber-jid-symbol jid) 'resources))) jids)))) (defun jabber-connection-jid (jc) "Return the full JID of connection JC." (let ((sd (fsm-get-state-data jc))) (concat (plist-get sd :username) "@" (plist-get sd :server) "/" (plist-get sd :resource)))) (defun jabber-connection-bare-jid (jc) "Return the bare JID of connection JC." (let ((sd (fsm-get-state-data jc))) (concat (plist-get sd :username) "@" (plist-get sd :server)))) (defun jabber-connection-original-jid (jc) "Return the original JID of connection JC. The \"original JID\" is the JID we authenticated with. The server might subsequently assign us a different JID at resource binding." (plist-get (fsm-get-state-data jc) :original-jid)) (defun jabber-find-connection (bare-jid) "Find the connection to the account named by BARE-JID. Return nil if none found." (cl-dolist (jc jabber-connections) (when (string= bare-jid (jabber-connection-bare-jid jc)) (cl-return jc)))) (defun jabber-find-active-connection (dead-jc) "Find an active connection for dead connection DEAD-JC. Return nil if none found." (let ((jid (jabber-connection-bare-jid dead-jc))) (jabber-find-connection jid))) (defun jabber-jid-username (jid) "Return the username portion of JID, or nil if none found. JID must be a string." (when (string-match "\\(.*\\)@.*\\(/.*\\)?" jid) (match-string 1 jid))) (defun jabber-jid-user (jid) "Return the user portion (username@server) of JID. JID must be a string." ;;transports don't have @, so don't require it ;;(string-match ".*@[^/]*" jid) (string-match "[^/]*" jid) (match-string 0 jid)) (defun jabber-jid-server (jid) "Return the server portion of JID." (string-match "^\\(.*@\\)?\\([^@/]+\\)\\(/.*\\)?$" jid) (match-string 2 jid)) (defun jabber-jid-rostername (user) "Return the name of USER if present in roster, or nil." (let ((user (jabber-jid-symbol user))) (if (> (length (get user 'name)) 0) (get user 'name)))) (defun jabber-jid-displayname (string) "Return the name of the user from STRING as in roster, else username@server." (or (jabber-jid-rostername string) (jabber-jid-user (if (symbolp string) (symbol-name string) string)))) (defvar jabber-bookmarks) (defun jabber-jid-bookmarkname (string) "Return from STRING the conference name from bookmarks or displayname. Use the name according to roster or else the JID if none set." (require 'jabber-bookmarks) (or (cl-block nil (maphash (lambda (_account bookmarks) (dolist (bm bookmarks) (when (string= (plist-get bm :jid) string) (cl-return (plist-get bm :name))))) jabber-bookmarks)) (jabber-jid-displayname string))) (defun jabber-jid-resource (jid) "Return the resource portion of a JID, or nil if there is none. JID must be a string." (when (string-match "^\\(\\([^/]*@\\)?[^/]*\\)/\\(.*\\)" jid) (match-string 3 jid))) (defvar jabber-jid-obarray) (defun jabber-jid-symbol (jid) "Return the symbol for JID, which must be a symbol or a string." ;; If it's already a symbol, just return it. (if (symbolp jid) jid ;; XXX: "downcase" is a poor man's nodeprep. See XMPP CORE. (intern (downcase (jabber-jid-user jid)) jabber-jid-obarray))) (defvar jabber-account-list) (defun jabber-my-jid-p (jc jid) "Return non-nil if the specified JID is in the `jabber-account-list'. Comment: (modulo resource). Also return non-nil if JID matches JC, modulo resource." (or (equal (jabber-jid-user jid) (jabber-connection-bare-jid jc)) (member (jabber-jid-user jid) (mapcar (lambda (x) (jabber-jid-user (car x))) jabber-account-list)))) (defcustom jabber-jid-completion-display 'jid "What to show as the primary completion candidate for JID prompts. Both modes match against JID and display name; this only controls which is shown as the candidate and which as the annotation. `jid' shows JIDs with display names as annotations. `name' shows display names with JIDs as annotations. Contacts without a display name always show as bare JIDs." :type '(choice (const :tag "JID (annotated with name)" jid) (const :tag "Display name (annotated with JID)" name)) :group 'jabber) (defun jabber--jid-completion-table (roster-items) "Build a completion table from ROSTER-ITEMS. Returns an alist of (CANDIDATE . SYMBOL) pairs, where CANDIDATE is either a JID or display name depending on `jabber-jid-completion-display'." (let ((use-names (eq jabber-jid-completion-display 'name))) (mapcar (lambda (item) (let ((jid (symbol-name item)) (name (get item 'name))) (cons (if (and use-names name) name jid) item))) roster-items))) (defun jabber--jid-completion-with-metadata (table) "Wrap TABLE as a completion table matching both JIDs and names. Candidates follow `jabber-jid-completion-display'; the other form is shown as an annotation. Both are matchable regardless of mode." (let ((alt-to-candidate (make-hash-table :test 'equal)) (use-names (eq jabber-jid-completion-display 'name))) ;; Build reverse lookup: alternate form -> candidate string. (dolist (entry table) (let* ((candidate (car entry)) (sym (cdr entry)) (jid (symbol-name sym)) (name (get sym 'name)) (alt (if use-names jid name))) (when (and alt (not (string= alt candidate))) (puthash (downcase alt) candidate alt-to-candidate)))) (lambda (string pred action) (cond ((eq action 'metadata) `(metadata (annotation-function . ,(lambda (candidate) (when-let* ((sym (cdr (assoc-string candidate table t)))) (let* ((jid (symbol-name sym)) (name (get sym 'name)) (ann (if use-names jid name))) (when (and ann (not (string= ann candidate))) (propertize (concat " " ann) 'face 'completions-annotations)))))))) ;; all-completions: match by candidate or alternate form. ((eq action t) (let ((matches (all-completions string table pred)) (down (downcase string))) (maphash (lambda (alt candidate) (when (and (string-prefix-p down alt) (not (member candidate matches)) (or (null pred) (funcall pred candidate))) (push candidate matches))) alt-to-candidate) matches)) ;; test-completion: accept exact alternate form matches. ((eq action 'lambda) (or (test-completion string table pred) (and (gethash (downcase string) alt-to-candidate) t))) (t (complete-with-action action table string pred)))))) (declare-function jabber-muc-joined-p "jabber-muc.el" (group &optional jc)) (defun jabber-read-jid-completing (prompt &optional subset require-match default resource fulljids) "Read a jid out of the current roster from the minibuffer. If SUBSET is non-nil, it should be a list of symbols from which the JID is to be selected, instead of using the entire roster. If REQUIRE-MATCH is non-nil, the JID must be in the list used. If DEFAULT is non-nil, it's used as the default value, otherwise the default is inferred from context. RESOURCE is one of the following: nil Accept full or bare JID, as entered full Turn bare JIDs to full ones with highest-priority resource bare-or-muc Turn full JIDs to bare ones, except for in MUC If FULLJIDS is non-nil, complete jids with resources." (let* ((roster-items (or subset (funcall (if fulljids 'jabber-concat-rosters-full 'jabber-concat-rosters)))) (jid-completion-table (jabber--jid-completion-table roster-items)) (completion-ignore-case t) (jid-at-point (or (and default (if (symbolp default) (symbol-name default) default)) (let* ((jid (get-text-property (point) 'jabber-jid)) (res (get (jabber-jid-symbol jid) 'resource))) (when jid (if (and fulljids res (not (jabber-jid-resource jid))) (format "%s/%s" jid res) jid))) (bound-and-true-p jabber-chatting-with) (bound-and-true-p jabber-group))) chosen) ;; Convert default to display form when using name mode. (when (and jid-at-point (eq jabber-jid-completion-display 'name)) (let ((sym (cdr (assoc-string jid-at-point jid-completion-table t)))) (unless sym ;; Default is a JID but table has names; find by symbol. (setq sym (jabber-jid-symbol jid-at-point))) (when (and sym (get sym 'name)) (setq jid-at-point (get sym 'name))))) ;; If the default is not in the allowed subset, it's not a good default. (when (and subset (not (assoc jid-at-point jid-completion-table))) (setq jid-at-point nil)) (let ((input (completing-read (concat prompt (if jid-at-point (format "(default %s) " jid-at-point))) (jabber--jid-completion-with-metadata jid-completion-table) nil require-match nil 'jabber-jid-history jid-at-point))) (setq chosen (if (and input (assoc-string input jid-completion-table t)) (symbol-name (cdr (assoc-string input jid-completion-table t))) (and (not (zerop (length input))) input)))) (when chosen (pcase resource ('full ;; If JID is bare, add the highest-priority resource. (if (jabber-jid-resource chosen) chosen (let ((highest-resource (get (jabber-jid-symbol chosen) 'resource))) (if highest-resource (concat chosen "/" highest-resource) chosen)))) ('bare-or-muc ;; If JID is full and non-MUC, remove resource. (if (null (jabber-jid-resource chosen)) chosen (let ((bare (jabber-jid-user chosen))) (if (jabber-muc-joined-p bare) chosen bare)))) (_ chosen))))) (defun jabber-read-node (prompt) "Read node name, taking default from disco item at point." (let ((node-at-point (get-text-property (point) 'jabber-node))) (read-string (concat prompt (if node-at-point (format "(default %s) " node-at-point))) node-at-point))) (defun jabber-password-key (bare-jid) "Construct key for `password' library from BARE-JID." (concat "xmpp:" bare-jid)) (defun jabber-read-password (bare-jid) "Read Jabber password from minibuffer." (let ((found (nth 0 (auth-source-search :user (jabber-jid-username bare-jid) :host (jabber-jid-server bare-jid) :port "xmpp" :max 1 :require '(:secret))))) (if found (let ((secret (plist-get found :secret))) (copy-sequence (if (functionp secret) (funcall secret) secret))) (let ((prompt (format "Jabber password for %s: " bare-jid))) ;; Need to copy the password, as sasl.el wants to erase it. (copy-sequence (password-read prompt (jabber-password-key bare-jid))))))) (defun jabber-cache-password (bare-jid password) "Cache PASSWORD for BARE-JID." (password-cache-add (jabber-password-key bare-jid) password)) (defun jabber-uncache-password (bare-jid) "Uncache cached password for BARE-JID. Useful if the password proved to be wrong." (interactive (list (jabber-jid-user (completing-read "Forget password of account: " jabber-account-list nil nil nil 'jabber-account-history)))) (password-cache-remove (jabber-password-key bare-jid))) (defvar jabber-buffer-connection) (defun jabber-read-account (&optional always-ask contact-hint) "Ask for which connected account to use. If ALWAYS-ASK is nil and there is only one account, return that account. If CONTACT-HINT is a string or a JID symbol, default to an account that has that contact in its roster." (let ((completions (mapcar (lambda (c) (cons (jabber-connection-bare-jid c) c)) jabber-connections))) (cond ((null jabber-connections) (error "Not connected to Jabber")) ((and (null (cdr jabber-connections)) (not always-ask)) ;; only one account (car jabber-connections)) (t (or ;; if there is a jabber-account property at point, ;; present it as default value (cdr (assoc (let ((at-point (get-text-property (point) 'jabber-account))) (when (and at-point (memq at-point jabber-connections)) (jabber-connection-bare-jid at-point))) completions)) (let* ((default (or (and contact-hint (setq contact-hint (jabber-jid-symbol contact-hint)) (let ((matching (cl-find-if (lambda (jc) (memq contact-hint (plist-get (fsm-get-state-data jc) :roster))) jabber-connections))) (when matching (jabber-connection-bare-jid matching)))) ;; if the buffer is associated with a connection, use it (when (and jabber-buffer-connection (jabber-find-active-connection jabber-buffer-connection)) (jabber-connection-bare-jid jabber-buffer-connection)) ;; else, use the first connection in the list (caar completions))) (input (completing-read (concat "Select Jabber account (default " default "): ") completions nil t nil 'jabber-account-history default))) (cdr (assoc input completions)))))))) (defun jabber-iq-query (xml-data) "Return the query part of an IQ stanza. An IQ stanza may have zero or one query child, and zero or one child. The query child is often but not always . XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let (query) (dolist (x (jabber-xml-node-children xml-data)) (if (and (listp x) (not (eq (jabber-xml-node-name x) 'error))) (setq query x))) query)) (defun jabber-iq-error (xml-data) "Return the part of an IQ stanza, if any. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (car (jabber-xml-get-children xml-data 'error))) (defun jabber-iq-xmlns (xml-data) "Return the namespace of an IQ stanza, i.e. the namespace of its query part. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (jabber-xml-get-attribute (jabber-iq-query xml-data) 'xmlns)) (defun jabber-message-timestamp (xml-data) "Given a element, return its timestamp, or nil if none. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." ;; Since Emacs 27.1, timestamps may be represented by a cons ;; consisting of two integers. :rare-time EWOC entries consist of ;; just a timestamp, detect those timestamps and return them ;; directly. (if (integerp (cdr xml-data)) (time-convert xml-data 'list) (jabber-x-delay (or (jabber-xml-path xml-data `((,jabber-delay-xmlns . "delay"))) (jabber-xml-path xml-data `((,jabber-delay-legacy-xmlns . "x"))))))) (defun jabber-x-delay (xml-data) "Return timestamp given a delayed delivery element. This can be either a tag in namespace urn:xmpp:delay (XEP-0203), or a tag in namespace jabber:x:delay (XEP-0091). Return nil if no such data available. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (cond ((and (eq (jabber-xml-node-name xml-data) 'x) (string= (jabber-xml-get-attribute xml-data 'xmlns) jabber-delay-legacy-xmlns)) (let ((stamp (jabber-xml-get-attribute xml-data 'stamp))) (if (and (stringp stamp) (= (length stamp) 17)) (jabber-parse-legacy-time stamp)))) ((and (eq (jabber-xml-node-name xml-data) 'delay) (string= (jabber-xml-get-attribute xml-data 'xmlns) jabber-delay-xmlns)) (let ((stamp (jabber-xml-get-attribute xml-data 'stamp))) (when (stringp stamp) (jabber-parse-time stamp)))))) (defun jabber-parse-legacy-time (timestamp) "Parse timestamp in ccyymmddThh:mm:ss format (UTC) and return as internal time value." (let ((year (string-to-number (substring timestamp 0 4))) (month (string-to-number (substring timestamp 4 6))) (day (string-to-number (substring timestamp 6 8))) (hour (string-to-number (substring timestamp 9 11))) (minute (string-to-number (substring timestamp 12 14))) (second (string-to-number (substring timestamp 15 17)))) (encode-time (list second minute hour day month year nil -1 nil)))) (defun jabber-encode-legacy-time (timestamp) "Parse TIMESTAMP as internal time value and encode as ccyymmddThh:mm:ss (UTC)." (format-time-string "%Y%m%dT%H:%M:%S" timestamp t)) (defun jabber-encode-time (time) "Convert TIME to a string by XEP-0082. TIME is in a format accepted by `format-time-string'." (format-time-string "%Y-%m-%dT%H:%M:%SZ" time t)) (defun jabber-encode-timezone () (let ((time-zone-offset (nth 0 (current-time-zone)))) (if (null time-zone-offset) "Z" (let* ((positivep (>= time-zone-offset 0)) (hours (/ (abs time-zone-offset) 3600)) (minutes (/ (% (abs time-zone-offset) 3600) 60))) (format "%s%02d:%02d"(if positivep "+" "-") hours minutes))))) (defun jabber-parse-time (raw-time) "Parse the DateTime encoded in TIME according to XEP-0082." (let* ((time (if (string= (substring raw-time 4 5) "-") raw-time (concat (substring raw-time 0 4) "-" (substring raw-time 4 6) "-" (substring raw-time 6 (length raw-time))))) (year (string-to-number (substring time 0 4))) (month (string-to-number (substring time 5 7))) (day (string-to-number (substring time 8 10))) (hour (string-to-number (substring time 11 13))) (minute (string-to-number (substring time 14 16))) (tail (substring time 17)) (tz (string-match "[Z+-]" tail)) (second (string-to-number (substring tail 0 tz))) (timezone (if tz (substring tail tz) "Z"))) ;; timezone is either Z (UTC) or [+-]HH:MM (let ((timezone-seconds (if (string= timezone "Z") 0 (* (if (eq (aref timezone 0) ?+) 1 -1) (* 60 (+ (* 60 (string-to-number (substring timezone 1 3))) (string-to-number (substring timezone 4 6)))))))) (encode-time (list second minute hour day month year nil -1 timezone-seconds))))) (defun jabber-report-success (_jc xml-data context) "IQ callback reporting success or failure of the operation. CONTEXT is a string describing the action. \"CONTEXT succeeded\" or \"CONTEXT failed: REASON\" is displayed in the echo area. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((type (jabber-xml-get-attribute xml-data 'type))) (message (concat context (if (string= type "result") " succeeded" (concat " failed: " (let ((the-error (jabber-iq-error xml-data))) (if the-error (jabber-parse-error the-error) "No error message given")))))))) (defconst jabber-error-messages (list (cons 'bad-request "Bad request") (cons 'conflict "Conflict") (cons 'feature-not-implemented "Feature not implemented") (cons 'forbidden "Forbidden") (cons 'gone "Gone") (cons 'internal-server-error "Internal server error") (cons 'item-not-found "Item not found") (cons 'jid-malformed "JID malformed") (cons 'not-acceptable "Not acceptable") (cons 'not-allowed "Not allowed") (cons 'not-authorized "Not authorized") (cons 'payment-required "Payment required") (cons 'recipient-unavailable "Recipient unavailable") (cons 'redirect "Redirect") (cons 'registration-required "Registration required") (cons 'remote-server-not-found "Remote server not found") (cons 'remote-server-timeout "Remote server timeout") (cons 'resource-constraint "Resource constraint") (cons 'service-unavailable "Service unavailable") (cons 'subscription-required "Subscription required") (cons 'undefined-condition "Undefined condition") (cons 'unexpected-request "Unexpected request")) "String descriptions of XMPP stanza errors.") (defconst jabber-legacy-error-messages (list (cons 302 "Redirect") (cons 400 "Bad request") (cons 401 "Unauthorized") (cons 402 "Payment required") (cons 403 "Forbidden") (cons 404 "Not found") (cons 405 "Not allowed") (cons 406 "Not acceptable") (cons 407 "Registration required") (cons 408 "Request timeout") (cons 409 "Conflict") (cons 500 "Internal server error") (cons 501 "Not implemented") (cons 502 "Remote server error") (cons 503 "Service unavailable") (cons 504 "Remote server timeout") (cons 510 "Disconnected")) "String descriptions of legacy errors (XEP-0086).") (defun jabber-parse-error (error-xml) "Parse the given tag and return a string fit for human consumption. See secton 9.3, Stanza Errors, of XMPP Core, and XEP-0086, Legacy Errors." (let ((error-type (jabber-xml-get-attribute error-xml 'type)) (error-code (jabber-xml-get-attribute error-xml 'code)) condition text) (if error-type ;; If the tag has a type element, it is new-school. (dolist (child (jabber-xml-node-children error-xml)) (when (string= (jabber-xml-get-attribute child 'xmlns) jabber-stanzas-xmlns) (if (eq (jabber-xml-node-name child) 'text) (setq text (car (jabber-xml-node-children child))) (setq condition (or (cdr (assq (jabber-xml-node-name child) jabber-error-messages)) (symbol-name (jabber-xml-node-name child))))))) (setq condition (or (cdr (assq (string-to-number error-code) jabber-legacy-error-messages)) error-code)) (setq text (car (jabber-xml-node-children error-xml)))) (concat condition (if text (format ": %s" text))))) (defun jabber-error-condition (error-xml) "Parse the given tag and return the condition symbol." (catch 'condition (dolist (child (jabber-xml-node-children error-xml)) (when (string= (jabber-xml-get-attribute child 'xmlns) jabber-stanzas-xmlns) (throw 'condition (jabber-xml-node-name child)))))) (defvar jabber-stream-error-messages (list (cons 'bad-format "Bad XML format") (cons 'bad-namespace-prefix "Bad namespace prefix") (cons 'conflict "Conflict") (cons 'connection-timeout "Connection timeout") (cons 'host-gone "Host gone") (cons 'host-unknown "Host unknown") (cons 'improper-addressing "Improper addressing") ; actually only s2s (cons 'internal-server-error "Internal server error") (cons 'invalid-from "Invalid from") (cons 'invalid-id "Invalid id") (cons 'invalid-namespace "Invalid namespace") (cons 'invalid-xml "Invalid XML") (cons 'not-authorized "Not authorized") (cons 'policy-violation "Policy violation") (cons 'remote-connection-failed "Remote connection failed") (cons 'resource-constraint "Resource constraint") (cons 'restricted-xml "Restricted XML") (cons 'see-other-host "See other host") (cons 'system-shutdown "System shutdown") (cons 'undefined-condition "Undefined condition") (cons 'unsupported-encoding "Unsupported encoding") (cons 'unsupported-stanza-type "Unsupported stanza type") (cons 'unsupported-version "Unsupported version") (cons 'xml-not-well-formed "XML not well formed")) "String descriptions of XMPP stream errors.") (defun jabber-stream-error-condition (error-xml) "Return the condition of a tag." ;; as we don't know the node name of the condition, we have to ;; search for it. (cl-dolist (node (jabber-xml-node-children error-xml)) (when (and (string= (jabber-xml-get-attribute node 'xmlns) "urn:ietf:params:xml:ns:xmpp-streams") (assq (jabber-xml-node-name node) jabber-stream-error-messages)) (cl-return (jabber-xml-node-name node))))) (defun jabber-parse-stream-error (error-xml) "Parse the given error tag and return a string fit for human consumption. ERROR-XML is a tag parsed with `xml-parse-region'." (let ((text-node (car (jabber-xml-get-children error-xml 'text))) (condition (jabber-stream-error-condition error-xml))) (concat (if condition (cdr (assq condition jabber-stream-error-messages)) "Unknown stream error") (if (and text-node (stringp (car (jabber-xml-node-children text-node)))) (concat ": " (car (jabber-xml-node-children text-node))))))) (put 'jabber-error 'error-conditions '(error jabber-error)) (put 'jabber-error 'error-message "Jabber error") ;; https://www.rfc-editor.org/rfc/rfc6120.html#section-8.3 explains ;; that there are stanza errors, which are recoverable and do not ;; terminate the stream. ;; Each stanza has a type which are the one explained at the ;; ERROR-TYPE parameter. checkdoc throws warnings stating that errors ;; messages should start with capital letters, thus the `downcase' ;; function is used as a workaround. (defun jabber-signal-error (error-type condition &optional text app-specific) "Signal an error to be sent by Jabber. ERROR-TYPE is one of \"Cancel\", \"Continue\", \"Mmodify\", \"Auth\" and \"Wait\" (lowercase versions make `checkdoc' to throw errors). CONDITION is a symbol denoting a defined XMPP condition. TEXT is a string to be sent in the error message, or nil for no text. APP-SPECIFIC is a list of extra XML tags. See section 9.3 of XMPP Core (RFC 3920). See section 8.3 of XMPP Core (RFC 6120)." (signal 'jabber-error (list (downcase error-type) condition text app-specific))) (defun jabber-unhex (string) "Convert a hex-encoded UTF-8 string to Emacs representation. For example, \"ji%C5%99i@%C4%8Dechy.example/v%20Praze\" becomes \"jiři@čechy.example/v Praze\"." (decode-coding-string (url-unhex-string string) 'utf-8)) (defun jabber-handle-uri (uri &rest _ignored-args) "Handle XMPP links according to draft-saintandre-xmpp-iri-04. See Info node `(jabber)XMPP URIs'. URI is a string with the \"xmpp://\" link to handle. IGNORED-ARGS are ignored arguments the handler may pass. " (interactive "sEnter XMPP URI: ") (when (string-match "//" uri) (error "URIs with authority part are not supported")) ;; This regexp handles three cases: ;; xmpp:romeo@montague.net ;; xmpp:romeo@montague.net?roster ;; xmpp:romeo@montague.net?roster;name=Romeo%20Montague;group=Lovers (unless (string-match "^xmpp:\\([^?]+\\)\\(\\?\\([a-z]+\\)\\(;\\(.*\\)\\)?\\)?" uri) (error "Invalid XMPP URI '%s'" uri)) ;; We start by raising the Emacs frame. (raise-frame) (let ((jid (jabber-unhex (match-string 1 uri))) (method (match-string 3 uri)) (args (let ((text (match-string 5 uri))) ;; If there are arguments... (when text ;; ...split the pairs by ';'... (let ((pairs (split-string text ";"))) (mapcar (lambda (pair) ;; ...and split keys from values by '='. (pcase-let ((`(,key ,value) (split-string pair "="))) ;; Values can be hex-coded. (cons key (jabber-unhex value)))) pairs)))))) ;; The full list of methods is at ;; . (cond ;; Join an MUC. ((string= method "join") (let ((account (jabber-read-account))) (jabber-muc-join account jid (jabber-muc-read-my-nickname account jid) t))) ;; Register with a service. ((string= method "register") (jabber-get-register (jabber-read-account) jid)) ;; Run an ad-hoc command ((string= method "command") ;; XXX: does the 'action' attribute make sense? (jabber-ahc-execute-command (jabber-read-account) jid (cdr (assoc "node" args)))) ;; Everything else: open a chat buffer. (t (jabber-chat-with (jabber-read-account) jid))))) (defun url-xmpp (url) "Handle XMPP URLs from internal Emacs functions." ;; XXX: This parsing roundtrip is redundant, and the parser of the ;; url package might lose information. (jabber-handle-uri (url-recreate-url url))) (defun string>-numerical (s1 s2) "Return t if first arg string is more than second in numerical order." (cond ((string= s1 s2) nil) ((> (length s1) (length s2)) t) ((< (length s1) (length s2)) nil) ((< (string-to-number (substring s1 0 1)) (string-to-number (substring s2 0 1))) nil) ((> (string-to-number (substring s1 0 1)) (string-to-number (substring s2 0 1))) t) (t (string>-numerical (substring s1 1) (substring s2 1))))) (defun jabber-append-string-to-file (string file &optional func &rest args) "Append STRING (may be nil) to FILE. Create FILE if needed. If FUNC is non-nil, then call FUNC with ARGS at beginning of temporaly buffer _before_ inserting STRING." (when (or (stringp string) (functionp func)) (with-temp-buffer (when (functionp func) (apply func args)) (when (stringp string) (insert string)) (write-region (point-min) (point-max) file t (list t))))) (defun jabber-tree-map (fn tree) "Apply FN to all nodes in the TREE starting with root. FN is applied to the node and not to the data itself." (let ((result (cons nil nil))) (cl-do ((tail tree (cdr tail)) (prev result end) (end result (let* ((x (car tail)) (val (if (atom x) (funcall fn x) (jabber-tree-map fn x)))) (setf (car end) val (cdr end) (cons nil nil))))) ((atom tail) (progn (setf (cdr prev) (if tail (funcall fn tail) nil)) result))))) (defface jabber-separator '((((background light)) :strike-through "gray70" :foreground "gray70") (t :strike-through "gray30" :foreground "gray30")) "Face for separator lines in jabber buffers." :group 'jabber) (defun jabber-separator () "Return a propertized separator string. Uses a `display' property so the separator adjusts to window width on redisplay." (propertize " " 'display '(space :width text) 'face 'jabber-separator)) (provide 'jabber-util) ;;; jabber-util.el ends here emacs-jabber/lisp/jabber-vcard-avatars.el000066400000000000000000000133251516610113500206460ustar00rootroot00000000000000;;; jabber-vcard-avatars.el --- Avatars by JEP-0153 -*- lexical-binding: t; -*- ;; Copyright (C) 2006, 2007, 2008 Magnus Henoch ;; Copyright (C) 2026 Thanos Apollo ;; Author: Magnus Henoch ;; Maintainer: Thanos Apollo ;; This file 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, or (at your option) ;; any later version. ;; This file 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 GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; ;;; Code: (require 'jabber-util) (require 'jabber-xml) (require 'jabber-vcard) (require 'jabber-presence) (require 'jabber-iq) (require 'jabber-avatar) (defvar jabber-vcard-xmlns) ; jabber-vcard.el (declare-function jabber-muc-presence-p "jabber-muc" (xml-data)) (defconst jabber-vcard-update-xmlns "vcard-temp:x:update" "XEP-0153 vCard-based avatars namespace.") (defcustom jabber-vcard-avatars-retrieve (display-images-p) "Automatically download vCard avatars?" :group 'jabber-avatar :type 'boolean) (defcustom jabber-vcard-avatars-publish t "Publish your vCard photo as avatar?" :group 'jabber-avatar :type 'boolean) (defvar jabber-vcard-avatars-current-hash (make-hash-table :test 'equal) "For each connection, SHA1 hash of current avatar. Keys are full JIDs.") (with-eval-after-load "jabber-core" (jabber-chain-add 'jabber-presence-chain #'jabber-vcard-avatars-presence 20)) (defun jabber-vcard-avatars-presence (jc xml-data) "Look for vCard avatar mark in stanza. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." ;; Only look at ordinary, non-MUC presence. MUC presences use ;; occupant JIDs (room@server/nick) which are useless for vCard ;; fetches, and a large room would flood the connection with IQs. (when (and jabber-vcard-avatars-retrieve (null (jabber-xml-get-attribute xml-data 'type)) (not (jabber-muc-presence-p xml-data))) (let* ((from (jabber-jid-user (jabber-xml-get-attribute xml-data 'from))) (photo (jabber-xml-path xml-data `((,jabber-vcard-update-xmlns . "x") photo))) (sha1-hash (car (jabber-xml-node-children photo)))) (cond ((null sha1-hash) ;; User has removed avatar (jabber-avatar-set from nil)) ((string= sha1-hash (get (jabber-jid-symbol from) 'avatar-hash)) ;; Same avatar as before; do nothing ) ((jabber-avatar-find-cached sha1-hash) ;; Avatar is cached (jabber-avatar-set from sha1-hash)) (t ;; Avatar is not cached; retrieve it (jabber-vcard-avatars-fetch jc from sha1-hash)))))) (defun jabber-vcard-avatars-fetch (jc jid sha1-hash) "Fetch vCard for JID and extract the avatar. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Fetch whose vCard avatar: ") nil)) (jabber-send-iq jc jid "get" `(vCard ((xmlns . ,jabber-vcard-xmlns))) #'jabber-vcard-avatars-vcard (cons jid sha1-hash) #'ignore nil)) (defun jabber-vcard-avatars-vcard (_jc iq closure) "Get the photo from the vCard, and set the avatar." (let ((from (car closure)) (sha1-hash (cdr closure)) (photo (assq 'PHOTO (jabber-vcard-parse (jabber-iq-query iq))))) (if photo (let ((avatar (jabber-avatar-from-base64-string (nth 2 photo) (nth 1 photo)))) (unless (or (null sha1-hash) (string= sha1-hash (avatar-sha1-sum avatar))) (when jabber-avatar-verbose (message "%s's avatar should have SHA1 sum %s, but has %s" (jabber-jid-displayname from) sha1-hash (avatar-sha1-sum avatar)))) (jabber-avatar-cache avatar) (jabber-avatar-set from avatar)) (jabber-avatar-set from nil)))) (defun jabber-vcard-avatars-find-current (jc) "Request our own vCard, to find hash of avatar. JC is the Jabber connection." (when jabber-vcard-avatars-publish (jabber-send-iq jc nil "get" `(vCard ((xmlns . ,jabber-vcard-xmlns))) #'jabber-vcard-avatars-find-current-1 t #'jabber-vcard-avatars-find-current-1 nil))) (defun jabber-vcard-avatars-find-current-1 (jc xml-data success) (jabber-vcard-avatars-update-current jc (and success (let ((photo (assq 'PHOTO (jabber-vcard-parse (jabber-iq-query xml-data))))) (when photo (let ((avatar (jabber-avatar-from-base64-string (nth 2 photo) (nth 1 photo)))) (avatar-sha1-sum avatar))))))) (defun jabber-vcard-avatars-update-current (jc new-hash) (let ((old-hash (gethash (jabber-connection-bare-jid jc) jabber-vcard-avatars-current-hash))) (unless (equal old-hash new-hash) (puthash (jabber-connection-bare-jid jc) new-hash jabber-vcard-avatars-current-hash) (jabber-send-current-presence jc)))) (add-to-list 'jabber-presence-element-functions 'jabber-vcard-avatars-presence-element) (defun jabber-vcard-avatars-presence-element (jc) (when jabber-vcard-avatars-publish (let ((hash (gethash (jabber-connection-bare-jid jc) jabber-vcard-avatars-current-hash))) (list `(x ((xmlns . ,jabber-vcard-update-xmlns)) ;; if "not yet ready to advertise image", don't. ;; that is, we haven't yet checked what avatar we have. ,(when hash `(photo () ,hash))))))) (provide 'jabber-vcard-avatars) ;;; jabber-vcard-avatars.el ends hereemacs-jabber/lisp/jabber-vcard.el000066400000000000000000000446311516610113500172130ustar00rootroot00000000000000;;; jabber-vcard.el --- vcards according to JEP-0054 -*- lexical-binding: t; -*- ;; Copyright (C) 2005, 2007 Magnus Henoch ;; Copyright (C) 2026 Thanos Apollo ;; Author: Magnus Henoch ;; Maintainer: Thanos Apollo ;; 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, 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 GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: ;; There are great variations in Jabber vcard implementations. This ;; one adds some spice to the mix, while trying to follow the JEP ;; closely. ;; Fields not implemented: GEO, LOGO, AGENT, ORG, CATEGORIES, SOUND, ;; CLASS, KEY. ;; The internal data structure used for vCards is an alist. All ;; keys are uppercase symbols. ;; ;; FN, NICKNAME, BDAY, JABBERID, MAILER, TZ, TITLE, ROLE, NOTE, ;; PRODID, REV, SORT-STRING, UID, URL, DESC: ;; Value is a string. ;; ;; N: ;; Value is an alist, with keys FAMILY, GIVEN, MIDDLE, PREFIX and SUFFIX. ;; ;; ADR: ;; Value is a list, each element representing a separate address. ;; The car of each address is a list of types; possible values are ;; HOME, WORK, POSTAL, PARCEL, DOM, INTL, PREF. ;; The cdr of each address is an alist, with keys POBOX, EXTADD, ;; STREET, LOCALITY, REGION, PCODE, CTRY, and values being strings. ;; ;; TEL: ;; Value is a list, each element representing a separate phone number. ;; The car of each number is a list of types; possible values are ;; HOME, WORK, VOICE, FAX, PAGER, MSG, CELL, VIDEO, BBS, MODEM, ISDN, ;; PCS, PREF ;; The cdr is the phone number as a string. ;; ;; EMAIL: ;; Value is a list, each element representing a separate e-mail address. ;; The car of each address is a list of types; possible values are ;; HOME, WORK, INTERNET, PREF, X400. At least one of INTERNET and ;; X400 is always present. ;; The cdr is the address as a string. ;;; Code: (require 'jabber-core) (require 'jabber-widget) (require 'jabber-iq) (require 'jabber-avatar) (defconst jabber-vcard-xmlns "vcard-temp" "XEP-0054 vCard namespace.") (defvar-local jabber-vcard-photo nil "The avatar structure for the photo in the vCard edit buffer.") ;; Global reference declarations (declare-function jabber-vcard-avatars-update-current "jabber-vcard-avatars.el" (jc new-hash)) (declare-function jabber-image-create "jabber-image" (data &optional mime-type max-width max-height)) (defvar jabber-vcard-fields) ; jabber-vcard.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el ;; (defun jabber-vcard-parse (vcard) "Parse the vCard XML structure given in VCARD. The top node should be the `vCard' node." ;; Hm... stpeter has a as top node... ;;(unless (eq (jabber-xml-node-name vcard) 'vCard) ;; (error "Invalid vCard")) (let (result) (dolist (verbatim-node '(FN NICKNAME BDAY JABBERID MAILER TZ TITLE ROLE NOTE PRODID REV SORT-STRING UID URL DESC)) ;; There should only be one of each of these. They are ;; used verbatim. (let ((node (car (jabber-xml-get-children vcard verbatim-node)))) ;; Some clients include the node, but without data (when (car (jabber-xml-node-children node)) (push (cons (jabber-xml-node-name node) (car (jabber-xml-node-children node))) result)))) ;; Name components (let ((node (car (jabber-xml-get-children vcard 'N)))) ;; Subnodes are FAMILY, GIVEN, MIDDLE, PREFIX, SUFFIX (push (cons 'N (let (name) (dolist (subnode (jabber-xml-node-children node)) (when (and (memq (jabber-xml-node-name subnode) '(FAMILY GIVEN MIDDLE PREFIX SUFFIX)) (not (zerop (length (car (jabber-xml-node-children subnode)))))) (push (cons (jabber-xml-node-name subnode) (car (jabber-xml-node-children subnode))) name))) name)) result)) ;; There can be several addresses (let (addresses) (dolist (adr (jabber-xml-get-children vcard 'ADR)) ;; Find address type(s) (let (types) (dolist (possible-type '(HOME WORK POSTAL PARCEL DOM INTL PREF)) (when (jabber-xml-get-children adr possible-type) (push possible-type types))) (let (components) (dolist (component (jabber-xml-node-children adr)) (when (and (memq (jabber-xml-node-name component) '(POBOX EXTADD STREET LOCALITY REGION PCODE CTRY)) (not (zerop (length (car (jabber-xml-node-children component)))))) (push (cons (jabber-xml-node-name component) (car (jabber-xml-node-children component))) components))) (push (cons types components) addresses)))) (when addresses (push (cons 'ADR addresses) result))) ;; Likewise for phone numbers (let (phone-numbers) (dolist (tel (jabber-xml-get-children vcard 'TEL)) ;; Find phone type(s) (let ((number (car (jabber-xml-node-children (car (jabber-xml-get-children tel 'NUMBER))))) types) ;; Some clients put no NUMBER node. Avoid that. (when number (dolist (possible-type '(HOME WORK VOICE FAX PAGER MSG CELL VIDEO BBS MODEM ISDN PCS PREF)) (when (jabber-xml-get-children tel possible-type) (push possible-type types))) (push (cons types number) phone-numbers)))) (when phone-numbers (push (cons 'TEL phone-numbers) result))) ;; And for e-mail addresses (let (e-mails) (dolist (email (jabber-xml-get-children vcard 'EMAIL)) (let ((userid (car (jabber-xml-node-children (car (jabber-xml-get-children email 'USERID))))) types) ;; Some clients put no USERID node. Avoid that. (when userid (dolist (possible-type '(HOME WORK INTERNET PREF X400)) (when (jabber-xml-get-children email possible-type) (push possible-type types))) (unless (or (memq 'INTERNET types) (memq 'X400 types)) (push 'INTERNET types)) (push (cons types userid) e-mails)))) (when e-mails (push (cons 'EMAIL e-mails) result))) ;; XEP-0153: vCard-based avatars (let ((photo-tag (car (jabber-xml-get-children vcard 'PHOTO)))) (when photo-tag (let ((type (jabber-xml-path photo-tag '(TYPE ""))) (binval (jabber-xml-path photo-tag '(BINVAL "")))) (when (and type binval) (push (list 'PHOTO type binval) result))))) result)) (defun jabber-vcard-reassemble (parsed) "Create a vCard XML structure from PARSED." ;; Save photo in jabber-vcard-photo, to avoid excessive processing. (let ((photo (cdr (assq 'PHOTO parsed)))) (cond ;; No photo ((null photo) (setq jabber-vcard-photo nil)) ;; Existing photo ((listp photo) (setq jabber-vcard-photo (jabber-avatar-from-base64-string (nth 1 photo) (nth 0 photo)))) ;; New photo from file (t (access-file photo "Avatar file not found") ;; Maximum allowed size is 8 kilobytes (when (> (nth 7 (file-attributes photo)) 8192) (error "Avatar bigger than 8 kilobytes")) (setq jabber-vcard-photo (jabber-avatar-from-file photo))))) `(vCard ((xmlns . ,jabber-vcard-xmlns)) ;; Put in simple fields ,@(mapcar (lambda (field) (when (and (assq (car field) jabber-vcard-fields) (not (zerop (length (cdr field))))) (list (car field) nil (cdr field)))) parsed) ;; Put in decomposited name (N nil ,@(mapcar (lambda (name-part) (when (not (zerop (length (cdr name-part)))) (list (car name-part) nil (cdr name-part)))) (cdr (assq 'N parsed)))) ;; Put in addresses ,@(mapcar (lambda (address) (append '(ADR) '(()) (mapcar #'list (nth 0 address)) (mapcar (lambda (field) (list (car field) nil (cdr field))) (cdr address)))) (cdr (assq 'ADR parsed))) ;; Put in phone numbers ,@(mapcar (lambda (phone) (append '(TEL) '(()) (mapcar #'list (car phone)) (list (list 'NUMBER nil (cdr phone))))) (cdr (assq 'TEL parsed))) ;; Put in e-mail addresses ,@(mapcar (lambda (email) (append '(EMAIL) '(()) (mapcar #'list (car email)) (list (list 'USERID nil (cdr email))))) (cdr (assq 'EMAIL parsed))) ;; Put in photo ,@(when jabber-vcard-photo `((PHOTO () (TYPE () ,(avatar-mime-type jabber-vcard-photo)) (BINVAL () ,(avatar-base64-data jabber-vcard-photo))))))) (defun jabber-vcard-get (jc jid) "Request vcard from JID. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Request vcard from: " nil nil nil 'bare-or-muc))) (jabber-send-iq jc jid "get" `(vCard ((xmlns . ,jabber-vcard-xmlns))) #'jabber-process-data #'jabber-vcard-display #'jabber-process-data "Vcard request failed")) (defun jabber-vcard-edit (jc) "Edit your own vcard. JC is the Jabber connection." (interactive (list (jabber-read-account))) (jabber-send-iq jc nil "get" `(vCard ((xmlns . ,jabber-vcard-xmlns))) #'jabber-vcard-do-edit nil #'jabber-report-success "Vcard request failed")) (defconst jabber-vcard-fields '((FN . "Full name") (NICKNAME . "Nickname") (BDAY . "Birthday") (URL . "URL") (JABBERID . "JID") (MAILER . "User agent") (TZ . "Time zone") (TITLE . "Title") (ROLE . "Role") (REV . "Last changed") (DESC . "Description") (NOTE . "Note"))) (defconst jabber-vcard-name-fields '((PREFIX . "Prefix") (GIVEN . "Given name") (MIDDLE . "Middle name") (FAMILY . "Family name") (SUFFIX . "Suffix"))) (defconst jabber-vcard-phone-types '((HOME . "Home") (WORK . "Work") (VOICE . "Voice") (FAX . "Fax") (PAGER . "Pager") (MSG . "Message") (CELL . "Cell phone") (VIDEO . "Video") (BBS . "BBS") (MODEM . "Modem") (ISDN . "ISDN") (PCS . "PCS"))) (defconst jabber-vcard-email-types '((HOME . "Home") (WORK . "Work") (INTERNET . "Internet") (X400 . "X400") (PREF . "Preferred"))) (defconst jabber-vcard-address-types '((HOME . "Home") (WORK . "Work") (POSTAL . "Postal") (PARCEL . "Parcel") (DOM . "Domestic") (INTL . "International") (PREF . "Preferred"))) (defconst jabber-vcard-address-fields '((POBOX . "Post box") (EXTADD . "Ext. address") (STREET . "Street") (LOCALITY . "Locality") (REGION . "Region") (PCODE . "Post code") (CTRY . "Country"))) (defun jabber-vcard-display (_jc xml-data) "Display received vcard. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data)))) (dolist (simple-field jabber-vcard-fields) (let ((field (assq (car simple-field) parsed))) (when field (insert (cdr simple-field)) (indent-to 20) (insert (cdr field) "\n")))) (let ((names (cdr (assq 'N parsed)))) (when names (insert "\n") (dolist (name-field jabber-vcard-name-fields) (let ((field (assq (car name-field) names))) (when field (insert (cdr name-field)) (indent-to 20) (insert (cdr field) "\n")))))) (let ((email-addresses (cdr (assq 'EMAIL parsed)))) (when email-addresses (insert "\n") (insert (propertize "E-mail addresses:\n" 'face 'jabber-title)) (dolist (email email-addresses) (insert (mapconcat (lambda (type) (cdr (assq type jabber-vcard-email-types))) (car email) " ")) (insert ": " (cdr email) "\n")))) (let ((phone-numbers (cdr (assq 'TEL parsed)))) (when phone-numbers (insert "\n") (insert (propertize "Phone numbers:\n" 'face 'jabber-title)) (dolist (number phone-numbers) (insert (mapconcat (lambda (type) (cdr (assq type jabber-vcard-phone-types))) (car number) " ")) (insert ": " (cdr number) "\n")))) (let ((addresses (cdr (assq 'ADR parsed)))) (when addresses (insert "\n") (insert (propertize "Addresses:\n" 'face 'jabber-title)) (dolist (address addresses) (insert (propertize (mapconcat (lambda (type) (cdr (assq type jabber-vcard-address-types))) (car address) " ") 'face 'jabber-title)) (insert "\n") (dolist (address-field jabber-vcard-address-fields) (let ((field (assq (car address-field) address))) (when field (insert (cdr address-field)) (indent-to 20) (insert (cdr field) "\n"))))))) ;; XEP-0153: vCard-based avatars (let ((photo-type (nth 1 (assq 'PHOTO parsed))) (photo-binval (nth 2 (assq 'PHOTO parsed)))) (when (and photo-type photo-binval) (condition-case nil ;; ignore the type, let create-image figure it out. (let ((image (jabber-image-create (base64-decode-string photo-binval)))) (insert-image image "[Photo]") (insert "\n")) (error (insert "Couldn't display photo\n"))))))) (defun jabber-vcard-do-edit (jc xml-data _closure-data) (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data))) start-position) (with-current-buffer (get-buffer-create "Edit vcard") (jabber-widget-init-buffer nil) (setq jabber-buffer-connection jc) (setq start-position (point)) (dolist (simple-field jabber-vcard-fields) (widget-insert (cdr simple-field)) (indent-to 15) (let ((default-value (cdr (assq (car simple-field) parsed)))) (push (cons (car simple-field) (widget-create 'editable-field (or default-value ""))) jabber-widget-alist))) (widget-insert "\n") (push (cons 'N (widget-create '(set :tag "Decomposited name" (cons :tag "Prefix" :format "%t: %v" (const :format "" PREFIX) (string :format "%v")) (cons :tag "Given name" :format "%t: %v" (const :format "" GIVEN) (string :format "%v")) (cons :tag "Middle name" :format "%t: %v" (const :format "" MIDDLE) (string :format "%v")) (cons :tag "Family name" :format "%t: %v" (const :format "" FAMILY) (string :format "%v")) (cons :tag "Suffix" :format "%t: %v" (const :format "" SUFFIX) (string :format "%v"))) :value (cdr (assq 'N parsed)))) jabber-widget-alist) (widget-insert "\n") (push (cons 'ADR (widget-create '(repeat :tag "Postal addresses" (cons :tag "Address" (set :tag "Type" (const :tag "Home" HOME) (const :tag "Work" WORK) (const :tag "Postal" POSTAL) (const :tag "Parcel" PARCEL) (const :tag "Domestic" DOM) (const :tag "International" INTL) (const :tag "Preferred" PREF)) (set :tag "Address" (cons :tag "Post box" :format "%t: %v" (const :format "" POBOX) (string :format "%v")) (cons :tag "Ext. address" :format "%t: %v" (const :format "" EXTADD) (string :format "%v")) (cons :tag "Street" :format "%t: %v" (const :format "" STREET) (string :format "%v")) (cons :tag "Locality" :format "%t: %v" (const :format "" LOCALITY) (string :format "%v")) (cons :tag "Region" :format "%t: %v" (const :format "" REGION) (string :format "%v")) (cons :tag "Post code" :format "%t: %v" (const :format "" PCODE) (string :format "%v")) (cons :tag "Country" :format "%t: %v" (const :format "" CTRY) (string :format "%v"))))) :value (cdr (assq 'ADR parsed)))) jabber-widget-alist) (widget-insert "\n") (push (cons 'TEL (widget-create '(repeat :tag "Phone numbers" (cons :tag "Number" (set :tag "Type" (const :tag "Home" HOME) (const :tag "Work" WORK) (const :tag "Voice" VOICE) (const :tag "Fax" FAX) (const :tag "Pager" PAGER) (const :tag "Message" MSG) (const :tag "Cell phone" CELL) (const :tag "Video" VIDEO) (const :tag "BBS" BBS) (const :tag "Modem" MODEM) (const :tag "ISDN" ISDN) (const :tag "PCS" PCS)) (string :tag "Number"))) :value (cdr (assq 'TEL parsed)))) jabber-widget-alist) (widget-insert "\n") (push (cons 'EMAIL (widget-create '(repeat :tag "E-mail addresses" (cons :tag "Address" (set :tag "Type" (const :tag "Home" HOME) (const :tag "Work" WORK) (const :tag "Internet" INTERNET) (const :tag "X400" X400) (const :tag "Preferred" PREF)) (string :tag "Address"))) :value (cdr (assq 'EMAIL parsed)))) jabber-widget-alist) (widget-insert "\n") (widget-insert "Photo/avatar:\n") (let* ((photo (assq 'PHOTO parsed)) (avatar (when photo (jabber-avatar-from-base64-string (nth 2 photo) (nth 1 photo))))) (push (cons 'PHOTO (widget-create `(radio-button-choice (const :tag "None" nil) ,@(when photo (list `(const :tag ,(concat "Existing: " (propertize " " 'display (jabber-avatar-image avatar))) ,(cdr photo)))) (file :must-match t :tag "From file")) :value (cdr photo))) jabber-widget-alist)) (widget-insert "\n") (widget-create 'push-button :notify #'jabber-vcard-submit "Submit") (widget-setup) (widget-minor-mode 1) (switch-to-buffer (current-buffer)) (goto-char start-position)))) (defun jabber-vcard-submit (&rest _ignore) (let ((to-publish (jabber-vcard-reassemble (mapcar (lambda (entry) (cons (car entry) (widget-value (cdr entry)))) jabber-widget-alist)))) (jabber-send-iq jabber-buffer-connection nil "set" to-publish #'jabber-report-success "Changing vCard" #'jabber-report-success "Changing vCard") (when (bound-and-true-p jabber-vcard-avatars-publish) (jabber-vcard-avatars-update-current jabber-buffer-connection (and jabber-vcard-photo (avatar-sha1-sum jabber-vcard-photo)))))) (provide 'jabber-vcard) ;;; jabber-vcard.el ends hereemacs-jabber/lisp/jabber-version.el000066400000000000000000000074611516610113500176010ustar00rootroot00000000000000;;; jabber-version.el --- version reporting by JEP-0092 -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'jabber-iq) (require 'jabber-util) (require 'jabber-disco) (require 'jabber-menu) (require 'find-func) (require 'lisp-mnt) (defconst jabber-version-xmlns "jabber:iq:version" "XEP-0092 Software Version namespace.") (defcustom jabber-version-show t "Show our client version to others. Acts on loading." :type 'boolean :group 'jabber) (defconst jabber-version (lm-version (find-library-name "jabber")) "Version string extracted from jabber.el. This value provides the version field of the XEP-0092 Service Discovery jabber:iq:version query response, when `jabber-version-show` is non `nil`.") (defun jabber-get-version (jc to) "Request software version. JC is the Jabber connection." (interactive (list (jabber-read-account) (jabber-read-jid-completing "Request version of: " nil nil nil 'full t))) (jabber-send-iq jc to "get" `(query ((xmlns . ,jabber-version-xmlns))) #'jabber-process-data #'jabber-process-version #'jabber-process-data "Version request failed")) ;; called by jabber-process-data (defun jabber-process-version (_jc xml-data) "Handle results from jabber:iq:version requests. Return a formatted string with name, version, and OS." (let ((query (jabber-iq-query xml-data))) (mapconcat #'identity (cl-loop for (tag . label) in '((name . "Name:\t\t") (version . "Version:\t") (os . "OS:\t\t")) for data = (car (jabber-xml-node-children (car (jabber-xml-get-children query tag)))) when data collect (concat label data)) "\n"))) (if jabber-version-show (and (add-to-list 'jabber-iq-get-xmlns-alist (cons jabber-version-xmlns 'jabber-return-version)) (jabber-disco-advertise-feature jabber-version-xmlns))) (defun jabber-return-version (jc xml-data) "Return client version as defined in XEP-0092. Sender and ID are determined from the incoming packet passed in XML-DATA. JC is the Jabber connection." ;; Things we might check: does this iq message really have type='get' and ;; exactly one child, namely query with xmlns='jabber:iq:version'? ;; Then again, jabber-process-iq should take care of that. (let ((to (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id)) (os (format "Emacs %d.%d (%s)" emacs-major-version emacs-minor-version system-type))) (jabber-send-iq jc to "result" `(query ((xmlns . ,jabber-version-xmlns)) (name () "jabber.el") (version () ,jabber-version) ;; Booting... /vmemacs.el ;; Shamelessly stolen from someone's sig. (os () ,os)) nil nil nil nil id))) (provide 'jabber-version) ;;; jabber-version.el ends hereemacs-jabber/lisp/jabber-widget.el000066400000000000000000000325061516610113500173750ustar00rootroot00000000000000;;; jabber-widget.el --- display various kinds of forms -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2007 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'widget) (require 'wid-edit) (require 'jabber-util) (require 'jabber-disco) (defvar jabber-widget-alist nil "Alist of widgets currently used.") (defvar jabber-widget-form-type nil "Type of form. One of: `x-data', jabber:x:data `register', as used in jabber:iq:register and jabber:iq:search.") (defvar jabber-widget-submit-to nil "JID of the entity to which form data is to be sent.") ;; Global reference declarations (defvar *jabber-roster*) ; jabber-core.el (defvar jabber-xdata-xmlns) ; jabber-xml.el ;; (jabber-disco-advertise-feature jabber-xdata-xmlns) (define-widget 'jabber-widget-jid 'string "JID widget." :value-to-internal (lambda (_widget value) (let ((displayname (jabber-jid-rostername value))) (if displayname (format "%s <%s>" displayname value) value))) :value-to-external (lambda (_widget value) (if (string-match "<\\([^>]+\\)>[ \t]*$" value) (match-string 1 value) value)) :complete #'jabber-widget-jid-complete) (defun jabber-widget-jid-complete (widget) "Perform completion on JID preceding point." ;; mostly stolen from widget-color-complete (let* ((prefix (buffer-substring-no-properties (widget-field-start widget) (point))) (list (append (mapcar #'symbol-name *jabber-roster*) (delq nil (mapcar #'(lambda (item) (when (jabber-jid-rostername item) (format "%s <%s>" (jabber-jid-rostername item) (symbol-name item)))) *jabber-roster*)))) (completion (try-completion prefix list))) (cond ((eq completion t) (message "Exact match.")) ((null completion) (error "Can't find completion for \"%s\"" prefix)) ((not (string-equal prefix completion)) (insert-and-inherit (substring completion (length prefix)))) (t (message "Making completion list...") (with-output-to-temp-buffer "*Completions*" (display-completion-list (all-completions prefix list nil))) (message "Making completion list...done"))))) (defun jabber-widget-init-buffer (submit-to) "Setup buffer-local variables for widgets." (setq-local jabber-widget-alist nil) (setq-local jabber-widget-submit-to submit-to) (setq buffer-read-only nil) ;; XXX: This is because data from other queries would otherwise be ;; appended to this buffer, which would fail since widget buffers ;; are read-only... or something like that. Maybe there's a ;; better way. (rename-uniquely)) (defun jabber-widget-render-register-form (query &optional default-username) "Display widgets from element in IQ register or search namespace. Display widgets from element in jabber:iq:{register,search} namespace. DEFAULT-USERNAME is the default value for the username field." (setq-local jabber-widget-alist nil) (setq-local jabber-widget-form-type 'register) (if (jabber-xml-get-children query 'instructions) (widget-insert "Instructions: " (car (jabber-xml-node-children (car (jabber-xml-get-children query 'instructions)))) "\n")) (if (jabber-xml-get-children query 'registered) (widget-insert "You are already registered. You can change your details here.\n")) (widget-insert "\n") (let ((possible-fields ;; taken from XEP-0077 '((username . "Username") (nick . "Nickname") (password . "Password") (name . "Full name") (first . "First name") (last . "Last name") (email . "E-mail") (address . "Address") (city . "City") (state . "State") (zip . "Zip") (phone . "Telephone") (url . "Web page") (date . "Birth date")))) (dolist (field (jabber-xml-node-children query)) (let ((entry (assq (jabber-xml-node-name field) possible-fields))) (when entry (widget-insert (cdr entry) "\t") ;; Special case: when registering a new account, the default ;; username is the one specified in jabber-username. Things ;; will break if the user changes that name, though... (let ((default-value (or (when (eq (jabber-xml-node-name field) 'username) default-username) ""))) (setq jabber-widget-alist (cons (cons (car entry) (widget-create 'editable-field :secret (if (eq (car entry) 'password) ?* nil) (or (car (jabber-xml-node-children field)) default-value))) jabber-widget-alist))) (widget-insert "\n")))))) (defun jabber-widget-parse-register-form () "Return children of a tag containing information entered. Return children of a tag containing information entered in the widgets of the current buffer." (mapcar (lambda (widget-cons) (list (car widget-cons) nil (widget-value (cdr widget-cons)))) jabber-widget-alist)) (defun jabber-widget-render-xdata-form (x &optional defaults) "Display widgets from element in jabber:x:data namespace. DEFAULTS is an alist associating variable names with default values. DEFAULTS takes precedence over values specified in the form." (setq-local jabber-widget-alist nil) (setq-local jabber-widget-form-type 'xdata) (let ((title (car (jabber-xml-node-children (car (jabber-xml-get-children x 'title)))))) (if (stringp title) (widget-insert (propertize title 'face 'jabber-title) "\n\n"))) (let ((instructions (car (jabber-xml-node-children (car (jabber-xml-get-children x 'instructions)))))) (if (stringp instructions) (widget-insert "Instructions: " instructions "\n\n"))) (dolist (field (jabber-xml-get-children x 'field)) (let* ((var (jabber-xml-get-attribute field 'var)) (label (jabber-xml-get-attribute field 'label)) (type (jabber-xml-get-attribute field 'type)) (values (jabber-xml-get-children field 'value)) (options (jabber-xml-get-children field 'option)) (desc (car (jabber-xml-get-children field 'desc))) (default-value (assoc var defaults))) ;; "required" not implemented yet (cond ((string= type "fixed") (widget-insert (car (jabber-xml-node-children (car values))))) ((string= type "text-multi") (if (or label var) (widget-insert (or label var) ":\n")) (push (cons (cons var type) (widget-create 'text (or (cdr default-value) (mapconcat #'(lambda (val) (car (jabber-xml-node-children val))) values "\n") ""))) jabber-widget-alist)) ((string= type "list-single") (if (or label var) (widget-insert (or label var) ":\n")) (push (cons (cons var type) (apply #'widget-create 'radio-button-choice :value (or (cdr default-value) (car (xml-node-children (car values)))) (mapcar (lambda (option) `(item :tag ,(jabber-xml-get-attribute option 'label) :value ,(car (jabber-xml-node-children (car (jabber-xml-get-children option 'value)))))) options))) jabber-widget-alist)) ((string= type "boolean") (push (cons (cons var type) (widget-create 'checkbox :tag (or label var) :value (if default-value (cdr default-value) (not (null (member (car (xml-node-children (car values))) '("1" "true"))))))) jabber-widget-alist) (if (or label var) (widget-insert " " (or label var) "\n"))) (t ; in particular including text-single and text-private (if (or label var) (widget-insert (or label var) ": ")) (setq jabber-widget-alist (cons (cons (cons var type) (widget-create 'editable-field :secret (if (string= type "text-private") ?* nil) (or (cdr default-value) (car (jabber-xml-node-children (car values))) ""))) jabber-widget-alist)))) (when (and desc (car (jabber-xml-node-children desc))) (widget-insert "\n" (car (jabber-xml-node-children desc)))) (widget-insert "\n")))) (defun jabber-widget-parse-xdata-form () "Return an tag containing information entered in the widgets. Return an tag containing information entered in the widgets of the current buffer." `(x ((xmlns . ,jabber-xdata-xmlns) (type . "submit")) ,@(mapcar (lambda (widget-cons) (let ((values (jabber-widget-xdata-value-convert (widget-value (cdr widget-cons)) (cdar widget-cons)))) ;; empty fields are not included (when values `(field ((var . ,(caar widget-cons))) ,@(mapcar (lambda (value) (list 'value nil value)) values))))) jabber-widget-alist))) (defun jabber-widget-xdata-value-convert (value type) "Convert VALUE from form used by widget library to form required by XEP-0004. Return a list of strings, each of which to be included as cdata in a tag." (cond ((string= type "boolean") (if value (list "1") (list "0"))) ((string= type "text-multi") (split-string value "[\n\r]")) (t ; in particular including text-single, text-private and list-single (if (zerop (length value)) nil (list value))))) (defun jabber-widget-render-xdata-search-results (xdata) "Render search results in x:data form." (let ((title (car (jabber-xml-get-children xdata 'title)))) (when title (insert (propertize (car (jabber-xml-node-children title)) 'face 'jabber-title) "\n"))) (if (jabber-xml-get-children xdata 'reported) (jabber-widget-render-xdata-search-results-multi xdata) (jabber-widget-render-xdata-search-results-single xdata))) (defun jabber-widget-render-xdata-search-results-multi (xdata) "Render multi-record search results." (let (fields (jid-fields 0)) (let ((reported (car (jabber-xml-get-children xdata 'reported))) (column 0)) (dolist (field (jabber-xml-get-children reported 'field)) (let (width) ;; Clever algorithm for estimating width based on field type goes here. (setq width 20) (setq fields (append fields (list (cons (jabber-xml-get-attribute field 'var) (list 'label (jabber-xml-get-attribute field 'label) 'type (jabber-xml-get-attribute field 'type) 'column column))))) (setq column (+ column width)) (if (string= (jabber-xml-get-attribute field 'type) "jid-single") (setq jid-fields (1+ jid-fields)))))) (dolist (field-cons fields) (indent-to (plist-get (cdr field-cons) 'column) 1) (insert (propertize (plist-get (cdr field-cons) 'label) 'face 'bold))) (insert "\n\n") ;; Now, the items (dolist (item (jabber-xml-get-children xdata 'item)) (let ((start-of-line (point)) jid) ;; The following code assumes that the order of the s in each ;; is the same as in the tag. (dolist (field (jabber-xml-get-children item 'field)) (let ((field-plist (cdr (assoc (jabber-xml-get-attribute field 'var) fields))) (value (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value)))))) (indent-to (plist-get field-plist 'column) 1) ;; Absent values are sometimes "", sometimes nil. insert ;; doesn't like nil. (when value ;; If there is only one JID field, let the whole row ;; have the jabber-jid property. If there are many JID ;; fields, the string belonging to each field has that ;; property. (if (string= (plist-get field-plist 'type) "jid-single") (if (not (eq jid-fields 1)) (insert (propertize value 'jabber-jid value)) (setq jid value) (insert value)) (insert value))))) (if jid (put-text-property start-of-line (point) 'jabber-jid jid)) (insert "\n"))))) (defun jabber-widget-render-xdata-search-results-single (xdata) "Render single-record search results." (dolist (field (jabber-xml-get-children xdata 'field)) (let ((label (jabber-xml-get-attribute field 'label)) (values (mapcar #'(lambda (val) (car (jabber-xml-node-children val))) (jabber-xml-get-children field 'value)))) ;; XXX: consider type (insert (propertize (concat label ": ") 'face 'bold)) (indent-to 30) (insert (apply #'concat values) "\n")))) (defun jabber-widget-xdata-formtype (x) "Return the form type of the xdata form in X, by XEP-0068. Return nil if no form type is specified." (catch 'found-formtype (dolist (field (jabber-xml-get-children x 'field)) (when (and (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE") (string= (jabber-xml-get-attribute field 'type) "hidden")) (throw 'found-formtype (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value))))))))) (provide 'jabber-widget) ;;; jabber-widget.el ends hereemacs-jabber/lisp/jabber-xml.el000066400000000000000000000271041516610113500167100ustar00rootroot00000000000000;;; jabber-xml.el --- XML functions -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; Copyright (C) 2026 Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Commentary: ;; ;;; Code: (require 'xml) (eval-when-compile (require 'cl-lib)) (defsubst jabber-replace-in-string (string regexp newtext) "Return STRING with all matches for REGEXP replaced with NEWTEXT. NEWTEXT is inserted literally, without changing its case or treating \"\\\" specially." (replace-regexp-in-string regexp newtext string t t)) (defun jabber-escape-xml (string) "Escape STRING for XML." (if (stringp string) (let ((newstr (concat string))) ;; Form feeds might appear in code you copy, etc. Nevertheless, ;; it's invalid XML. (setq newstr (jabber-replace-in-string newstr "\f" "\n")) ;; Other control characters are also illegal, except for ;; tab, CR, and LF. (setq newstr (jabber-replace-in-string newstr "[\000-\010\013\014\016-\037]" " ")) (setq newstr (jabber-replace-in-string newstr "&" "&")) (setq newstr (jabber-replace-in-string newstr "<" "<")) (setq newstr (jabber-replace-in-string newstr ">" ">")) (setq newstr (jabber-replace-in-string newstr "'" "'")) (setq newstr (jabber-replace-in-string newstr "\"" """)) newstr) string)) (defun jabber-unescape-xml (string) "Unescape STRING for XML." (if (stringp string) (let ((newstr string)) (setq newstr (jabber-replace-in-string newstr """ "\"")) (setq newstr (jabber-replace-in-string newstr "'" "'")) (setq newstr (jabber-replace-in-string newstr ">" ">")) (setq newstr (jabber-replace-in-string newstr "<" "<")) (setq newstr (jabber-replace-in-string newstr "&" "&")) newstr) string)) (defun jabber-sexp2xml (sexp) "Return SEXP as well-formatted XML. SEXP should be in the form: (tagname ((attribute-name . attribute-value)...) children...)" (cond ((stringp sexp) (jabber-escape-xml sexp)) ((listp (car sexp)) (let ((xml "")) (dolist (tag sexp) (setq xml (concat xml (jabber-sexp2xml tag)))) xml)) ;; work around bug in old versions of xml.el, where ("") can appear ;; as children of a node ((and (consp sexp) (stringp (car sexp)) (zerop (length (car sexp)))) "") (t (let ((xml "")) (setq xml (concat "<" (symbol-name (car sexp)))) (dolist (attr (cadr sexp)) (if (consp attr) (setq xml (concat xml (format " %s='%s'" (symbol-name (car attr)) (jabber-escape-xml (cdr attr))))))) (if (cddr sexp) (progn (setq xml (concat xml ">")) (dolist (child (cddr sexp)) (setq xml (concat xml (jabber-sexp2xml child)))) (setq xml (concat xml ""))) (setq xml (concat xml "/>"))) xml)))) (defun jabber-xml-skip-tag-forward (&optional dont-recurse-into-stream) "Skip to end of tag or matching closing tag if present. Return t iff after a closing tag, otherwise throws an `unfinished' tag with value nil. If DONT-RECURSE-INTO-STREAM is non-nil, stop after an opening tag. Uses a custom parser instead of `sgml-skip-tag-forward'." (skip-chars-forward "^<") (cond ((looking-at "" nil t) (goto-char (match-end 0)) (throw 'unfinished nil))) ((looking-at "<\\([^[:space:]/>]+\\)\\([[:space:]]+[^=>]+=[[:space:]]*'[^']*'\\|[[:space:]]+[^=>]+=[[:space:]]*\"[^\"]*\"\\)*") (let ((node-name (match-string 1))) (goto-char (match-end 0)) (skip-syntax-forward "\s-") ; Skip over trailing white space. (cond ((looking-at "/>") (goto-char (match-end 0)) t) ((looking-at ">") (goto-char (match-end 0)) (unless (and dont-recurse-into-stream (equal node-name "stream:stream")) (cl-loop do (skip-chars-forward "^<") until (looking-at (regexp-quote (concat ""))) do (jabber-xml-skip-tag-forward)) (goto-char (match-end 0))) t) (t (throw 'unfinished nil))))) (t (throw 'unfinished nil)))) (defun jabber-xml-parse-next-stanza () "Parse the first XML stanza in the current buffer. Parse and return the first complete XML element in the buffer, leaving point at the end of it. If there is no complete XML element, return nil." (and (catch 'unfinished (goto-char (point-min)) (jabber-xml-skip-tag-forward) (> (point) (point-min))) (xml-parse-region (point-min) (point)))) (defsubst jabber-xml-node-name (node) "Return the tag associated with NODE. The tag is a lower-case symbol." (if (listp node) (car node))) (defsubst jabber-xml-node-attributes (node) "Return the list of attributes of NODE. The list can be nil." (if (listp node) (nth 1 node))) (defsubst jabber-xml-node-children (node) "Return the list of children of NODE. This is a list of nodes, and it can be nil." (let ((children (cddr node))) ;; Work around a bug in early versions of xml.el (if (equal children '((""))) nil children))) (defun jabber-xml-get-children (node child-name) "Return the children of NODE whose tag is CHILD-NAME. CHILD-NAME should be a lower case symbol." (let ((match ())) (dolist (child (jabber-xml-node-children node)) (if child (if (equal (jabber-xml-node-name child) child-name) (push child match)))) (nreverse match))) ;; `xml-get-attribute' returns "" if the attribute is not found, which ;; is not very useful. Therefore, we use `xml-get-attribute-or-nil'. (defsubst jabber-xml-get-attribute (node attribute) "Get from NODE the value of ATTRIBUTE. Return nil if the attribute was not found." (when (consp node) (xml-get-attribute-or-nil node attribute))) (defsubst jabber-xml-get-xmlns (node) "Get \"xmlns\" attribute of NODE, or nil if not present." (jabber-xml-get-attribute node 'xmlns)) (defun jabber-xml-child-with-xmlns (node xmlns) "Return the first child element of NODE whose xmlns equals XMLNS." (let ((children (jabber-xml-node-children node)) result) (while (and children (not result)) (let ((child (car children))) (when (and (listp child) (string= (jabber-xml-get-xmlns child) xmlns)) (setq result child))) (setq children (cdr children))) result)) (defun jabber-xml-encrypted-p (xml-data) "Return non-nil if XML-DATA contains an encryption element. Checks for OMEMO, legacy OpenPGP, and OX namespaces." (and (or (jabber-xml-child-with-xmlns xml-data "eu.siacs.conversations.axolotl") (jabber-xml-child-with-xmlns xml-data "jabber:x:encrypted") (jabber-xml-child-with-xmlns xml-data "urn:xmpp:openpgp:0")) t)) (defun jabber-xml-path (xml-data path) "Find sub-node of XML-DATA according to PATH. PATH is a vaguely XPath-inspired list. Each element can be: a symbol go to first child node with this node name cons cell car is string containing namespace URI, cdr is string containing node name. Find first matching child node. any string character data of this node." (let ((node xml-data)) (while (and path node) (let ((step (car path))) (cond ((symbolp step) (setq node (car (jabber-xml-get-children node step)))) ((consp step) ;; This will be easier with namespace-aware use ;; of xml.el. It will also be more correct. ;; Now, it only matches explicit namespace declarations. (setq node (cl-dolist (x (jabber-xml-get-children node (intern (cdr step)))) (when (string= (jabber-xml-get-attribute x 'xmlns) (car step)) (cl-return x))))) ((stringp step) (setq node (car (jabber-xml-node-children node))) (unless (stringp node) (setq node nil))) (t (error "Unknown path step: %s" step)))) (setq path (cdr path))) node)) (defmacro jabber-xml-let-attributes (attributes xml-data &rest body) "Evaluate BODY with ATTRIBUTES bound to their values in XML-DATA. ATTRIBUTES must be a list of symbols, as present in XML-DATA." (declare (indent 2) (debug (sexp form body))) `(let ,(mapcar #'(lambda (attr) (list attr `(jabber-xml-get-attribute ,xml-data ',attr))) attributes) ,@body)) (defun jabber-xml-resolve-namespace-prefixes (xml-data &optional default-ns prefixes) (let ((node-name (jabber-xml-node-name xml-data)) (attrs (jabber-xml-node-attributes xml-data))) (setq prefixes (jabber-xml-merge-namespace-declarations attrs prefixes)) ;; If there is an xmlns attribute, it is the new default ;; namespace. (let ((xmlns (jabber-xml-get-xmlns xml-data))) (when xmlns (setq default-ns xmlns))) ;; Now, if the node name has a prefix, replace it and add an ;; "xmlns" attribute. Slightly ugly, but avoids the need to ;; change all the rest of jabber.el at once. (let ((node-name-string (symbol-name node-name))) (when (string-match "\\(.*\\):\\(.*\\)" node-name-string) (let* ((prefix (match-string 1 node-name-string)) (unprefixed (match-string 2 node-name-string)) (ns (assoc prefix prefixes))) (if (null ns) ;; This is not supposed to happen... (message "jabber-xml-resolve-namespace-prefixes: Unknown prefix in %s" node-name-string) (setf (car xml-data) (intern unprefixed)) (setf (cadr xml-data) (cons (cons 'xmlns (cdr ns)) (delq 'xmlns attrs))))))) ;; And iterate through all child elements. (mapc (lambda (x) (when (listp x) (jabber-xml-resolve-namespace-prefixes x default-ns prefixes))) (jabber-xml-node-children xml-data)) xml-data)) (defun jabber-xml-merge-namespace-declarations (attrs prefixes) ;; First find any xmlns:foo attributes.. (dolist (attr attrs) (let ((attr-name (symbol-name (car attr)))) (when (string-match "xmlns:" attr-name) (let ((prefix (substring attr-name (match-end 0))) (ns-uri (cdr attr))) ;; A slightly complicated dance to never change the ;; original value of prefixes (since the caller depends on ;; it), but also to avoid excessive copying (which remove ;; always does). Might need to profile and tweak this for ;; performance. (setq prefixes (cons (cons prefix ns-uri) (if (assoc prefix prefixes) (remove (assoc prefix prefixes) prefixes) prefixes))))))) prefixes) ;;; Shared xmlns constants (defconst jabber-xdata-xmlns "jabber:x:data" "XEP-0004: Data Forms.") (defconst jabber-oob-xmlns "jabber:x:oob" "XEP-0066: Out of Band Data.") (defconst jabber-delay-xmlns "urn:xmpp:delay" "XEP-0203: Delayed Delivery.") (defconst jabber-delay-legacy-xmlns "jabber:x:delay" "XEP-0091: Legacy Delayed Delivery.") (defconst jabber-roster-xmlns "jabber:iq:roster" "RFC 6121: Roster Management.") (defconst jabber-stanzas-xmlns "urn:ietf:params:xml:ns:xmpp-stanzas" "RFC 6120: XMPP Stanza Errors.") (provide 'jabber-xml) ;;; jabber-xml.el ends here. emacs-jabber/lisp/jabber.el000066400000000000000000000177261516610113500161230ustar00rootroot00000000000000;;; jabber.el --- XMPP/Jabber client -*- lexical-binding: t; -*- ;; Author: Magnus Henoch ;; Maintainer: Thanos Apollo ;; Keywords: comm ;; Homepage: https://git.thanosapollo.org/emacs-jabber ;; Package-Requires: ((emacs "29.1") (fsm "0.2.0")) ;; Version: 0.10.5 ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - Tom Berger - object@intelectronica.net ;; Copyright (C) 2026 Thanos Apollo ;; SSL - Support, mostly inspired by Gnus ;; 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 ;;; Commentary: ;; jabber.el is an XMPP client for Emacs. XMPP (also known as ;; 'Jabber') is the IETF-standard federated instant messaging protocol ;; - see http://xmpp.org for more information. ;;; History: ;; ;;; Code: (require 'cl-lib) (require 'goto-addr) ;; These are variables shared with more than one section. For ;; instance, `jabber-process-buffer' is used in jabber-core.el but also in ;; jabber-conn.el. ;; Placing these variable definitions before using them avoid ;; byte-compile warnings. Moreover, it is common practice to define ;; variables before its usage. ;; This was originally defined in jabber-core.el (defvar jabber-process-buffer " *-jabber-process-*" "The name of the process buffer.") ;; Shared between jabber-core.el and jabber-alert.el (defvar jabber-xml-data) (defcustom jabber-debug-keep-process-buffers nil "If nil, kill process buffers when the process dies. Contents of process buffers might be useful for debugging." :type 'boolean :group 'jabber-debug) (defcustom jabber-silent-mode nil "If non-nil, do not ask for confirmation for some operations. DANGEROUS!" :type 'boolean :group 'jabber) ;;; these customize fields should come first (defgroup jabber nil "Jabber instant messaging" :group 'applications) ;;;###autoload (defcustom jabber-account-list nil "List of Jabber accounts. Each element of the list is a cons cell describing a Jabber account, where the car is a JID and the CDR is an alist. JID is a full Jabber ID string (e.g. foo@bar.tld). You can also specify the resource (e.g. foo@bar.tld/emacs). The following keys can be present in the alist: :password is a string to authenticate ourself against the server. It can be empty. If you don't want to store your password in your Emacs configuration, try auth-source (info node `(auth)Top'). :network-server is a string identifying the address to connect to, if it's different from the server part of the JID. :port is the port to use (default depends on connection type). :connection-type is a symbol. Valid symbols are `starttls' and `network'. Only JID is mandatory. The rest can be guessed at run-time. Examples: Two accounts without any special configuration: \((\"foo@example.com\") (\"bar@example.net\")) One disabled account with a non-standard port: \((\"romeo@montague.net\" (:port . 5242) (:disabled . t)))" :type '(repeat (cons :tag "Account information" (string :tag "JID") (set :format "%v" (cons :format "%v" (const :format "" :disabled) (const :tag "Disabled" t)) (cons :format "%v" (const :format "" :password) (string :tag "Password")) (cons :format "%v" (const :format "" :network-server) (string :tag "Network server")) (cons :format "%v" (const :format "" :port) (integer :tag "Port" 5222)) (cons :format "%v" (const :format "" :connection-type) (choice :tag "Connection type" (const :tag "STARTTLS" starttls) (const :tag "Unencrypted" network)))))) :group 'jabber) (defcustom jabber-default-resource "emacs" "Default resource for connections when the JID has no resource part." :type 'string :group 'jabber) (defcustom jabber-default-show "" "Default show state." :type '(choice (const :tag "Online" "") (const :tag "Chatty" "chat") (const :tag "Away" "away") (const :tag "Extended away" "xa") (const :tag "Do not disturb" "dnd")) :group 'jabber) (defcustom jabber-default-status "" "Default status string." :type 'string :group 'jabber) (defcustom jabber-default-priority 10 "Default priority." :type 'integer :group 'jabber) ;;; guess internal dependencies! (require 'jabber-util) (require 'jabber-menu) (require 'jabber-xml) (require 'jabber-conn) (require 'jabber-core) (require 'jabber-roster) (require 'jabber-presence) (require 'jabber-alert) (require 'jabber-chat) (require 'jabber-db) (require 'jabber-disco) (require 'jabber-iq) (require 'jabber-widget) (require 'jabber-register) (require 'jabber-search) (require 'jabber-blocking) (require 'jabber-moderation) (require 'jabber-message-correct) (require 'jabber-message-reply) (require 'jabber-styling) (require 'jabber-browse) (require 'jabber-compose) (require 'jabber-muc) (require 'jabber-mam) (require 'jabber-muc-nick-completion) (require 'jabber-version) (require 'jabber-ahc-presence) (require 'jabber-modeline) (require 'jabber-activity) (require 'jabber-vcard) (require 'jabber-chatstates) (require 'jabber-csi) (require 'jabber-receipts) (require 'jabber-vcard-avatars) (require 'jabber-omemo-trust) (require 'jabber-autoaway) (require 'jabber-time) (require 'jabber-truncate) (when (featurep 'dbusbind) (require 'jabber-notifications nil t)) ;;;###autoload (defvar *jabber-current-status* nil "The user's current presence status.") ;;;###autoload (defvar *jabber-current-show* nil "The user's current presence show.") ;;;###autoload (defvar *jabber-current-priority* nil "The user's current priority.") (defvar *jabber-status-history* nil "History of status messages.") (defgroup jabber-faces nil "Faces for displaying Jabber instant messaging." :group 'jabber) (defface jabber-title '((t :inherit outline-3)) "Face for titles and section headings." :group 'jabber-faces) (define-obsolete-face-alias 'jabber-title-small 'jabber-title "0.10") (define-obsolete-face-alias 'jabber-title-medium 'jabber-title "0.10") (define-obsolete-face-alias 'jabber-title-large 'jabber-title "0.10") (defgroup jabber-debug nil "debugging options" :group 'jabber) ;;;###autoload (defconst jabber-presence-faces '(("" . jabber-roster-user-online) ("away" . jabber-roster-user-away) ("xa" . jabber-roster-user-xa) ("dnd" . jabber-roster-user-dnd) ("chat" . jabber-roster-user-chatty) ("error" . jabber-roster-user-error) (nil . jabber-roster-user-offline)) "Mapping from presence types to faces.") (defconst jabber-presence-strings `(("" . ,(propertize "Online" 'face 'jabber-roster-user-online)) ("away" . ,(propertize "Away" 'face 'jabber-roster-user-away)) ("xa" . ,(propertize "Extended Away" 'face 'jabber-roster-user-xa)) ("dnd" . ,(propertize "Do not Disturb" 'face 'jabber-roster-user-dnd)) ("chat" . ,(propertize "Chatty" 'face 'jabber-roster-user-chatty)) ("error" . ,(propertize "Error" 'face 'jabber-roster-user-error)) (nil . ,(propertize "Offline" 'face 'jabber-roster-user-offline))) "Mapping from presence types to readable, colorized strings.") ;;;###autoload (defun jabber-customize () "Customize Jabber options." (interactive) (customize-group 'jabber)) ;;;###autoload (defun jabber-info () "Open jabber.el manual." (interactive) (info "jabber")) (provide 'jabber) ;;; jabber.el ends here. emacs-jabber/src/000077500000000000000000000000001516610113500141575ustar00rootroot00000000000000emacs-jabber/src/Makefile000066400000000000000000000016111516610113500156160ustar00rootroot00000000000000CC = gcc CFLAGS += -fPIC -Wall -Wno-pointer-sign -Wno-unused-function -I. UNAME := $(shell uname) ifeq ($(UNAME),Darwin) LDFLAGS += -dynamiclib -undefined dynamic_lookup SOEXT = .dylib else LDFLAGS += -shared -Wl,--no-undefined SOEXT = .so endif MBED_FLAGS ?= $(shell pkg-config --cflags --libs mbedcrypto 2>/dev/null) SRCS = jabber-omemo-core.c picomemo/omemo.c picomemo/hacl.c TARGET = jabber-omemo-core$(SOEXT) INSTALL_DIR ?= $(if $(wildcard ../lisp),../lisp,..) all: $(INSTALL_DIR)/$(TARGET) picomemo/omemo.c: git -C .. submodule update --init src/picomemo $(TARGET): $(SRCS) picomemo/omemo.h picomemo/hacl.h ifeq ($(MBED_FLAGS),) $(error libmbedcrypto not found. Install libmbedtls-dev or set MBED_FLAGS manually) endif $(CC) $(CFLAGS) $(LDFLAGS) -o $@ $(SRCS) $(MBED_FLAGS) $(INSTALL_DIR)/$(TARGET): $(TARGET) cp $< $@ clean: rm -f $(TARGET) $(INSTALL_DIR)/$(TARGET) .PHONY: all clean emacs-jabber/src/jabber-omemo-core.c000066400000000000000000000721401516610113500176140ustar00rootroot00000000000000/* * jabber-omemo-core.c -- Emacs dynamic module wrapping picomemo * * Exposes OMEMO 0.3 (eu.siacs.conversations.axolotl) store lifecycle, * bundle extraction, key rotation, and message encrypt/decrypt to Elisp. * Also provides AES-256-GCM encrypt/decrypt for XEP-0454 media sharing. * * Copyright 2026 Thanos Apollo * SPDX-License-Identifier: GPL-3.0-or-later * * picomemo is ISC-licensed; see src/picomemo/LICENSE. */ #include #include #include #include #include #include "picomemo/omemo.h" int plugin_is_GPL_compatible; /* picomemo callbacks */ int omemoRandom(void *p, size_t n) { return getrandom(p, n, 0) != (ssize_t)n; } /* Skipped-message-key callbacks: stubbed for milestone 1. Sessions are not exposed yet, so these are never hit through the public Elisp API. They satisfy the linker. */ int omemoLoadMessageKey(struct omemoSession *s, struct omemoMessageKey *k) { (void)s; (void)k; return 1; /* not found */ } int omemoStoreMessageKey(struct omemoSession *s, const struct omemoMessageKey *k, uint64_t n) { (void)s; (void)k; (void)n; return 0; } /* Emacs helpers */ static emacs_value Qnil_v, Qt_v; static emacs_value Qjabber_omemo_error; static emacs_value Qidentity_key, Qsigned_pre_key, Qsigned_pre_key_id; static emacs_value Qsignature, Qpre_keys; static emacs_value Qkey, Qiv, Qciphertext; static emacs_value Qdata, Qpre_key_p; static void bind_function(emacs_env *env, const char *name, emacs_value func) { emacs_value sym = env->intern(env, name); emacs_value args[] = { sym, func }; env->funcall(env, env->intern(env, "defalias"), 2, args); } static void provide(emacs_env *env, const char *feature) { emacs_value sym = env->intern(env, feature); emacs_value args[] = { sym }; env->funcall(env, env->intern(env, "provide"), 1, args); } static void signal_error(emacs_env *env, int code, const char *msg) { emacs_value data = env->make_string(env, msg, strlen(msg)); emacs_value errsym = Qjabber_omemo_error; env->non_local_exit_signal(env, errsym, data); (void)code; } static emacs_value make_unibyte(emacs_env *env, const uint8_t *buf, size_t len) { return env->make_unibyte_string(env, (const char *)buf, len); } static int extract_unibyte(emacs_env *env, emacs_value arg, uint8_t *buf, size_t bufsize, size_t *outlen) { ptrdiff_t len = (ptrdiff_t)bufsize; if (!env->copy_string_contents(env, arg, (char *)buf, &len)) return -1; /* copy_string_contents appends a NUL; actual length is len-1. */ if (outlen) *outlen = (size_t)(len - 1); return 0; } /* Finalizers for user-ptr */ static void free_store(void *ptr) { free(ptr); } static void free_session(void *ptr) { free(ptr); } /* jabber-omemo--setup-store */ static emacs_value F_setup_store(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)args; (void)data; struct omemoStore store; int rc = omemoSetupStore(&store); if (rc) { signal_error(env, rc, "omemoSetupStore failed"); return Qnil_v; } size_t sz = omemoGetSerializedStoreSize(&store); uint8_t *buf = malloc(sz); if (!buf) { signal_error(env, -1, "malloc failed"); return Qnil_v; } omemoSerializeStore(buf, &store); emacs_value result = make_unibyte(env, buf, sz); free(buf); return result; } /* jabber-omemo--deserialize-store */ static emacs_value F_deserialize_store(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; /* Get size of the blob. */ ptrdiff_t bloblen = 0; env->copy_string_contents(env, args[0], NULL, &bloblen); if (env->non_local_exit_check(env)) return Qnil_v; uint8_t *blob = malloc((size_t)bloblen); if (!blob) { signal_error(env, -1, "malloc failed"); return Qnil_v; } env->copy_string_contents(env, args[0], (char *)blob, &bloblen); if (env->non_local_exit_check(env)) { free(blob); return Qnil_v; } /* actual data length is bloblen-1 (NUL terminator) */ size_t datalen = (size_t)(bloblen - 1); struct omemoStore *store = calloc(1, sizeof(*store)); if (!store) { free(blob); signal_error(env, -1, "calloc failed"); return Qnil_v; } int rc = omemoDeserializeStore(blob, datalen, store); free(blob); if (rc) { free(store); signal_error(env, rc, "omemoDeserializeStore failed"); return Qnil_v; } return env->make_user_ptr(env, free_store, store); } /* jabber-omemo--serialize-store */ static emacs_value F_serialize_store(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; struct omemoStore *store = env->get_user_ptr(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; size_t sz = omemoGetSerializedStoreSize(store); uint8_t *buf = malloc(sz); if (!buf) { signal_error(env, -1, "malloc failed"); return Qnil_v; } omemoSerializeStore(buf, store); emacs_value result = make_unibyte(env, buf, sz); free(buf); return result; } /* jabber-omemo--get-bundle */ static emacs_value F_get_bundle(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; struct omemoStore *store = env->get_user_ptr(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; /* Serialize identity key */ omemoSerializedKey ik; omemoSerializeKey(ik, store->identity.pub); /* Serialize signed pre-key */ omemoSerializedKey spk; omemoSerializeKey(spk, store->cursignedprekey.kp.pub); /* Build list of (id . key) pairs for pre-keys */ emacs_value Qcons = env->intern(env, "cons"); emacs_value Qlist = env->intern(env, "list"); /* Count valid pre-keys first */ int npk = 0; for (int i = 0; i < OMEMO_NUMPREKEYS; i++) { /* A zeroed pre-key has id=0 and zeroed key pair; skip it */ uint8_t zero[32] = {0}; if (store->prekeys[i].id == 0 && memcmp(store->prekeys[i].kp.pub, zero, 32) == 0) continue; npk++; } /* Build pre-keys list backwards for efficiency */ emacs_value prekey_list = Qnil_v; emacs_value Qnreverse = env->intern(env, "nreverse"); for (int i = 0; i < OMEMO_NUMPREKEYS; i++) { uint8_t zero[32] = {0}; if (store->prekeys[i].id == 0 && memcmp(store->prekeys[i].kp.pub, zero, 32) == 0) continue; omemoSerializedKey pk; omemoSerializeKey(pk, store->prekeys[i].kp.pub); emacs_value pair_args[2]; pair_args[0] = env->make_integer(env, store->prekeys[i].id); pair_args[1] = make_unibyte(env, pk, sizeof(pk)); emacs_value pair = env->funcall(env, Qcons, 2, pair_args); emacs_value cons_args[2] = { pair, prekey_list }; prekey_list = env->funcall(env, Qcons, 2, cons_args); } emacs_value rev_args[] = { prekey_list }; prekey_list = env->funcall(env, Qnreverse, 1, rev_args); emacs_value plist_args[10]; plist_args[0] = Qidentity_key; plist_args[1] = make_unibyte(env, ik, sizeof(ik)); plist_args[2] = Qsigned_pre_key; plist_args[3] = make_unibyte(env, spk, sizeof(spk)); plist_args[4] = Qsigned_pre_key_id; plist_args[5] = env->make_integer(env, store->cursignedprekey.id); plist_args[6] = Qsignature; plist_args[7] = make_unibyte(env, store->cursignedprekey.sig, sizeof(store->cursignedprekey.sig)); plist_args[8] = Qpre_keys; plist_args[9] = prekey_list; return env->funcall(env, Qlist, 10, plist_args); } /* jabber-omemo--rotate-signed-pre-key */ static emacs_value F_rotate_signed_pre_key(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; struct omemoStore *store = env->get_user_ptr(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; int rc = omemoRotateSignedPreKey(store); if (rc) { signal_error(env, rc, "omemoRotateSignedPreKey failed"); return Qnil_v; } return Qnil_v; } /* jabber-omemo--refill-pre-keys */ static emacs_value F_refill_pre_keys(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; struct omemoStore *store = env->get_user_ptr(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; int rc = omemoRefillPreKeys(store); if (rc) { signal_error(env, rc, "omemoRefillPreKeys failed"); return Qnil_v; } return Qnil_v; } /* jabber-omemo--encrypt-message */ static emacs_value F_encrypt_message(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; /* Get plaintext size */ ptrdiff_t ptlen = 0; env->copy_string_contents(env, args[0], NULL, &ptlen); if (env->non_local_exit_check(env)) return Qnil_v; uint8_t *plaintext = malloc((size_t)ptlen); if (!plaintext) { signal_error(env, -1, "malloc failed"); return Qnil_v; } env->copy_string_contents(env, args[0], (char *)plaintext, &ptlen); if (env->non_local_exit_check(env)) { free(plaintext); return Qnil_v; } size_t msglen = (size_t)(ptlen - 1); uint8_t *ciphertext = malloc(msglen); if (!ciphertext) { free(plaintext); signal_error(env, -1, "malloc failed"); return Qnil_v; } uint8_t key[32]; uint8_t iv[12]; int rc = omemoEncryptMessage(ciphertext, key, iv, plaintext, msglen); free(plaintext); if (rc) { free(ciphertext); signal_error(env, rc, "omemoEncryptMessage failed"); return Qnil_v; } emacs_value Qlist = env->intern(env, "list"); emacs_value plist_args[6]; plist_args[0] = Qkey; plist_args[1] = make_unibyte(env, key, 32); plist_args[2] = Qiv; plist_args[3] = make_unibyte(env, iv, 12); plist_args[4] = Qciphertext; plist_args[5] = make_unibyte(env, ciphertext, msglen); free(ciphertext); return env->funcall(env, Qlist, 6, plist_args); } /* jabber-omemo--decrypt-message */ static emacs_value F_decrypt_message(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; /* Extract key (32 bytes) */ uint8_t key[33]; /* +1 for NUL from copy_string_contents */ size_t keylen; if (extract_unibyte(env, args[0], key, sizeof(key), &keylen)) return Qnil_v; /* Extract IV (12 bytes) */ uint8_t iv[13]; size_t ivlen; if (extract_unibyte(env, args[1], iv, sizeof(iv), &ivlen)) return Qnil_v; /* Extract ciphertext */ ptrdiff_t ctlen_raw = 0; env->copy_string_contents(env, args[2], NULL, &ctlen_raw); if (env->non_local_exit_check(env)) return Qnil_v; uint8_t *ciphertext = malloc((size_t)ctlen_raw); if (!ciphertext) { signal_error(env, -1, "malloc failed"); return Qnil_v; } env->copy_string_contents(env, args[2], (char *)ciphertext, &ctlen_raw); if (env->non_local_exit_check(env)) { free(ciphertext); return Qnil_v; } size_t ctlen = (size_t)(ctlen_raw - 1); uint8_t *plaintext = malloc(ctlen); if (!plaintext) { free(ciphertext); signal_error(env, -1, "malloc failed"); return Qnil_v; } int rc = omemoDecryptMessage(plaintext, key, keylen, iv, ciphertext, ctlen); free(ciphertext); if (rc) { free(plaintext); signal_error(env, rc, "omemoDecryptMessage failed"); return Qnil_v; } emacs_value result = make_unibyte(env, plaintext, ctlen); free(plaintext); return result; } /* jabber-omemo--make-session */ static emacs_value F_make_session(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)args; (void)data; struct omemoSession *session = calloc(1, sizeof(*session)); if (!session) { signal_error(env, -1, "calloc failed"); return Qnil_v; } return env->make_user_ptr(env, free_session, session); } /* jabber-omemo--initiate-session */ static emacs_value F_initiate_session(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; struct omemoStore *store = env->get_user_ptr(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; /* Extract signature (64 bytes) */ uint8_t sig[65]; if (extract_unibyte(env, args[1], sig, sizeof(sig), NULL)) return Qnil_v; /* Extract signed pre-key (33 bytes) */ uint8_t spk[34]; if (extract_unibyte(env, args[2], spk, sizeof(spk), NULL)) return Qnil_v; /* Extract identity key (33 bytes) */ uint8_t ik[34]; if (extract_unibyte(env, args[3], ik, sizeof(ik), NULL)) return Qnil_v; /* Extract pre-key (33 bytes) */ uint8_t pk[34]; if (extract_unibyte(env, args[4], pk, sizeof(pk), NULL)) return Qnil_v; uint32_t spk_id = (uint32_t)env->extract_integer(env, args[5]); if (env->non_local_exit_check(env)) return Qnil_v; uint32_t pk_id = (uint32_t)env->extract_integer(env, args[6]); if (env->non_local_exit_check(env)) return Qnil_v; struct omemoSession *session = calloc(1, sizeof(*session)); if (!session) { signal_error(env, -1, "calloc failed"); return Qnil_v; } int rc = omemoInitiateSession(session, store, sig, spk, ik, pk, spk_id, pk_id); if (rc) { free(session); signal_error(env, rc, "omemoInitiateSession failed"); return Qnil_v; } return env->make_user_ptr(env, free_session, session); } /* jabber-omemo--serialize-session */ static emacs_value F_serialize_session(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; struct omemoSession *session = env->get_user_ptr(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; size_t sz = omemoGetSerializedSessionSize(session); uint8_t *buf = malloc(sz); if (!buf) { signal_error(env, -1, "malloc failed"); return Qnil_v; } omemoSerializeSession(buf, session); emacs_value result = make_unibyte(env, buf, sz); free(buf); return result; } /* jabber-omemo--deserialize-session */ static emacs_value F_deserialize_session(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; ptrdiff_t bloblen = 0; env->copy_string_contents(env, args[0], NULL, &bloblen); if (env->non_local_exit_check(env)) return Qnil_v; uint8_t *blob = malloc((size_t)bloblen); if (!blob) { signal_error(env, -1, "malloc failed"); return Qnil_v; } env->copy_string_contents(env, args[0], (char *)blob, &bloblen); if (env->non_local_exit_check(env)) { free(blob); return Qnil_v; } size_t datalen = (size_t)(bloblen - 1); struct omemoSession *session = calloc(1, sizeof(*session)); if (!session) { free(blob); signal_error(env, -1, "calloc failed"); return Qnil_v; } int rc = omemoDeserializeSession(blob, datalen, session); free(blob); if (rc) { free(session); signal_error(env, rc, "omemoDeserializeSession failed"); return Qnil_v; } return env->make_user_ptr(env, free_session, session); } /* jabber-omemo--encrypt-key */ static emacs_value F_encrypt_key(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; struct omemoSession *session = env->get_user_ptr(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; /* Extract plaintext key */ uint8_t keybuf[OMEMO_KEYSIZE + 1]; size_t keylen; if (extract_unibyte(env, args[1], keybuf, sizeof(keybuf), &keylen)) return Qnil_v; struct omemoKeyMessage msg; memset(&msg, 0, sizeof(msg)); int rc = omemoEncryptKey(session, &msg, keybuf, keylen); if (rc) { signal_error(env, rc, "omemoEncryptKey failed"); return Qnil_v; } emacs_value Qlist = env->intern(env, "list"); emacs_value plist_args[4]; plist_args[0] = Qdata; plist_args[1] = make_unibyte(env, msg.p, msg.n); plist_args[2] = Qpre_key_p; plist_args[3] = msg.isprekey ? Qt_v : Qnil_v; return env->funcall(env, Qlist, 4, plist_args); } /* jabber-omemo--decrypt-key */ static emacs_value F_decrypt_key(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; struct omemoSession *session = env->get_user_ptr(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; struct omemoStore *store = env->get_user_ptr(env, args[1]); if (env->non_local_exit_check(env)) return Qnil_v; bool isprekey = env->is_not_nil(env, args[2]); /* Extract encrypted message */ ptrdiff_t msglen_raw = 0; env->copy_string_contents(env, args[3], NULL, &msglen_raw); if (env->non_local_exit_check(env)) return Qnil_v; uint8_t *msgbuf = malloc((size_t)msglen_raw); if (!msgbuf) { signal_error(env, -1, "malloc failed"); return Qnil_v; } env->copy_string_contents(env, args[3], (char *)msgbuf, &msglen_raw); if (env->non_local_exit_check(env)) { free(msgbuf); return Qnil_v; } size_t msglen = (size_t)(msglen_raw - 1); uint8_t key[OMEMO_KEYSIZE]; size_t keyn = sizeof(key); int rc = omemoDecryptKey(session, store, key, &keyn, isprekey, msgbuf, msglen); free(msgbuf); if (rc) { signal_error(env, rc, "omemoDecryptKey failed"); return Qnil_v; } return make_unibyte(env, key, keyn); } /* jabber-omemo--heartbeat */ static emacs_value F_heartbeat(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; struct omemoSession *session = env->get_user_ptr(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; struct omemoStore *store = env->get_user_ptr(env, args[1]); if (env->non_local_exit_check(env)) return Qnil_v; struct omemoKeyMessage msg; memset(&msg, 0, sizeof(msg)); int rc = omemoHeartbeat(session, store, &msg); if (rc) { signal_error(env, rc, "omemoHeartbeat failed"); return Qnil_v; } if (msg.n == 0) return Qnil_v; return make_unibyte(env, msg.p, msg.n); } /* jabber-omemo--aesgcm-decrypt */ static emacs_value F_aesgcm_decrypt(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; /* Extract 32-byte key */ uint8_t key[33]; size_t keylen; if (extract_unibyte(env, args[0], key, sizeof(key), &keylen)) return Qnil_v; if (keylen != 32) { signal_error(env, -1, "aesgcm key must be exactly 32 bytes"); return Qnil_v; } /* Extract 12-byte IV */ uint8_t iv[13]; size_t ivlen; if (extract_unibyte(env, args[1], iv, sizeof(iv), &ivlen)) return Qnil_v; if (ivlen != 12) { signal_error(env, -1, "aesgcm IV must be exactly 12 bytes"); return Qnil_v; } /* Extract ciphertext + 16-byte GCM auth tag */ ptrdiff_t ct_raw = 0; env->copy_string_contents(env, args[2], NULL, &ct_raw); if (env->non_local_exit_check(env)) return Qnil_v; uint8_t *ctbuf = malloc((size_t)ct_raw); if (!ctbuf) { signal_error(env, -1, "malloc failed"); return Qnil_v; } env->copy_string_contents(env, args[2], (char *)ctbuf, &ct_raw); if (env->non_local_exit_check(env)) { free(ctbuf); return Qnil_v; } size_t total = (size_t)(ct_raw - 1); if (total < 16) { free(ctbuf); signal_error(env, -1, "aesgcm ciphertext too short (need >= 16 bytes for tag)"); return Qnil_v; } size_t ct_len = total - 16; const uint8_t *tag = ctbuf + ct_len; uint8_t *plaintext = malloc(ct_len); if (!plaintext) { free(ctbuf); signal_error(env, -1, "malloc failed"); return Qnil_v; } mbedtls_gcm_context ctx; mbedtls_gcm_init(&ctx); int rc = mbedtls_gcm_setkey(&ctx, MBEDTLS_CIPHER_ID_AES, key, 256); if (!rc) rc = mbedtls_gcm_auth_decrypt(&ctx, ct_len, iv, 12, NULL, 0, tag, 16, ctbuf, plaintext); mbedtls_gcm_free(&ctx); if (rc) { free(ctbuf); free(plaintext); signal_error(env, rc, "AES-256-GCM decryption failed"); return Qnil_v; } emacs_value result = make_unibyte(env, plaintext, ct_len); free(ctbuf); free(plaintext); return result; } /* jabber-omemo--aesgcm-encrypt */ static emacs_value F_aesgcm_encrypt(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; /* Extract plaintext */ ptrdiff_t pt_raw = 0; env->copy_string_contents(env, args[0], NULL, &pt_raw); if (env->non_local_exit_check(env)) return Qnil_v; uint8_t *ptbuf = malloc((size_t)pt_raw); if (!ptbuf) { signal_error(env, -1, "malloc failed"); return Qnil_v; } env->copy_string_contents(env, args[0], (char *)ptbuf, &pt_raw); if (env->non_local_exit_check(env)) { free(ptbuf); return Qnil_v; } size_t pt_len = (size_t)(pt_raw - 1); /* Generate random 32-byte key and 12-byte IV */ uint8_t key[32]; uint8_t iv[12]; if (getrandom(key, sizeof(key), 0) != sizeof(key)) { free(ptbuf); signal_error(env, -1, "getrandom failed for key"); return Qnil_v; } if (getrandom(iv, sizeof(iv), 0) != sizeof(iv)) { free(ptbuf); signal_error(env, -1, "getrandom failed for IV"); return Qnil_v; } /* Allocate output: ciphertext + 16-byte GCM auth tag */ uint8_t *outbuf = malloc(pt_len + 16); if (!outbuf) { free(ptbuf); signal_error(env, -1, "malloc failed"); return Qnil_v; } mbedtls_gcm_context ctx; mbedtls_gcm_init(&ctx); int rc = mbedtls_gcm_setkey(&ctx, MBEDTLS_CIPHER_ID_AES, key, 256); if (!rc) rc = mbedtls_gcm_crypt_and_tag(&ctx, MBEDTLS_GCM_ENCRYPT, pt_len, iv, 12, NULL, 0, ptbuf, outbuf, 16, outbuf + pt_len); mbedtls_gcm_free(&ctx); free(ptbuf); if (rc) { free(outbuf); signal_error(env, rc, "AES-256-GCM encryption failed"); return Qnil_v; } emacs_value Qlist = env->intern(env, "list"); emacs_value plist_args[6]; plist_args[0] = Qkey; plist_args[1] = make_unibyte(env, key, 32); plist_args[2] = Qiv; plist_args[3] = make_unibyte(env, iv, 12); plist_args[4] = Qciphertext; plist_args[5] = make_unibyte(env, outbuf, pt_len + 16); free(outbuf); return env->funcall(env, Qlist, 6, plist_args); } /* Module init */ int emacs_module_init(struct emacs_runtime *runtime) { if (runtime->size < sizeof(*runtime)) return 1; emacs_env *env = runtime->get_environment(runtime); if (env->size < sizeof(*env)) return 2; /* Cache symbols as global references so they survive GC */ #define GLOBAL_SYM(var, name) \ var = env->make_global_ref(env, env->intern(env, name)) GLOBAL_SYM(Qnil_v, "nil"); GLOBAL_SYM(Qt_v, "t"); GLOBAL_SYM(Qidentity_key, ":identity-key"); GLOBAL_SYM(Qsigned_pre_key, ":signed-pre-key"); GLOBAL_SYM(Qsigned_pre_key_id, ":signed-pre-key-id"); GLOBAL_SYM(Qsignature, ":signature"); GLOBAL_SYM(Qpre_keys, ":pre-keys"); GLOBAL_SYM(Qkey, ":key"); GLOBAL_SYM(Qiv, ":iv"); GLOBAL_SYM(Qciphertext, ":ciphertext"); GLOBAL_SYM(Qdata, ":data"); GLOBAL_SYM(Qpre_key_p, ":pre-key-p"); #undef GLOBAL_SYM /* Define error symbol */ Qjabber_omemo_error = env->make_global_ref( env, env->intern(env, "jabber-omemo-error")); { emacs_value args[2]; args[0] = Qjabber_omemo_error; args[1] = env->make_string(env, "OMEMO error", 11); env->funcall(env, env->intern(env, "define-error"), 2, args); } /* Bind functions */ #define DEFUN(lname, cfunc, minargs, maxargs, doc) \ bind_function(env, lname, \ env->make_function(env, minargs, maxargs, cfunc, \ doc, NULL)) DEFUN("jabber-omemo--setup-store", F_setup_store, 0, 0, "Generate a new OMEMO device store.\n" "Returns a serialized store as a unibyte string."); DEFUN("jabber-omemo--deserialize-store", F_deserialize_store, 1, 1, "Deserialize BLOB into an OMEMO store object.\n" "Returns a user-ptr; freed automatically by GC."); DEFUN("jabber-omemo--serialize-store", F_serialize_store, 1, 1, "Serialize STORE-PTR back to a unibyte string."); DEFUN("jabber-omemo--get-bundle", F_get_bundle, 1, 1, "Extract the public bundle from STORE-PTR.\n" "Returns a plist with keys :identity-key, :signed-pre-key,\n" ":signed-pre-key-id, :signature, :pre-keys."); DEFUN("jabber-omemo--rotate-signed-pre-key", F_rotate_signed_pre_key, 1, 1, "Rotate the signed pre-key in STORE-PTR.\n" "Mutates the store; caller must re-serialize."); DEFUN("jabber-omemo--refill-pre-keys", F_refill_pre_keys, 1, 1, "Refill removed pre-keys in STORE-PTR.\n" "Mutates the store; caller must re-serialize."); DEFUN("jabber-omemo--encrypt-message", F_encrypt_message, 1, 1, "Encrypt PLAINTEXT (a unibyte string) with OMEMO 0.3.\n" "Returns a plist (:key KEY :iv IV :ciphertext CT),\n" "all unibyte strings."); DEFUN("jabber-omemo--decrypt-message", F_decrypt_message, 3, 3, "Decrypt an OMEMO 0.3 message.\n" "KEY is a unibyte string (>= 32 bytes: 16 AES + auth tag).\n" "IV is a 12-byte unibyte string.\n" "CIPHERTEXT is the encrypted payload.\n" "Returns the plaintext as a unibyte string."); DEFUN("jabber-omemo--make-session", F_make_session, 0, 0, "Allocate an empty OMEMO session.\n" "Returns a session user-ptr; freed automatically by GC.\n" "Use for the receiving side of a pre-key message."); DEFUN("jabber-omemo--initiate-session", F_initiate_session, 7, 7, "Initiate an OMEMO session with a remote device's bundle.\n" "STORE-PTR is the local OMEMO store.\n" "SIGNATURE is a 64-byte unibyte string.\n" "SIGNED-PRE-KEY, IDENTITY-KEY, PRE-KEY are 33-byte unibyte strings.\n" "SPK-ID and PK-ID are integer key IDs.\n" "Returns a session user-ptr; freed automatically by GC."); DEFUN("jabber-omemo--serialize-session", F_serialize_session, 1, 1, "Serialize SESSION-PTR to a unibyte string."); DEFUN("jabber-omemo--deserialize-session", F_deserialize_session, 1, 1, "Deserialize BLOB into an OMEMO session object.\n" "Returns a session user-ptr; freed automatically by GC."); DEFUN("jabber-omemo--encrypt-key", F_encrypt_key, 2, 2, "Encrypt KEY for a recipient using SESSION-PTR.\n" "KEY is a unibyte string (the message encryption key).\n" "Returns a plist (:data BYTES :pre-key-p BOOL)."); DEFUN("jabber-omemo--decrypt-key", F_decrypt_key, 4, 4, "Decrypt an encrypted key message.\n" "SESSION-PTR is the session with the sender.\n" "STORE-PTR is the local OMEMO store.\n" "PRE-KEY-P is non-nil if this is a pre-key message.\n" "MSG is the encrypted key message as a unibyte string.\n" "Returns the decrypted key as a unibyte string."); DEFUN("jabber-omemo--heartbeat", F_heartbeat, 2, 2, "Check if a heartbeat message is needed after decryption.\n" "SESSION-PTR is the session to check.\n" "STORE-PTR is the local OMEMO store.\n" "Returns heartbeat message bytes or nil."); DEFUN("jabber-omemo--aesgcm-decrypt", F_aesgcm_decrypt, 3, 3, "Decrypt ciphertext using AES-256-GCM (for aesgcm:// URLs).\n" "KEY is a 32-byte unibyte string.\n" "IV is a 12-byte unibyte string.\n" "CIPHERTEXT-WITH-TAG has the 16-byte GCM auth tag appended.\n" "Returns the decrypted plaintext as a unibyte string."); DEFUN("jabber-omemo--aesgcm-encrypt", F_aesgcm_encrypt, 1, 1, "Encrypt PLAINTEXT using AES-256-GCM (for aesgcm:// URLs).\n" "Generates a random 32-byte key and 12-byte IV internally.\n" "Returns a plist (:key KEY :iv IV :ciphertext CT-WITH-TAG),\n" "all unibyte strings. The last 16 bytes of CT-WITH-TAG are\n" "the GCM auth tag."); #undef DEFUN provide(env, "jabber-omemo-core"); return 0; } emacs-jabber/src/picomemo/000077500000000000000000000000001516610113500157675ustar00rootroot00000000000000emacs-jabber/tests/000077500000000000000000000000001516610113500145325ustar00rootroot00000000000000emacs-jabber/tests/Makefile.am000066400000000000000000000006141516610113500165670ustar00rootroot00000000000000# LOG_COMPILER was introduced in Automake 1.12; don't expect "make # check" or "make distcheck" to work with earlier versions. LOG_COMPILER = env top_builddir=$(top_builddir) $(EMACS) -batch -L $(top_builddir) -L $(top_srcdir) -L $(srcdir) -l TESTS = load-all.el skip-tag-forward.el history.el jabberd.el nick-change-fail.el TESTS += caps-hash.el parse-next-stanza.el dist_noinst_DATA = $(TESTS) emacs-jabber/tests/caps-hash.el000066400000000000000000000026671516610113500167360ustar00rootroot00000000000000;;; caps-hash.el --- Test disco hash against examples in XEP-0115 -*- lexical-binding: t; -*- (require 'jabber-disco) (require 'jabber-widget) (let ((query (with-temp-buffer (insert " urn:xmpp:dataforms:softwareinfo ipv4 ipv6 Mac 10.5.1 Psi 0.11 ") (car (xml-parse-region (point-min) (point-max)))))) (message "parsed xml") (unless (equal "q07IKJEyjvHSyhy//CH0CxmKi8w=" (jabber-caps-ver-string query "sha-1")) (error "Incorrect caps hash"))) emacs-jabber/tests/jabber-activity-tests.el000066400000000000000000000225141516610113500212770ustar00rootroot00000000000000;;; jabber-activity-tests.el --- ERT tests for jabber-activity -*- lexical-binding: t; -*- ;;; Code: (require 'ert) (require 'cl-lib) ;; Stub out dependencies so we can load jabber-activity in isolation. (unless (featurep 'jabber-core) (provide 'jabber-core) (defvar *jabber-roster* nil) (defvar jabber-jid-obarray (make-vector 127 0))) (unless (featurep 'jabber-util) (provide 'jabber-util) (defun jabber-jid-displayname (jid) jid) (defun jabber-jid-user (jid) jid) (defun jabber-jid-username (jid) (when (string-match "\\`\\([^@]+\\)@" jid) (match-string 1 jid))) (defun jabber-jid-resource (jid) (when (string-match "/\\(.+\\)\\'" jid) (match-string 1 jid)))) ;; Stub MUC functions referenced by declare-function. (unless (fboundp 'jabber-muc-sender-p) (defun jabber-muc-sender-p (_jid) nil)) (unless (fboundp 'jabber-muc-find-buffer) (defun jabber-muc-find-buffer (_group) nil)) (unless (fboundp 'jabber-chat-find-buffer) (defun jabber-chat-find-buffer (_jid) nil)) (unless (fboundp 'jabber-muc-private-find-buffer) (defun jabber-muc-private-find-buffer (_group _nick) nil)) (unless (fboundp 'jabber-muc-joined-p) (defun jabber-muc-joined-p (_group) nil)) (unless (fboundp 'jabber-muc-looks-like-personal-p) (defun jabber-muc-looks-like-personal-p (_msg &optional _group) nil)) (load (expand-file-name "../lisp/jabber-activity.el" (file-name-directory (or load-file-name buffer-file-name)))) ;; Declare dynamically-bound variables used in let-bindings below. (defvar jabber-activity-jids) (defvar jabber-activity-personal-jids) (defvar jabber-activity-mode-string) (defvar jabber-activity-count-string) (defvar jabber-activity--updating) (defvar jabber-activity-update-hook) (defvar jabber-activity-make-string) (defvar jabber-activity-make-strings) (defvar jabber-activity-shorten-minimum) (defvar jabber-activity-shorten-aggressively) (defvar jabber-activity--shortened-names) (defvar jabber-activity-shorten-cutoff) (defvar jabber-activity-name-alist) (defvar *jabber-roster*) ;; Declare functions loaded at runtime via `load'. (declare-function jabber-activity-common-prefix "jabber-activity" (s1 s2)) (declare-function jabber-activity-make-strings-shorten "jabber-activity" (jids)) (declare-function jabber-activity-mode-line-update "jabber-activity" ()) (declare-function jabber-activity-make-name-alist "jabber-activity" ()) ;;; Group 1: jabber-activity-common-prefix (ert-deftest jabber-activity-test-common-prefix-basic () "Common prefix of strings with shared start." (should (= 3 (jabber-activity-common-prefix "abcdef" "abcxyz")))) (ert-deftest jabber-activity-test-common-prefix-empty () "Common prefix when one or both strings are empty." (should (= 0 (jabber-activity-common-prefix "" "abc"))) (should (= 0 (jabber-activity-common-prefix "abc" ""))) (should (= 0 (jabber-activity-common-prefix "" "")))) (ert-deftest jabber-activity-test-common-prefix-identical () "Common prefix of identical strings." (should (= 5 (jabber-activity-common-prefix "hello" "hello")))) (ert-deftest jabber-activity-test-common-prefix-no-match () "Common prefix of strings with no shared start." (should (= 0 (jabber-activity-common-prefix "abc" "xyz")))) (ert-deftest jabber-activity-test-common-prefix-substring () "Common prefix when one string is a prefix of the other." (should (= 3 (jabber-activity-common-prefix "abc" "abcdef"))) (should (= 3 (jabber-activity-common-prefix "abcdef" "abc")))) ;;; Group 2: jabber-activity-make-strings-shorten (ert-deftest jabber-activity-test-shorten-unique () "Shortened names should be unique." (let ((jabber-activity-make-string #'identity) (jabber-activity-shorten-minimum 1) (jabber-activity-shorten-aggressively nil) (jabber-activity--shortened-names (make-hash-table :test #'equal))) (let* ((result (jabber-activity-make-strings-shorten '("alice" "alex" "bob"))) (names (mapcar #'cdr result))) (should (= (length names) (length (cl-remove-duplicates names :test #'string=))))))) (ert-deftest jabber-activity-test-shorten-minimum-length () "Shortened names respect jabber-activity-shorten-minimum." (let ((jabber-activity-make-string #'identity) (jabber-activity-shorten-minimum 3) (jabber-activity-shorten-aggressively nil) (jabber-activity--shortened-names (make-hash-table :test #'equal))) (let ((result (jabber-activity-make-strings-shorten '("alice" "bob" "carol")))) (dolist (entry result) (should (>= (length (cdr entry)) 3)))))) (ert-deftest jabber-activity-test-shorten-aggressively () "Aggressive shortening allows prefixes shorter than minimum." (let ((jabber-activity-make-string #'identity) (jabber-activity-shorten-minimum 5) (jabber-activity-shorten-aggressively t) (jabber-activity--shortened-names (make-hash-table :test #'equal))) (let* ((result (jabber-activity-make-strings-shorten '("alice" "bob" "carol"))) (names (mapcar #'cdr result))) ;; With no shared prefixes and aggressive mode, names should be ;; shortened below the minimum of 5. (should (cl-some (lambda (n) (< (length n) 5)) names)) ;; But still unique. (should (= (length names) (length (cl-remove-duplicates names :test #'string=))))))) ;;; Group 3: re-entrance guard (ert-deftest jabber-activity-test-reentrance-guard () "Recursive calls to mode-line-update should be suppressed." (let ((jabber-activity-jids nil) (jabber-activity-personal-jids nil) (jabber-activity-mode-string "") (jabber-activity-count-string "0") (jabber-activity--updating nil) (jabber-activity-update-hook nil) (call-count 0)) ;; Hook that tries to re-enter. (add-hook 'jabber-activity-update-hook (lambda () (cl-incf call-count) (jabber-activity-mode-line-update))) (unwind-protect (progn (setq jabber-activity-jids '("test@example.com")) (setq jabber-activity-name-alist '(("test@example.com" . "test"))) (jabber-activity-mode-line-update) ;; Hook fires once; re-entrant call is blocked. (should (= call-count 1))) (remove-hook 'jabber-activity-update-hook t)))) ;;; Group 4: compare-before-update (ert-deftest jabber-activity-test-no-update-when-unchanged () "force-mode-line-update should not fire when strings are unchanged." (let ((jabber-activity-jids nil) (jabber-activity-personal-jids nil) (jabber-activity-mode-string "") (jabber-activity-count-string "0") (jabber-activity--updating nil) (jabber-activity-update-hook nil) (hook-called nil)) (add-hook 'jabber-activity-update-hook (lambda () (setq hook-called t))) (unwind-protect (progn ;; No JIDs, mode-string is already "", count is "0". (jabber-activity-mode-line-update) (should-not hook-called)) (remove-hook 'jabber-activity-update-hook t)))) (ert-deftest jabber-activity-test-update-when-changed () "Hook fires when the mode string changes." (let ((jabber-activity-jids nil) (jabber-activity-personal-jids nil) (jabber-activity-mode-string "old") (jabber-activity-count-string "1") (jabber-activity--updating nil) (jabber-activity-update-hook nil) (hook-called nil)) (add-hook 'jabber-activity-update-hook (lambda () (setq hook-called t))) (unwind-protect (progn ;; No JIDs, so new string will be "" which differs from "old". (jabber-activity-mode-line-update) (should hook-called)) (remove-hook 'jabber-activity-update-hook t)))) ;;; Group 5: cutoff truncation (ert-deftest jabber-activity-test-cutoff-overflow () "Mode string shows overflow indicator when exceeding cutoff." (let ((jabber-activity-shorten-cutoff 2) (jabber-activity-jids '("a@x" "b@x" "c@x" "d@x")) (jabber-activity-personal-jids nil) (jabber-activity-name-alist '(("a@x" . "A") ("b@x" . "B") ("c@x" . "C") ("d@x" . "D"))) (jabber-activity-mode-string "") (jabber-activity-count-string "0") (jabber-activity--updating nil) (jabber-activity-update-hook nil)) (jabber-activity-mode-line-update) (should (string-match-p ", \\+2\\]\\'" jabber-activity-mode-string)) (should (string= jabber-activity-count-string "4")))) (ert-deftest jabber-activity-test-no-cutoff () "No overflow indicator when cutoff is nil." (let ((jabber-activity-shorten-cutoff nil) (jabber-activity-jids '("a@x" "b@x" "c@x")) (jabber-activity-personal-jids nil) (jabber-activity-name-alist '(("a@x" . "A") ("b@x" . "B") ("c@x" . "C"))) (jabber-activity-mode-string "") (jabber-activity-count-string "0") (jabber-activity--updating nil) (jabber-activity-update-hook nil)) (jabber-activity-mode-line-update) (should-not (string-match-p "\\+" jabber-activity-mode-string)))) ;;; Group 6: cache invalidation (ert-deftest jabber-activity-test-cache-invalidation () "Cache is cleared when name alist is rebuilt." (let ((jabber-activity-make-strings #'jabber-activity-make-strings-shorten) (jabber-activity-make-string #'identity) (jabber-activity-shorten-minimum 1) (jabber-activity-shorten-aggressively nil) (jabber-activity--shortened-names (make-hash-table :test #'equal)) (jabber-activity-name-alist '(("foo@bar" . "foo"))) (*jabber-roster* nil)) ;; Populate cache. (jabber-activity-make-strings-shorten '("foo@bar")) (should (= 1 (hash-table-count jabber-activity--shortened-names))) ;; Rebuild name alist should clear cache. (jabber-activity-make-name-alist) (should (= 0 (hash-table-count jabber-activity--shortened-names))))) (provide 'jabber-activity-tests) ;;; jabber-activity-tests.el ends here emacs-jabber/tests/jabber-bookmarks-tests.el000066400000000000000000000754131516610113500214410ustar00rootroot00000000000000;;; jabber-bookmarks-tests.el --- Tests for jabber-bookmarks -*- lexical-binding: t; -*- (require 'ert) ;; Pre-define variables that other modules expect at load time: (defvar jabber-body-printers nil) (defvar jabber-message-chain nil) (defvar jabber-presence-chain nil) (defvar jabber-iq-chain nil) (defvar jabber-jid-obarray (make-vector 127 0)) (require 'jabber-bookmarks) ;;; Group 1: Parse XEP-0402 items (ert-deftest jabber-bookmarks2-test-parse-full () "Parse conference item with all fields." (let* ((item '(item ((id . "room@conference.example.com")) (conference ((xmlns . "urn:xmpp:bookmarks:1") (name . "The Room") (autojoin . "true")) (nick () "MyNick") (password () "secret")))) (result (jabber-bookmarks2--parse-item item))) (should (string= (plist-get result :jid) "room@conference.example.com")) (should (string= (plist-get result :name) "The Room")) (should (plist-get result :autojoin)) (should (string= (plist-get result :nick) "MyNick")) (should (string= (plist-get result :password) "secret")))) (ert-deftest jabber-bookmarks2-test-parse-minimal () "Parse conference item with only JID (no name, nick, password)." (let* ((item '(item ((id . "room@conference.example.com")) (conference ((xmlns . "urn:xmpp:bookmarks:1"))))) (result (jabber-bookmarks2--parse-item item))) (should (string= (plist-get result :jid) "room@conference.example.com")) (should-not (plist-get result :name)) (should-not (plist-get result :autojoin)) (should-not (plist-get result :nick)) (should-not (plist-get result :password)))) (ert-deftest jabber-bookmarks2-test-parse-autojoin-variants () "Parse autojoin attribute: \"true\", \"1\", and absent." (let ((make-item (lambda (val) `(item ((id . "r@c.example.com")) (conference ((xmlns . "urn:xmpp:bookmarks:1") ,@(when val `((autojoin . ,val))))))))) (should (plist-get (jabber-bookmarks2--parse-item (funcall make-item "true")) :autojoin)) (should (plist-get (jabber-bookmarks2--parse-item (funcall make-item "1")) :autojoin)) (should-not (plist-get (jabber-bookmarks2--parse-item (funcall make-item nil)) :autojoin)) (should-not (plist-get (jabber-bookmarks2--parse-item (funcall make-item "false")) :autojoin)))) (ert-deftest jabber-bookmarks2-test-parse-no-conference () "Return nil when item has no child." (let ((item '(item ((id . "room@conference.example.com")) (something-else ())))) (should-not (jabber-bookmarks2--parse-item item)))) ;;; Group 2: Build conference XML (ert-deftest jabber-bookmarks2-test-build-full () "Build conference element with all fields." (let ((elem (jabber-bookmarks2--build-conference '(:jid "room@c.example.com" :name "Room" :autojoin t :nick "Me" :password "pw")))) (should (eq (car elem) 'conference)) (should (string= (cdr (assq 'xmlns (cadr elem))) "urn:xmpp:bookmarks:1")) (should (string= (cdr (assq 'name (cadr elem))) "Room")) (should (string= (cdr (assq 'autojoin (cadr elem))) "true")) ;; Check nick child (let ((nick (car (jabber-xml-get-children elem 'nick)))) (should nick) (should (string= (car (jabber-xml-node-children nick)) "Me"))) ;; Check password child (let ((pw (car (jabber-xml-get-children elem 'password)))) (should pw) (should (string= (car (jabber-xml-node-children pw)) "pw"))))) (ert-deftest jabber-bookmarks2-test-build-minimal () "Build conference element with JID only." (let ((elem (jabber-bookmarks2--build-conference '(:jid "room@c.example.com")))) (should (eq (car elem) 'conference)) (should (string= (cdr (assq 'xmlns (cadr elem))) "urn:xmpp:bookmarks:1")) (should-not (assq 'name (cadr elem))) (should-not (assq 'autojoin (cadr elem))) (should-not (jabber-xml-get-children elem 'nick)) (should-not (jabber-xml-get-children elem 'password)))) (ert-deftest jabber-bookmarks2-test-build-autojoin-false () "Autojoin nil omits the attribute entirely." (let ((elem (jabber-bookmarks2--build-conference '(:jid "r@c.example.com" :autojoin nil)))) (should-not (assq 'autojoin (cadr elem))))) (ert-deftest jabber-bookmarks2-test-roundtrip () "Build then parse returns equivalent plist." (let* ((original '(:jid "room@c.example.com" :name "Room" :autojoin t :nick "Me" :password "pw")) (elem (jabber-bookmarks2--build-conference original)) (item `(item ((id . "room@c.example.com")) ,elem)) (parsed (jabber-bookmarks2--parse-item item))) (should (string= (plist-get parsed :jid) "room@c.example.com")) (should (string= (plist-get parsed :name) "Room")) (should (plist-get parsed :autojoin)) (should (string= (plist-get parsed :nick) "Me")) (should (string= (plist-get parsed :password) "pw")))) ;;; Group 3: Parse XEP-0048 items (regression) (ert-deftest jabber-bookmarks-test-parse-0048 () "Verify jabber-parse-conference-bookmark still works for XEP-0048." (let* ((node '(conference ((jid . "room@conference.example.com") (name . "Old Room") (autojoin . "true")) (nick () "OldNick") (password () "oldpw"))) (result (jabber-parse-conference-bookmark node))) (should (string= (plist-get result :jid) "room@conference.example.com")) (should (string= (plist-get result :name) "Old Room")) (should (plist-get result :autojoin)) (should (string= (plist-get result :nick) "OldNick")) (should (string= (plist-get result :password) "oldpw")))) (ert-deftest jabber-bookmarks-test-parse-0048-minimal () "XEP-0048 conference with no optional fields." (let* ((node '(conference ((jid . "room@conference.example.com")))) (result (jabber-parse-conference-bookmark node))) (should (string= (plist-get result :jid) "room@conference.example.com")) (should-not (plist-get result :autojoin)) (should-not (plist-get result :nick)))) (ert-deftest jabber-bookmarks-test-parse-non-conference () "jabber-parse-conference-bookmark returns nil for non-conference nodes." (should-not (jabber-parse-conference-bookmark '(url ((url . "http://example.com") (name . "Test")))))) ;;; Group 4: Fetch and cache (defun jabber-bookmarks-test--fake-jc () "Create a fake connection symbol with bare JID." (let ((jc (gensym "test-jc-"))) (put jc :state-data '(:username "user" :server "example.com")) jc)) (defun jabber-bookmarks-test--bare-jid (jc) "Return bare JID for fake JC." (let ((data (get jc :state-data))) (concat (plist-get data :username) "@" (plist-get data :server)))) (ert-deftest jabber-bookmarks2-test-handle-fetch () "PubSub response is parsed into plists and cached." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (jc (jabber-bookmarks-test--fake-jc)) (result nil)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (j) (jabber-bookmarks-test--bare-jid j)))) (jabber-bookmarks2--handle-fetch jc `(iq ((type . "result")) (pubsub ((xmlns . ,jabber-pubsub-xmlns)) (items ((node . ,jabber-bookmarks2-xmlns)) (item ((id . "room1@c.example.com")) (conference ((xmlns . ,jabber-bookmarks2-xmlns) (name . "Room 1") (autojoin . "true")) (nick () "Me"))) (item ((id . "room2@c.example.com")) (conference ((xmlns . ,jabber-bookmarks2-xmlns))))))) (lambda (_jc bookmarks) (setq result bookmarks)))) ;; Two bookmarks parsed (should (= 2 (length result))) (should (string= (plist-get (nth 0 result) :jid) "room1@c.example.com")) (should (plist-get (nth 0 result) :autojoin)) (should (string= (plist-get (nth 0 result) :nick) "Me")) (should (string= (plist-get (nth 1 result) :jid) "room2@c.example.com")) ;; Cached (let ((cached (gethash "user@example.com" jabber-bookmarks))) (should (listp cached)) (should (= 2 (length cached)))))) (ert-deftest jabber-bookmarks2-test-handle-fetch-empty () "Empty PubSub response caches t." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (jc (jabber-bookmarks-test--fake-jc)) (result 'not-called)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (j) (jabber-bookmarks-test--bare-jid j)))) (jabber-bookmarks2--handle-fetch jc `(iq ((type . "result")) (pubsub ((xmlns . ,jabber-pubsub-xmlns)) (items ((node . ,jabber-bookmarks2-xmlns))))) (lambda (_jc bookmarks) (setq result bookmarks)))) (should (null result)) (should (eq t (gethash "user@example.com" jabber-bookmarks))))) (ert-deftest jabber-bookmarks-test-handle-legacy () "XEP-0049 storage response is parsed to plists and cached." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (jabber-bookmarks--legacy-accounts (make-hash-table :test 'equal)) (jc (jabber-bookmarks-test--fake-jc)) (result nil)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (j) (jabber-bookmarks-test--bare-jid j)))) (jabber-bookmarks--handle-legacy jc '(storage ((xmlns . "storage:bookmarks")) (conference ((jid . "room@c.example.com") (name . "Room") (autojoin . "1")) (nick () "Nick")) (url ((url . "http://example.com") (name . "Site")))) (lambda (_jc bookmarks) (setq result bookmarks)))) ;; Only conference is kept (url is discarded) (should (= 1 (length result))) (should (string= (plist-get (car result) :jid) "room@c.example.com")) (should (string= (plist-get (car result) :nick) "Nick")))) (ert-deftest jabber-bookmarks-test-get-uses-cache () "jabber-get-bookmarks returns cached data without fetching." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (jc (jabber-bookmarks-test--fake-jc)) (result nil) (fetched nil)) (puthash "user@example.com" (list '(:jid "cached@c.example.com" :name "Cached")) jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (j) (jabber-bookmarks-test--bare-jid j))) ((symbol-function 'jabber-bookmarks--detect-and-fetch) (lambda (&rest _) (setq fetched t))) ((symbol-function 'run-with-timer) (lambda (_delay _repeat fn &rest args) (apply fn args)))) (jabber-get-bookmarks jc (lambda (_jc bms) (setq result bms))) (should-not fetched) (should (= 1 (length result))) (should (string= (plist-get (car result) :jid) "cached@c.example.com"))))) (ert-deftest jabber-bookmarks-test-get-conference-data-from-cache () "jabber-get-conference-data-internal finds by JID in plist cache." (let ((cache '((:jid "room1@c.example.com" :name "Room 1" :nick "A") (:jid "room2@c.example.com" :name "Room 2" :nick "B")))) (should (string= (jabber-get-conference-data-internal cache "room2@c.example.com" :nick) "B")) (should (string= (plist-get (jabber-get-conference-data-internal cache "room1@c.example.com" nil) :name) "Room 1")) (should-not (jabber-get-conference-data-internal cache "unknown@c.example.com" nil)))) ;;; Group 5: Publish and retract IQ structure (defvar jabber-bookmarks-test--iq-calls nil "List of captured jabber-send-iq calls.") (defmacro jabber-bookmarks-test-with-mock-iq (&rest body) "Execute BODY with `jabber-send-iq' mocked to capture calls." `(let ((jabber-bookmarks-test--iq-calls nil)) (cl-letf (((symbol-function 'jabber-send-iq) (lambda (jc to type query &optional success-cb _success-data error-cb _error-data &rest _) (push (list :jc jc :to to :type type :query query :success-cb success-cb :error-cb error-cb) jabber-bookmarks-test--iq-calls)))) ,@body))) (ert-deftest jabber-bookmarks2-test-publish-iq () "Publish sends correct PubSub IQ with publish-options." (jabber-bookmarks-test-with-mock-iq (jabber-bookmarks2--publish 'fake-jc '(:jid "room@c.example.com" :name "Room" :autojoin t :nick "Me")) (should (= 1 (length jabber-bookmarks-test--iq-calls))) (let* ((call (car jabber-bookmarks-test--iq-calls)) (query (plist-get call :query)) (publish (nth 2 query)) (item (nth 2 publish))) (should (eq (car query) 'pubsub)) (should (eq (car publish) 'publish)) (should (string= (cdr (assq 'node (cadr publish))) jabber-bookmarks2-xmlns)) (should (string= (cdr (assq 'id (cadr item))) "room@c.example.com")) ;; Has publish-options (let ((pub-opts (cl-find 'publish-options (cddr query) :key #'car))) (should pub-opts))))) (ert-deftest jabber-bookmarks2-test-retract-iq () "Retract sends correct PubSub IQ with notify." (jabber-bookmarks-test-with-mock-iq (jabber-bookmarks2--retract 'fake-jc "room@c.example.com") (should (= 1 (length jabber-bookmarks-test--iq-calls))) (let* ((call (car jabber-bookmarks-test--iq-calls)) (query (plist-get call :query)) (retract (nth 2 query)) (item (nth 2 retract))) (should (string= (cdr (assq 'notify (cadr retract))) "true")) (should (string= (cdr (assq 'id (cadr item))) "room@c.example.com"))))) ;;; Group 6: set-bookmarks diff logic (ert-deftest jabber-bookmarks-test-set-publishes-and-retracts () "set-bookmarks publishes new/changed and retracts removed." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (published nil) (retracted nil) (cb-result nil)) ;; Old cache: room1 and room2 (puthash "user@example.com" '((:jid "room1@c.example.com" :name "Room 1") (:jid "room2@c.example.com" :name "Room 2")) jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "user@example.com")) ((symbol-function 'jabber-bookmarks2--publish) (lambda (jc plist &optional cb _ecb) (push (plist-get plist :jid) published) (when cb (funcall cb jc nil nil)))) ((symbol-function 'jabber-bookmarks2--retract) (lambda (jc jid &optional cb _ecb) (push jid retracted) (when cb (funcall cb jc nil nil))))) ;; New: keep room1, add room3, drop room2 (jabber-set-bookmarks 'fake-jc '((:jid "room1@c.example.com" :name "Room 1") (:jid "room3@c.example.com" :name "Room 3")) (lambda (_jc ok) (setq cb-result ok)))) (should (member "room1@c.example.com" published)) (should (member "room3@c.example.com" published)) (should (equal retracted '("room2@c.example.com"))) (should cb-result))) (ert-deftest jabber-bookmarks-test-set-empty-to-empty () "set-bookmarks with no old and no new succeeds immediately." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (cb-result nil)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "user@example.com"))) (jabber-set-bookmarks 'fake-jc nil (lambda (_jc ok) (setq cb-result ok)))) (should cb-result))) (ert-deftest jabber-bookmarks-test-set-falls-back-on-error () "set-bookmarks falls back to XEP-0049 on PubSub error." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (legacy-called nil)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "user@example.com")) ((symbol-function 'jabber-bookmarks2--publish) (lambda (jc _plist &optional _cb ecb) ;; Simulate PubSub error (when ecb (funcall ecb jc nil nil)))) ((symbol-function 'jabber-bookmarks--set-legacy) (lambda (_jc _bms &optional _cb) (setq legacy-called t)))) (jabber-set-bookmarks 'fake-jc '((:jid "room@c.example.com" :name "Room")) #'ignore)) (should legacy-called))) ;;; Group 7: Event handler (live sync) (ert-deftest jabber-bookmarks2-test-event-item-autojoin () "New item with autojoin=true updates cache and joins." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (joined nil)) (puthash "user@example.com" t jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "user@example.com")) ((symbol-function 'jabber-muc-joined-p) (lambda (_g &optional _jc) nil)) ((symbol-function 'jabber-muc-join) (lambda (_jc group _nick &optional _popup) (push group joined))) ((symbol-function 'fsm-get-state-data) (lambda (_jc) '(:username "user")))) (jabber-bookmarks2--handle-event 'fake-jc nil nil `((item ((id . "room@c.example.com")) (conference ((xmlns . ,jabber-bookmarks2-xmlns) (autojoin . "true")) (nick () "Me")))))) (should (member "room@c.example.com" joined)) (let ((cached (gethash "user@example.com" jabber-bookmarks))) (should (= 1 (length cached))) (should (string= (plist-get (car cached) :jid) "room@c.example.com"))))) (ert-deftest jabber-bookmarks2-test-event-item-no-autojoin-leaves () "Item without autojoin leaves if currently joined." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (left nil)) (puthash "user@example.com" '((:jid "room@c.example.com" :autojoin t)) jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "user@example.com")) ((symbol-function 'jabber-muc-joined-p) (lambda (_g &optional _jc) t)) ((symbol-function 'jabber-muc-get-buffer) (lambda (_g &optional _jc) nil)) ((symbol-function 'jabber-muc-leave) (lambda (_jc group) (push group left)))) (jabber-bookmarks2--handle-event 'fake-jc nil nil `((item ((id . "room@c.example.com")) (conference ((xmlns . ,jabber-bookmarks2-xmlns))))))) (should (member "room@c.example.com" left)))) (ert-deftest jabber-bookmarks2-test-event-retract () "Retract removes from cache and leaves." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (left nil)) (puthash "user@example.com" '((:jid "room@c.example.com" :name "Room")) jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "user@example.com")) ((symbol-function 'jabber-muc-joined-p) (lambda (_g &optional _jc) t)) ((symbol-function 'jabber-muc-get-buffer) (lambda (_g &optional _jc) nil)) ((symbol-function 'jabber-muc-leave) (lambda (_jc group) (push group left)))) (jabber-bookmarks2--handle-event 'fake-jc nil nil '((retract ((id . "room@c.example.com")))))) (should (member "room@c.example.com" left)) ;; Cache should be t (empty) (should (eq t (gethash "user@example.com" jabber-bookmarks))))) (ert-deftest jabber-bookmarks2-test-event-already-joined-skips () "Item with autojoin for already-joined room does not re-join." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (join-count 0)) (puthash "user@example.com" t jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "user@example.com")) ((symbol-function 'jabber-muc-joined-p) (lambda (_g &optional _jc) t)) ((symbol-function 'jabber-muc-join) (lambda (&rest _) (cl-incf join-count)))) (jabber-bookmarks2--handle-event 'fake-jc nil nil `((item ((id . "room@c.example.com")) (conference ((xmlns . ,jabber-bookmarks2-xmlns) (autojoin . "true"))))))) (should (= 0 join-count)))) (ert-deftest jabber-bookmarks2-test-event-retract-not-joined-skips () "Retract for not-joined room only updates cache." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (leave-count 0)) (puthash "user@example.com" '((:jid "room@c.example.com")) jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "user@example.com")) ((symbol-function 'jabber-muc-joined-p) (lambda (_g &optional _jc) nil)) ((symbol-function 'jabber-muc-leave) (lambda (&rest _) (cl-incf leave-count)))) (jabber-bookmarks2--handle-event 'fake-jc nil nil '((retract ((id . "room@c.example.com")))))) (should (= 0 leave-count)) (should (eq t (gethash "user@example.com" jabber-bookmarks))))) ;;; Group 8: Cache management (ert-deftest jabber-bookmarks2-test-update-cache-new () "Update cache adds a new bookmark." (let ((jabber-bookmarks (make-hash-table :test 'equal))) (puthash "user@example.com" t jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "user@example.com"))) (jabber-bookmarks2--update-cache 'fake-jc '(:jid "room@c.example.com" :name "Room"))) (let ((cached (gethash "user@example.com" jabber-bookmarks))) (should (= 1 (length cached))) (should (string= (plist-get (car cached) :jid) "room@c.example.com"))))) (ert-deftest jabber-bookmarks2-test-update-cache-replace () "Update cache replaces existing entry with same JID." (let ((jabber-bookmarks (make-hash-table :test 'equal))) (puthash "user@example.com" '((:jid "room@c.example.com" :name "Old")) jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "user@example.com"))) (jabber-bookmarks2--update-cache 'fake-jc '(:jid "room@c.example.com" :name "New"))) (let ((cached (gethash "user@example.com" jabber-bookmarks))) (should (= 1 (length cached))) (should (string= (plist-get (car cached) :name) "New"))))) (ert-deftest jabber-bookmarks2-test-remove-from-cache () "Remove from cache drops the entry." (let ((jabber-bookmarks (make-hash-table :test 'equal))) (puthash "user@example.com" '((:jid "room1@c.example.com") (:jid "room2@c.example.com")) jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "user@example.com"))) (jabber-bookmarks2--remove-from-cache 'fake-jc "room1@c.example.com")) (let ((cached (gethash "user@example.com" jabber-bookmarks))) (should (= 1 (length cached))) (should (string= (plist-get (car cached) :jid) "room2@c.example.com"))))) (ert-deftest jabber-bookmarks2-test-remove-last-caches-t () "Removing the last bookmark caches t." (let ((jabber-bookmarks (make-hash-table :test 'equal))) (puthash "user@example.com" '((:jid "room@c.example.com")) jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "user@example.com"))) (jabber-bookmarks2--remove-from-cache 'fake-jc "room@c.example.com")) (should (eq t (gethash "user@example.com" jabber-bookmarks))))) ;;; Group 9: Tabulated-list entries (ert-deftest jabber-bookmarks-test-entries-full () "Entries builds correct vectors from cache." (let ((jabber-bookmarks (make-hash-table :test 'equal))) (puthash "user@example.com" '((:jid "room@c.example.com" :name "Room" :autojoin t :nick "Me" :password "secret")) jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (j) (jabber-bookmarks-test--bare-jid j)))) (with-temp-buffer (setq-local jabber-buffer-connection (jabber-bookmarks-test--fake-jc)) (let ((entries (jabber-bookmarks--entries))) (should (= 1 (length entries))) (let ((entry (car entries))) (should (string= (car entry) "room@c.example.com")) (let ((cols (cadr entry))) (should (string= (aref cols 0) "room@c.example.com")) (should (string= (aref cols 1) "Room")) (should (string= (aref cols 2) "true")) (should (string= (aref cols 3) "Me")) (should (string= (aref cols 4) "***"))))))))) (ert-deftest jabber-bookmarks-test-entries-minimal () "Entries handles missing optional fields." (let ((jabber-bookmarks (make-hash-table :test 'equal))) (puthash "user@example.com" '((:jid "room@c.example.com")) jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (j) (jabber-bookmarks-test--bare-jid j)))) (with-temp-buffer (setq-local jabber-buffer-connection (jabber-bookmarks-test--fake-jc)) (let* ((entries (jabber-bookmarks--entries)) (cols (cadr (car entries)))) (should (string= (aref cols 1) "")) (should (string= (aref cols 2) "false")) (should (string= (aref cols 3) "")) (should (string= (aref cols 4) ""))))))) (ert-deftest jabber-bookmarks-test-entries-empty () "Entries returns nil when cache is empty (t)." (let ((jabber-bookmarks (make-hash-table :test 'equal))) (puthash "user@example.com" t jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (j) (jabber-bookmarks-test--bare-jid j)))) (with-temp-buffer (setq-local jabber-buffer-connection (jabber-bookmarks-test--fake-jc)) (should-not (jabber-bookmarks--entries)))))) ;;; Group 10: Legacy account detection and write routing (ert-deftest jabber-bookmarks-test-legacy-flag-set-on-fallback () "Legacy flag is set when fetch falls back to XEP-0049." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (jabber-bookmarks--legacy-accounts (make-hash-table :test 'equal)) (jc (jabber-bookmarks-test--fake-jc))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (j) (jabber-bookmarks-test--bare-jid j)))) (jabber-bookmarks--handle-legacy jc '(storage ((xmlns . "storage:bookmarks")) (conference ((jid . "room@c.example.com") (autojoin . "1")))) #'ignore) (should (jabber-bookmarks--legacy-p jc))))) (ert-deftest jabber-bookmarks-test-legacy-flag-cleared-on-pubsub () "Legacy flag is cleared when PubSub fetch succeeds." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (jabber-bookmarks--legacy-accounts (make-hash-table :test 'equal)) (jc (jabber-bookmarks-test--fake-jc))) (puthash "user@example.com" t jabber-bookmarks--legacy-accounts) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (j) (jabber-bookmarks-test--bare-jid j)))) (jabber-bookmarks2--handle-fetch jc `(iq ((type . "result")) (pubsub ((xmlns . ,jabber-pubsub-xmlns)) (items ((node . ,jabber-bookmarks2-xmlns))))) #'ignore) (should-not (jabber-bookmarks--legacy-p jc))))) (ert-deftest jabber-bookmarks-test-set-uses-legacy-when-flagged () "jabber-set-bookmarks uses XEP-0049 when account is legacy." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (jabber-bookmarks--legacy-accounts (make-hash-table :test 'equal)) (legacy-called nil) (pubsub-called nil)) (puthash "user@example.com" t jabber-bookmarks--legacy-accounts) (puthash "user@example.com" '((:jid "room@c.example.com" :name "Room")) jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "user@example.com")) ((symbol-function 'jabber-bookmarks--set-legacy) (lambda (_jc _bms &optional _cb) (setq legacy-called t))) ((symbol-function 'jabber-bookmarks2--publish) (lambda (&rest _) (setq pubsub-called t)))) (jabber-set-bookmarks 'fake-jc '((:jid "room@c.example.com" :name "Room" :autojoin t)) #'ignore)) (should legacy-called) (should-not pubsub-called))) (ert-deftest jabber-bookmarks-test-toggle-uses-legacy-when-flagged () "Toggle autojoin writes via legacy bulk save on legacy accounts." (let ((jabber-bookmarks (make-hash-table :test 'equal)) (jabber-bookmarks--legacy-accounts (make-hash-table :test 'equal)) (legacy-called nil) (pubsub-called nil)) (puthash "user@example.com" t jabber-bookmarks--legacy-accounts) (puthash "user@example.com" '((:jid "room@c.example.com" :name "Room" :autojoin nil)) jabber-bookmarks) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "user@example.com")) ((symbol-function 'jabber-bookmarks--set-legacy) (lambda (jc _bms &optional cb) (setq legacy-called t) (when cb (funcall cb jc nil t)))) ((symbol-function 'jabber-bookmarks2--publish) (lambda (&rest _) (setq pubsub-called t))) ((symbol-function 'jabber-muc-joined-p) (lambda (_g &optional _jc) nil)) ((symbol-function 'jabber-muc-join) (lambda (&rest _) nil)) ((symbol-function 'fsm-get-state-data) (lambda (_jc) '(:username "user"))) ((symbol-function 'jabber-bookmarks--get-bookmark-at-point) (lambda () '(:jid "room@c.example.com" :name "Room" :autojoin nil)))) (with-temp-buffer (setq-local jabber-buffer-connection 'fake-jc) (jabber-bookmarks-toggle-autojoin))) (should legacy-called) (should-not pubsub-called))) (provide 'jabber-bookmarks-tests) ;;; jabber-bookmarks-tests.el ends here emacs-jabber/tests/jabber-carbons-tests.el000066400000000000000000000231421516610113500210700ustar00rootroot00000000000000;;; jabber-carbons-tests.el --- Tests for XEP-0280 carbon handling -*- lexical-binding: t; -*- ;; Copyright (C) 2026 - Thanos Apollo ;; Author: Thanos Apollo ;; Maintainer: Thanos Apollo ;; 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 ;;; Code: (require 'ert) (require 'jabber-chat) (require 'jabber-db) (require 'jabber-message-correct) ;;; Test helpers (defun jabber-carbons-test--make-carbon (type from inner-from inner-to &optional id body) "Build a carbon-wrapped message stanza. TYPE is `sent' or `received'. FROM is the outer stanza's from. INNER-FROM and INNER-TO are attributes on the inner message. Optional ID is the inner message's stanza id. Optional BODY overrides the default \"Hello\"." (let ((inner-attrs `((from . ,inner-from) (to . ,inner-to) (type . "chat")))) (when id (push `(id . ,id) inner-attrs)) `(message ((from . ,from) (type . "chat")) (,type ((xmlns . "urn:xmpp:carbons:2")) (forwarded ((xmlns . "urn:xmpp:forward:0")) (message ,inner-attrs (body nil ,(or body "Hello")))))))) (defun jabber-carbons-test--make-plain-message (from to) "Build a plain (non-carbon) message stanza." `(message ((from . ,from) (to . ,to) (type . "chat")) (body nil "Hello"))) ;;; Group 1: jabber-chat--extract-carbon (ert-deftest jabber-chat-test-extract-carbon-sent () "Extract-carbon returns (sent . msg) for a sent carbon." (let* ((stanza (jabber-carbons-test--make-carbon 'sent "me@example.com" "me@example.com/phone" "friend@example.com")) (result (jabber-chat--extract-carbon stanza))) (should result) (should (eq (car result) 'sent)) (should (equal (jabber-xml-get-attribute (cdr result) 'to) "friend@example.com")))) (ert-deftest jabber-chat-test-extract-carbon-received () "Extract-carbon returns (received . msg) for a received carbon." (let* ((stanza (jabber-carbons-test--make-carbon 'received "me@example.com" "friend@example.com" "me@example.com/phone")) (result (jabber-chat--extract-carbon stanza))) (should result) (should (eq (car result) 'received)) (should (equal (jabber-xml-get-attribute (cdr result) 'from) "friend@example.com")))) (ert-deftest jabber-chat-test-extract-carbon-plain () "Extract-carbon returns nil for a plain message." (let* ((stanza (jabber-carbons-test--make-plain-message "friend@example.com" "me@example.com")) (result (jabber-chat--extract-carbon stanza))) (should-not result))) ;;; Group 2: jabber-chat--unwrap-carbon (ert-deftest jabber-chat-test-unwrap-carbon-rejects-forged () "Unwrap-carbon drops carbon framing when outer from doesn't match our JID." (let* ((stanza (jabber-carbons-test--make-carbon 'sent "evil@attacker.com" "evil@attacker.com/phone" "victim@example.com"))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (let ((result (jabber-chat--unwrap-carbon 'fake-jc stanza))) ;; Should return original stanza unchanged (carbon rejected) (should (eq (car result) stanza)) (should-not (cdr result)))))) (ert-deftest jabber-chat-test-unwrap-carbon-valid-sent () "Unwrap-carbon returns inner message and buffer for valid sent carbon." (let* ((stanza (jabber-carbons-test--make-carbon 'sent "me@example.com" "me@example.com/phone" "friend@example.com")) (test-buffer (generate-new-buffer " *test-carbon*"))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-chat-create-buffer) (lambda (_jc _to) test-buffer))) (unwind-protect (let ((result (jabber-chat--unwrap-carbon 'fake-jc stanza))) (should (equal (jabber-xml-get-attribute (car result) 'to) "friend@example.com")) (should (eq (cdr result) test-buffer))) (kill-buffer test-buffer))))) (ert-deftest jabber-chat-test-unwrap-carbon-valid-received () "Unwrap-carbon returns inner message with no buffer for valid received carbon." (let* ((stanza (jabber-carbons-test--make-carbon 'received "me@example.com" "friend@example.com" "me@example.com/phone"))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (let ((result (jabber-chat--unwrap-carbon 'fake-jc stanza))) (should (equal (jabber-xml-get-attribute (car result) 'from) "friend@example.com")) (should-not (cdr result)))))) ;;; Group 3: jabber-chat--store-carbon (defvar jabber-db-path) (defvar jabber-db--connection) (defvar jabber-backlog-days) (defvar jabber-backlog-number) (declare-function jabber-db-ensure-open "jabber-db" ()) (declare-function jabber-db-close "jabber-db" ()) (defmacro jabber-carbons-test-with-db (&rest body) "Run BODY with a fresh temp SQLite database." (declare (indent 0) (debug t)) `(let* ((jabber-carbons-test--dir (make-temp-file "jabber-carbons-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-carbons-test--dir)) (jabber-db--connection nil) (jabber-backlog-days 3.0) (jabber-backlog-number 10)) (unwind-protect (progn (jabber-db-ensure-open) ,@body) (jabber-db-close) (when (file-directory-p jabber-carbons-test--dir) (delete-directory jabber-carbons-test--dir t))))) (ert-deftest jabber-chat-test-store-carbon-sent () "Sent carbon is stored with direction=out and peer=recipient." (jabber-carbons-test-with-db (let ((xml-data (jabber-carbons-test--make-carbon 'sent "me@example.com" "me@example.com/phone" "friend@example.com" "msg-001" "Hi from phone"))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-chat-create-buffer) (lambda (_jc _to) (generate-new-buffer " *test*")))) (let* ((unwrapped (jabber-chat--unwrap-carbon 'fake-jc xml-data)) (inner (car unwrapped))) (jabber-chat--store-carbon 'fake-jc inner) (let ((row (car (sqlite-select jabber-db--connection "SELECT peer, direction, body FROM message")))) (should row) (should (equal (nth 0 row) "friend@example.com")) (should (equal (nth 1 row) "out")) (should (equal (nth 2 row) "Hi from phone")))))))) (ert-deftest jabber-chat-test-store-carbon-received () "Received carbon is stored with direction=in and peer=sender." (jabber-carbons-test-with-db (let ((xml-data (jabber-carbons-test--make-carbon 'received "me@example.com" "friend@example.com/laptop" "me@example.com/emacs" "msg-002" "Hi from laptop"))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (let* ((unwrapped (jabber-chat--unwrap-carbon 'fake-jc xml-data)) (inner (car unwrapped))) (jabber-chat--store-carbon 'fake-jc inner) (let ((row (car (sqlite-select jabber-db--connection "SELECT peer, direction, body FROM message")))) (should row) (should (equal (nth 0 row) "friend@example.com")) (should (equal (nth 1 row) "in")) (should (equal (nth 2 row) "Hi from laptop")))))))) (ert-deftest jabber-chat-test-store-carbon-dedup () "Duplicate carbon with same stanza-id is not stored twice." (jabber-carbons-test-with-db (let ((xml-data (jabber-carbons-test--make-carbon 'sent "me@example.com" "me@example.com/phone" "friend@example.com" "msg-dup" "Hello"))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-chat-create-buffer) (lambda (_jc _to) (generate-new-buffer " *test*")))) (let* ((unwrapped (jabber-chat--unwrap-carbon 'fake-jc xml-data)) (inner (car unwrapped))) (jabber-chat--store-carbon 'fake-jc inner) (jabber-chat--store-carbon 'fake-jc inner) (let ((count (caar (sqlite-select jabber-db--connection "SELECT COUNT(*) FROM message")))) (should (= 1 count)))))))) (provide 'jabber-carbons-tests) ;;; jabber-carbons-tests.el ends here emacs-jabber/tests/jabber-chat-tests.el000066400000000000000000000415731516610113500203700ustar00rootroot00000000000000;;; jabber-chat-tests.el --- Tests for jabber-chat -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-chat) ;; jabber-chat uses this constant from jabber-muc, which has too many ;; dependencies to load in isolation. Define it here for tests. (defvar jabber-muc-xmlns-user "http://jabber.org/protocol/muc#user") ;;; Group 1: jabber-chat--msg-plist-from-stanza (ert-deftest jabber-chat-test-plist-from-stanza-basic () "Basic chat message produces correct plist keys." (let* ((stanza '(message ((from . "alice@example.com/res") (type . "chat")) (body () "Hello!"))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (string= "alice@example.com/res" (plist-get plist :from))) (should (string= "Hello!" (plist-get plist :body))) (should-not (plist-get plist :subject)) (should-not (plist-get plist :delayed)) (should-not (plist-get plist :oob-url)) (should-not (plist-get plist :error-text)) (should (plist-get plist :timestamp)))) (ert-deftest jabber-chat-test-plist-from-stanza-nil-body () "Message with no body produces nil :body." (let* ((stanza '(message ((from . "alice@example.com")) (subject () "Topic"))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should-not (plist-get plist :body)) (should (string= "Topic" (plist-get plist :subject))))) (ert-deftest jabber-chat-test-plist-from-stanza-muc () "MUC message has room JID with nick as resource." (let* ((stanza '(message ((from . "room@conf.example.com/Alice") (type . "groupchat")) (body () "Hi room"))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (string= "room@conf.example.com/Alice" (plist-get plist :from))) (should (string= "Hi room" (plist-get plist :body))))) (ert-deftest jabber-chat-test-plist-from-stanza-delay () "Message with XEP-0203 delay element is marked delayed." (let* ((stanza '(message ((from . "alice@example.com")) (body () "Old message") (delay ((xmlns . "urn:xmpp:delay") (stamp . "2025-01-15T10:30:00Z"))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (plist-get plist :delayed)) (should (string= "Old message" (plist-get plist :body))))) (ert-deftest jabber-chat-test-plist-from-stanza-forced-delay () "Passing DELAYED arg forces :delayed to non-nil." (let* ((stanza '(message ((from . "alice@example.com")) (body () "Backlog"))) (plist (jabber-chat--msg-plist-from-stanza stanza t))) (should (plist-get plist :delayed)))) (ert-deftest jabber-chat-test-plist-from-stanza-oob () "OOB URL and description are extracted." (let* ((stanza '(message ((from . "alice@example.com")) (body () "Check this") (x ((xmlns . "jabber:x:oob")) (url () "https://example.com/file.png") (desc () "A picture")))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (string= "https://example.com/file.png" (plist-get plist :oob-url))) (should (string= "A picture" (plist-get plist :oob-desc))))) (ert-deftest jabber-chat-test-plist-from-stanza-error () "Error node is parsed into :error-text." (let* ((stanza '(message ((from . "alice@example.com") (type . "error")) (body () "Bad request") (error ((type . "modify") (code . "400")) (bad-request ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (stringp (plist-get plist :error-text))))) (ert-deftest jabber-chat-test-plist-from-stanza-oob-no-url () "OOB element with no url child yields nil :oob-url." (let* ((stanza '(message ((from . "alice@example.com")) (body () "Check this") (x ((xmlns . "jabber:x:oob"))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should-not (plist-get plist :oob-url)))) (ert-deftest jabber-chat-test-plist-from-stanza-invite () "MUC invitation preserves raw XML in :xml-data." (let* ((stanza '(message ((from . "room@conf.example.com")) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (invite ((from . "alice@example.com")) (reason () "Join us"))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (plist-get plist :xml-data)) (should (eq stanza (plist-get plist :xml-data))))) (ert-deftest jabber-chat-test-plist-from-stanza-no-invite-no-xml () "Non-invitation message does not include :xml-data." (let* ((stanza '(message ((from . "alice@example.com")) (body () "Normal message"))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should-not (plist-get plist :xml-data)))) ;;; Group 2: jabber-chat--oob-field (ert-deftest jabber-chat-test-oob-field-url () "Extract URL from OOB node." (let ((oob '(x ((xmlns . "jabber:x:oob")) (url () "https://example.com/file.png")))) (should (string= (jabber-chat--oob-field oob 'url) "https://example.com/file.png")))) (ert-deftest jabber-chat-test-oob-field-missing-child () "Return nil when OOB child element is absent." (let ((oob '(x ((xmlns . "jabber:x:oob")) (url () "https://example.com/file.png")))) (should-not (jabber-chat--oob-field oob 'desc)))) (ert-deftest jabber-chat-test-oob-field-nil-node () "Return nil when OOB node is nil." (should-not (jabber-chat--oob-field nil 'url))) ;;; Group 3: jabber-chat--has-muc-invite-p (ert-deftest jabber-chat-test-has-muc-invite-positive () "Detect MUC invitation in stanza." (let ((stanza '(message ((from . "room@conf.example.com")) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (invite ((from . "alice@example.com"))))))) (should (jabber-chat--has-muc-invite-p stanza)))) (ert-deftest jabber-chat-test-has-muc-invite-negative () "Return nil for stanza without MUC invitation." (let ((stanza '(message ((from . "alice@example.com")) (body () "Hello")))) (should-not (jabber-chat--has-muc-invite-p stanza)))) (ert-deftest jabber-chat-test-has-muc-invite-muc-user-no-invite () "Return nil when muc#user element exists but has no invite child." (let ((stanza '(message ((from . "room@conf.example.com")) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (status ((code . "110"))))))) (should-not (jabber-chat--has-muc-invite-p stanza)))) ;;; Group 4: jabber-chat-entry-time (ert-deftest jabber-chat-test-entry-time-plist () "Entry time from a msg-plist entry." (let* ((ts (encode-time '(0 30 14 15 1 2025 nil nil 0))) (entry (list :foreign (list :from "alice" :timestamp ts)))) (should (equal ts (jabber-chat-entry-time entry))))) (ert-deftest jabber-chat-test-entry-time-rare-time () "Entry time from a :rare-time entry." (let* ((ts (encode-time '(0 0 12 10 3 2025 nil nil 0))) (entry (list :rare-time ts))) (should (equal ts (jabber-chat-entry-time entry))))) (ert-deftest jabber-chat-test-entry-time-string-notice () "Entry time from a string :muc-notice with :time in cddr." (let* ((ts (current-time)) (entry (list :muc-notice "user enters the room" :time ts))) (should (equal ts (jabber-chat-entry-time entry))))) (ert-deftest jabber-chat-test-entry-time-string-no-time () "String entry without :time returns nil." (let ((entry (list :notice "some notice"))) (should-not (jabber-chat-entry-time entry)))) ;;; Group 5: jabber-chat--decrypt-if-needed (ert-deftest jabber-chat-test-decrypt-if-needed-returns-xml-unchanged () "No-op decryption returns xml-data unchanged." (let ((xml '(message ((from . "alice@example.com") (type . "chat")) (body () "Hello!")))) (should (eq xml (jabber-chat--decrypt-if-needed nil xml))))) (ert-deftest jabber-chat-test-decrypt-if-needed-preserves-complex-stanza () "No-op decryption preserves a stanza with nested elements." (let ((xml '(message ((from . "bob@example.com")) (body () "Encrypted?") (x ((xmlns . "jabber:x:oob")) (url () "https://example.com/file.png"))))) (should (eq xml (jabber-chat--decrypt-if-needed nil xml))))) ;;; Group 6: jabber-chat--set-body (ert-deftest jabber-chat-test-set-body-replaces-existing () "set-body replaces existing text." (let ((xml '(message ((from . "alice@example.com")) (body () "old text")))) (jabber-chat--set-body xml "new text") (should (string= "new text" (car (jabber-xml-node-children (car (jabber-xml-get-children xml 'body)))))))) (ert-deftest jabber-chat-test-set-body-creates-missing () "set-body appends when none exists." (let ((xml '(message ((from . "alice@example.com"))))) (jabber-chat--set-body xml "created") (let ((body-el (car (jabber-xml-get-children xml 'body)))) (should body-el) (should (string= "created" (car (jabber-xml-node-children body-el))))))) ;;; Group 7: decrypt handler dispatch (ert-deftest jabber-chat-test-register-decrypt-handler-adds-entry () "Register a handler, assert it appears in the alist." (let ((jabber-chat-decrypt-handlers nil) (jabber-chat--sorted-decrypt-handlers-cache nil)) (jabber-chat-register-decrypt-handler 'test-handler :detect #'ignore :decrypt #'ignore :priority 10 :error-label "Test") (should (assq 'test-handler jabber-chat-decrypt-handlers)))) (ert-deftest jabber-chat-test-unregister-decrypt-handler-removes-entry () "Register then unregister, assert the alist is empty." (let ((jabber-chat-decrypt-handlers nil) (jabber-chat--sorted-decrypt-handlers-cache nil)) (jabber-chat-register-decrypt-handler 'test-handler :detect #'ignore :decrypt #'ignore :priority 10 :error-label "Test") (jabber-chat-unregister-decrypt-handler 'test-handler) (should-not jabber-chat-decrypt-handlers))) (ert-deftest jabber-chat-test-register-decrypt-handler-replaces-existing () "Register a handler twice, assert only one entry with new priority." (let ((jabber-chat-decrypt-handlers nil) (jabber-chat--sorted-decrypt-handlers-cache nil)) (jabber-chat-register-decrypt-handler 'test-handler :detect #'ignore :decrypt #'ignore :priority 10 :error-label "Test") (jabber-chat-register-decrypt-handler 'test-handler :detect #'ignore :decrypt #'ignore :priority 20 :error-label "Test") (should (= 1 (length jabber-chat-decrypt-handlers))) (should (= 20 (plist-get (cdr (assq 'test-handler jabber-chat-decrypt-handlers)) :priority))))) (ert-deftest jabber-chat-test-decrypt-dispatches-to-matching-handler () "Handler whose :detect matches gets its :decrypt called." (let ((jabber-chat-decrypt-handlers nil) (jabber-chat--sorted-decrypt-handlers-cache nil) (jabber-chat--crypto-loaded t) (called nil)) (jabber-chat-register-decrypt-handler 'test-handler :detect (lambda (_xml) 'detected) :decrypt (lambda (_jc xml _parsed) (setq called t) xml) :priority 10 :error-label "Test") (let ((xml '(message ((from . "alice@example.com")) (body () "hello")))) (jabber-chat--decrypt-if-needed nil xml) (should called)))) (ert-deftest jabber-chat-test-decrypt-skips-non-matching-handler () "Handler whose :detect returns nil leaves xml-data unchanged." (let ((jabber-chat-decrypt-handlers nil) (jabber-chat--sorted-decrypt-handlers-cache nil) (jabber-chat--crypto-loaded t)) (jabber-chat-register-decrypt-handler 'test-handler :detect (lambda (_xml) nil) :decrypt (lambda (_jc _xml _parsed) (error "Should not be called")) :priority 10 :error-label "Test") (let ((xml '(message ((from . "alice@example.com")) (body () "hello")))) (should (eq xml (jabber-chat--decrypt-if-needed nil xml)))))) (ert-deftest jabber-chat-test-decrypt-priority-order () "Lower-priority handler runs first when both match." (let ((jabber-chat-decrypt-handlers nil) (jabber-chat--sorted-decrypt-handlers-cache nil) (jabber-chat--crypto-loaded t) (winner nil)) (jabber-chat-register-decrypt-handler 'handler-20 :detect (lambda (_xml) 'detected) :decrypt (lambda (_jc xml _parsed) (setq winner 20) xml) :priority 20 :error-label "H20") (jabber-chat-register-decrypt-handler 'handler-10 :detect (lambda (_xml) 'detected) :decrypt (lambda (_jc xml _parsed) (setq winner 10) xml) :priority 10 :error-label "H10") (let ((xml '(message ((from . "alice@example.com")) (body () "hello")))) (jabber-chat--decrypt-if-needed nil xml) (should (= 10 winner))))) (ert-deftest jabber-chat-test-decrypt-error-replaces-body () "Handler that signals error gets body replaced with error label." (let ((jabber-chat-decrypt-handlers nil) (jabber-chat--sorted-decrypt-handlers-cache nil) (jabber-chat--crypto-loaded t)) (jabber-chat-register-decrypt-handler 'test-handler :detect (lambda (_xml) 'detected) :decrypt (lambda (_jc _xml _parsed) (error "Decrypt boom")) :priority 10 :error-label "BOOM") (let ((xml '(message ((from . "alice@example.com")) (body () "fallback")))) (jabber-chat--decrypt-if-needed nil xml) (should (string= "[BOOM: could not decrypt]" (car (jabber-xml-node-children (car (jabber-xml-get-children xml 'body))))))))) (ert-deftest jabber-chat-test-decrypt-no-handlers-returns-unchanged () "With empty handler alist, xml-data passes through." (let ((jabber-chat-decrypt-handlers nil) (jabber-chat--sorted-decrypt-handlers-cache nil) (jabber-chat--crypto-loaded t)) (let ((xml '(message ((from . "alice@example.com")) (body () "hello")))) (should (eq xml (jabber-chat--decrypt-if-needed nil xml)))))) (ert-deftest jabber-chat-test-decrypt-skips-nil-from () "Stanza with no from attribute bypasses decrypt dispatch entirely." (let ((jabber-chat--crypto-loaded t) (called nil)) (jabber-chat-register-decrypt-handler 'test-nil-from :detect (lambda (_xml) (setq called t) nil) :decrypt (lambda (_jc _xml _det) nil) :priority 1 :error-label "test") (unwind-protect (let ((xml '(message () (body () "no from")))) (should (eq xml (jabber-chat--decrypt-if-needed nil xml))) (should-not called)) (jabber-chat-unregister-decrypt-handler 'test-nil-from)))) ;;; Group 8: jabber-chat-goto-address error handling (ert-deftest jabber-chat-test-goto-address-logs-error-on-failure () "goto-address error is logged via message, not silently swallowed." (let ((logged-messages nil)) (cl-letf (((symbol-function 'goto-address-fontify) (lambda (&rest _) (error "Test fontify error"))) ((symbol-function 'message) (lambda (fmt &rest args) (push (apply #'format fmt args) logged-messages)))) (with-temp-buffer (insert "https://example.com some text") (jabber-chat-goto-address nil nil :insert) (should (cl-some (lambda (m) (string-match-p "goto-address-fontify failed" m)) logged-messages)))))) (ert-deftest jabber-chat-test-goto-address-succeeds-normally () "goto-address runs without error when fontify succeeds." (with-temp-buffer (insert "Visit https://example.com today") ;; Should not signal an error (jabber-chat-goto-address nil nil :insert))) (ert-deftest jabber-chat-test-goto-address-skips-non-insert-mode () "goto-address does nothing when mode is not :insert." (let ((called nil)) (cl-letf (((symbol-function 'goto-address-fontify) (lambda (&rest _) (setq called t)))) (with-temp-buffer (insert "https://example.com") (jabber-chat-goto-address nil nil :printp) (should-not called))))) ;;; Group 9: jabber-chat-muc-presence-patterns-history variable (ert-deftest jabber-chat-test-muc-presence-patterns-history-exists () "The correctly-named history variable exists and is nil by default." (should (boundp 'jabber-chat-muc-presence-patterns-history)) ;; The old typo should not exist (should-not (boundp 'jaber-chat-much-presence-patterns-history))) (provide 'jabber-chat-tests) ;;; jabber-chat-tests.el ends here emacs-jabber/tests/jabber-chatbuffer-tests.el000066400000000000000000000546251516610113500215640ustar00rootroot00000000000000;;; jabber-chatbuffer-tests.el --- Tests for ewoc hash table API -*- lexical-binding: t; -*- (require 'ert) (require 'ewoc) (require 'jabber-chatbuffer) (require 'jabber-chat) (require 'jabber-db) ;; jabber-chat requires this via jabber-muc (defvar jabber-muc-xmlns-user "http://jabber.org/protocol/muc#user") (defvar jabber-muc-participants nil) ;;; Test helpers (defmacro jabber-chatbuffer-test-with-ewoc (&rest body) "Set up a temp buffer with a chat ewoc and hash table, then run BODY." (declare (indent 0) (debug t)) `(with-temp-buffer (let ((jabber-chat-ewoc (ewoc-create #'ignore nil nil 'nosep)) (jabber-chat--msg-nodes (make-hash-table :test 'equal))) ,@body))) ;;; Group 1: jabber-chat-ewoc-enter (ert-deftest jabber-chat-test-ewoc-enter-registers-id () "Inserting a message with :id registers it in the hash table." (jabber-chatbuffer-test-with-ewoc (let* ((msg (list :id "msg-001" :body "hello" :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :local msg)))) (should node) (should (eq node (gethash "msg-001" jabber-chat--msg-nodes)))))) (ert-deftest jabber-chat-test-ewoc-enter-skips-nil-id () "Inserting a message without :id does not pollute the hash table." (jabber-chatbuffer-test-with-ewoc (let* ((msg (list :body "notice text" :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :notice msg)))) (should node) (should (zerop (hash-table-count jabber-chat--msg-nodes)))))) (ert-deftest jabber-chat-test-ewoc-enter-notice-string () "Inserting a notice with string body does not error." (jabber-chatbuffer-test-with-ewoc (let ((node (jabber-chat-ewoc-enter (list :notice "Someone joined" :time (current-time))))) (should node) (should (zerop (hash-table-count jabber-chat--msg-nodes)))))) (ert-deftest jabber-chat-test-ewoc-enter-multiple-ids () "Multiple messages with distinct IDs are all registered." (jabber-chatbuffer-test-with-ewoc (dotimes (i 5) (let ((msg (list :id (format "msg-%03d" i) :body "x" :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :local msg)))) (should (= 5 (hash-table-count jabber-chat--msg-nodes))) (should (gethash "msg-002" jabber-chat--msg-nodes)))) ;;; Group 2: jabber-chat-ewoc-find-by-id (ert-deftest jabber-chat-test-find-by-id-returns-node () "Looking up a registered ID returns the correct ewoc node." (jabber-chatbuffer-test-with-ewoc (let* ((msg (list :id "find-me" :body "test" :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :foreign msg)))) (should (eq node (jabber-chat-ewoc-find-by-id "find-me")))))) (ert-deftest jabber-chat-test-find-by-id-returns-nil-for-missing () "Looking up a nonexistent ID returns nil." (jabber-chatbuffer-test-with-ewoc (should-not (jabber-chat-ewoc-find-by-id "no-such-id")))) (ert-deftest jabber-chat-test-find-by-id-nil-safe () "Looking up nil returns nil without error." (jabber-chatbuffer-test-with-ewoc (should-not (jabber-chat-ewoc-find-by-id nil)))) ;;; Group 3: In-place status update (ert-deftest jabber-chat-test-status-update-in-place () "Mutating :status on the shared plist is visible through the ewoc node." (jabber-chatbuffer-test-with-ewoc (let* ((msg (list :id "msg-upd" :body "hi" :status :sent :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :local msg)))) ;; Simulate receipt arrival: mutate plist in place (plist-put msg :status :delivered) ;; The ewoc node shares the same plist object (should (eq :delivered (plist-get (cadr (ewoc-data node)) :status)))))) (ert-deftest jabber-chat-test-status-update-via-lookup () "Status update via find-by-id + plist-put works end-to-end." (jabber-chatbuffer-test-with-ewoc (let ((msg (list :id "msg-e2e" :body "test" :status :sent :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :local msg)) ;; Look up and update (when-let* ((node (jabber-chat-ewoc-find-by-id "msg-e2e"))) (plist-put (cadr (ewoc-data node)) :status :displayed)) ;; Verify the original plist was mutated (shared object) (should (eq :displayed (plist-get msg :status)))))) ;;; Group 4: Hash table cleanup (ert-deftest jabber-chat-test-hash-cleanup-on-clear () "Clearing the hash table via clrhash removes all entries." (jabber-chatbuffer-test-with-ewoc (dotimes (i 3) (let ((msg (list :id (format "clr-%d" i) :body "x" :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :local msg)))) (should (= 3 (hash-table-count jabber-chat--msg-nodes))) ;; Simulate what jabber-mam--reload-buffer does (ewoc-filter jabber-chat-ewoc #'ignore) (clrhash jabber-chat--msg-nodes) (should (zerop (hash-table-count jabber-chat--msg-nodes))))) (ert-deftest jabber-chat-test-hash-remhash-on-delete () "Removing an entry via remhash drops that ID from the table." (jabber-chatbuffer-test-with-ewoc (let ((msg (list :id "del-me" :body "x" :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :local msg))) (should (gethash "del-me" jabber-chat--msg-nodes)) (remhash "del-me" jabber-chat--msg-nodes) (should-not (gethash "del-me" jabber-chat--msg-nodes)))) ;;; Group 5: DB backlog includes stanza ID (ert-deftest jabber-db-test-backlog-includes-stanza-id () "Backlog entries from DB include :id from stanza_id column." (skip-unless (fboundp 'sqlite-open)) (let* ((jabber-db-test--dir (make-temp-file "jabber-db-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-db-test--dir)) (jabber-db--connection nil) (jabber-backlog-days 3.0) (jabber-backlog-number 10)) (unwind-protect (progn (jabber-db-ensure-open) ;; Insert a message with stanza_id (sqlite-execute jabber-db--connection "INSERT INTO message (account, peer, direction, body, timestamp, stanza_id) VALUES (?, ?, ?, ?, ?, ?)" (list "me@example.com" "them@example.com" "out" "Hello" (floor (float-time)) "emacs-msg-1234")) (let* ((entries (jabber-db-backlog "me@example.com" "them@example.com")) (entry (car entries))) (should entry) (should (equal "emacs-msg-1234" (plist-get entry :id))))) (jabber-db-close) (when (file-directory-p jabber-db-test--dir) (delete-directory jabber-db-test--dir t))))) (ert-deftest jabber-db-test-backlog-status-from-receipts () "Backlog entries derive :status from delivered_at/displayed_at." (skip-unless (fboundp 'sqlite-open)) (let* ((jabber-db-test--dir (make-temp-file "jabber-db-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-db-test--dir)) (jabber-db--connection nil) (jabber-backlog-days 3.0) (jabber-backlog-number 10) (now (floor (float-time)))) (unwind-protect (progn (jabber-db-ensure-open) ;; Sent, no receipt (sqlite-execute jabber-db--connection "INSERT INTO message (account, peer, direction, body, timestamp, stanza_id) VALUES (?, ?, ?, ?, ?, ?)" (list "me@x.com" "them@x.com" "out" "a" now "id-sent")) ;; Delivered (sqlite-execute jabber-db--connection "INSERT INTO message (account, peer, direction, body, timestamp, stanza_id, delivered_at) VALUES (?, ?, ?, ?, ?, ?, ?)" (list "me@x.com" "them@x.com" "out" "b" now "id-del" now)) ;; Displayed (sqlite-execute jabber-db--connection "INSERT INTO message (account, peer, direction, body, timestamp, stanza_id, delivered_at, displayed_at) VALUES (?, ?, ?, ?, ?, ?, ?, ?)" (list "me@x.com" "them@x.com" "out" "c" now "id-disp" now now)) (let ((entries (jabber-db-backlog "me@x.com" "them@x.com"))) ;; Entries are DESC, reverse to get chronological (let ((by-id (make-hash-table :test 'equal))) (dolist (e entries) (puthash (plist-get e :id) e by-id)) (should-not (plist-get (gethash "id-sent" by-id) :status)) (should (eq :delivered (plist-get (gethash "id-del" by-id) :status))) (should (eq :displayed (plist-get (gethash "id-disp" by-id) :status)))))) (jabber-db-close) (when (file-directory-p jabber-db-test--dir) (delete-directory jabber-db-test--dir t))))) ;;; Group 6: :id in message plist from stanza (ert-deftest jabber-chat-test-build-msg-plist-includes-id () "jabber-chat--build-msg-plist extracts the stanza id attribute." (let* ((stanza '(message ((from . "alice@example.com") (id . "emacs-msg-42") (type . "chat")) (body () "Hello"))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (equal "emacs-msg-42" (plist-get plist :id))))) (ert-deftest jabber-chat-test-build-msg-plist-nil-id () "jabber-chat--build-msg-plist returns nil :id when stanza has none." (let* ((stanza '(message ((from . "alice@example.com") (type . "chat")) (body () "Hello"))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should-not (plist-get plist :id)))) ;;; Group 7: OMEMO anonymous-room warning (ert-deftest jabber-chatbuffer-test-omemo-warns-anonymous-room () "Enabling OMEMO in a room with no visible JIDs emits a warning." (let ((messages nil) (jabber-muc-participants nil)) (with-temp-buffer (setq-local jabber-group "room@conf.example.com") (setq-local jabber-buffer-connection nil) (cl-letf (((symbol-function 'jabber-chat-encryption--save) #'ignore) ((symbol-function 'jabber-chat-encryption--update-header) #'ignore) ((symbol-function 'require) #'ignore) ((symbol-function 'force-mode-line-update) #'ignore) ((symbol-function 'jabber-omemo--muc-participant-jids) (lambda (&rest _) nil)) ((symbol-function 'message) (lambda (fmt &rest args) (push (apply #'format fmt args) messages)))) (jabber-chat-encryption-set-omemo) (should (cl-some (lambda (m) (string-match-p "anonymous" m)) messages)))))) (ert-deftest jabber-chatbuffer-test-omemo-no-warning-when-jids-visible () "No warning when participant JIDs are available." (let ((messages nil) (jabber-muc-participants nil)) (with-temp-buffer (setq-local jabber-group "room@conf.example.com") (setq-local jabber-buffer-connection nil) (cl-letf (((symbol-function 'jabber-chat-encryption--save) #'ignore) ((symbol-function 'jabber-chat-encryption--update-header) #'ignore) ((symbol-function 'require) #'ignore) ((symbol-function 'force-mode-line-update) #'ignore) ((symbol-function 'jabber-omemo--muc-participant-jids) (lambda (&rest _) (list "alice@example.com"))) ((symbol-function 'message) (lambda (fmt &rest args) (push (apply #'format fmt args) messages)))) (jabber-chat-encryption-set-omemo) (should-not (cl-some (lambda (m) (string-match-p "anonymous" m)) messages)))))) ;;; Group 8: Buffer lookup registry (ert-deftest jabber-chatbuffer-test-registry-chat-find () "Register a temp buffer as a chat buffer; registry-get returns it." (let ((jabber-chatbuffer--registry (make-hash-table :test #'equal))) (with-temp-buffer (setq-local jabber-chatting-with "alice@example.com") (jabber-chatbuffer--registry-put 'chat "alice@example.com") (should (eq (current-buffer) (jabber-chatbuffer--registry-get 'chat "alice@example.com")))))) (ert-deftest jabber-chatbuffer-test-registry-kill-removes-entry () "Killing the buffer removes its registry entry." (let ((jabber-chatbuffer--registry (make-hash-table :test #'equal))) (let ((buf (generate-new-buffer " *test-chat-registry*"))) (with-current-buffer buf (setq-local jabber-chatting-with "bob@example.com") (jabber-chatbuffer--registry-put 'chat "bob@example.com")) (should (eq buf (jabber-chatbuffer--registry-get 'chat "bob@example.com"))) (kill-buffer buf) ;; The kill-buffer-hook removed it; get now returns nil. (should-not (jabber-chatbuffer--registry-get 'chat "bob@example.com"))))) (ert-deftest jabber-chatbuffer-test-registry-no-collision () "MUC and chat buffers with the same bare JID do not collide." (let ((jabber-chatbuffer--registry (make-hash-table :test #'equal))) (let ((chat-buf (generate-new-buffer " *test-chat*")) (muc-buf (generate-new-buffer " *test-muc*"))) (unwind-protect (progn (with-current-buffer chat-buf (setq-local jabber-chatting-with "room@conf.example.com") (jabber-chatbuffer--registry-put 'chat "room@conf.example.com")) (with-current-buffer muc-buf (setq-local jabber-group "room@conf.example.com") (jabber-chatbuffer--registry-put 'muc "room@conf.example.com")) (should (eq chat-buf (jabber-chatbuffer--registry-get 'chat "room@conf.example.com"))) (should (eq muc-buf (jabber-chatbuffer--registry-get 'muc "room@conf.example.com")))) (kill-buffer chat-buf) (kill-buffer muc-buf))))) (ert-deftest jabber-chatbuffer-test-registry-muc-private () "MUC-private lookup by group+nick returns correct buffer." (let ((jabber-chatbuffer--registry (make-hash-table :test #'equal))) (let ((buf (generate-new-buffer " *test-muc-private*"))) (unwind-protect (progn (with-current-buffer buf (setq-local jabber-chatting-with "room@conf.example.com/alice") (jabber-chatbuffer--registry-put 'muc-private "room@conf.example.com/alice")) (should (eq buf (jabber-chatbuffer--registry-get 'muc-private "room@conf.example.com/alice")))) (kill-buffer buf))))) (ert-deftest jabber-chatbuffer-test-registry-kill-full-jid-removes-bare-key () "kill-buffer-hook cleans up bare-JID key when chatting-with is a full JID." (let ((jabber-chatbuffer--registry (make-hash-table :test #'equal))) (let ((buf (generate-new-buffer " *test-chat-full-jid*"))) (with-current-buffer buf ;; Registered with bare JID (as jabber-chat-create-buffer does). (setq-local jabber-chatting-with "carol@example.com/phone") (jabber-chatbuffer--registry-put 'chat "carol@example.com")) ;; At this point the registry holds bare key. (should (eq buf (jabber-chatbuffer--registry-get 'chat "carol@example.com"))) ;; jabber-chatting-with has a resource — kill-hook should still remove ;; the bare-JID key because it normalises via jabber-jid-user. (kill-buffer buf) (should-not (jabber-chatbuffer--registry-get 'chat "carol@example.com"))))) ;;; Group 9: OMEMO immediate display status transitions (defmacro jabber-chatbuffer-test-with-rendering-ewoc (&rest body) "Set up a temp buffer with a rendering chat ewoc, then run BODY. Uses `jabber-chat-pp' so status indicators are actually rendered." (declare (indent 0) (debug t)) `(with-temp-buffer (let ((jabber-chat-ewoc (ewoc-create #'jabber-chat-pp nil nil 'nosep)) (jabber-chat--msg-nodes (make-hash-table :test 'equal)) (jabber-chat-printers '(jabber-chat-print-body)) (jabber-chat-header-line-format nil) (inhibit-read-only t)) (cl-letf (((symbol-function 'jabber-chat-self-prompt) (lambda (_msg _ts _delayed _/me-p) (insert "me: ")))) ,@body)))) (ert-deftest jabber-chat-test-sending-status-renders-warning-dot () "A message with :sending status renders a warning-face dot." (jabber-chatbuffer-test-with-rendering-ewoc (let* ((msg (list :id "omemo-001" :body "secret" :status :sending :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :local msg)))) (should node) (goto-char (point-min)) (should (search-forward "\u00b7" nil t)) (should (eq 'warning (get-text-property (1- (point)) 'face)))))) (ert-deftest jabber-chat-test-status-sending-to-sent () "Status :sending -> :sent updates the indicator face." (jabber-chatbuffer-test-with-rendering-ewoc (let* ((msg (list :id "omemo-002" :body "hello" :status :sending :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :local msg)))) (plist-put (cadr (ewoc-data node)) :status :sent) (ewoc-invalidate jabber-chat-ewoc node) (goto-char (point-min)) (should (search-forward "\u00b7" nil t)) (should (eq 'shadow (get-text-property (1- (point)) 'face)))))) (ert-deftest jabber-chat-test-status-sending-to-undelivered () "Status :sending -> :undelivered shows error-face X." (jabber-chatbuffer-test-with-rendering-ewoc (let* ((msg (list :id "omemo-003" :body "fail" :status :sending :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :local msg)))) (plist-put (cadr (ewoc-data node)) :status :undelivered) (ewoc-invalidate jabber-chat-ewoc node) (goto-char (point-min)) (should (search-forward "\u2717" nil t)) (should (eq 'error (get-text-property (1- (point)) 'face)))))) (ert-deftest jabber-chat-test-send-failed-restores-body () "jabber-omemo--send-failed restores body text to buffer input area." (require 'jabber-omemo) (jabber-chatbuffer-test-with-ewoc (let* ((jabber-point-insert (point-marker)) (msg (list :id "omemo-004" :body "restore me" :status :sending :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :local msg)))) (jabber-omemo--send-failed (current-buffer) node "restore me" "OMEMO: test failure") (should (string= "restore me" (buffer-substring jabber-point-insert (point-max)))) (should (eq :undelivered (plist-get (cadr (ewoc-data node)) :status)))))) ;;; Group 10: jabber-chat-mode-setup ewoc idempotency (ert-deftest jabber-chatbuffer-test-mode-setup-preserves-ewoc-on-repeat () "Calling jabber-chat-mode-setup twice preserves the existing ewoc. The `make-local-variable' pattern for jabber-chat-ewoc and jabber-point-insert is critical: on reconnection the function is called again, and the ewoc created on the first call must survive." (with-temp-buffer (let ((jabber-chat-ewoc nil) (jabber-chat--msg-nodes nil) (jabber-point-insert nil) (jabber-send-function nil) (jabber-chat-encryption nil) (jabber-chat-default-encryption 'plaintext) (jabber-buffer-connection nil) (jabber-chat-encryption-message "")) ;; Stub out DB and connection helpers called by jabber-chat-mode-setup (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-get-chat-encryption) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-nick-completion-at-point) #'ignore)) ;; First call: creates the ewoc (jabber-chat-mode-setup 'fake-jc #'ignore) (let ((ewoc-1 jabber-chat-ewoc) (marker-1 jabber-point-insert)) (should ewoc-1) (should marker-1) ;; Insert a message into the ewoc to verify identity later (jabber-chat-ewoc-enter (list :local (list :id "persist-me" :body "x" :timestamp (current-time)))) ;; Second call (simulates reconnection): ewoc must survive (jabber-chat-mode-setup 'fake-jc-2 #'ignore) (should (eq ewoc-1 jabber-chat-ewoc)) (should (eq marker-1 jabber-point-insert)) ;; The message inserted before the second call is still there (should (gethash "persist-me" jabber-chat--msg-nodes))))))) (ert-deftest jabber-chatbuffer-test-mode-setup-creates-ewoc-on-first-call () "First call to jabber-chat-mode-setup creates a new ewoc and marker." (with-temp-buffer (let ((jabber-chat-ewoc nil) (jabber-chat--msg-nodes nil) (jabber-point-insert nil) (jabber-send-function nil) (jabber-chat-encryption nil) (jabber-chat-default-encryption 'plaintext) (jabber-buffer-connection nil) (jabber-chat-encryption-message "")) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-get-chat-encryption) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-nick-completion-at-point) #'ignore)) (jabber-chat-mode-setup 'fake-jc #'ignore) (should jabber-chat-ewoc) (should (markerp jabber-point-insert)) (should (hash-table-p jabber-chat--msg-nodes)))))) (ert-deftest jabber-chatbuffer-test-mode-setup-updates-connection () "Second call to jabber-chat-mode-setup updates jabber-buffer-connection." (with-temp-buffer (let ((jabber-chat-ewoc nil) (jabber-chat--msg-nodes nil) (jabber-point-insert nil) (jabber-send-function nil) (jabber-chat-encryption nil) (jabber-chat-default-encryption 'plaintext) (jabber-buffer-connection nil) (jabber-chat-encryption-message "")) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-get-chat-encryption) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-nick-completion-at-point) #'ignore)) (jabber-chat-mode-setup 'jc-old #'ignore) (should (eq 'jc-old jabber-buffer-connection)) (jabber-chat-mode-setup 'jc-new #'ignore) (should (eq 'jc-new jabber-buffer-connection)))))) (provide 'jabber-chatbuffer-tests) ;;; jabber-chatbuffer-tests.el ends here emacs-jabber/tests/jabber-chatstates-tests.el000066400000000000000000000142221516610113500216030ustar00rootroot00000000000000;;; jabber-chatstates-tests.el --- Tests for jabber-chatstates -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-chatstates) ;;; Group 1: Composing notification fix (ert-deftest jabber-chatstates-test-composing-after-first-send () "Composing notification works after the first message send. The first-time gating used to set jabber-chatstates-requested to nil after the first message, breaking subsequent composing detection." (let ((sent-states nil)) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc sexp) (push sexp sent-states)))) (with-temp-buffer (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatting-with "them@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-point-insert (point-min)) (setq-local jabber-chatstates-composing-sent nil) (setq-local jabber-chatstates-paused-timer nil) ;; Simulate sending the first message (triggers when-sending) (jabber-chatstates-when-sending "hello" "id-1") ;; Now simulate typing a second message (setq sent-states nil) (goto-char (point-max)) (insert "world") (jabber-chatstates-after-change) (should sent-states))))) (ert-deftest jabber-chatstates-test-no-composing-when-disabled () "Composing notification is not sent when jabber-chatstates-confirm is nil." (let ((sent-states nil)) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc sexp) (push sexp sent-states)))) (with-temp-buffer (setq-local jabber-chatstates-confirm nil) (setq-local jabber-chatting-with "them@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-point-insert (point-min)) (setq-local jabber-chatstates-composing-sent nil) (goto-char (point-max)) (insert "hello") (jabber-chatstates-after-change) (should-not sent-states))))) (ert-deftest jabber-chatstates-test-send-hook-returns-active () "Send hook returns active element when chatstates-confirm is t." (with-temp-buffer (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatstates-last-state nil) (setq-local jabber-chatstates-composing-sent nil) (setq-local jabber-chatstates-paused-timer nil) (let ((result (jabber-chatstates-when-sending "hello" "id-1"))) (should result) (should (equal (caar result) 'active))))) (ert-deftest jabber-chatstates-test-send-hook-nil-when-disabled () "Send hook returns nil when chatstates-confirm is nil." (with-temp-buffer (setq-local jabber-chatstates-confirm nil) (setq-local jabber-chatstates-last-state nil) (setq-local jabber-chatstates-composing-sent nil) (setq-local jabber-chatstates-paused-timer nil) (let ((result (jabber-chatstates-when-sending "hello" "id-1"))) (should-not result)))) ;;; Group 2: Inactive and gone states (ert-deftest jabber-chatstates-test-paused-starts-inactive-timer () "Sending paused starts a 30s timer for inactive." (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) #'ignore)) (with-temp-buffer (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatting-with "them@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chatstates-composing-sent t) (setq-local jabber-chatstates-inactive-timer nil) (jabber-chatstates-send-paused) (should jabber-chatstates-inactive-timer) (cancel-timer jabber-chatstates-inactive-timer)))) (ert-deftest jabber-chatstates-test-stop-timer-cancels-both () "stop-timer cancels both paused and inactive timers." (with-temp-buffer (setq-local jabber-chatstates-paused-timer (run-with-timer 999 nil #'ignore)) (setq-local jabber-chatstates-inactive-timer (run-with-timer 999 nil #'ignore)) (jabber-chatstates-stop-timer) ;; Timers should be cancelled (not in timer-list) (should-not (memq jabber-chatstates-paused-timer timer-list)) (should-not (memq jabber-chatstates-inactive-timer timer-list)))) (ert-deftest jabber-chatstates-test-send-inactive-sends-stanza () "send-inactive sends an inactive chat state stanza." (let ((sent nil)) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc sexp) (setq sent sexp)))) (with-temp-buffer (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatting-with "them@example.com") (setq-local jabber-buffer-connection 'fake-jc) (jabber-chatstates-send-inactive) (should sent) (should (assq 'inactive (cddr sent))))))) (ert-deftest jabber-chatstates-test-send-gone-sends-stanza () "send-gone sends a gone chat state stanza." (let ((sent nil)) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc sexp) (setq sent sexp)))) (with-temp-buffer (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatting-with "them@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chatstates-paused-timer nil) (setq-local jabber-chatstates-inactive-timer nil) (jabber-chatstates-send-gone) (should sent) (should (assq 'gone (cddr sent))))))) (ert-deftest jabber-chatstates-test-after-change-cancels-inactive-timer () "Typing again cancels the inactive timer." (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) #'ignore)) (with-temp-buffer (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatting-with "them@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-point-insert (point-min)) (setq-local jabber-chatstates-composing-sent nil) (setq-local jabber-chatstates-paused-timer nil) (setq-local jabber-chatstates-inactive-timer (run-with-timer 999 nil #'ignore)) (goto-char (point-max)) (insert "hello") (jabber-chatstates-after-change) (should-not (memq jabber-chatstates-inactive-timer timer-list))))) (provide 'jabber-chatstates-tests) ;;; jabber-chatstates-tests.el ends here emacs-jabber/tests/jabber-csi-tests.el000066400000000000000000000060041516610113500202150ustar00rootroot00000000000000;;; jabber-csi-tests.el --- Tests for jabber-csi -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-csi) ;;; Group 1: State detection (ert-deftest jabber-csi-test-focused-p-returns-bool () "focused-p returns non-nil or nil without error." (should (or (jabber-csi--focused-p) (not (jabber-csi--focused-p))))) ;;; Group 2: Send logic (ert-deftest jabber-csi-test-send-active-when-focused () "Sends active element when focused." (let ((sent nil) (jabber-csi-enable t) (jabber-csi--last-state nil) (jabber-connections '(fake-jc))) (cl-letf (((symbol-function 'jabber-csi--focused-p) (lambda () t)) ((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc sexp) (setq sent sexp)))) (jabber-csi--send-state) (should sent) (should (eq (car sent) 'active)) (should (eq jabber-csi--last-state 'active))))) (ert-deftest jabber-csi-test-send-inactive-when-unfocused () "Sends inactive element when unfocused." (let ((sent nil) (jabber-csi-enable t) (jabber-csi--last-state nil) (jabber-connections '(fake-jc))) (cl-letf (((symbol-function 'jabber-csi--focused-p) (lambda () nil)) ((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc sexp) (setq sent sexp)))) (jabber-csi--send-state) (should sent) (should (eq (car sent) 'inactive)) (should (eq jabber-csi--last-state 'inactive))))) (ert-deftest jabber-csi-test-no-duplicate-send () "Does not resend the same state." (let ((send-count 0) (jabber-csi-enable t) (jabber-csi--last-state 'active) (jabber-connections '(fake-jc))) (cl-letf (((symbol-function 'jabber-csi--focused-p) (lambda () t)) ((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc _sexp) (cl-incf send-count)))) (jabber-csi--send-state) (should (= send-count 0))))) (ert-deftest jabber-csi-test-disabled-sends-nothing () "Sends nothing when jabber-csi-enable is nil." (let ((sent nil) (jabber-csi-enable nil) (jabber-csi--last-state nil) (jabber-connections '(fake-jc))) (cl-letf (((symbol-function 'jabber-csi--focused-p) (lambda () t)) ((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc sexp) (setq sent sexp)))) (jabber-csi--send-state) (should-not sent)))) (ert-deftest jabber-csi-test-on-connect-resets-state () "on-connect resets last-state and sends current state." (let ((jabber-csi-enable t) (jabber-csi--last-state 'active) (jabber-connections '(fake-jc))) (cl-letf (((symbol-function 'jabber-csi--focused-p) (lambda () t)) ((symbol-function 'jabber-send-sexp-if-connected) #'ignore)) (jabber-csi--on-connect 'fake-jc) (should (eq jabber-csi--last-state 'active))))) (provide 'jabber-csi-tests) ;;; jabber-csi-tests.el ends here emacs-jabber/tests/jabber-db-tests.el000066400000000000000000002152221516610113500200300ustar00rootroot00000000000000;;; jabber-db-tests.el --- Tests for jabber-db -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-chat) (require 'jabber-db) ;;; Test infrastructure (defmacro jabber-db-test-with-db (&rest body) "Run BODY with a fresh temp SQLite database. Binds `jabber-db-path' to a temp file, ensures the DB is open, and tears down on exit." (declare (indent 0) (debug t)) `(let* ((jabber-db-test--dir (make-temp-file "jabber-db-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-db-test--dir)) (jabber-db--connection nil) (jabber-backlog-days 3.0) (jabber-backlog-number 10)) (unwind-protect (progn (jabber-db-ensure-open) ,@body) (jabber-db-close) (when (file-directory-p jabber-db-test--dir) (delete-directory jabber-db-test--dir t))))) ;;; Group 1: Schema and lifecycle (ert-deftest jabber-db-test-ensure-open-creates-db () "Opening the database creates the file and returns a connection." (jabber-db-test-with-db (should (sqlitep jabber-db--connection)) (should (file-exists-p jabber-db-path)))) (ert-deftest jabber-db-test-ensure-open-idempotent () "Calling ensure-open twice returns the same connection." (jabber-db-test-with-db (let ((db1 jabber-db--connection) (db2 (jabber-db-ensure-open))) (should (eq db1 db2))))) (ert-deftest jabber-db-test-close-and-reopen () "Closing and reopening the database works." (jabber-db-test-with-db (jabber-db-close) (should (null jabber-db--connection)) (let ((db (jabber-db-ensure-open))) (should (sqlitep db))))) (ert-deftest jabber-db-test-schema-version () "The user_version pragma matches `jabber-db--schema-version'." (jabber-db-test-with-db (should (= jabber-db--schema-version (caar (sqlite-select jabber-db--connection "PRAGMA user_version")))))) (ert-deftest jabber-db-test-wal-mode () "WAL journal mode is active." (jabber-db-test-with-db (should (string= "wal" (caar (sqlite-select jabber-db--connection "PRAGMA journal_mode")))))) (ert-deftest jabber-db-test-tables-exist () "All expected tables and indexes exist." (jabber-db-test-with-db (let ((tables (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM sqlite_master WHERE type='table'")))) (should (member "message" tables)) (should (member "message_fts" tables)) (should (member "chat_settings" tables))))) ;;; Group 2: Store and retrieve (ert-deftest jabber-db-test-store-and-query () "Storing a message and querying it back returns matching fields." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Hello!" ts "laptop") (let* ((rows (jabber-db-query "me@example.com" "friend@example.com")) (row (car rows))) (should (= 1 (length rows))) (should (string= "me@example.com" (plist-get row :account))) (should (string= "friend@example.com" (plist-get row :peer))) (should (string= "in" (plist-get row :direction))) (should (string= "chat" (plist-get row :type))) (should (string= "Hello!" (plist-get row :body))) (should (= ts (plist-get row :timestamp))) (should (string= "laptop" (plist-get row :resource))))))) (ert-deftest jabber-db-test-store-with-stanza-id () "Storing a message with stanza-id and server-id preserves them." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Test" ts nil "origin-123" "server-456") (let* ((rows (jabber-db-query "me@example.com" "friend@example.com")) (row (car rows))) (should (string= "origin-123" (plist-get row :stanza-id))) (should (string= "server-456" (plist-get row :server-id))))))) (ert-deftest jabber-db-test-store-unicode-body () "Unicode text in message body is preserved." (jabber-db-test-with-db (let ((ts (floor (float-time))) (body "Hej! Gruss Gott! Ελληνικά 日本語 🎉")) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" body ts) (let ((row (car (jabber-db-query "me@example.com" "friend@example.com")))) (should (string= body (plist-get row :body))))))) (ert-deftest jabber-db-test-store-nil-body () "Storing a message with nil body succeeds." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" nil ts) (let ((row (car (jabber-db-query "me@example.com" "friend@example.com")))) (should (null (plist-get row :body))))))) (ert-deftest jabber-db-test-store-multiline-body () "Newlines in message body are preserved." (jabber-db-test-with-db (let ((ts (floor (float-time))) (body "Line one\nLine two\nLine three")) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" body ts) (let ((row (car (jabber-db-query "me@example.com" "friend@example.com")))) (should (string= body (plist-get row :body))))))) ;;; Group 3: Backlog format and ordering (ert-deftest jabber-db-test-backlog-plist-format () "Backlog entries are plists with :from, :body, :timestamp, :delayed, :direction, :msg-type." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Hello!" ts "laptop") (let* ((entries (jabber-db-backlog "me@example.com" "friend@example.com")) (entry (car entries))) (should (listp entry)) (should (string= "friend@example.com/laptop" (plist-get entry :from))) (should (string= "Hello!" (plist-get entry :body))) (should (string= "in" (plist-get entry :direction))) (should (string= "chat" (plist-get entry :msg-type))) (should (plist-get entry :delayed)) (should (plist-get entry :timestamp)))))) (ert-deftest jabber-db-test-backlog-chat-no-resource () "Chat backlog sender is bare JID when no resource is stored." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Hello!" ts) (let ((entry (car (jabber-db-backlog "me@example.com" "friend@example.com")))) (should (string= "friend@example.com" (plist-get entry :from))))))) (ert-deftest jabber-db-test-backlog-outgoing-format () "Outgoing backlog entries have account JID as :from." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "out" "chat" "Hi there" ts) (let ((entry (car (jabber-db-backlog "me@example.com" "friend@example.com")))) (should (string= "out" (plist-get entry :direction))) (should (string= "me@example.com" (plist-get entry :from))))))) (ert-deftest jabber-db-test-backlog-ordering () "Backlog returns messages in reverse chronological order." (jabber-db-test-with-db (let ((now (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "First" (- now 200)) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Second" (- now 100)) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Third" now) (let ((entries (jabber-db-backlog "me@example.com" "friend@example.com"))) (should (= 3 (length entries))) ;; DESC order: newest first (should (string= "Third" (plist-get (nth 0 entries) :body))) (should (string= "Second" (plist-get (nth 1 entries) :body))) (should (string= "First" (plist-get (nth 2 entries) :body))))))) (ert-deftest jabber-db-test-backlog-respects-count () "Backlog returns at most COUNT messages." (jabber-db-test-with-db (let ((now (floor (float-time)))) (dotimes (i 5) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" (format "Message %d" i) (- now (* i 10)))) (let ((entries (jabber-db-backlog "me@example.com" "friend@example.com" 2))) (should (= 2 (length entries))))))) (ert-deftest jabber-db-test-backlog-time-filter () "Backlog respects the start-time parameter." (jabber-db-test-with-db (let* ((now (floor (float-time))) (old (- now 86400)) ; 1 day ago (very-old (- now 172800))) ; 2 days ago (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Recent" now) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Old" old) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Very old" very-old) ;; Only get messages from last 1.5 days (let* ((cutoff (- (float-time) (* 1.5 86400))) (entries (jabber-db-backlog "me@example.com" "friend@example.com" nil cutoff))) (should (= 2 (length entries))) (should (string= "Recent" (plist-get (nth 0 entries) :body))) (should (string= "Old" (plist-get (nth 1 entries) :body))))))) (ert-deftest jabber-db-test-backlog-msg-type-filter () "Backlog with msg-type filters by message type." (jabber-db-test-with-db (let ((jabber-backlog-days 3.0) (jabber-backlog-number 50) (now (floor (float-time)))) (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "group msg" now "alice") (jabber-db-store-message "me@x.com" "room@x.com" "in" "chat" "private msg" (1+ now) "bob") ;; Without filter, both messages returned. (should (= 2 (length (jabber-db-backlog "me@x.com" "room@x.com")))) ;; With groupchat filter, only group message returned. (let ((entries (jabber-db-backlog "me@x.com" "room@x.com" nil nil nil "groupchat"))) (should (= 1 (length entries))) (should (string= "group msg" (plist-get (car entries) :body)))) ;; With chat filter, only private message returned. (let ((entries (jabber-db-backlog "me@x.com" "room@x.com" nil nil nil "chat"))) (should (= 1 (length entries))) (should (string= "private msg" (plist-get (car entries) :body))))))) ;;; Group 4: FTS search (ert-deftest jabber-db-test-fts-search () "Full-text search finds messages by keyword." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Let's meet for coffee tomorrow" ts) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "The weather is nice today" (1+ ts)) (let ((results (jabber-db-search "me@example.com" "coffee"))) (should (= 1 (length results))) (should (string-match-p "coffee" (plist-get (car results) :body))))))) (ert-deftest jabber-db-test-fts-search-with-peer () "FTS search scoped to a specific peer." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "alice@example.com" "in" "chat" "Hello from Alice" ts) (jabber-db-store-message "me@example.com" "bob@example.com" "in" "chat" "Hello from Bob" (1+ ts)) ;; Search for "Hello" scoped to Alice (let ((results (jabber-db-search "me@example.com" "Hello" "alice@example.com"))) (should (= 1 (length results))) (should (string= "alice@example.com" (plist-get (car results) :peer))))))) (ert-deftest jabber-db-test-fts-search-no-match () "FTS search returns nil when no messages match." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Hello world" ts) (should (null (jabber-db-search "me@example.com" "xyzzynonexistent")))))) ;;; Group 5: Dedup and last-timestamp (ert-deftest jabber-db-test-dedup-stanza-id () "Duplicate stanza_id keeps one row with body preserved and timestamp updated." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "First" ts nil "dup-id-123") (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Duplicate" (1+ ts) nil "dup-id-123") (let ((rows (sqlite-select (jabber-db-ensure-open) "SELECT body, timestamp FROM message WHERE stanza_id = 'dup-id-123'"))) (should (= 1 (length rows))) (should (string= "First" (caar rows))) (should (= (1+ ts) (cadar rows))))))) (ert-deftest jabber-db-test-dedup-scoped-by-account () "Same stanza_id from different accounts are stored as separate messages." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "alice@example.com" "friend@example.com" "in" "chat" "Alice got it" ts nil "shared-id-999") (jabber-db-store-message "bob@example.com" "friend@example.com" "in" "chat" "Bob got it" (1+ ts) nil "shared-id-999") ;; Both rows should exist (let ((rows (sqlite-select jabber-db--connection "SELECT account FROM message WHERE stanza_id='shared-id-999'"))) (should (= 2 (length rows))))))) (ert-deftest jabber-db-test-no-dedup-without-stanza-id () "Messages without stanza_id are never deduped." (jabber-db-test-with-db (let ((ts (- (floor (float-time)) 10))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Same body" ts) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Same body" (1+ ts)) (let ((rows (jabber-db-query "me@example.com" "friend@example.com"))) (should (= 2 (length rows))))))) (ert-deftest jabber-db-test-last-timestamp () "last-timestamp returns the latest timestamp for a peer." (jabber-db-test-with-db (let ((now (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Old" (- now 100)) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "New" now) (should (= now (jabber-db-last-timestamp "me@example.com" "friend@example.com")))))) ;;; Group 6: Account isolation (ert-deftest jabber-db-test-account-isolation () "Messages from different accounts are isolated." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "alice@example.com" "friend@example.com" "in" "chat" "Alice's message" ts) (jabber-db-store-message "bob@example.com" "friend@example.com" "in" "chat" "Bob's message" (1+ ts)) (let ((alice-msgs (jabber-db-backlog "alice@example.com" "friend@example.com")) (bob-msgs (jabber-db-backlog "bob@example.com" "friend@example.com"))) (should (= 1 (length alice-msgs))) (should (= 1 (length bob-msgs))) (should (string= "Alice's message" (plist-get (car alice-msgs) :body))) (should (string= "Bob's message" (plist-get (car bob-msgs) :body))))))) (ert-deftest jabber-db-test-peer-isolation () "Messages to different peers are isolated." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "alice@example.com" "out" "chat" "To Alice" ts) (jabber-db-store-message "me@example.com" "bob@example.com" "out" "chat" "To Bob" (1+ ts)) (let ((alice-msgs (jabber-db-backlog "me@example.com" "alice@example.com")) (bob-msgs (jabber-db-backlog "me@example.com" "bob@example.com"))) (should (= 1 (length alice-msgs))) (should (= 1 (length bob-msgs))))))) ;;; Group 7: Empty database (ert-deftest jabber-db-test-empty-backlog () "Backlog returns nil on an empty database." (jabber-db-test-with-db (should (null (jabber-db-backlog "me@example.com" "friend@example.com"))))) (ert-deftest jabber-db-test-empty-search () "Search returns nil on an empty database." (jabber-db-test-with-db (should (null (jabber-db-search "me@example.com" "anything"))))) (ert-deftest jabber-db-test-empty-last-timestamp () "last-timestamp returns nil when no messages exist." (jabber-db-test-with-db (should (null (jabber-db-last-timestamp "me@example.com" "friend@example.com"))))) ;;; Group 8: Query pagination (ert-deftest jabber-db-test-query-pagination () "Query with limit and offset returns correct page." (jabber-db-test-with-db (let ((now (floor (float-time)))) (dotimes (i 5) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" (format "Message %d" i) (+ now i))) ;; Page 1: first 2 messages (let ((page1 (jabber-db-query "me@example.com" "friend@example.com" now (+ now 10) 2 0))) (should (= 2 (length page1))) (should (string= "Message 0" (plist-get (car page1) :body)))) ;; Page 2: next 2 messages (let ((page2 (jabber-db-query "me@example.com" "friend@example.com" now (+ now 10) 2 2))) (should (= 2 (length page2))) (should (string= "Message 2" (plist-get (car page2) :body))))))) (ert-deftest jabber-db-test-query-time-range () "Query with start-time and end-time filters correctly." (jabber-db-test-with-db (let ((now (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Before" (- now 100)) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "During" now) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "After" (+ now 100)) (let ((rows (jabber-db-query "me@example.com" "friend@example.com" (- now 10) (+ now 10)))) (should (= 1 (length rows))) (should (string= "During" (plist-get (car rows) :body))))))) ;;; Group 9: Data persistence across close/reopen (ert-deftest jabber-db-test-persistence () "Data survives close and reopen." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Persistent message" ts) (jabber-db-close) (jabber-db-ensure-open) (let ((rows (jabber-db-query "me@example.com" "friend@example.com"))) (should (= 1 (length rows))) (should (string= "Persistent message" (plist-get (car rows) :body))))))) ;;; Group 10: MUC backlog round-trip (ert-deftest jabber-db-test-muc-backlog-sender-has-nickname () "MUC backlog sender includes room JID and nickname as resource." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "room@conference.example.com" "in" "groupchat" "Hello everyone" ts "knighthk") (let ((entry (car (jabber-db-backlog "me@example.com" "room@conference.example.com")))) (should (string= "room@conference.example.com/knighthk" (plist-get entry :from))) (should (string= "in" (plist-get entry :direction))) (should (string= "groupchat" (plist-get entry :msg-type))) (should (string= "Hello everyone" (plist-get entry :body))))))) (ert-deftest jabber-db-test-muc-backlog-multiple-senders () "MUC backlog preserves distinct nicknames for different senders." (jabber-db-test-with-db (let ((now (floor (float-time)))) (jabber-db-store-message "me@example.com" "room@conference.example.com" "in" "groupchat" "Hi from Alice" (- now 20) "alice") (jabber-db-store-message "me@example.com" "room@conference.example.com" "in" "groupchat" "Hi from Bob" (- now 10) "bob") (jabber-db-store-message "me@example.com" "room@conference.example.com" "out" "groupchat" "Hi from me" now) (let ((entries (jabber-db-backlog "me@example.com" "room@conference.example.com"))) (should (= 3 (length entries))) ;; DESC order: newest first (should (string= "me@example.com" (plist-get (nth 0 entries) :from))) (should (string= "room@conference.example.com/bob" (plist-get (nth 1 entries) :from))) (should (string= "room@conference.example.com/alice" (plist-get (nth 2 entries) :from))))))) (ert-deftest jabber-db-test-muc-backlog-persistence () "MUC messages survive close/reopen and retain nicknames." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "room@conference.example.com" "in" "groupchat" "Persistent MUC msg" ts "someuser") (jabber-db-close) (jabber-db-ensure-open) (let ((entry (car (jabber-db-backlog "me@example.com" "room@conference.example.com")))) (should (string= "room@conference.example.com/someuser" (plist-get entry :from))) (should (string= "Persistent MUC msg" (plist-get entry :body))))))) (ert-deftest jabber-db-test-nil-path-disables-storage () "Setting jabber-db-path to nil disables all DB operations." (let ((jabber-db-path nil) (jabber-db--connection nil)) (should (null (jabber-db-ensure-open))) (should (null (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Hello" (floor (float-time))))) (should (null (jabber-db-backlog "me@example.com" "friend@example.com"))))) ;;; Group 11: Import from history (ert-deftest jabber-db-test-import-history () "Importing from flat-file history populates the database." (jabber-db-test-with-db (let* ((jabber-use-global-history nil) (jabber-history-dir (expand-file-name "history" (file-name-directory jabber-db-path))) (history-file (expand-file-name "friend@example.com" jabber-history-dir))) ;; Create a fake history file (make-directory jabber-history-dir) (with-temp-file history-file (insert "[\"2024-01-15T10:00:00Z\" \"in\" \"friend@example.com\" \"me\" \"Hi there\"]\n") (insert "[\"2024-01-15T10:01:00Z\" \"out\" \"me\" \"friend@example.com\" \"Hey!\"]\n")) (jabber-db-import-history "me@example.com") (let ((rows (jabber-db-query "me@example.com" "friend@example.com" 0 (floor (float-time))))) (should (= 2 (length rows))) (should (string= "Hi there" (plist-get (car rows) :body))) (should (string= "in" (plist-get (car rows) :direction))) (should (string= "Hey!" (plist-get (cadr rows) :body))) (should (string= "out" (plist-get (cadr rows) :direction))))))) (ert-deftest jabber-db-test-import-history-strips-resource () "Imported messages with resource JIDs are stored under the bare JID." (jabber-db-test-with-db (let* ((jabber-use-global-history nil) (jabber-history-dir (expand-file-name "history" (file-name-directory jabber-db-path))) (history-file (expand-file-name "friend@example.com" jabber-history-dir))) (make-directory jabber-history-dir) (with-temp-file history-file (insert "[\"2024-01-15T10:00:00Z\" \"in\" \"friend@example.com/Work PC\" \"me\" \"From work\"]\n") (insert "[\"2024-01-15T10:01:00Z\" \"out\" \"me\" \"friend@example.com/Work PC\" \"Reply\"]\n")) (jabber-db-import-history "me@example.com") (let ((rows (jabber-db-query "me@example.com" "friend@example.com" 0 (floor (float-time))))) (should (= 2 (length rows))) (should (string= "From work" (plist-get (car rows) :body))) (should (string= "Reply" (plist-get (cadr rows) :body))))))) (ert-deftest jabber-db-test-import-global-history () "Importing from a global history file works." (jabber-db-test-with-db (let* ((jabber-use-global-history t) (jabber-global-history-filename (expand-file-name "global-history" (file-name-directory jabber-db-path)))) (with-temp-file jabber-global-history-filename (insert "[\"2024-06-01T12:00:00Z\" \"in\" \"alice@example.com\" \"me\" \"Global msg\"]\n")) (jabber-db-import-history "me@example.com") (let ((rows (jabber-db-query "me@example.com" "alice@example.com" 0 (floor (float-time))))) (should (= 1 (length rows))) (should (string= "Global msg" (plist-get (car rows) :body))))))) ;;; Group 12: jabber-db--row-to-plist (ert-deftest jabber-db-test-row-to-plist-incoming-chat () "Incoming chat message builds correct plist." ;; id account peer dir body ts resource type (let* ((row '(1 "me@example.com" "alice@example.com" "in" "Hello!" 1700000000 "mobile" "chat")) (plist (jabber-db--row-to-plist row))) (should (string= "alice@example.com/mobile" (plist-get plist :from))) (should (string= "Hello!" (plist-get plist :body))) (should (string= "in" (plist-get plist :direction))) (should (string= "chat" (plist-get plist :msg-type))) (should (plist-get plist :delayed)) (should (equal (seconds-to-time 1700000000) (plist-get plist :timestamp))))) (ert-deftest jabber-db-test-row-to-plist-incoming-no-resource () "Incoming message without resource uses bare JID as :from." (let* ((row '(2 "me@example.com" "alice@example.com" "in" "Hi" 1700000000 nil "chat")) (plist (jabber-db--row-to-plist row))) (should (string= "alice@example.com" (plist-get plist :from))))) (ert-deftest jabber-db-test-row-to-plist-outgoing () "Outgoing message uses account JID as :from." (let* ((row '(3 "me@example.com" "alice@example.com" "out" "Bye!" 1700000000 nil "chat")) (plist (jabber-db--row-to-plist row))) (should (string= "me@example.com" (plist-get plist :from))))) (ert-deftest jabber-db-test-row-to-plist-groupchat () "Groupchat message has msg-type groupchat." (let* ((row '(4 "me@example.com" "room@conf.example.com" "in" "Hello room" 1700000000 "Alice" "groupchat")) (plist (jabber-db--row-to-plist row))) (should (string= "groupchat" (plist-get plist :msg-type))) (should (string= "room@conf.example.com/Alice" (plist-get plist :from))))) (ert-deftest jabber-db-test-row-to-plist-nil-body () "Nil body is converted to empty string." (let* ((row '(5 "me@example.com" "alice@example.com" "in" nil 1700000000 nil "chat")) (plist (jabber-db--row-to-plist row))) (should (string= "" (plist-get plist :body))))) (ert-deftest jabber-db-test-row-to-plist-encrypted-flag () "Encrypted flag is correctly converted to boolean." ;; id account peer dir body ts resource type encrypted (let* ((row '(6 "me@example.com" "alice@example.com" "in" "Secret" 1700000000 nil "chat" 1)) (plist (jabber-db--row-to-plist row))) (should (eq t (plist-get plist :encrypted))))) (ert-deftest jabber-db-test-row-to-plist-not-encrypted () "Zero encrypted flag yields nil." (let* ((row '(7 "me@example.com" "alice@example.com" "in" "Plain" 1700000000 nil "chat" 0)) (plist (jabber-db--row-to-plist row))) (should-not (plist-get plist :encrypted)))) ;;; Group 13: Chat settings (encryption persistence) (ert-deftest jabber-db-test-chat-settings-table-exists () "The chat_settings table is created by the schema." (jabber-db-test-with-db (let ((tables (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM sqlite_master WHERE type='table'")))) (should (member "chat_settings" tables))))) (ert-deftest jabber-db-test-set-and-get-encryption-omemo () "Storing OMEMO encryption and reading it back returns the symbol." (jabber-db-test-with-db (jabber-db-set-chat-encryption "me@example.com" "alice@example.com" 'omemo) (should (eq 'omemo (jabber-db-get-chat-encryption "me@example.com" "alice@example.com"))))) (ert-deftest jabber-db-test-set-and-get-encryption-plaintext () "Storing plaintext encryption and reading it back returns the symbol." (jabber-db-test-with-db (jabber-db-set-chat-encryption "me@example.com" "alice@example.com" 'plaintext) (should (eq 'plaintext (jabber-db-get-chat-encryption "me@example.com" "alice@example.com"))))) (ert-deftest jabber-db-test-get-encryption-default-returns-nil () "Storing `default' encryption returns nil from get." (jabber-db-test-with-db (jabber-db-set-chat-encryption "me@example.com" "alice@example.com" 'default) (should (null (jabber-db-get-chat-encryption "me@example.com" "alice@example.com"))))) (ert-deftest jabber-db-test-get-encryption-missing-returns-nil () "Querying encryption for an unknown peer returns nil." (jabber-db-test-with-db (should (null (jabber-db-get-chat-encryption "me@example.com" "nobody@example.com"))))) (ert-deftest jabber-db-test-set-encryption-overwrites () "Setting encryption twice overwrites the previous value." (jabber-db-test-with-db (jabber-db-set-chat-encryption "me@example.com" "alice@example.com" 'omemo) (jabber-db-set-chat-encryption "me@example.com" "alice@example.com" 'plaintext) (should (eq 'plaintext (jabber-db-get-chat-encryption "me@example.com" "alice@example.com"))))) (ert-deftest jabber-db-test-chat-settings-account-isolation () "Encryption settings are isolated per account." (jabber-db-test-with-db (jabber-db-set-chat-encryption "alice@example.com" "bob@example.com" 'omemo) (jabber-db-set-chat-encryption "carol@example.com" "bob@example.com" 'plaintext) (should (eq 'omemo (jabber-db-get-chat-encryption "alice@example.com" "bob@example.com"))) (should (eq 'plaintext (jabber-db-get-chat-encryption "carol@example.com" "bob@example.com"))))) (ert-deftest jabber-db-test-chat-settings-peer-isolation () "Encryption settings are isolated per peer." (jabber-db-test-with-db (jabber-db-set-chat-encryption "me@example.com" "alice@example.com" 'omemo) (jabber-db-set-chat-encryption "me@example.com" "bob@example.com" 'plaintext) (should (eq 'omemo (jabber-db-get-chat-encryption "me@example.com" "alice@example.com"))) (should (eq 'plaintext (jabber-db-get-chat-encryption "me@example.com" "bob@example.com"))))) (ert-deftest jabber-db-test-chat-settings-persist-across-reopen () "Encryption settings survive close and reopen." (jabber-db-test-with-db (jabber-db-set-chat-encryption "me@example.com" "alice@example.com" 'omemo) (jabber-db-close) (jabber-db-ensure-open) (should (eq 'omemo (jabber-db-get-chat-encryption "me@example.com" "alice@example.com"))))) (ert-deftest jabber-db-test-chat-settings-muc-peer () "Encryption settings work with MUC room JIDs." (jabber-db-test-with-db (jabber-db-set-chat-encryption "me@example.com" "room@conference.example.com" 'plaintext) (should (eq 'plaintext (jabber-db-get-chat-encryption "me@example.com" "room@conference.example.com"))))) (ert-deftest jabber-db-test-chat-settings-nil-path () "Chat settings no-op when jabber-db-path is nil." (let ((jabber-db-path nil) (jabber-db--connection nil)) (should (null (jabber-db-set-chat-encryption "me@example.com" "alice@example.com" 'omemo))) (should (null (jabber-db-get-chat-encryption "me@example.com" "alice@example.com"))))) ;;; Group 14: Buffer encryption integration ;; ;; These tests verify that jabber-chat-mode-setup loads encryption ;; from the DB when jabber-chatting-with / jabber-group is set ;; BEFORE the setup call (the bug was calling setup before setting ;; the peer variable, so the DB lookup always returned nil). (require 'jabber-chatbuffer) (require 'fsm) (defun jabber-db-test--make-fake-jc (account) "Create a fake connection symbol for ACCOUNT (user@server)." (let ((jc (gensym "jabber-db-test-jc-")) (parts (split-string account "@"))) (put jc :state-data (list :username (nth 0 parts) :server (nth 1 parts))) jc)) (defmacro jabber-db-test-with-chat-buffer (account peer &rest body) "Run BODY in a temp chat buffer with fake connection for ACCOUNT talking to PEER. Sets up jabber-chatting-with before jabber-chat-mode-setup, mimicking the corrected jabber-chat-create-buffer order." (declare (indent 2) (debug t)) `(jabber-db-test-with-db (let* ((jc (jabber-db-test--make-fake-jc ,account)) (buf (generate-new-buffer " *test-chat*")) (jabber-chat-default-encryption 'omemo) (jabber-chatting-with nil)) (unwind-protect (with-current-buffer buf (jabber-chat-mode) (set (make-local-variable 'jabber-chatting-with) ,peer) (jabber-chat-mode-setup jc #'ignore) ,@body) (kill-buffer buf))))) (defmacro jabber-db-test-with-muc-buffer (account group &rest body) "Run BODY in a temp MUC buffer with fake connection for ACCOUNT in GROUP. Sets up jabber-group before jabber-chat-mode-setup, mimicking the corrected jabber-muc-create-buffer order." (declare (indent 2) (debug t)) `(jabber-db-test-with-db (let* ((jc (jabber-db-test--make-fake-jc ,account)) (buf (generate-new-buffer " *test-muc*")) (jabber-chat-default-encryption 'omemo) (jabber-chatting-with nil)) (unwind-protect (with-current-buffer buf (jabber-chat-mode) (set (make-local-variable 'jabber-group) ,group) (jabber-chat-mode-setup jc #'ignore) ,@body) (kill-buffer buf))))) (ert-deftest jabber-db-test-chat-buffer-loads-encryption-from-db () "1:1 chat buffer loads saved encryption from DB on setup." (jabber-db-test-with-chat-buffer "me@example.com" "alice@example.com" (jabber-db-set-chat-encryption "me@example.com" "alice@example.com" 'plaintext) ;; Reset and re-run setup to simulate fresh buffer (setq jabber-chat-encryption nil) (jabber-chat-mode-setup jc #'ignore) (should (eq 'plaintext jabber-chat-encryption)))) (ert-deftest jabber-db-test-chat-buffer-falls-back-to-default () "1:1 chat buffer uses default when no DB setting exists." (jabber-db-test-with-chat-buffer "me@example.com" "bob@example.com" (should (eq 'omemo jabber-chat-encryption)))) (ert-deftest jabber-db-test-chat-buffer-default-plaintext () "1:1 chat buffer respects jabber-chat-default-encryption when set to plaintext." (jabber-db-test-with-db (let* ((jc (jabber-db-test--make-fake-jc "me@example.com")) (buf (generate-new-buffer " *test-chat-plain*")) (jabber-chat-default-encryption 'plaintext) (jabber-chatting-with nil)) (unwind-protect (with-current-buffer buf (jabber-chat-mode) (set (make-local-variable 'jabber-chatting-with) "carol@example.com") (jabber-chat-mode-setup jc #'ignore) (should (eq 'plaintext jabber-chat-encryption))) (kill-buffer buf))))) (ert-deftest jabber-db-test-chat-buffer-db-overrides-default () "DB setting overrides jabber-chat-default-encryption." (jabber-db-test-with-chat-buffer "me@example.com" "alice@example.com" ;; Default is omemo, but DB says plaintext (jabber-db-set-chat-encryption "me@example.com" "alice@example.com" 'plaintext) (setq jabber-chat-encryption nil) (jabber-chat-mode-setup jc #'ignore) (should (eq 'plaintext jabber-chat-encryption)))) (ert-deftest jabber-db-test-muc-buffer-loads-encryption-from-db () "MUC buffer loads saved encryption from DB on setup." (jabber-db-test-with-db (let* ((jc (jabber-db-test--make-fake-jc "me@example.com")) (buf (generate-new-buffer " *test-muc-load*")) (jabber-chat-default-encryption 'omemo) (jabber-chatting-with nil)) ;; Store plaintext BEFORE creating the buffer (jabber-db-set-chat-encryption "me@example.com" "room@conference.example.com" 'plaintext) (unwind-protect (with-current-buffer buf (jabber-chat-mode) (set (make-local-variable 'jabber-group) "room@conference.example.com") (jabber-chat-mode-setup jc #'ignore) (should (eq 'plaintext jabber-chat-encryption))) (kill-buffer buf))))) (ert-deftest jabber-db-test-muc-buffer-falls-back-to-plaintext () "MUC buffer defaults to plaintext when no DB setting exists." (jabber-db-test-with-muc-buffer "me@example.com" "room@conference.example.com" (should (eq 'plaintext jabber-chat-encryption)))) (ert-deftest jabber-db-test-chat-buffer-without-peer-falls-back () "Buffer without jabber-chatting-with or jabber-group falls back to default." (jabber-db-test-with-db (let* ((jc (jabber-db-test--make-fake-jc "me@example.com")) (buf (generate-new-buffer " *test-no-peer*")) (jabber-chat-default-encryption 'omemo) (jabber-chatting-with nil)) (unwind-protect (with-current-buffer buf (jabber-chat-mode) ;; Deliberately not setting jabber-chatting-with or jabber-group (jabber-chat-mode-setup jc #'ignore) (should (eq 'omemo jabber-chat-encryption))) (kill-buffer buf))))) (ert-deftest jabber-db-test-toggle-save-roundtrip () "Toggling encryption saves to DB and reloading a fresh buffer picks it up." (jabber-db-test-with-db (let* ((jc (jabber-db-test--make-fake-jc "me@example.com")) (jabber-chat-default-encryption 'omemo) (jabber-chatting-with nil)) ;; First buffer: toggle to plaintext (let ((buf1 (generate-new-buffer " *test-toggle-1*"))) (unwind-protect (with-current-buffer buf1 (jabber-chat-mode) (set (make-local-variable 'jabber-chatting-with) "alice@example.com") (jabber-chat-mode-setup jc #'ignore) (should (eq 'omemo jabber-chat-encryption)) (jabber-chat-encryption-set-plaintext) (should (eq 'plaintext jabber-chat-encryption))) (kill-buffer buf1))) ;; Second buffer: should load plaintext from DB (let ((buf2 (generate-new-buffer " *test-toggle-2*"))) (unwind-protect (with-current-buffer buf2 (jabber-chat-mode) (set (make-local-variable 'jabber-chatting-with) "alice@example.com") (jabber-chat-mode-setup jc #'ignore) (should (eq 'plaintext jabber-chat-encryption))) (kill-buffer buf2)))))) (defvar jabber-chat-header-line-format) ; jabber-chat.el (ert-deftest jabber-db-test-redisplay-reloads-encryption () "jabber-chat-redisplay reloads encryption from DB." (jabber-db-test-with-db (let* ((jc (jabber-db-test--make-fake-jc "me@example.com")) (buf (generate-new-buffer " *test-redisplay*")) (jabber-chat-default-encryption 'omemo) (jabber-chatting-with nil) (jabber-chat-header-line-format '("test"))) (unwind-protect (with-current-buffer buf (jabber-chat-mode) (set (make-local-variable 'jabber-chatting-with) "alice@example.com") (jabber-chat-mode-setup jc #'ignore) (should (eq 'omemo jabber-chat-encryption)) ;; Simulate external DB change (jabber-db-set-chat-encryption "me@example.com" "alice@example.com" 'plaintext) ;; Redisplay should pick up the DB change (jabber-chat-redisplay) (should (eq 'plaintext jabber-chat-encryption))) (kill-buffer buf))))) ;;; Group 15: Receipt columns and updates (ert-deftest jabber-db-test-receipt-columns () "Message table has delivered_at and displayed_at columns." (jabber-db-test-with-db (sqlite-execute jabber-db--connection "INSERT INTO message (account,peer,direction,timestamp) VALUES ('a','b','out',1)") (let ((row (car (sqlite-select jabber-db--connection "SELECT delivered_at, displayed_at FROM message")))) (should (equal row '(nil nil)))))) (ert-deftest jabber-db-test-update-receipt-delivered () "Update delivered_at for an outgoing message by stanza_id." (jabber-db-test-with-db (jabber-db-store-message "me@example.com" "them@example.com" "out" "chat" "hello" 1000 nil "msg-001") (jabber-db-update-receipt "me@example.com" "them@example.com" "msg-001" "delivered_at" 1001) (let ((row (car (sqlite-select jabber-db--connection "SELECT delivered_at FROM message WHERE stanza_id='msg-001'")))) (should (equal row '(1001)))))) (ert-deftest jabber-db-test-update-receipt-displayed () "Update displayed_at for an outgoing message by stanza_id." (jabber-db-test-with-db (jabber-db-store-message "me@example.com" "them@example.com" "out" "chat" "hello" 1000 nil "msg-002") (jabber-db-update-receipt "me@example.com" "them@example.com" "msg-002" "displayed_at" 1002) (let ((row (car (sqlite-select jabber-db--connection "SELECT displayed_at FROM message WHERE stanza_id='msg-002'")))) (should (equal row '(1002)))))) (ert-deftest jabber-db-test-update-receipt-no-overwrite () "Duplicate receipt does not overwrite earlier timestamp." (jabber-db-test-with-db (jabber-db-store-message "me@example.com" "them@example.com" "out" "chat" "hello" 1000 nil "msg-003") (jabber-db-update-receipt "me@example.com" "them@example.com" "msg-003" "delivered_at" 1001) (jabber-db-update-receipt "me@example.com" "them@example.com" "msg-003" "delivered_at" 9999) (let ((row (car (sqlite-select jabber-db--connection "SELECT delivered_at FROM message WHERE stanza_id='msg-003'")))) (should (equal row '(1001)))))) (ert-deftest jabber-db-test-update-receipt-nil-stanza-id () "Update with nil stanza_id is a no-op." (jabber-db-test-with-db (jabber-db-store-message "me@example.com" "them@example.com" "out" "chat" "hello" 1000) (jabber-db-update-receipt "me@example.com" "them@example.com" nil "delivered_at" 1001) (let ((row (car (sqlite-select jabber-db--connection "SELECT delivered_at FROM message LIMIT 1")))) (should (equal row '(nil)))))) (ert-deftest jabber-db-test-update-receipt-scoped-by-peer () "Receipt update only affects matching account+peer, not other conversations." (jabber-db-test-with-db (jabber-db-store-message "me@example.com" "alice@example.com" "out" "chat" "hi alice" 1000 nil "msg-same-id") (jabber-db-store-message "me@example.com" "bob@example.com" "out" "chat" "hi bob" 1001 nil "msg-same-id") (jabber-db-update-receipt "me@example.com" "alice@example.com" "msg-same-id" "delivered_at" 2000) (let ((alice (caar (sqlite-select jabber-db--connection "SELECT delivered_at FROM message WHERE peer='alice@example.com'"))) (bob (caar (sqlite-select jabber-db--connection "SELECT delivered_at FROM message WHERE peer='bob@example.com'")))) (should (equal alice 2000)) (should (null bob))))) (ert-deftest jabber-db-test-update-receipt-only-outgoing () "Receipt update only affects outgoing messages, not incoming." (jabber-db-test-with-db (jabber-db-store-message "me@example.com" "them@example.com" "in" "chat" "incoming" 1000 nil "msg-in") (jabber-db-update-receipt "me@example.com" "them@example.com" "msg-in" "delivered_at" 2000) (let ((row (caar (sqlite-select jabber-db--connection "SELECT delivered_at FROM message WHERE stanza_id='msg-in'")))) (should (null row))))) ;;; Group 16: Delete peer messages (ert-deftest jabber-db-test-delete-peer-messages () "Deleting peer messages removes all rows for that account+peer." (jabber-db-test-with-db (let ((ts (- (floor (float-time)) 10))) (jabber-db-store-message "me@example.com" "alice@example.com" "in" "chat" "Hello" ts) (jabber-db-store-message "me@example.com" "alice@example.com" "out" "chat" "Hi" (1+ ts)) (jabber-db-store-message "me@example.com" "bob@example.com" "in" "chat" "Hey" (+ ts 2)) ;; Delete alice's messages (jabber-db-delete-peer-messages "me@example.com" "alice@example.com") ;; Alice gone (should (null (jabber-db-query "me@example.com" "alice@example.com"))) ;; Bob untouched (let ((rows (jabber-db-query "me@example.com" "bob@example.com"))) (should (= 1 (length rows))) (should (string= "Hey" (plist-get (car rows) :body))))))) (ert-deftest jabber-db-test-delete-peer-messages-empty () "Deleting from a nonexistent peer is a no-op." (jabber-db-test-with-db (jabber-db-delete-peer-messages "me@example.com" "nobody@example.com") ;; No error, no rows affected (should t))) ;;; Group 17: Message retraction (ert-deftest jabber-db-test-retract-with-reason () "jabber-db-retract-message persists moderator and reason; backlog returns both." (skip-unless (fboundp 'sqlite-open)) (let ((jabber-backlog-days 3.0) (jabber-backlog-number 10) (now (floor (float-time)))) (jabber-db-test-with-db (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "offensive" now nil nil "srv-retract-1") (jabber-db-retract-message "srv-retract-1" "room@x.com/mod" "spam") (let* ((entries (jabber-db-backlog "me@x.com" "room@x.com")) (entry (car entries))) (should entry) (should (plist-get entry :retracted)) (should (equal "room@x.com/mod" (plist-get entry :retracted-by))) (should (equal "spam" (plist-get entry :retraction-reason))))))) (ert-deftest jabber-db-test-retract-without-reason () "jabber-db-retract-message with no reason leaves :retraction-reason nil." (skip-unless (fboundp 'sqlite-open)) (let ((jabber-backlog-days 3.0) (jabber-backlog-number 10) (now (floor (float-time)))) (jabber-db-test-with-db (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "msg" now nil nil "srv-retract-2") (jabber-db-retract-message "srv-retract-2" "room@x.com/mod") (let* ((entries (jabber-db-backlog "me@x.com" "room@x.com")) (entry (car entries))) (should (plist-get entry :retracted)) (should-not (plist-get entry :retraction-reason)))))) ;;; Group: Failed-decrypt replacement (ert-deftest jabber-db-test-store-replaces-failed-decrypt-by-stanza-id () "Re-storing a message with real text replaces a decrypt-failure placeholder." (jabber-db-test-with-db ;; Store with failed-decrypt body (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "[OMEMO: could not decrypt]" 1700000000 "res" "stanza-1" "srv-1") ;; Re-store same stanza-id with decrypted body (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "hello there" 1700000000 "res" "stanza-1" "srv-1" nil nil t) ;; Should have exactly one row with the decrypted body (let ((rows (sqlite-select (jabber-db-ensure-open) "SELECT body FROM message WHERE stanza_id = ?" '("stanza-1")))) (should (= 1 (length rows))) (should (string= "hello there" (caar rows)))))) (ert-deftest jabber-db-test-store-replaces-failed-decrypt-by-server-id () "Re-storing by server-id replaces a decrypt-failure placeholder." (jabber-db-test-with-db (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "[OMEMO: could not decrypt]" 1700000000 "res" nil "srv-2") (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "decrypted text" 1700000000 "res" nil "srv-2" nil nil t) (let ((rows (sqlite-select (jabber-db-ensure-open) "SELECT body FROM message WHERE server_id = ?" '("srv-2")))) (should (= 1 (length rows))) (should (string= "decrypted text" (caar rows)))))) (ert-deftest jabber-db-test-store-no-replace-when-still-undecryptable () "Re-storing with another failed-decrypt body does not update." (jabber-db-test-with-db (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "[OMEMO: could not decrypt]" 1700000000 "res" "stanza-3" "srv-3") (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "[OMEMO: could not decrypt]" 1700000000 "res" "stanza-3" "srv-3") ;; Still one row, body unchanged (let ((rows (sqlite-select (jabber-db-ensure-open) "SELECT body FROM message WHERE stanza_id = ?" '("stanza-3")))) (should (= 1 (length rows))) (should (string= "[OMEMO: could not decrypt]" (caar rows)))))) (ert-deftest jabber-db-test-store-no-replace-when-already-decrypted () "Re-storing does not overwrite an already-decrypted message." (jabber-db-test-with-db (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "original text" 1700000000 "res" "stanza-4" "srv-4") (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "different text" 1700000000 "res" "stanza-4" "srv-4") ;; Still one row, original body preserved (let ((rows (sqlite-select (jabber-db-ensure-open) "SELECT body FROM message WHERE stanza_id = ?" '("stanza-4")))) (should (= 1 (length rows))) (should (string= "original text" (caar rows)))))) (ert-deftest jabber-db-test-store-normalizes-timestamp-on-dedup () "Re-storing a duplicate updates the timestamp to the server's value." (jabber-db-test-with-db ;; Store with local timestamp (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "hello" 1700000099 "res" "stanza-5" "srv-5") ;; Re-store same message with server's authoritative timestamp (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "hello" 1700000100 "res" "stanza-5" "srv-5") (let ((rows (sqlite-select (jabber-db-ensure-open) "SELECT timestamp FROM message WHERE stanza_id = ?" '("stanza-5")))) (should (= 1 (length rows))) (should (= 1700000100 (caar rows)))))) (ert-deftest jabber-db-test-store-normalizes-timestamp-and-replaces-decrypt () "Failed-decrypt replacement also normalizes the timestamp." (jabber-db-test-with-db (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "[OMEMO: could not decrypt]" 1700000099 "res" "stanza-6" "srv-6") (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "decrypted" 1700000100 "res" "stanza-6" "srv-6" nil nil t) (let ((rows (sqlite-select (jabber-db-ensure-open) "SELECT body, timestamp FROM message WHERE stanza_id = ?" '("stanza-6")))) (should (= 1 (length rows))) (should (string= "decrypted" (caar rows))) (should (= 1700000100 (cadar rows)))))) ;;; Group: Schema v2 migration and constraints (defconst jabber-db-test--v1-ddl '("CREATE TABLE IF NOT EXISTS message ( id INTEGER PRIMARY KEY, stanza_id TEXT, server_id TEXT, account TEXT NOT NULL, peer TEXT NOT NULL, resource TEXT, direction TEXT NOT NULL, type TEXT, body TEXT, timestamp INTEGER NOT NULL, encrypted INTEGER DEFAULT 0, raw_xml TEXT, oob_url TEXT, oob_desc TEXT, delivered_at INTEGER, displayed_at INTEGER, retracted_by TEXT, retraction_reason TEXT, edited INTEGER DEFAULT 0)" "CREATE INDEX IF NOT EXISTS idx_msg_peer_ts ON message(account, peer, timestamp)" "CREATE INDEX IF NOT EXISTS idx_msg_stanza_id ON message(account, stanza_id) WHERE stanza_id IS NOT NULL" "CREATE INDEX IF NOT EXISTS idx_msg_server_id ON message(account, server_id) WHERE server_id IS NOT NULL") "V1 schema DDL for migration tests.") (defmacro jabber-db-test-with-v1-db (&rest body) "Run BODY with a v1 database (has raw_xml, no occupant_id)." (declare (indent 0) (debug t)) `(let* ((jabber-db-test--dir (make-temp-file "jabber-db-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-db-test--dir)) (jabber-db--connection nil)) (unwind-protect (let ((db (sqlite-open jabber-db-path))) (dolist (ddl jabber-db-test--v1-ddl) (sqlite-execute db ddl)) (sqlite-execute db "PRAGMA user_version=1") (sqlite-close db) ,@body) (jabber-db-close) (when (file-directory-p jabber-db-test--dir) (delete-directory jabber-db-test--dir t))))) (ert-deftest jabber-db-test-v1-to-v2-migration () "Migrating from v1 adds occupant_id, drops raw_xml, and runs through v3." (skip-unless (fboundp 'sqlite-open)) (jabber-db-test-with-v1-db ;; Insert a v1 row with raw_xml (let ((db (sqlite-open jabber-db-path))) (sqlite-execute db "\ INSERT INTO message (account, peer, direction, type, body, timestamp, raw_xml) VALUES ('me@x.com', 'friend@x.com', 'in', 'chat', 'hello', 1000, '')") (sqlite-close db)) ;; Open via jabber-db which triggers migration (jabber-db-ensure-open) (let ((version (caar (sqlite-select jabber-db--connection "PRAGMA user_version")))) (should (= jabber-db--schema-version version))) ;; occupant_id column exists (NULL for old rows) (let ((rows (sqlite-select jabber-db--connection "SELECT occupant_id FROM message LIMIT 1"))) (should (= 1 (length rows))) (should (null (caar rows)))) ;; raw_xml column is gone (should-error (sqlite-select jabber-db--connection "SELECT raw_xml FROM message LIMIT 1")))) (ert-deftest jabber-db-test-v1-migration-preserves-data () "Migrating from v1 preserves existing message data." (skip-unless (fboundp 'sqlite-open)) (jabber-db-test-with-v1-db (let ((db (sqlite-open jabber-db-path))) (sqlite-execute db "\ INSERT INTO message (account, peer, direction, type, body, timestamp, resource) VALUES ('me@x.com', 'friend@x.com', 'in', 'chat', 'preserved', 2000, 'laptop')") (sqlite-close db)) (jabber-db-ensure-open) (let ((row (car (sqlite-select jabber-db--connection "SELECT body, resource FROM message LIMIT 1")))) (should (string= "preserved" (nth 0 row))) (should (string= "laptop" (nth 1 row)))))) (ert-deftest jabber-db-test-check-direction-on-fresh-db () "CHECK constraint rejects invalid direction on fresh databases." (skip-unless (fboundp 'sqlite-open)) (jabber-db-test-with-db (should-error (sqlite-execute jabber-db--connection "INSERT INTO message (account, peer, direction, type, body, timestamp) VALUES ('a', 'b', 'bad', 'chat', 'x', 1000)")))) (ert-deftest jabber-db-test-check-type-on-fresh-db () "CHECK constraint rejects invalid message type on fresh databases." (skip-unless (fboundp 'sqlite-open)) (jabber-db-test-with-db (should-error (sqlite-execute jabber-db--connection "INSERT INTO message (account, peer, direction, type, body, timestamp) VALUES ('a', 'b', 'in', 'invalid', 'x', 1000)")))) (ert-deftest jabber-db-test-occupant-id-round-trip () "Storing and retrieving occupant_id works end-to-end." (skip-unless (fboundp 'sqlite-open)) (jabber-db-test-with-db (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "hello" (floor (float-time)) "nick" "sid-1" nil "occ-abc-123") (let* ((rows (jabber-db-query "me@x.com" "room@x.com")) (row (car rows))) (should row) (should (string= "occ-abc-123" (plist-get row :occupant-id)))))) (ert-deftest jabber-db-test-occupant-id-nil-when-absent () "occupant_id is nil when not provided." (skip-unless (fboundp 'sqlite-open)) (jabber-db-test-with-db (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "hello" (floor (float-time))) (let* ((rows (jabber-db-query "me@x.com" "friend@x.com")) (row (car rows))) (should row) (should (null (plist-get row :occupant-id)))))) ;;; Group: server-ids-by-occupant-id (ert-deftest jabber-db-test-server-ids-by-occupant-id () "Returns correct server-ids for an occupant-id." (jabber-db-test-with-db (let ((now (floor (float-time)))) (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "msg1" now "nick" nil "srv-a" "occ-1") (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "msg2" (1+ now) "nick" nil "srv-b" "occ-1") (let ((ids (jabber-db-server-ids-by-occupant-id "me@x.com" "room@x.com" "occ-1"))) (should (= 2 (length ids))) (should (member "srv-a" ids)) (should (member "srv-b" ids)))))) (ert-deftest jabber-db-test-server-ids-by-occupant-id-excludes-retracted () "Already-retracted messages are excluded." (jabber-db-test-with-db (let ((now (floor (float-time)))) (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "msg1" now "nick" nil "srv-c" "occ-2") (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "msg2" (1+ now) "nick" nil "srv-d" "occ-2") (jabber-db-retract-message "srv-c" "room@x.com/mod" "spam") (let ((ids (jabber-db-server-ids-by-occupant-id "me@x.com" "room@x.com" "occ-2"))) (should (= 1 (length ids))) (should (string= "srv-d" (car ids))))))) (ert-deftest jabber-db-test-server-ids-by-occupant-id-excludes-nil-server-id () "Messages without server-id are excluded." (jabber-db-test-with-db (let ((now (floor (float-time)))) (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "msg1" now "nick" nil "srv-e" "occ-3") ;; Message with occupant-id but no server-id (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "msg2" (1+ now) "nick" nil nil "occ-3") (let ((ids (jabber-db-server-ids-by-occupant-id "me@x.com" "room@x.com" "occ-3"))) (should (= 1 (length ids))) (should (string= "srv-e" (car ids))))))) (ert-deftest jabber-db-test-server-ids-by-occupant-id-unknown () "Returns nil for an unknown occupant-id." (jabber-db-test-with-db (should (null (jabber-db-server-ids-by-occupant-id "me@x.com" "room@x.com" "nonexistent"))))) (ert-deftest jabber-db-test-occupant-id-by-server-id () "Returns occupant-id for a known server-id." (jabber-db-test-with-db (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "hello" (floor (float-time)) "nick" nil "srv-occ-1" "occ-lookup") (should (string= "occ-lookup" (jabber-db-occupant-id-by-server-id "srv-occ-1"))))) (ert-deftest jabber-db-test-occupant-id-by-server-id-nil () "Returns nil for unknown server-id." (jabber-db-test-with-db (should (null (jabber-db-occupant-id-by-server-id "nonexistent"))))) (ert-deftest jabber-db-test-store-preserves-retraction-on-dedup () "Re-storing a retracted message does not clear retracted_by." (jabber-db-test-with-db (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "spam" 1000 "nick" nil "srv-pres-1") (jabber-db-retract-message "srv-pres-1" "room@x.com/mod" "spam") ;; MAM re-stores the same message (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "spam" 1000 "nick" nil "srv-pres-1") (let ((row (car (sqlite-select jabber-db--connection "SELECT retracted_by FROM message WHERE server_id = ?" '("srv-pres-1"))))) (should (string= "room@x.com/mod" (car row)))))) ;;; Group: message_oob child table (ert-deftest jabber-db-test-oob-table-exists () "The message_oob table and index exist in fresh databases." (jabber-db-test-with-db (let ((tables (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM sqlite_master WHERE type='table'")))) (should (member "message_oob" tables))) (let ((indexes (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM sqlite_master WHERE type='index'")))) (should (member "idx_oob_message_id" indexes))))) (ert-deftest jabber-db-test-store-single-oob () "Storing a message with one OOB entry creates a child row." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Check this out" ts nil "id-oob-1" nil nil '(("https://example.com/file.pdf" . "A PDF"))) (let ((rows (sqlite-select jabber-db--connection "SELECT url, desc FROM message_oob"))) (should (= 1 (length rows))) (should (string= "https://example.com/file.pdf" (caar rows))) (should (string= "A PDF" (cadar rows))))))) (ert-deftest jabber-db-test-store-multiple-oob () "Storing a message with multiple OOB entries creates multiple child rows." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Attachments" ts nil "id-oob-multi" nil nil '(("https://example.com/a.jpg" . "Photo A") ("https://example.com/b.pdf" . nil) ("https://example.com/c.mp3" . "Audio"))) (let ((rows (sqlite-select jabber-db--connection "SELECT url, desc FROM message_oob ORDER BY id"))) (should (= 3 (length rows))) (should (string= "https://example.com/a.jpg" (car (nth 0 rows)))) (should (string= "Photo A" (cadr (nth 0 rows)))) (should (string= "https://example.com/b.pdf" (car (nth 1 rows)))) (should (null (cadr (nth 1 rows)))) (should (string= "https://example.com/c.mp3" (car (nth 2 rows)))))))) (ert-deftest jabber-db-test-store-nil-oob () "Storing a message with nil OOB creates no child rows." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Plain text" ts nil "id-no-oob") (let ((rows (sqlite-select jabber-db--connection "SELECT count(*) FROM message_oob"))) (should (= 0 (caar rows))))))) (ert-deftest jabber-db-test-backlog-oob-entries () "Backlog returns :oob-entries with correct data." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "File" ts nil "id-back-oob" nil nil '(("https://example.com/a.pdf" . "Doc A") ("https://example.com/b.png" . nil))) (let* ((entries (jabber-db-backlog "me@example.com" "friend@example.com")) (entry (car entries)) (oob (plist-get entry :oob-entries))) (should (= 2 (length oob))) (should (string= "https://example.com/a.pdf" (caar oob))) (should (string= "Doc A" (cdar oob))) (should (string= "https://example.com/b.png" (car (cadr oob)))) (should (null (cdr (cadr oob)))))))) (ert-deftest jabber-db-test-backlog-oob-compat () "Backlog sets :oob-url and :oob-desc from first entry for compat." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "File" ts nil "id-compat-oob" nil nil '(("https://example.com/first.pdf" . "First") ("https://example.com/second.pdf" . "Second"))) (let* ((entries (jabber-db-backlog "me@example.com" "friend@example.com")) (entry (car entries))) (should (string= "https://example.com/first.pdf" (plist-get entry :oob-url))) (should (string= "First" (plist-get entry :oob-desc))))))) (ert-deftest jabber-db-test-backlog-no-oob () "Backlog returns nil :oob-entries for messages without OOB." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Plain" ts nil "id-nooob") (let* ((entries (jabber-db-backlog "me@example.com" "friend@example.com")) (entry (car entries))) (should (null (plist-get entry :oob-entries))) (should (null (plist-get entry :oob-url))))))) (ert-deftest jabber-db-test-oob-cascade-delete () "Deleting a message cascades to message_oob rows." (jabber-db-test-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "peer@example.com" "in" "chat" "File" ts nil "id-cascade" nil nil '(("https://example.com/x.pdf" . "X"))) (jabber-db-delete-peer-messages "me@example.com" "peer@example.com") (should (= 0 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message_oob"))))))) (ert-deftest jabber-db-test-migration-v2-to-v4 () "Migration v2->v4 applies the full chain: OOB child table, caps cache." (let* ((jabber-db-test--dir (make-temp-file "jabber-db-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-db-test--dir)) (jabber-db--connection nil) (jabber-backlog-days 3.0) (jabber-backlog-number 10)) (unwind-protect (progn ;; Create a v2 database manually. (let ((db (sqlite-open jabber-db-path))) (sqlite-execute db "PRAGMA journal_mode=WAL") (sqlite-execute db "\ CREATE TABLE message ( id INTEGER PRIMARY KEY, account TEXT NOT NULL, peer TEXT NOT NULL, resource TEXT, occupant_id TEXT, direction TEXT NOT NULL, type TEXT, body TEXT, timestamp INTEGER NOT NULL, stanza_id TEXT, server_id TEXT, oob_url TEXT, oob_desc TEXT, encrypted INTEGER DEFAULT 0, delivered_at INTEGER, displayed_at INTEGER, retracted_by TEXT, retraction_reason TEXT, edited INTEGER DEFAULT 0)") ;; Insert a message with OOB data. (sqlite-execute db "\ INSERT INTO message (account, peer, direction, type, body, timestamp, stanza_id, oob_url, oob_desc) VALUES ('me@x.com', 'peer@x.com', 'in', 'chat', 'file', 1000, 'sid-1', 'https://example.com/f.pdf', 'A file')") ;; Insert a message without OOB data. (sqlite-execute db "\ INSERT INTO message (account, peer, direction, type, body, timestamp, stanza_id) VALUES ('me@x.com', 'peer@x.com', 'in', 'chat', 'text', 1001, 'sid-2')") (sqlite-execute db "PRAGMA user_version=2") (sqlite-close db)) ;; Open with migration. (jabber-db-ensure-open) ;; Check version is now 4 (full chain: v2->v3->v4). (should (= 4 (caar (sqlite-select jabber-db--connection "PRAGMA user_version")))) ;; OOB data migrated to child table. (let ((oob-rows (sqlite-select jabber-db--connection "SELECT url, desc FROM message_oob"))) (should (= 1 (length oob-rows))) (should (string= "https://example.com/f.pdf" (caar oob-rows))) (should (string= "A file" (cadar oob-rows)))) ;; Old columns should be gone. (let ((cols (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM pragma_table_info('message')")))) (should-not (member "oob_url" cols)) (should-not (member "oob_desc" cols)))) (jabber-db-close) (when (file-directory-p jabber-db-test--dir) (delete-directory jabber-db-test--dir t))))) (ert-deftest jabber-db-test-oob-dedup-replacement () "Failed-decrypt replacement updates OOB entries." (jabber-db-test-with-db (let ((ts (floor (float-time)))) ;; Store with failed decrypt body and OOB. (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "[me@example.com: could not decrypt]" ts nil "id-dec" nil nil '(("https://old.com/x.pdf" . "Old"))) ;; Re-store with real body and new OOB entries. (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Decrypted text" ts nil "id-dec" nil nil '(("https://new.com/a.pdf" . "New A") ("https://new.com/b.pdf" . "New B"))) ;; Body should be updated. (let ((body (caar (sqlite-select jabber-db--connection "SELECT body FROM message WHERE stanza_id = 'id-dec'")))) (should (string= "Decrypted text" body))) ;; OOB entries should be replaced. (let ((oob (sqlite-select jabber-db--connection "SELECT url, desc FROM message_oob ORDER BY id"))) (should (= 2 (length oob))) (should (string= "https://new.com/a.pdf" (car (nth 0 oob)))) (should (string= "https://new.com/b.pdf" (car (nth 1 oob)))))))) (provide 'jabber-db-tests) ;;; jabber-db-tests.el ends here emacs-jabber/tests/jabber-disco-tests.el000066400000000000000000000163051516610113500205450ustar00rootroot00000000000000;;; jabber-disco-tests.el --- Tests for jabber-disco -*- lexical-binding: t; -*- (require 'ert) ;; Pre-define variables expected at load time. (defvar jabber-body-printers nil) (defvar jabber-message-chain nil) (defvar jabber-presence-chain nil) (defvar jabber-iq-chain nil) (defvar jabber-jid-obarray (make-vector 127 0)) (require 'jabber-disco) (require 'jabber-db) ;;; Group 1: jabber-caps--store-hash (ert-deftest jabber-disco-test-store-hash-sets-caps-on-resource () "Storing a caps hash sets the caps property on the resource plist." (let ((jabber-jid-obarray (make-vector 127 0))) (jabber-caps--store-hash "alice@example.com/mobile" '("sha-1" . "abc123")) (let* ((sym (intern-soft "alice@example.com" jabber-jid-obarray)) (resources (get sym 'resources)) (entry (assoc "mobile" resources))) (should entry) (should (equal (plist-get (cdr entry) 'caps) '("sha-1" . "abc123")))))) (ert-deftest jabber-disco-test-store-hash-updates-existing-resource () "Storing a caps hash updates an existing resource entry, not duplicating it." (let ((jabber-jid-obarray (make-vector 127 0))) ;; Store initial caps. (jabber-caps--store-hash "alice@example.com/mobile" '("sha-1" . "v1")) ;; Update caps for same resource. (jabber-caps--store-hash "alice@example.com/mobile" '("sha-1" . "v2")) (let* ((sym (intern-soft "alice@example.com" jabber-jid-obarray)) (resources (get sym 'resources)) (matching (cl-remove-if-not (lambda (r) (string= (car r) "mobile")) resources))) ;; Only one resource entry for "mobile". (should (= (length matching) 1)) ;; Updated to v2. (should (equal (plist-get (cdr (car matching)) 'caps) '("sha-1" . "v2")))))) (ert-deftest jabber-disco-test-store-hash-bare-jid () "Storing caps for a bare JID (no resource) uses empty string as resource key." (let ((jabber-jid-obarray (make-vector 127 0))) (jabber-caps--store-hash "bob@example.com" '("sha-256" . "xyz")) (let* ((sym (intern-soft "bob@example.com" jabber-jid-obarray)) (resources (get sym 'resources)) (entry (assoc "" resources))) (should entry) (should (equal (plist-get (cdr entry) 'caps) '("sha-256" . "xyz")))))) ;;; Group 2: jabber-caps--query-if-needed (ert-deftest jabber-disco-test-query-if-needed-cache-hit () "On cache hit, disco info is copied to jabber-disco-info-cache." (let ((jabber-caps-cache (make-hash-table :test 'equal)) (jabber-disco-info-cache (make-hash-table :test 'equal)) (cached-data '(("id1") ("feat1" "feat2"))) (key '("sha-1" . "ver1"))) (puthash key cached-data jabber-caps-cache) (jabber-caps--query-if-needed nil "alice@example.com/res" "sha-1" "http://node" "ver1" key cached-data) (should (equal (gethash '("alice@example.com/res" . nil) jabber-disco-info-cache) cached-data)))) (ert-deftest jabber-disco-test-query-if-needed-cache-miss () "On cache miss, a pending entry is created in jabber-caps-cache." (let ((jabber-caps-cache (make-hash-table :test 'equal)) (jabber-disco-info-cache (make-hash-table :test 'equal)) (key '("sha-1" . "ver1")) (iq-sent nil)) ;; Stub jabber-send-iq to record the call without needing a connection. (cl-letf (((symbol-function 'jabber-send-iq) (lambda (&rest _args) (setq iq-sent t)))) (jabber-caps--query-if-needed nil "alice@example.com/res" "sha-1" "http://node" "ver1" key nil) ;; A pending entry should exist. (let ((entry (gethash key jabber-caps-cache))) (should (consp entry)) (should (floatp (car entry)))) ;; An IQ query should have been dispatched. (should iq-sent)))) (ert-deftest jabber-disco-test-query-if-needed-pending-recent () "On recent pending query (<10s), JID is added to fallback list." (let ((jabber-caps-cache (make-hash-table :test 'equal)) (jabber-disco-info-cache (make-hash-table :test 'equal)) (key '("sha-1" . "ver1")) (pending-entry (list (float-time)))) (puthash key pending-entry jabber-caps-cache) (jabber-caps--query-if-needed nil "bob@example.com/laptop" "sha-1" "http://node" "ver1" key pending-entry) ;; bob's JID should be in the fallback list (cdr of entry). (should (member "bob@example.com/laptop" (cdr pending-entry))))) (ert-deftest jabber-disco-test-query-if-needed-pending-stale () "On stale pending query (>10s), a new disco query is sent." (let ((jabber-caps-cache (make-hash-table :test 'equal)) (jabber-disco-info-cache (make-hash-table :test 'equal)) (key '("sha-1" . "ver1")) ;; Create a pending entry from 15 seconds ago. (pending-entry (list (- (float-time) 15.0))) (iq-sent nil)) (puthash key pending-entry jabber-caps-cache) (cl-letf (((symbol-function 'jabber-send-iq) (lambda (&rest _args) (setq iq-sent t)))) (jabber-caps--query-if-needed nil "carol@example.com/phone" "sha-1" "http://node" "ver1" key pending-entry) ;; Timestamp should be refreshed (recent). (should (< (- (float-time) (car pending-entry)) 2.0)) ;; A new IQ query should have been dispatched. (should iq-sent)))) ;;; Group 3: jabber-process-caps-modern (integration) (ert-deftest jabber-disco-test-process-caps-modern-unsupported-hash () "When the hash algorithm is not in jabber-caps-hash-names, nothing happens." (let ((jabber-jid-obarray (make-vector 127 0)) (jabber-caps-cache (make-hash-table :test 'equal)) (jabber-disco-info-cache (make-hash-table :test 'equal))) ;; "md5" is not in jabber-caps-hash-names. (jabber-process-caps-modern nil "alice@example.com/res" "md5" "http://node" "ver1") ;; No symbol should have been interned for this JID. (should-not (intern-soft "alice@example.com" jabber-jid-obarray)))) (ert-deftest jabber-disco-test-process-caps-modern-stores-and-queries () "With a supported hash and empty cache, store-hash and query are both called." (let ((jabber-jid-obarray (make-vector 127 0)) (jabber-caps-cache (make-hash-table :test 'equal)) (jabber-disco-info-cache (make-hash-table :test 'equal)) (iq-sent nil)) (cl-letf (((symbol-function 'jabber-send-iq) (lambda (&rest _args) (setq iq-sent t)))) (jabber-process-caps-modern nil "alice@example.com/phone" "sha-1" "http://node" "ver1") ;; Hash should be stored on the resource. (let* ((sym (intern-soft "alice@example.com" jabber-jid-obarray)) (resources (get sym 'resources)) (entry (assoc "phone" resources))) (should entry) (should (equal (plist-get (cdr entry) 'caps) '("sha-1" . "ver1")))) ;; Query should have been sent. (should iq-sent)))) (provide 'jabber-disco-tests) ;;; jabber-disco-tests.el ends here emacs-jabber/tests/jabber-mam-tests.el000066400000000000000000001230131516610113500202110ustar00rootroot00000000000000;;; jabber-mam-tests.el --- Tests for jabber-mam -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-db) (require 'jabber-disco) (require 'jabber-chat) (require 'jabber-muc) (require 'jabber-mam) (require 'jabber-message-correct) ;;; Test infrastructure (defmacro jabber-mam-test-with-db (&rest body) "Run BODY with a fresh temp SQLite database." (declare (indent 0) (debug t)) `(let* ((jabber-mam-test--dir (make-temp-file "jabber-mam-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-mam-test--dir)) (jabber-db--connection nil)) (unwind-protect (progn (jabber-db-ensure-open) ,@body) (jabber-db-close) (when (file-directory-p jabber-mam-test--dir) (delete-directory jabber-mam-test--dir t))))) (defvar jabber-mam-test-queryid "test-query" "Default query ID used in test MAM stanzas.") (defun jabber-mam-test--make-message (index &optional peer type) "Build a fake MAM result stanza for message INDEX. PEER defaults to \"friend@example.com\". TYPE defaults to \"chat\"." (let* ((peer (or peer "friend@example.com")) (type (or type "chat")) (archive-id (format "archive-%06d" index)) (stanza-id (format "stanza-%06d" index)) (stamp (format-time-string "%Y-%m-%dT%H:%M:%SZ" (seconds-to-time (+ 1700000000 (* index 86400))) t)) (from (if (= (% index 3) 0) "me@example.com" (concat peer "/resource"))) (to (if (= (% index 3) 0) (concat peer "/resource") "me@example.com"))) ;; Outer with MAM wrapping forwarded content `(message ((from . "me@example.com")) (result ((xmlns . ,jabber-mam-xmlns) (queryid . ,jabber-mam-test-queryid) (id . ,archive-id)) (forwarded ((xmlns . ,jabber-mam-forward-xmlns)) (delay ((xmlns . ,jabber-mam-delay-xmlns) (stamp . ,stamp))) (message ((from . ,from) (to . ,to) (type . ,type) (id . ,stanza-id)) (body () ,(format "Message %d" index)))))))) (defun jabber-mam-test--make-fin (last-id &optional complete) "Build a fake IQ result with LAST-ID. When COMPLETE is non-nil, mark the archive as fully consumed." `(iq ((type . "result")) (fin ((xmlns . ,jabber-mam-xmlns) ,@(when complete '((complete . "true")))) (set ((xmlns . ,jabber-mam-rsm-xmlns)) (first () "first-id") (last () ,last-id))))) (defun jabber-mam-test--make-fake-jc (account) "Create a fake connection symbol for ACCOUNT." (let ((jc (gensym "jabber-mam-test-jc-")) (parts (split-string account "@"))) (put jc :state-data (list :username (nth 0 parts) :server (nth 1 parts))) jc)) ;;; Group 1: Large sync (ert-deftest jabber-mam-test-large-sync () "3650 messages (10 years, 1/day) are stored and deduped correctly." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (count 3650) (jabber-mam--syncing (list (cons jc jabber-mam-test-queryid))) (jabber-muc-participants nil) (start-time (float-time))) ;; Feed all messages through the process function inside a transaction (jabber-db-with-transaction (dotimes (i count) (let ((xml (jabber-mam-test--make-message i))) (jabber-mam--process-message jc xml)))) ;; Verify all stored (let ((rows (jabber-db-query "me@example.com" "friend@example.com" 0 (+ 1700000000 (* count 86400)) -1))) (should (= count (length rows)))) ;; Should complete in under 5 seconds (let ((elapsed (- (float-time) start-time))) (should (< elapsed 5.0)))))) ;;; Group 2: Dedup on re-sync (ert-deftest jabber-mam-test-dedup-resync () "Running 3650 messages twice yields exactly 3650 rows." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (count 3650) (jabber-mam--syncing (list (cons jc jabber-mam-test-queryid))) (jabber-muc-participants nil)) ;; First pass (jabber-db-with-transaction (dotimes (i count) (jabber-mam--process-message jc (jabber-mam-test--make-message i)))) ;; Second pass (re-sync) (jabber-db-with-transaction (dotimes (i count) (jabber-mam--process-message jc (jabber-mam-test--make-message i)))) ;; Still exactly count rows (let ((rows (jabber-db-query "me@example.com" "friend@example.com" 0 (+ 1700000000 (* count 86400)) -1))) (should (= count (length rows))))))) ;;; Group 3: Transaction batching performance (ert-deftest jabber-mam-test-transaction-batching () "Batched inserts inside a transaction are faster than unbatched." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (batch-count 500) (jabber-mam--syncing (list (cons jc jabber-mam-test-queryid))) (jabber-muc-participants nil)) ;; Batched: all in one transaction (let ((t1 (float-time))) (jabber-db-with-transaction (dotimes (i batch-count) (jabber-mam--process-message jc (jabber-mam-test--make-message i)))) (let ((batched-time (- (float-time) t1))) ;; Verify they all stored (let ((rows (jabber-db-query "me@example.com" "friend@example.com" 0 (+ 1700000000 (* batch-count 86400)) -1))) (should (= batch-count (length rows)))) ;; Batched should be under 2 seconds for 500 messages (should (< batched-time 2.0))))))) ;;; Group 4: Parse helpers (ert-deftest jabber-mam-test-parse-result () "jabber-mam--parse-result extracts archive-id, stamp, and inner message." (let* ((xml (jabber-mam-test--make-message 42)) (parsed (jabber-mam--parse-result xml))) (should parsed) (should (string= "archive-000042" (nth 0 parsed))) (should (stringp (nth 1 parsed))) (should (listp (nth 2 parsed))) (should (string= "Message 42" (car (jabber-xml-node-children (car (jabber-xml-get-children (nth 2 parsed) 'body)))))))) (ert-deftest jabber-mam-test-build-query-before-id-empty () "build-query with before-id=t emits an empty element." (let ((query (jabber-mam--build-query "q1" "peer@example.com" nil nil 30 t))) ;; Should have RSM set with max and before (let* ((set-el (cl-find 'set (jabber-xml-node-children query) :key (lambda (n) (and (listp n) (jabber-xml-node-name n))))) (before-el (car (jabber-xml-get-children set-el 'before))) (max-el (car (jabber-xml-get-children set-el 'max)))) (should set-el) (should before-el) ;; before element should have no children (empty ) (should-not (jabber-xml-node-children before-el)) (should max-el) (should (string= "30" (car (jabber-xml-node-children max-el))))))) (ert-deftest jabber-mam-test-build-query-before-id-string () "build-query with before-id as a string emits ID." (let ((query (jabber-mam--build-query "q2" nil nil nil 10 "some-id"))) (let* ((set-el (cl-find 'set (jabber-xml-node-children query) :key (lambda (n) (and (listp n) (jabber-xml-node-name n))))) (before-el (car (jabber-xml-get-children set-el 'before)))) (should before-el) (should (string= "some-id" (car (jabber-xml-node-children before-el))))))) (ert-deftest jabber-mam-test-parse-fin-incomplete () "jabber-mam--parse-fin returns :complete nil when not complete." (let* ((xml (jabber-mam-test--make-fin "last-123")) (fin (jabber-mam--parse-fin xml))) (should-not (plist-get fin :complete)) (should (string= "last-123" (plist-get fin :last))))) (ert-deftest jabber-mam-test-parse-fin-complete () "jabber-mam--parse-fin returns :complete t when archive is exhausted." (let* ((xml (jabber-mam-test--make-fin "last-456" t)) (fin (jabber-mam--parse-fin xml))) (should (plist-get fin :complete)) (should (string= "last-456" (plist-get fin :last))))) ;;; Group 5: Transaction ref-count lifecycle (ert-deftest jabber-mam-test-tx-depth-single-query () "Single query cycle: depth goes 0 -> 1 -> 0, transaction commits." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (jabber-mam--tx-depth 0) (jabber-mam--syncing (list (cons jc jabber-mam-test-queryid))) (jabber-mam--dirty-peers nil) (jabber-muc-participants nil)) ;; Simulate what jabber-mam--query does to the transaction (when (zerop jabber-mam--tx-depth) (setq jabber-mam--dirty-peers nil) (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "BEGIN"))) (cl-incf jabber-mam--tx-depth) (should (= 1 jabber-mam--tx-depth)) ;; Insert a message inside the open transaction (jabber-mam--process-message jc (jabber-mam-test--make-message 0)) ;; Simulate what jabber-mam--handle-fin does (when (> jabber-mam--tx-depth 0) (cl-decf jabber-mam--tx-depth)) (should (= 0 jabber-mam--tx-depth)) (when (zerop jabber-mam--tx-depth) (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "COMMIT"))) ;; Message should be committed and queryable (let ((rows (jabber-db-query "me@example.com" "friend@example.com" 0 (+ 1700000000 86400) -1))) (should (= 1 (length rows))))))) (ert-deftest jabber-mam-test-tx-depth-concurrent-queries () "Concurrent queries share one transaction: depth 0 -> 1 -> 2 -> 1 -> 0." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (jabber-mam--tx-depth 0) (jabber-mam--syncing (list (cons jc jabber-mam-test-queryid) (cons jc "muc-query"))) (jabber-mam--dirty-peers nil) (jabber-muc--rooms (make-hash-table :test 'equal)) (jabber-muc-participants nil)) (puthash "room@conference.example.com" (list (cons jc "mynick")) jabber-muc--rooms) ;; First query opens transaction (when (zerop jabber-mam--tx-depth) (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "BEGIN"))) (cl-incf jabber-mam--tx-depth) (should (= 1 jabber-mam--tx-depth)) ;; Second query piggybacks (cl-incf jabber-mam--tx-depth) (should (= 2 jabber-mam--tx-depth)) ;; Insert messages from both "queries" (jabber-mam--process-message jc (jabber-mam-test--make-message 0)) (jabber-mam--process-message jc (jabber-mam-test--make-muc-message 1 "room@conference.example.com" "mynick")) ;; First query finishes (when (> jabber-mam--tx-depth 0) (cl-decf jabber-mam--tx-depth)) (should (= 1 jabber-mam--tx-depth)) ;; No COMMIT yet ;; Second query finishes (when (> jabber-mam--tx-depth 0) (cl-decf jabber-mam--tx-depth)) (should (= 0 jabber-mam--tx-depth)) ;; Now COMMIT (when (zerop jabber-mam--tx-depth) (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "COMMIT"))) ;; Both messages committed (let ((chat-rows (jabber-db-query "me@example.com" "friend@example.com" 0 (+ 1700000000 86400) -1)) (muc-rows (jabber-db-query "me@example.com" "room@conference.example.com" 0 (+ 1700000000 (* 2 86400)) -1))) (should (= 1 (length chat-rows))) (should (= 1 (length muc-rows))))))) (ert-deftest jabber-mam-test-tx-depth-guard-negative () "Decrementing at depth 0 does not go negative." (let ((jabber-mam--tx-depth 0)) (when (> jabber-mam--tx-depth 0) (cl-decf jabber-mam--tx-depth)) (should (= 0 jabber-mam--tx-depth)) ;; Double-decrement still stays at 0 (when (> jabber-mam--tx-depth 0) (cl-decf jabber-mam--tx-depth)) (should (= 0 jabber-mam--tx-depth)))) ;;; Group 6: MUC messages (defun jabber-mam-test--make-muc-message (index room our-nick) "Build a fake MAM MUC result for message INDEX in ROOM. OUR-NICK is our nickname; every 3rd message is from us." (let* ((archive-id (format "muc-archive-%06d" index)) (stanza-id (format "muc-stanza-%06d" index)) (stamp (format-time-string "%Y-%m-%dT%H:%M:%SZ" (seconds-to-time (+ 1700000000 (* index 86400))) t)) (nick (if (= (% index 3) 0) our-nick "otherperson")) (from (concat room "/" nick))) `(message ((from . "me@example.com")) (result ((xmlns . ,jabber-mam-xmlns) (queryid . "muc-query") (id . ,archive-id)) (forwarded ((xmlns . ,jabber-mam-forward-xmlns)) (delay ((xmlns . ,jabber-mam-delay-xmlns) (stamp . ,stamp))) (message ((from . ,from) (to . ,room) (type . "groupchat") (id . ,stanza-id)) (body () ,(format "MUC message %d" index)))))))) (defvar jabber-muc--rooms) ; jabber-muc.el (ert-deftest jabber-mam-test-muc-message-storage () "MUC messages from MAM are stored with correct peer and type." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (room "room@conference.example.com") (jabber-mam--syncing (list (cons jc "muc-query"))) (jabber-muc--rooms (make-hash-table :test 'equal)) (jabber-muc-participants nil)) (puthash room (list (cons jc "mynick")) jabber-muc--rooms) (jabber-db-with-transaction (dotimes (i 10) (jabber-mam--process-message jc (jabber-mam-test--make-muc-message i room "mynick")))) (let ((rows (jabber-db-query "me@example.com" room 0 (+ 1700000000 (* 10 86400)) -1))) (should (= 10 (length rows))) (should (string= "groupchat" (plist-get (car rows) :type))) (should (string= room (plist-get (car rows) :peer))))))) (ert-deftest jabber-mam-test-muc-direction-detection () "MUC MAM detects outgoing messages by matching our nickname." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (room "room@conference.example.com") (jabber-mam--syncing (list (cons jc "muc-query"))) (jabber-muc--rooms (make-hash-table :test 'equal)) (jabber-muc-participants `((,room ("mynick" . nil) ("otherperson" . nil))))) (puthash room (list (cons jc "mynick")) jabber-muc--rooms) (jabber-db-with-transaction (jabber-mam--process-message jc (jabber-mam-test--make-muc-message 0 room "mynick")) ; from us (idx%3=0) (jabber-mam--process-message jc (jabber-mam-test--make-muc-message 1 room "mynick"))) ; from other (idx%3=1) (let ((rows (jabber-db-query "me@example.com" room 0 (+ 1700000000 (* 2 86400)) -1))) (should (= 2 (length rows))) (should (string= "out" (plist-get (car rows) :direction))) (should (string= "in" (plist-get (cadr rows) :direction))))))) ;;; Group 7: Dirty peer tracking (ert-deftest jabber-mam-test-mark-dirty-dedup () "jabber-mam--mark-dirty does not add the same peer twice." (let ((jabber-mam--dirty-peers nil)) (jabber-mam--mark-dirty "peer@example.com" "chat") (jabber-mam--mark-dirty "peer@example.com" "chat") (jabber-mam--mark-dirty "peer@example.com" "chat") (should (= 1 (length jabber-mam--dirty-peers))) (should (equal '("peer@example.com" . "chat") (car jabber-mam--dirty-peers))))) (ert-deftest jabber-mam-test-dirty-peers-reset-on-new-sync () "Starting a new sync cycle resets the dirty peer list." (let ((jabber-mam--dirty-peers '(("room@muc.example.com" . "groupchat"))) (jabber-mam--tx-depth 0)) ;; Simulate depth 0->1 transition (new sync cycle) (when (zerop jabber-mam--tx-depth) (setq jabber-mam--dirty-peers nil)) (should (null jabber-mam--dirty-peers)))) ;;; Group 8: jabber-mam-sync-buffer (ert-deftest jabber-mam-test-sync-buffer-not-connected () "Signal user-error when not connected." (with-temp-buffer (setq-local jabber-buffer-connection 'dead-jc) (let ((jabber-connections nil)) (should-error (jabber-mam-sync-buffer) :type 'user-error)))) (ert-deftest jabber-mam-test-sync-buffer-1to1-registers-and-queries () "1:1 sync registers reconciliation tracking and queries with before-id=t." (let ((query-args nil)) (cl-letf (((symbol-function 'jabber-mam--query) (lambda (&rest args) (setq query-args args))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-jid-user) (lambda (jid) jid))) (with-temp-buffer (let ((jabber-connections (list 'fake-jc)) (jabber-mam--dirty-peers nil) (jabber-mam--sync-received nil) (jabber-mam--completion-callbacks nil)) (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chatting-with "friend@example.com") (setq-local jabber-chat-buffer-msg-count 50) (jabber-mam-sync-buffer) ;; Should have registered sync tracking (should jabber-mam--sync-received) (let ((data (cdar jabber-mam--sync-received))) (should (hash-table-p (plist-get data :ids))) (should (string= "me@example.com" (plist-get data :account))) (should (string= "friend@example.com" (plist-get data :peer)))) ;; Should have registered completion callback (should jabber-mam--completion-callbacks) ;; (jc after-id queryid with start to before-id max) (should (eq 'fake-jc (nth 0 query-args))) (should (equal "friend@example.com" (nth 3 query-args))) (should-not (nth 5 query-args)) ; no to (1:1) (should (eq t (nth 6 query-args))) ; before-id = t (should (= 50 (nth 7 query-args)))))))) (ert-deftest jabber-mam-test-sync-buffer-muc-registers-and-queries () "MUC sync registers reconciliation tracking and queries with before-id=t." (let ((query-args nil)) (cl-letf (((symbol-function 'jabber-mam--query) (lambda (&rest args) (setq query-args args))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (with-temp-buffer (let ((jabber-connections (list 'fake-jc)) (jabber-mam--dirty-peers nil) (jabber-mam--sync-received nil) (jabber-mam--completion-callbacks nil)) (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-group "room@conference.example.com") (setq-local jabber-chat-buffer-msg-count 25) (jabber-mam-sync-buffer) ;; Should have registered sync tracking (should jabber-mam--sync-received) (let ((data (cdar jabber-mam--sync-received))) (should (string= "me@example.com" (plist-get data :account))) (should (string= "room@conference.example.com" (plist-get data :peer)))) ;; (jc after-id queryid with start to before-id max) (should (eq 'fake-jc (nth 0 query-args))) (should (equal "room@conference.example.com" (nth 5 query-args))) (should (eq t (nth 6 query-args))) ; before-id = t (should (= 25 (nth 7 query-args)))))))) ;;; Group 8b: sync reconciliation (ert-deftest jabber-mam-test-reconcile-deletes-orphan-messages () "Reconciliation deletes local messages whose IDs are not in the remote set." (jabber-mam-test-with-db (let ((db (jabber-db-ensure-open)) (account "me@example.com") (peer "friend@example.com")) ;; Insert 3 local messages with server_ids (dolist (sid '("srv-1" "srv-2" "srv-3")) (sqlite-execute db "INSERT INTO message (account,peer,direction,type,body,timestamp,server_id) VALUES (?,?,'in','chat',?,1700000100,?)" (list account peer (concat "msg " sid) sid))) ;; Simulate sync that received only srv-1 and srv-3 (srv-2 is orphan) (let* ((ids (make-hash-table :test #'equal)) (jabber-mam--sync-received (list (cons "test-q" (list :ids ids :min-ts 1700000100 :max-ts 1700000100 :account account :peer peer))))) (puthash "srv-1" t ids) (puthash "srv-3" t ids) (jabber-mam--reconcile-sync "test-q") ;; srv-2 should be deleted (should-not (caar (sqlite-select db "SELECT 1 FROM message WHERE server_id = 'srv-2'"))) ;; srv-1 and srv-3 should remain (should (caar (sqlite-select db "SELECT 1 FROM message WHERE server_id = 'srv-1'"))) (should (caar (sqlite-select db "SELECT 1 FROM message WHERE server_id = 'srv-3'"))) ;; Tracking entry should be cleaned up (should-not jabber-mam--sync-received))))) (ert-deftest jabber-mam-test-reconcile-keeps-messages-without-ids () "Reconciliation keeps local messages that have no stanza_id or server_id." (jabber-mam-test-with-db (let ((db (jabber-db-ensure-open)) (account "me@example.com") (peer "friend@example.com")) ;; Insert a message without any server-side IDs (sqlite-execute db "INSERT INTO message (account,peer,direction,type,body,timestamp) VALUES (?,?,'out','chat','local only',1700000100)" (list account peer)) ;; Insert a message with server_id that IS in remote (sqlite-execute db "INSERT INTO message (account,peer,direction,type,body,timestamp,server_id) VALUES (?,?,'in','chat','from server',1700000100,'srv-ok')" (list account peer)) (let* ((ids (make-hash-table :test #'equal)) (jabber-mam--sync-received (list (cons "test-q" (list :ids ids :min-ts 1700000100 :max-ts 1700000100 :account account :peer peer))))) (puthash "srv-ok" t ids) (jabber-mam--reconcile-sync "test-q") ;; Both messages should remain (should (= 2 (caar (sqlite-select db "SELECT count(*) FROM message WHERE account = ? AND peer = ?" (list account peer))))))))) (ert-deftest jabber-mam-test-reconcile-noop-when-empty () "Reconciliation is a no-op when no messages were received." (jabber-mam-test-with-db (let ((db (jabber-db-ensure-open)) (account "me@example.com") (peer "friend@example.com")) (sqlite-execute db "INSERT INTO message (account,peer,direction,type,body,timestamp,server_id) VALUES (?,?,'in','chat','keep me',1700000100,'srv-1')" (list account peer)) ;; Sync received nothing (min-ts and max-ts are nil) (let ((jabber-mam--sync-received (list (cons "test-q" (list :ids (make-hash-table :test #'equal) :min-ts nil :max-ts nil :account account :peer peer))))) (jabber-mam--reconcile-sync "test-q") ;; Message should still be there (should (caar (sqlite-select db "SELECT 1 FROM message WHERE server_id = 'srv-1'"))) ;; Tracking cleaned up (should-not jabber-mam--sync-received))))) (ert-deftest jabber-mam-test-reconcile-uses-stanza-id-too () "Reconciliation matches on stanza_id when server_id is absent." (jabber-mam-test-with-db (let ((db (jabber-db-ensure-open)) (account "me@example.com") (peer "friend@example.com")) ;; Message with stanza_id only (no server_id) (sqlite-execute db "INSERT INTO message (account,peer,direction,type,body,timestamp,stanza_id) VALUES (?,?,'in','chat','has stanza id',1700000100,'st-1')" (list account peer)) ;; Remote set includes this stanza_id (let* ((ids (make-hash-table :test #'equal)) (jabber-mam--sync-received (list (cons "test-q" (list :ids ids :min-ts 1700000100 :max-ts 1700000100 :account account :peer peer))))) (puthash "st-1" t ids) (jabber-mam--reconcile-sync "test-q") ;; Should be kept (matched by stanza_id) (should (caar (sqlite-select db "SELECT 1 FROM message WHERE stanza_id = 'st-1'"))))))) (ert-deftest jabber-mam-test-process-message-tracks-ids () "process-message accumulates IDs and timestamps for sync tracking." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (ids (make-hash-table :test #'equal)) (jabber-mam--sync-received (list (cons jabber-mam-test-queryid (list :ids ids :min-ts nil :max-ts nil :account "me@example.com" :peer "friend@example.com")))) (jabber-mam--syncing (list (cons jc jabber-mam-test-queryid))) (jabber-mam--tx-depth 1) (jabber-muc-participants nil)) ;; Process two messages (jabber-mam--process-message jc (jabber-mam-test--make-message 0)) (jabber-mam--process-message jc (jabber-mam-test--make-message 5)) ;; Check that IDs were tracked (let ((data (cdr (car jabber-mam--sync-received)))) (should (gethash "archive-000000" (plist-get data :ids))) (should (gethash "archive-000005" (plist-get data :ids))) (should (gethash "stanza-000000" (plist-get data :ids))) (should (gethash "stanza-000005" (plist-get data :ids))) ;; Timestamps should bracket the range (should (plist-get data :min-ts)) (should (plist-get data :max-ts)) (should (<= (plist-get data :min-ts) (plist-get data :max-ts))))))) ;;; Group 9: disconnect cleanup (ert-deftest jabber-mam-test-cleanup-all-commits-transaction () "cleanup-all commits open transaction and resets state." (jabber-mam-test-with-db (sqlite-execute (jabber-db-ensure-open) "BEGIN") (let ((jabber-mam--tx-depth 2) (jabber-mam--syncing '((jc1 . "q1") (jc2 . "q2"))) (jabber-mam--completion-callbacks '(("q1" . ignore) ("q2" . ignore))) (jabber-mam--dirty-peers nil)) (jabber-mam--cleanup-all) (should (= 0 jabber-mam--tx-depth)) (should-not jabber-mam--syncing) (should-not jabber-mam--completion-callbacks) ;; Transaction was committed; verify we can write without error. (sqlite-execute (jabber-db-ensure-open) "INSERT INTO message (account,peer,direction,type,body,timestamp) \ VALUES ('a','b','in','chat','test',1)") (should (caar (sqlite-select (jabber-db-ensure-open) "SELECT 1 FROM message WHERE body='test'")))))) (ert-deftest jabber-mam-test-cleanup-connection-scoped () "cleanup-connection only removes entries for the given connection." (jabber-mam-test-with-db (sqlite-execute (jabber-db-ensure-open) "BEGIN") (let ((jabber-mam--tx-depth 2) (jabber-mam--syncing '((jc1 . "q1") (jc2 . "q2"))) (jabber-mam--completion-callbacks '(("q1" . ignore))) (jabber-mam--dirty-peers nil)) (jabber-mam--cleanup-connection 'jc1) (should (= 1 jabber-mam--tx-depth)) (should (equal '((jc2 . "q2")) jabber-mam--syncing)) (should-not jabber-mam--completion-callbacks)))) (ert-deftest jabber-mam-test-cleanup-triggers-redisplay () "cleanup-all redraws dirty buffers." (jabber-mam-test-with-db (let ((jabber-mam--tx-depth 1) (jabber-mam--syncing '((jc1 . "q1"))) (jabber-mam--completion-callbacks nil) (jabber-mam--dirty-peers '(("peer@example.com" . "chat"))) ) ;; (redrawn nil) (cl-letf (((symbol-function 'jabber-chat-find-buffer) (lambda (_peer) nil))) (jabber-mam--cleanup-all) ;; Dirty peers list should be drained after cleanup. (should (null jabber-mam--dirty-peers)))))) (ert-deftest jabber-mam-test-cleanup-all-noop-when-idle () "cleanup-all is safe to call with no active queries." (let ((jabber-mam--tx-depth 0) (jabber-mam--syncing nil) (jabber-mam--completion-callbacks nil) (jabber-mam--dirty-peers nil)) (jabber-mam--cleanup-all) (should (= 0 jabber-mam--tx-depth)))) ;;; Group 10: stanza mutation guard (ert-deftest jabber-mam-test-body-stanza-stripped () "Body-bearing MAM result has children stripped after processing." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-mam-test-queryid))) (jabber-mam--tx-depth 1) (jabber-chat--crypto-loaded t) (stanza (jabber-mam-test--make-message 1))) (jabber-mam--process-message jc stanza) (should-not (cddr stanza))))) (ert-deftest jabber-mam-test-bodyless-stanza-unwrapped () "Bodyless MAM result is unwrapped with original sender and MAM marker." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-mam-test-queryid))) (jabber-mam--tx-depth 1) (jabber-chat--crypto-loaded t) ;; Receipt stanza: no body, just a element (stanza `(message ((from . "me@example.com")) (result ((xmlns . ,jabber-mam-xmlns) (queryid . ,jabber-mam-test-queryid) (id . "archive-001")) (forwarded ((xmlns . ,jabber-mam-forward-xmlns)) (delay ((xmlns . ,jabber-mam-delay-xmlns) (stamp . "2025-01-01T00:00:00Z"))) (message ((from . "alice@example.com/res") (to . "me@example.com") (id . "receipt-1")) (received ((xmlns . "urn:xmpp:receipts") (id . "msg-42"))))))))) (jabber-mam--process-message jc stanza) ;; Outer stanza should now have inner message's from (should (string= "alice@example.com/res" (jabber-xml-get-attribute stanza 'from))) ;; MAM origin marker should be set (should (jabber-xml-get-attribute stanza 'jabber-mam--origin)) ;; The receipt element should be a child (should (car (jabber-xml-get-children stanza 'received)))))) ;;; Group 9: query ID validation (ert-deftest jabber-mam-test-unknown-queryid-rejected () "MAM result with unknown queryid is not processed." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc "known-query"))) (jabber-mam--tx-depth 1) (jabber-chat--crypto-loaded t) ;; Build stanza with queryid that doesn't match (stanza `(message ((from . "me@example.com")) (result ((xmlns . ,jabber-mam-xmlns) (queryid . "unknown-query") (id . "arch-1")) (forwarded ((xmlns . ,jabber-mam-forward-xmlns)) (delay ((xmlns . ,jabber-mam-delay-xmlns) (stamp . "2025-01-01T00:00:00Z"))) (message ((from . "alice@example.com") (to . "me@example.com") (id . "s1")) (body () "secret"))))))) (jabber-mam--process-message jc stanza) ;; Stanza should NOT have been stripped (not processed) (should (cddr stanza)) ;; Message should NOT be in DB (should-not (caar (sqlite-select (jabber-db-ensure-open) "SELECT 1 FROM message WHERE stanza_id='s1'")))))) (ert-deftest jabber-mam-test-known-queryid-accepted () "MAM result with known queryid is processed normally." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc "known-query"))) (jabber-mam--tx-depth 1) (jabber-chat--crypto-loaded t) ;; Use the test helper but we need to add queryid (stanza `(message ((from . "me@example.com")) (result ((xmlns . ,jabber-mam-xmlns) (queryid . "known-query") (id . "arch-2")) (forwarded ((xmlns . ,jabber-mam-forward-xmlns)) (delay ((xmlns . ,jabber-mam-delay-xmlns) (stamp . "2025-01-01T00:00:00Z"))) (message ((from . "alice@example.com/res") (to . "me@example.com") (id . "s2")) (body () "hello"))))))) (jabber-mam--process-message jc stanza) ;; Message should be in DB (should (caar (sqlite-select (jabber-db-ensure-open) "SELECT 1 FROM message WHERE stanza_id='s2'")))))) ;;; Group 10: error handler callback transfer (ert-deftest jabber-mam-test-error-callback-transferred () "item-not-found fallback transfers callback to new query." (jabber-mam-test-with-db (sqlite-execute (jabber-db-ensure-open) "BEGIN") (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (jabber-mam--tx-depth 1) (jabber-mam--syncing (list (cons jc "old-q"))) (jabber-mam--dirty-peers nil) (callback-fired nil) (jabber-mam--completion-callbacks (list (cons "old-q" (lambda () (setq callback-fired t))))) (captured-queryid nil)) ;; Mock jabber-mam--query to capture the new queryid (cl-letf (((symbol-function 'jabber-mam--query) (lambda (_jc _after qid &rest _) (setq captured-queryid qid)))) ;; Simulate item-not-found error IQ (jabber-mam--handle-error jc `(iq ((type . "error")) (error () (item-not-found ()))) '("old-q" nil))) ;; Old callback should be removed (should-not (assoc "old-q" jabber-mam--completion-callbacks #'string=)) ;; New callback should be registered under the new queryid (should captured-queryid) (should (assoc captured-queryid jabber-mam--completion-callbacks #'string=)) ;; Fire it to confirm it's the same callback (funcall (cdr (assoc captured-queryid jabber-mam--completion-callbacks #'string=))) (should callback-fired)))) ;;; Group 11: sender JID validation (ert-deftest jabber-mam-test-rejects-foreign-sender () "MAM result from a server other than ours is rejected." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-mam-test-queryid))) (jabber-mam--tx-depth 1) (jabber-chat--crypto-loaded t) (jabber-muc--rooms (make-hash-table :test 'equal)) ;; Outer from is evil.com, not our bare JID (stanza `(message ((from . "evil.com")) (result ((xmlns . ,jabber-mam-xmlns) (queryid . ,jabber-mam-test-queryid) (id . "arch-evil")) (forwarded ((xmlns . ,jabber-mam-forward-xmlns)) (delay ((xmlns . ,jabber-mam-delay-xmlns) (stamp . "2025-01-01T00:00:00Z"))) (message ((from . "alice@legit.com/res") (to . "me@example.com") (id . "forged-1")) (body () "injected"))))))) (jabber-mam--process-message jc stanza) ;; Stanza should NOT have been stripped (should (cddr stanza)) ;; Message should NOT be in DB (should-not (caar (sqlite-select (jabber-db-ensure-open) "SELECT 1 FROM message WHERE stanza_id='forged-1'")))))) (ert-deftest jabber-mam-test-accepts-own-jid-sender () "MAM result from our own bare JID is accepted." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-mam-test-queryid))) (jabber-mam--tx-depth 1) (jabber-chat--crypto-loaded t) ;; Normal 1:1 MAM result with from=our bare JID (stanza (jabber-mam-test--make-message 5))) (jabber-mam--process-message jc stanza) ;; Message should be stored (should (caar (sqlite-select (jabber-db-ensure-open) "SELECT 1 FROM message WHERE stanza_id='stanza-000005'")))))) (ert-deftest jabber-mam-test-accepts-joined-muc-sender () "MAM result from a joined MUC room is accepted." (jabber-mam-test-with-db (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (room "room@conference.example.com") (jabber-mam--syncing (list (cons jc "muc-query"))) (jabber-mam--tx-depth 1) (jabber-chat--crypto-loaded t) (jabber-muc--rooms (make-hash-table :test 'equal)) (jabber-muc-participants nil)) (puthash room (list (cons jc "mynick")) jabber-muc--rooms) ;; MUC MAM: outer from is the room bare JID (let ((stanza `(message ((from . ,room)) (result ((xmlns . ,jabber-mam-xmlns) (queryid . "muc-query") (id . "muc-arch-1")) (forwarded ((xmlns . ,jabber-mam-forward-xmlns)) (delay ((xmlns . ,jabber-mam-delay-xmlns) (stamp . "2025-01-01T12:00:00Z"))) (message ((from . ,(concat room "/otherperson")) (to . ,room) (type . "groupchat") (id . "muc-s1")) (body () "hello room"))))))) (jabber-mam--process-message jc stanza) ;; Message should be stored (should (caar (sqlite-select (jabber-db-ensure-open) "SELECT 1 FROM message WHERE stanza_id='muc-s1'"))))))) ;;; Group 12: MUC query cancellation (ert-deftest jabber-mam-test-cancel-muc-query () "Cancelling a MUC MAM query removes it from active state." (jabber-mam-test-with-db (sqlite-execute (jabber-db-ensure-open) "BEGIN") (let* ((jc (jabber-mam-test--make-fake-jc "me@example.com")) (room "room@conference.example.com") (jabber-mam--tx-depth 1) (jabber-mam--syncing (list (cons jc "muc-q1"))) (jabber-mam--query-targets (list (cons "muc-q1" room))) (jabber-mam--completion-callbacks (list (cons "muc-q1" #'ignore))) (jabber-mam--dirty-peers nil)) (jabber-mam--cancel-muc-query room) (should (= 0 jabber-mam--tx-depth)) (should-not jabber-mam--syncing) (should-not jabber-mam--query-targets) (should-not jabber-mam--completion-callbacks)))) (ert-deftest jabber-mam-test-cancel-muc-query-noop-for-unknown () "Cancelling a room with no active query is a no-op." (let ((jabber-mam--tx-depth 1) (jabber-mam--syncing (list (cons 'jc "q1"))) (jabber-mam--query-targets nil) (jabber-mam--dirty-peers nil)) (jabber-mam--cancel-muc-query "unknown@conference.example.com") ;; State unchanged (should (= 1 jabber-mam--tx-depth)) (should jabber-mam--syncing))) (provide 'jabber-mam-tests) ;;; jabber-mam-tests.el ends here emacs-jabber/tests/jabber-message-correct-tests.el000066400000000000000000000720711516610113500225310ustar00rootroot00000000000000;;; jabber-message-correct-tests.el --- Tests for XEP-0308 -*- lexical-binding: t; -*- (require 'ert) (require 'ewoc) (load (expand-file-name "../lisp/jabber-xml.el" (file-name-directory (or load-file-name buffer-file-name)))) (load (expand-file-name "../lisp/jabber-db.el" (file-name-directory (or load-file-name buffer-file-name)))) (load (expand-file-name "../lisp/jabber-chatbuffer.el" (file-name-directory (or load-file-name buffer-file-name)))) (load (expand-file-name "../lisp/jabber-message-correct.el" (file-name-directory (or load-file-name buffer-file-name)))) ;; jabber-chat and jabber-muc are needed for Groups 5 and 9. ;; jabber-muc requires jabber-chat, and both need this stub constant. (defvar jabber-muc-xmlns-user "http://jabber.org/protocol/muc#user") (require 'jabber-chat) (require 'jabber-muc) (require 'jabber-mam) ;;; Test helpers (defmacro jabber-message-correct-test-with-ewoc (&rest body) "Set up a temp buffer with a chat ewoc and hash table, then run BODY." (declare (indent 0) (debug t)) `(with-temp-buffer (let ((jabber-chat-ewoc (ewoc-create #'ignore nil nil 'nosep)) (jabber-chat--msg-nodes (make-hash-table :test 'equal))) ,@body))) (defmacro jabber-message-correct-test-with-db (&rest body) "Run BODY with a fresh temp SQLite database." (declare (indent 0) (debug t)) `(let* ((jabber-mc-test--dir (make-temp-file "jabber-mc-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-mc-test--dir)) (jabber-db--connection nil)) (unwind-protect (progn (jabber-db-ensure-open) ,@body) (jabber-db-close) (when (file-directory-p jabber-mc-test--dir) (delete-directory jabber-mc-test--dir t))))) ;;; Group 1: jabber-message-correct--replace-id (ert-deftest jabber-message-correct-test-replace-id-nil-for-plain () "Plain message with no returns nil." (let ((stanza '(message ((from . "alice@example.com") (id . "msg-1")) (body () "hello")))) (should-not (jabber-message-correct--replace-id stanza)))) (ert-deftest jabber-message-correct-test-replace-id-returns-id () "Correction stanza returns the id from ." (let ((stanza `(message ((from . "alice@example.com") (id . "msg-2")) (body () "hello corrected") (replace ((id . "msg-1") (xmlns . ,jabber-message-correct-xmlns)))))) (should (equal "msg-1" (jabber-message-correct--replace-id stanza))))) (ert-deftest jabber-message-correct-test-replace-id-wrong-xmlns () "Element with wrong xmlns is not treated as a correction." (let ((stanza '(message ((from . "alice@example.com") (id . "msg-3")) (body () "hello") (replace ((id . "msg-0") (xmlns . "urn:xmpp:wrong:0")))))) (should-not (jabber-message-correct--replace-id stanza)))) ;;; Group 2: jabber-message-correct--valid-sender-p (ert-deftest jabber-message-correct-test-valid-sender-1to1-same () "1:1: same bare JID allows correction." (should (jabber-message-correct--valid-sender-p "alice@example.com/laptop" "alice@example.com/phone" nil))) (ert-deftest jabber-message-correct-test-valid-sender-1to1-different () "1:1: different bare JID rejects correction." (should-not (jabber-message-correct--valid-sender-p "alice@example.com/laptop" "mallory@example.com/phone" nil))) (ert-deftest jabber-message-correct-test-valid-sender-muc-same-full () "MUC: same full JID (nick) allows correction." (should (jabber-message-correct--valid-sender-p "room@muc.example.com/alice" "room@muc.example.com/alice" t))) (ert-deftest jabber-message-correct-test-valid-sender-muc-different-nick () "MUC: different nick rejects correction." (should-not (jabber-message-correct--valid-sender-p "room@muc.example.com/alice" "room@muc.example.com/mallory" t))) ;;; Group 3: DB integration (ert-deftest jabber-message-correct-test-db-correct-message () "jabber-db-correct-message updates body and sets edited=1." (jabber-message-correct-test-with-db (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Original body" (floor (float-time)) nil "stanza-abc") (jabber-db-correct-message "stanza-abc" "Corrected body") (let* ((rows (sqlite-select jabber-db--connection "SELECT body, edited FROM message \ WHERE stanza_id = 'stanza-abc'")) (row (car rows))) (should (equal "Corrected body" (car row))) (should (= 1 (cadr row)))))) (ert-deftest jabber-message-correct-test-db-row-to-plist-edited () "jabber-db--row-to-plist returns :edited t for edited messages." (jabber-message-correct-test-with-db (let* ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Hello" ts nil "stanza-edit-1") (jabber-db-correct-message "stanza-edit-1" "Hello fixed") (let* ((rows (jabber-db-backlog "me@example.com" "friend@example.com" 1 (- (float-time) 60))) (plist (car rows))) (should (plist-get plist :edited)) (should (equal "Hello fixed" (plist-get plist :body))))))) (ert-deftest jabber-message-correct-test-db-correct-unknown-id () "jabber-db-correct-message is a no-op for unknown stanza-id." (jabber-message-correct-test-with-db (jabber-db-correct-message "nonexistent-id" "body") (let ((count (caar (sqlite-select jabber-db--connection "SELECT COUNT(*) FROM message")))) (should (= 0 count))))) (ert-deftest jabber-message-correct-test-db-unedited-returns-nil () "Unedited message returns :edited nil via jabber-db--row-to-plist." (jabber-message-correct-test-with-db (let* ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Hello" ts nil "stanza-plain-1") (let* ((rows (jabber-db-backlog "me@example.com" "friend@example.com" 1 (- (float-time) 60))) (plist (car rows))) (should-not (plist-get plist :edited)))))) ;;; Group 4: ewoc apply correction (ert-deftest jabber-message-correct-test-apply-updates-ewoc () "jabber-message-correct--apply updates body and edited in the ewoc node, and writes DB." (jabber-message-correct-test-with-ewoc (let ((msg (list :id "orig-1" :from "alice@example.com/phone" :body "original" :timestamp (current-time))) db-called) (jabber-chat-ewoc-enter (list :foreign msg)) (cl-letf (((symbol-function 'jabber-db-message-sender-by-stanza-id) (lambda (_id) "alice@example.com/phone")) ((symbol-function 'jabber-db-correct-message) (lambda (_id _body) (setq db-called t)))) (jabber-message-correct--apply "orig-1" "corrected" "alice@example.com/laptop" nil (current-buffer))) (let* ((node (jabber-chat-ewoc-find-by-id "orig-1")) (msg (cadr (ewoc-data node)))) (should (equal "corrected" (plist-get msg :body))) (should (plist-get msg :edited)) (should db-called))))) (ert-deftest jabber-message-correct-test-apply-rejects-wrong-sender () "jabber-message-correct--apply rejects correction from wrong sender." (jabber-message-correct-test-with-ewoc (let ((msg (list :id "orig-2" :from "alice@example.com/phone" :body "original" :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :foreign msg))) (cl-letf (((symbol-function 'jabber-db-message-sender-by-stanza-id) (lambda (_id) "alice@example.com/phone")) ((symbol-function 'jabber-db-correct-message) #'ignore)) (jabber-message-correct--apply "orig-2" "evil" "mallory@example.com/x" nil (current-buffer))) (let* ((node (jabber-chat-ewoc-find-by-id "orig-2")) (msg (cadr (ewoc-data node)))) (should (equal "original" (plist-get msg :body))) (should-not (plist-get msg :edited))))) (ert-deftest jabber-message-correct-test-apply-nil-buffer-db-update () "With nil buffer and valid sender, jabber-db-correct-message is called." (let (db-called) (cl-letf (((symbol-function 'jabber-db-message-sender-by-stanza-id) (lambda (_id) "alice@example.com/phone")) ((symbol-function 'jabber-db-correct-message) (lambda (_id _body) (setq db-called t)))) (jabber-message-correct--apply "orig-3" "corrected" "alice@example.com/laptop" nil nil)) (should db-called))) (ert-deftest jabber-message-correct-test-apply-nil-buffer-wrong-sender-no-db () "With nil buffer and wrong sender, jabber-db-correct-message is not called." (let (db-called) (cl-letf (((symbol-function 'jabber-db-message-sender-by-stanza-id) (lambda (_id) "alice@example.com/phone")) ((symbol-function 'jabber-db-correct-message) (lambda (_id _body) (setq db-called t)))) (jabber-message-correct--apply "orig-4" "evil" "mallory@example.com/x" nil nil)) (should-not db-called))) (ert-deftest jabber-message-correct-test-apply-unknown-id-no-db () "When stanza-id not in DB, correction is dropped without DB write." (let (db-called) (cl-letf (((symbol-function 'jabber-db-message-sender-by-stanza-id) (lambda (_id) nil)) ((symbol-function 'jabber-db-correct-message) (lambda (_id _body) (setq db-called t)))) (jabber-message-correct--apply "unknown-id" "body" "alice@example.com" nil nil)) (should-not db-called))) (ert-deftest jabber-message-correct-test-apply-muc-same-nick () "MUC: correction from same nick is accepted." (let (db-called) (cl-letf (((symbol-function 'jabber-db-message-sender-by-stanza-id) (lambda (_id) "room@muc.example.com/alice")) ((symbol-function 'jabber-db-correct-message) (lambda (_id _body) (setq db-called t)))) (jabber-message-correct--apply "muc-orig-1" "corrected" "room@muc.example.com/alice" t nil)) (should db-called))) (ert-deftest jabber-message-correct-test-apply-muc-different-nick () "MUC: correction from different nick is rejected." (let (db-called) (cl-letf (((symbol-function 'jabber-db-message-sender-by-stanza-id) (lambda (_id) "room@muc.example.com/alice")) ((symbol-function 'jabber-db-correct-message) (lambda (_id _body) (setq db-called t)))) (jabber-message-correct--apply "muc-orig-2" "evil" "room@muc.example.com/mallory" t nil)) (should-not db-called))) (ert-deftest jabber-message-correct-test-apply-outgoing-carbon () "Outgoing message: carbon correction from same account is accepted." (let (db-called) (cl-letf (((symbol-function 'jabber-db-message-sender-by-stanza-id) (lambda (_id) "me@example.com")) ((symbol-function 'jabber-db-correct-message) (lambda (_id _body) (setq db-called t)))) (jabber-message-correct--apply "out-orig-1" "corrected" "me@example.com/other-device" nil nil)) (should db-called))) ;;; Group 5: MAM / delayed stanza guard (ert-deftest jabber-message-correct-test-replace-id-present-in-delayed-stanza () "A delayed stanza that contains still exposes its replace-id. This confirms that callers are responsible for the delayed guard, not jabber-message-correct--replace-id itself." ;; The stanza is delayed but structurally valid as a correction. ;; --replace-id must return the id so the caller can choose to skip it. (let ((stanza `(message ((from . "room@muc.example.com/alice") (id . "corr-1") (type . "groupchat")) (body () "fixed text") (replace ((id . "orig-1") (xmlns . ,jabber-message-correct-xmlns))) (delay ((xmlns . "urn:xmpp:delay") (stamp . "2025-01-15T10:30:00Z")))))) (should (equal "orig-1" (jabber-message-correct--replace-id stanza))))) (ert-deftest jabber-message-correct-test-history-message-p-detects-delay () "jabber-muc--history-message-p returns non-nil for stanzas with ." (let ((stanza '(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (body () "old message") (delay ((xmlns . "urn:xmpp:delay") (from . "room@muc.example.com") (stamp . "2025-01-15T10:30:00Z")))))) (should (jabber-muc--history-message-p stanza)))) (ert-deftest jabber-message-correct-test-history-message-p-nil-for-live () "jabber-muc--history-message-p returns nil for live stanzas without ." (let ((stanza '(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (body () "live message")))) (should-not (jabber-muc--history-message-p stanza)))) (ert-deftest jabber-message-correct-test-delayed-stanza-skipped-by-muc-dispatch () "jabber-muc-process-message must not apply corrections from delayed stanzas. Regression guard: a delayed correction arriving in MUC history replay must not mutate the DB or the ewoc." (let ((apply-called nil) (stanza `(message ((from . "room@muc.example.com/alice") (id . "corr-2") (type . "groupchat")) (body () "corrected text") (replace ((id . "orig-2") (xmlns . ,jabber-message-correct-xmlns))) (delay ((xmlns . "urn:xmpp:delay") (from . "room@muc.example.com") (stamp . "2025-01-15T10:30:00Z")))))) (cl-letf (((symbol-function 'jabber-muc-message-p) (lambda (_) t)) ((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc xml) xml)) ((symbol-function 'jabber-muc-find-buffer) (lambda (_) nil)) ((symbol-function 'jabber-muc--display-message) #'ignore) ((symbol-function 'jabber-message-correct--apply) (lambda (&rest _) (setq apply-called t)))) (jabber-muc-process-message nil stanza)) (should-not apply-called))) (ert-deftest jabber-message-correct-test-mam-syncing-skipped-by-chat-dispatch () "jabber-process-chat must not apply corrections while jabber-chat-mam-syncing is non-nil. Regression guard: a MAM catch-up stanza carrying must not be treated as a live edit." (let ((apply-called nil) (jabber-chat-mam-syncing t) (stanza `(message ((from . "alice@example.com/phone") (id . "corr-3") (type . "chat")) (body () "corrected") (replace ((id . "orig-3") (xmlns . ,jabber-message-correct-xmlns)))))) (cl-letf (((symbol-function 'jabber-muc-message-p) (lambda (_) nil)) ((symbol-function 'jabber-chat--unwrap-carbon) (lambda (_jc xml) (cons xml nil))) ((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc xml) xml)) ((symbol-function 'jabber-mam-chat-opened) #'ignore) ((symbol-function 'jabber-chat--display-message) #'ignore) ((symbol-function 'jabber-message-correct--apply) (lambda (&rest _) (setq apply-called t)))) (jabber-process-chat nil stanza)) (should-not apply-called))) ;;; Group 6: chained corrections (ert-deftest jabber-message-correct-test-chained-correction-id-unchanged () "jabber-correct-last-message re-uses the original :id after a first correction. The ewoc node's :id must not be updated when a correction is applied locally, so that a subsequent C-c C-e will reference the original id, not the correction's stanza-id." (jabber-message-correct-test-with-ewoc ;; Insert a sent message with id \"orig-chain-1\" (let ((msg (list :id "orig-chain-1" :from "me@example.com" :body "orignal" :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :local msg))) ;; Simulate first correction arriving as a carbon from another own device. ;; DB returns our account JID (direction=out); corrector is same bare JID. (cl-letf (((symbol-function 'jabber-db-message-sender-by-stanza-id) (lambda (_id) "me@example.com")) ((symbol-function 'jabber-db-correct-message) #'ignore)) (jabber-message-correct--apply "orig-chain-1" "original" "me@example.com/other-device" nil (current-buffer))) ;; After the apply the node's :id must still be the original id (let* ((node (jabber-chat-ewoc-find-by-id "orig-chain-1")) (msg (cadr (ewoc-data node)))) (should (equal "orig-chain-1" (plist-get msg :id))) (should (plist-get msg :edited))))) (ert-deftest jabber-message-correct-test-correct-last-uses-original-id () "jabber-correct-last-message sends replace referencing original id after edit. After --apply updates :body/:edited but leaves :id alone, jabber-correct-last-message must pick up the original id." (jabber-message-correct-test-with-ewoc (setq-local jabber-group nil) (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-buffer-connection 'fake-jc) ;; Insert an already-edited sent message (simulating post-first-correction state) (let ((msg (list :id "orig-chain-2" :from "me@example.com" :body "first correction" :edited t :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :local msg))) (let (sent-replace-id) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (_jc stanza) (let* ((replace (car (jabber-xml-get-children stanza 'replace)))) (setq sent-replace-id (jabber-xml-get-attribute replace 'id))))) ((symbol-function 'read-string) (lambda (&rest _) "second correction")) ((symbol-function 'jabber-db-correct-message) #'ignore)) (jabber-correct-last-message)) (should (equal "orig-chain-2" sent-replace-id))))) ;;; Group 7: nil and empty body edge cases (ert-deftest jabber-message-correct-test-nil-body-db-write () "Correction with nil body writes nil to the DB (no crash)." ;; A correction stanza lacking passes nil through --apply. ;; jabber-db-correct-message must not error on nil body. (jabber-message-correct-test-with-db (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "Original" (floor (float-time)) nil "stanza-nil-body") ;; Should not signal -- nil body is a valid (if odd) correction (jabber-db-correct-message "stanza-nil-body" nil) (let* ((rows (sqlite-select jabber-db--connection "SELECT body, edited FROM message \ WHERE stanza_id = 'stanza-nil-body'")) (row (car rows))) ;; edited flag must be set even for nil body (should (= 1 (cadr row)))))) (ert-deftest jabber-message-correct-test-nil-body-ewoc-update () "Correction with nil body updates ewoc :body to nil without error." (jabber-message-correct-test-with-ewoc (let ((msg (list :id "nil-body-orig" :from "alice@example.com/phone" :body "original" :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :foreign msg))) (cl-letf (((symbol-function 'jabber-db-message-sender-by-stanza-id) (lambda (_id) "alice@example.com/phone")) ((symbol-function 'jabber-db-correct-message) #'ignore)) (jabber-message-correct--apply "nil-body-orig" nil "alice@example.com/phone" nil (current-buffer))) (let* ((node (jabber-chat-ewoc-find-by-id "nil-body-orig")) (msg (cadr (ewoc-data node)))) (should-not (plist-get msg :body)) (should (plist-get msg :edited))))) (ert-deftest jabber-message-correct-test-empty-body-accepted () "Correction with empty string body is accepted and written." (jabber-message-correct-test-with-ewoc (let ((msg (list :id "empty-body-orig" :from "alice@example.com/phone" :body "original text" :timestamp (current-time))) db-called) (jabber-chat-ewoc-enter (list :foreign msg)) (cl-letf (((symbol-function 'jabber-db-message-sender-by-stanza-id) (lambda (_id) "alice@example.com/phone")) ((symbol-function 'jabber-db-correct-message) (lambda (_id _body) (setq db-called t)))) (jabber-message-correct--apply "empty-body-orig" "" "alice@example.com/phone" nil (current-buffer))) (let* ((node (jabber-chat-ewoc-find-by-id "empty-body-orig")) (msg (cadr (ewoc-data node)))) (should (equal "" (plist-get msg :body))) (should (plist-get msg :edited)) (should db-called))))) ;;; Group 8: carbon path (outgoing direction in DB) (ert-deftest jabber-message-correct-test-sender-lookup-outgoing-returns-account () "jabber-db-message-sender-by-stanza-id returns the account JID for direction=out. This enables carbon copies of our own corrections to be validated against the account bare JID and accepted." (jabber-message-correct-test-with-db ;; Store the message as outgoing (direction = \"out\") (jabber-db-store-message "me@example.com" "alice@example.com" "out" "chat" "Sent by me" (floor (float-time)) nil "stanza-outgoing") ;; The lookup returns the account JID for outgoing messages (should (equal "me@example.com" (jabber-db-message-sender-by-stanza-id "stanza-outgoing"))))) (ert-deftest jabber-message-correct-test-apply-accepts-outgoing-carbon-same-account () "Correction of an outgoing stanza-id is accepted when the carbon is from our account. The DB lookup returns the account bare JID; the sender in the carbon arrives as account/resource; bare-JID comparison succeeds." (let (db-called) (cl-letf (((symbol-function 'jabber-db-message-sender-by-stanza-id) ;; Simulates the outgoing-direction account-JID return (lambda (_id) "me@example.com")) ((symbol-function 'jabber-db-correct-message) (lambda (_id _body) (setq db-called t)))) ;; Carbon arrives as me@example.com/other-device (1:1, muc-p=nil) ;; bare-JID check: "me@example.com" == "me@example.com" => accepted (jabber-message-correct--apply "stanza-outgoing" "edited" "me@example.com/other-device" nil nil)) (should db-called))) (ert-deftest jabber-message-correct-test-apply-rejects-outgoing-carbon-wrong-account () "Correction of an outgoing stanza-id is rejected when the carbon is from a stranger." (let (db-called) (cl-letf (((symbol-function 'jabber-db-message-sender-by-stanza-id) (lambda (_id) "me@example.com")) ((symbol-function 'jabber-db-correct-message) (lambda (_id _body) (setq db-called t)))) (jabber-message-correct--apply "stanza-outgoing" "evil" "mallory@example.com/x" nil nil)) (should-not db-called))) ;;; Group 9: (edited) indicator rendering (defmacro jabber-message-correct-test-with-printer-buffer (&rest body) "Run BODY in a temp buffer with stubs for prompt-level dependencies. Stubs out jabber-buffer-connection / fsm-get-state-data so that jabber-chat-pp--local and related functions can run in batch." (declare (indent 0) (debug t)) `(with-temp-buffer (let ((jabber-buffer-connection 'fake-jc)) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_jc) '(:username "me"))) ((symbol-function 'jabber-jid-displayname) (lambda (jid) jid)) ((symbol-function 'jabber-jid-resource) (lambda (jid) (when (string-match "/\\(.*\\)$" jid) (match-string 1 jid))))) ,@body)))) (ert-deftest jabber-message-correct-test-edited-indicator-foreign () "jabber-chat-pp--foreign inserts \" (edited)\" when :edited is t." (jabber-message-correct-test-with-printer-buffer (let ((data (list :foreign (list :id "ind-1" :from "alice@example.com/phone" :body "corrected text" :edited t :timestamp (current-time) :delayed nil)))) (jabber-chat-pp--foreign data) (should (string-match-p "(edited)" (buffer-string)))))) (ert-deftest jabber-message-correct-test-no-edited-indicator-when-unedited () "jabber-chat-pp--foreign does not insert \" (edited)\" when :edited is nil." (jabber-message-correct-test-with-printer-buffer (let ((data (list :foreign (list :id "ind-2" :from "alice@example.com/phone" :body "original text" :edited nil :timestamp (current-time) :delayed nil)))) (jabber-chat-pp--foreign data) (should-not (string-match-p "(edited)" (buffer-string)))))) (ert-deftest jabber-message-correct-test-edited-indicator-local () "jabber-chat-pp--local inserts \" (edited)\" when :edited is t." (jabber-message-correct-test-with-printer-buffer (let ((data (list :local (list :id "ind-3" :from "me@example.com/laptop" :body "my corrected text" :edited t :timestamp (current-time) :delayed nil)))) (jabber-chat-pp--local data) (should (string-match-p "(edited)" (buffer-string)))))) (ert-deftest jabber-message-correct-test-edited-indicator-muc-foreign () "jabber-chat-pp--muc-foreign inserts \" (edited)\" when :edited is t." (jabber-message-correct-test-with-printer-buffer (let ((jabber-muc-printers nil) (jabber-chat-printers (list (lambda (msg _who mode) (when (eq mode :insert) (insert (or (plist-get msg :body) ""))) t))) (data (list :muc-foreign (list :id "ind-4" :from "room@muc.example.com/alice" :body "muc corrected" :edited t :timestamp (current-time) :delayed nil)))) (jabber-chat-pp--muc-foreign data) (should (string-match-p "(edited)" (buffer-string)))))) (ert-deftest jabber-message-correct-test-edited-indicator-muc-local () "jabber-chat-pp--muc-local inserts \" (edited)\" when :edited is t." (jabber-message-correct-test-with-printer-buffer (let ((jabber-muc-printers nil) (jabber-chat-printers (list (lambda (msg _who mode) (when (eq mode :insert) (insert (or (plist-get msg :body) ""))) t))) (data (list :muc-local (list :id "ind-5" :from "room@muc.example.com/me" :body "my muc corrected" :edited t :timestamp (current-time) :delayed nil)))) (jabber-chat-pp--muc-local data) (should (string-match-p "(edited)" (buffer-string)))))) (ert-deftest jabber-message-correct-test-edited-indicator-absent-for-retracted () "A retracted MUC message shows tombstone, not (edited), even if :edited is t. XEP-0425 retraction takes precedence over XEP-0308 edit display." (jabber-message-correct-test-with-printer-buffer (let ((jabber-muc-printers nil) (jabber-chat-printers nil) (data (list :muc-foreign (list :id "ind-6" :from "room@muc.example.com/alice" :body "spam" :edited t :retracted t :retracted-by "room@muc.example.com/admin" :timestamp (current-time) :delayed nil)))) (jabber-chat-pp--muc-foreign data) (let ((text (buffer-string))) (should (string-match-p "retracted" text)) (should-not (string-match-p "(edited)" text)))))) (provide 'jabber-message-correct-tests) ;;; jabber-message-correct-tests.el ends here emacs-jabber/tests/jabber-message-reply-tests.el000066400000000000000000000121051516610113500222130ustar00rootroot00000000000000;;; jabber-message-reply-tests.el --- Tests for XEP-0461 -*- lexical-binding: t; -*- (require 'ert) (require 'ewoc) (load (expand-file-name "../lisp/jabber-xml.el" (file-name-directory (or load-file-name buffer-file-name)))) (load (expand-file-name "../lisp/jabber-chatbuffer.el" (file-name-directory (or load-file-name buffer-file-name)))) (load (expand-file-name "../lisp/jabber-message-reply.el" (file-name-directory (or load-file-name buffer-file-name)))) ;;; Group 1: jabber-message-reply--build-fallback-text (ert-deftest jabber-message-reply-test-fallback-single-line () "Single-line body produces two-line fallback." (let ((result (jabber-message-reply--build-fallback-text "Alice" "Hello"))) (should (equal "> Alice:\n> Hello\n" result)))) (ert-deftest jabber-message-reply-test-fallback-multi-line () "Multi-line body quotes each line." (let ((result (jabber-message-reply--build-fallback-text "Bob" "Line 1\nLine 2\nLine 3"))) (should (equal "> Bob:\n> Line 1\n> Line 2\n> Line 3\n" result)))) (ert-deftest jabber-message-reply-test-fallback-empty-body () "Empty body produces author line plus empty quote." (let ((result (jabber-message-reply--build-fallback-text "Carol" ""))) (should (equal "> Carol:\n\n" result)))) (ert-deftest jabber-message-reply-test-fallback-nil-body () "Nil body produces author line plus newline." (let ((result (jabber-message-reply--build-fallback-text "Dave" nil))) (should (equal "> Dave:\n\n" result)))) ;;; Group 2: jabber-message-reply--select-id (ert-deftest jabber-message-reply-test-select-id-1to1 () "In 1:1 chat, select :id." (let ((msg (list :id "client-id-1" :server-id "server-id-1"))) (should (equal "client-id-1" (jabber-message-reply--select-id msg nil))))) (ert-deftest jabber-message-reply-test-select-id-muc-server () "In MUC, prefer :server-id." (let ((msg (list :id "client-id-2" :server-id "server-id-2"))) (should (equal "server-id-2" (jabber-message-reply--select-id msg t))))) (ert-deftest jabber-message-reply-test-select-id-muc-fallback () "In MUC without :server-id, fall back to :id." (let ((msg (list :id "client-id-3" :server-id nil))) (should (equal "client-id-3" (jabber-message-reply--select-id msg t))))) (ert-deftest jabber-message-reply-test-select-id-missing () "Missing both IDs returns nil." (let ((msg (list :id nil :server-id nil))) (should-not (jabber-message-reply--select-id msg nil)))) ;;; Group 3: jabber-message-reply--send-hook (ert-deftest jabber-message-reply-test-send-hook-produces-elements () "Send hook produces reply and fallback elements and clears state." (with-temp-buffer (setq-local jabber-message-reply--id "orig-id-1") (setq-local jabber-message-reply--jid "alice@example.com") (setq-local jabber-message-reply--fallback-length 20) (let* ((body "> Alice:\n> Hello\nReply text here") (elements (jabber-message-reply--send-hook body "new-id"))) ;; Should produce elements (should elements) ;; Should contain a reply element (should (cl-some (lambda (el) (eq (car el) 'reply)) elements)) ;; Should contain a fallback element (should (cl-some (lambda (el) (eq (car el) 'fallback)) elements)) ;; State should be cleared (should-not jabber-message-reply--id) (should-not jabber-message-reply--jid) (should-not jabber-message-reply--fallback-length)))) (ert-deftest jabber-message-reply-test-send-hook-nil-when-no-reply () "Send hook returns nil when no reply state is set." (with-temp-buffer (should-not (jabber-message-reply--send-hook "Hello" "msg-id")))) (ert-deftest jabber-message-reply-test-send-hook-reply-attributes () "Reply element has correct to and id attributes." (with-temp-buffer (setq-local jabber-message-reply--id "target-msg") (setq-local jabber-message-reply--jid "bob@example.com/phone") (setq-local jabber-message-reply--fallback-length 15) (let* ((elements (jabber-message-reply--send-hook "> Bob:\n> Hey\nYes!" "new-msg")) (reply-el (cl-find 'reply elements :key #'car))) (should reply-el) (let ((attrs (cadr reply-el))) (should (equal "urn:xmpp:reply:0" (cdr (assq 'xmlns attrs)))) (should (equal "bob@example.com/phone" (cdr (assq 'to attrs)))) (should (equal "target-msg" (cdr (assq 'id attrs)))))))) (ert-deftest jabber-message-reply-test-send-hook-no-fallback-when-zero-length () "No fallback element when fallback-length is 0." (with-temp-buffer (setq-local jabber-message-reply--id "target-msg") (setq-local jabber-message-reply--jid "carol@example.com") (setq-local jabber-message-reply--fallback-length 0) (let ((elements (jabber-message-reply--send-hook "Just a reply" "new-msg"))) (should elements) (should (cl-some (lambda (el) (eq (car el) 'reply)) elements)) (should-not (cl-some (lambda (el) (eq (car el) 'fallback)) elements))))) (provide 'jabber-message-reply-tests) ;;; jabber-message-reply-tests.el ends here emacs-jabber/tests/jabber-modeline-tests.el000066400000000000000000000051431516610113500212360ustar00rootroot00000000000000;;; jabber-modeline-tests.el --- Tests for jabber-modeline debounce -*- lexical-binding: t; -*- (require 'ert) (load (expand-file-name "../lisp/jabber-modeline.el" (file-name-directory (or load-file-name buffer-file-name)))) ;;; Group 1: jabber-mode-line-count-contacts debounce (ert-deftest jabber-modeline-test-debounce-coalesces-calls () "Rapid calls to jabber-mode-line-count-contacts leave exactly one pending timer." (let ((jabber-mode-line--recount-timer nil)) (cl-letf (((symbol-function 'run-with-timer) (lambda (_delay _repeat fn) (list 'mock-timer fn))) ((symbol-function 'cancel-timer) #'ignore) ((symbol-function 'timerp) (lambda (x) (and (consp x) (eq (car x) 'mock-timer))))) (jabber-mode-line-count-contacts) (let ((first jabber-mode-line--recount-timer)) (jabber-mode-line-count-contacts) (jabber-mode-line-count-contacts) ;; Only the last timer is kept; there is exactly one pending timer. (should (timerp jabber-mode-line--recount-timer)) ;; Each new call replaced the previous. (should-not (eq first jabber-mode-line--recount-timer)))))) (ert-deftest jabber-modeline-test-debounce-timer-fires-and-clears () "When the debounce timer fires, jabber-mode-line--recount-timer is set to nil." (let ((jabber-mode-line--recount-timer nil) (jabber-connections nil) (jabber-mode-line-compact t) (jabber-mode-line-contacts "")) (cl-letf (((symbol-function 'force-mode-line-update) #'ignore)) (jabber-mode-line--do-count-contacts) (should (null jabber-mode-line--recount-timer))))) (ert-deftest jabber-modeline-test-on-disconnect-cancels-timer () "jabber-modeline--on-disconnect cancels a pending timer and leaves it nil." (let ((jabber-mode-line--recount-timer (list 'mock-timer)) (jabber-connections nil) (jabber-mode-line-compact t) (jabber-mode-line-contacts "") (jabber-mode-line-presence "") (*jabber-disconnecting* t) (*jabber-current-show* nil)) (cl-letf (((symbol-function 'timerp) (lambda (x) (and (consp x) (eq (car x) 'mock-timer)))) ((symbol-function 'cancel-timer) #'ignore) ((symbol-function 'force-mode-line-update) #'ignore) ((symbol-function 'jabber-activity--on-disconnect) #'ignore) ((symbol-function 'jabber-mode-line-presence-update) #'ignore)) (jabber-modeline--on-disconnect) (should (null jabber-mode-line--recount-timer))))) (provide 'jabber-modeline-tests) ;;; jabber-modeline-tests.el ends here emacs-jabber/tests/jabber-moderation-tests.el000066400000000000000000000275011516610113500216050ustar00rootroot00000000000000;;; jabber-moderation-tests.el --- Tests for XEP-0425 moderation -*- lexical-binding: t; -*- (require 'ert) (require 'ewoc) (require 'jabber-chatbuffer) (require 'jabber-chat) (require 'jabber-muc) (require 'jabber-moderation) ;;; Test helpers (defmacro jabber-moderation-test-with-ewoc (&rest body) "Set up a temp buffer with a chat ewoc and hash table, then run BODY." (declare (indent 0) (debug t)) `(with-temp-buffer (let ((jabber-chat-ewoc (ewoc-create #'ignore nil nil 'nosep)) (jabber-chat--msg-nodes (make-hash-table :test 'equal))) ,@body))) ;;; Group 1: server-id indexing (ert-deftest jabber-moderation-test-server-id-indexed () "Ewoc hash stores and retrieves by :server-id." (jabber-moderation-test-with-ewoc (let* ((msg (list :id "client-1" :server-id "server-abc" :body "hello" :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :muc-foreign msg)))) (should (eq node (jabber-chat-ewoc-find-by-id "client-1"))) (should (eq node (jabber-chat-ewoc-find-by-id "server-abc")))))) (ert-deftest jabber-moderation-test-server-id-nil-no-index () "A nil :server-id does not pollute the hash table." (jabber-moderation-test-with-ewoc (let ((msg (list :id "client-2" :body "x" :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :muc-foreign msg))) (should (= 1 (hash-table-count jabber-chat--msg-nodes))) (should (gethash "client-2" jabber-chat--msg-nodes)))) ;;; Group 2: retraction handling (ert-deftest jabber-moderation-test-retract-updates-ewoc () "Retraction stanza sets :retracted on the original message." (jabber-moderation-test-with-ewoc ;; Insert a message with a server-id (let ((msg (list :id "msg-1" :server-id "stanza-id-1" :from "room@muc.example.com/alice" :body "spam" :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :muc-foreign msg))) ;; Name the buffer so jabber-muc-find-buffer can find it (let ((buf (current-buffer))) (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (_group) buf)) ((symbol-function 'jabber-db-retract-message) #'ignore)) ;; Simulate retraction stanza; is a child of ;; per XEP-0425, not of . (let ((retract-xml '(message ((from . "room@muc.example.com") (type . "groupchat")) (retract ((id . "stanza-id-1") (xmlns . "urn:xmpp:message-retract:1")) (moderated ((by . "room@muc.example.com/admin") (xmlns . "urn:xmpp:message-moderate:1"))) (reason () "spam"))))) (jabber-moderation--handle-message nil retract-xml))) ;; Verify the plist was mutated (let* ((node (jabber-chat-ewoc-find-by-id "stanza-id-1")) (data (ewoc-data node)) (msg (cadr data))) (should (plist-get msg :retracted)) (should (equal "room@muc.example.com/admin" (plist-get msg :retracted-by))) (should (equal "spam" (plist-get msg :retraction-reason))))))) ;;; Group 3: stanza-id source validation (ert-deftest jabber-moderation-test-rejects-client-id () "Retraction targeting a client message-id (not server stanza-id) is ignored." (jabber-moderation-test-with-ewoc (let ((msg (list :id "client-id-1" :server-id "server-stanza-id-1" :body "hello" :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :muc-foreign msg))) (let ((buf (current-buffer))) (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (_group) buf)) ((symbol-function 'jabber-db-retract-message) #'ignore)) ;; Use client-id-1, not server-stanza-id-1 -- MUST be ignored (let ((retract-xml '(message ((from . "room@muc.example.com") (type . "groupchat")) (retract ((id . "client-id-1") (xmlns . "urn:xmpp:message-retract:1")) (moderated ((by . "room@muc.example.com/admin") (xmlns . "urn:xmpp:message-moderate:1"))))))) ;; Returns t (consumed by chain) but must not mutate the message (jabber-moderation--handle-message nil retract-xml)))) (let* ((node (jabber-chat-ewoc-find-by-id "client-id-1")) (msg (cadr (ewoc-data node)))) (should-not (plist-get msg :retracted))))) ;;; Group 4: sender validation (ert-deftest jabber-moderation-test-validates-sender () "Retraction from a participant (not MUC service) is ignored." (jabber-moderation-test-with-ewoc (let ((msg (list :id "msg-2" :server-id "stanza-id-2" :from "room@muc.example.com/alice" :body "hello" :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :muc-foreign msg))) ;; Retraction from a full JID (has resource) should be rejected (let ((retract-xml '(message ((from . "room@muc.example.com/mallory") (type . "groupchat")) (retract ((id . "stanza-id-2") (xmlns . "urn:xmpp:message-retract:1")) (moderated ((by . "room@muc.example.com/mallory") (xmlns . "urn:xmpp:message-moderate:1"))))))) (should-not (jabber-moderation--handle-message nil retract-xml))) ;; Original message should be untouched (let* ((node (jabber-chat-ewoc-find-by-id "stanza-id-2")) (msg (cadr (ewoc-data node)))) (should-not (plist-get msg :retracted))))) (ert-deftest jabber-moderation-test-non-groupchat-ignored () "Retraction in a non-groupchat message is ignored." (let ((retract-xml '(message ((from . "room@muc.example.com") (type . "chat")) (retract ((id . "stanza-id-3") (xmlns . "urn:xmpp:message-retract:1")) (moderated ((by . "room@muc.example.com/admin") (xmlns . "urn:xmpp:message-moderate:1"))))))) (should-not (jabber-moderation--handle-message nil retract-xml)))) ;;; Group 5: missing message (ert-deftest jabber-moderation-test-missing-message-ignored () "Retraction for unknown stanza-id doesn't error." (jabber-moderation-test-with-ewoc (let ((buf (current-buffer))) (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (_group) buf)) ((symbol-function 'jabber-db-retract-message) #'ignore)) (let ((retract-xml '(message ((from . "room@muc.example.com") (type . "groupchat")) (retract ((id . "nonexistent-id") (xmlns . "urn:xmpp:message-retract:1")) (moderated ((by . "room@muc.example.com/admin") (xmlns . "urn:xmpp:message-moderate:1"))))))) ;; Should return t (consumed) but not error (should (jabber-moderation--handle-message nil retract-xml))))))) ;;; Group 6: tombstone rendering (ert-deftest jabber-moderation-test-tombstone-rendering () "Tombstone text is inserted for retracted messages." (with-temp-buffer (let ((msg (list :body "spam" :retracted t :retracted-by "room@muc.example.com/admin" :retraction-reason "spam"))) (jabber-chat--insert-tombstone msg) (should (string-match-p "Message retracted by: admin reason: spam" (buffer-string)))))) (ert-deftest jabber-moderation-test-tombstone-no-reason () "Tombstone without reason omits the reason part." (with-temp-buffer (let ((msg (list :body "x" :retracted t :retracted-by "room@muc.example.com/mod"))) (jabber-chat--insert-tombstone msg) (let ((text (buffer-string))) (should (string-match-p "Message retracted by: mod" text)) (should-not (string-match-p "reason:" text)))))) ;;; Group 7: build-msg-plist extracts server-id (ert-deftest jabber-moderation-test-plist-extracts-server-id () "jabber-chat--build-msg-plist extracts :server-id from stanza-id element." (let* ((stanza '(message ((from . "room@muc.example.com/alice") (id . "client-id") (type . "groupchat")) (body () "hello") (stanza-id ((id . "server-id-42") (by . "room@muc.example.com") (xmlns . "urn:xmpp:sid:0"))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (equal "server-id-42" (plist-get plist :server-id))))) (ert-deftest jabber-moderation-test-plist-nil-server-id () "jabber-chat--build-msg-plist returns nil :server-id when absent." (let* ((stanza '(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (body () "hello"))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should-not (plist-get plist :server-id)))) ;;; Group 8: retract command (ert-deftest jabber-moderation-test-retract-sends-iq () "jabber-moderation-retract sends correct IQ XML." (jabber-moderation-test-with-ewoc (setq-local jabber-group "room@muc.example.com") (setq-local jabber-buffer-connection 'fake-jc) (let* ((msg (list :id "msg-r1" :server-id "sid-retract" :body "spam" :timestamp (current-time))) (sent-iq nil)) (jabber-chat-ewoc-enter (list :muc-foreign msg)) (goto-char (point-min)) (cl-letf (((symbol-function 'jabber-send-iq) (lambda (_jc to type query &rest _rest) (setq sent-iq (list :to to :type type :query query)))) ((symbol-function 'read-string) (lambda (&rest _) "test reason")) ((symbol-function 'jabber-db-retract-message) #'ignore)) (jabber-moderation-retract)) (should (equal "room@muc.example.com" (plist-get sent-iq :to))) (should (equal "set" (plist-get sent-iq :type))) (let ((query (plist-get sent-iq :query))) (should (eq 'moderate (car query))) (should (equal "sid-retract" (cdr (assq 'id (cadr query))))) (should (equal jabber-moderation-xmlns (cdr (assq 'xmlns (cadr query))))) ;; Check retract child (let ((retract (nth 2 query))) (should (eq 'retract (car retract))) (should (equal jabber-moderation-retract-xmlns (cdr (assq 'xmlns (cadr retract)))))) ;; Check reason child (let ((reason (nth 3 query))) (should (eq 'reason (car reason))) (should (equal "test reason" (nth 2 reason)))))))) (ert-deftest jabber-moderation-test-retract-errors-without-server-id () "jabber-moderation-retract signals error when no server-id." (jabber-moderation-test-with-ewoc (setq-local jabber-group "room@muc.example.com") (setq-local jabber-buffer-connection 'fake-jc) (let ((msg (list :id "msg-r2" :body "hello" :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :muc-foreign msg)) (goto-char (point-min)) (should-error (jabber-moderation-retract) :type 'user-error)))) (ert-deftest jabber-moderation-test-retract-errors-outside-muc () "jabber-moderation-retract signals error outside MUC buffer." (with-temp-buffer (should-error (jabber-moderation-retract) :type 'user-error))) (provide 'jabber-moderation-tests) ;;; jabber-moderation-tests.el ends here emacs-jabber/tests/jabber-muc-tests.el000066400000000000000000001243051516610113500202300ustar00rootroot00000000000000;;; jabber-muc-tests.el --- Tests for jabber-muc -*- lexical-binding: t; -*- (require 'ert) ;; Pre-define variables that jabber-muc.el expects at load time ;; from jabber-core.el and jabber-chat.el: (defvar jabber-body-printers nil) (defvar jabber-message-chain nil) (defvar jabber-presence-chain nil) (defvar jabber-iq-chain nil) (defvar jabber-jid-obarray (make-vector 127 0)) (require 'jabber-chatbuffer) (require 'jabber-muc) (defmacro jabber-muc-test-with-rooms (rooms &rest body) "Run BODY with ROOMS as active groupchats. ROOMS is an alist of (group . nickname). Each room gets a single entry with JC=nil." (declare (indent 1)) `(let ((jabber-muc--rooms (make-hash-table :test #'equal))) (dolist (r ,rooms) (puthash (car r) (list (cons nil (cdr r))) jabber-muc--rooms)) ,@body)) ;;; Group 1: jabber-muc-message-p (ert-deftest jabber-test-muc-message-p-groupchat () "Groupchat type message is a MUC message." (let ((msg '(message ((from . "room@conference.example.com/nick") (type . "groupchat")) (body nil "Hello")))) (should (jabber-muc-message-p msg)))) (ert-deftest jabber-test-muc-message-p-error-from-room () "Error from a pending groupchat is a MUC message." (let ((jabber-pending-groupchats (make-hash-table)) (jabber-jid-obarray (make-vector 127 0))) (puthash (intern "room@conference.example.com" jabber-jid-obarray) "mynick" jabber-pending-groupchats) (let ((msg '(message ((from . "room@conference.example.com") (type . "error")) (error ((type . "cancel")))))) (should (jabber-muc-message-p msg))))) (ert-deftest jabber-test-muc-message-p-chat () "Normal chat message is not a MUC message." (let ((jabber-pending-groupchats (make-hash-table)) (jabber-jid-obarray (make-vector 127 0))) (let ((msg '(message ((from . "alice@example.com/home") (type . "chat")) (body nil "Hi")))) (should-not (jabber-muc-message-p msg))))) (ert-deftest jabber-test-muc-message-p-invite () "MUC invite is a MUC message." (let ((jabber-pending-groupchats (make-hash-table)) (jabber-jid-obarray (make-vector 127 0))) (let ((msg '(message ((from . "room@conference.example.com")) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (invite ((from . "alice@example.com")) (reason nil "Join us")))))) (should (jabber-muc-message-p msg))))) ;;; Group 2: jabber-muc-sender-p (ert-deftest jabber-test-muc-sender-p-full-jid () "Full JID from active groupchat is a MUC sender." (jabber-muc-test-with-rooms '(("room@conference.example.com" . "mynick")) (should (jabber-muc-sender-p "room@conference.example.com/othernick")))) (ert-deftest jabber-test-muc-sender-p-bare-jid () "Bare JID (no resource) is not a MUC sender." (jabber-muc-test-with-rooms '(("room@conference.example.com" . "mynick")) (should-not (jabber-muc-sender-p "room@conference.example.com")))) (ert-deftest jabber-test-muc-sender-p-not-active () "JID not in active groupchats is not a MUC sender." (jabber-muc-test-with-rooms nil (should-not (jabber-muc-sender-p "room@conference.example.com/nick")))) ;;; Group 3: jabber-muc-private-message-p (ert-deftest jabber-test-muc-private-message-p-private () "Private message from MUC participant returns non-nil." (jabber-muc-test-with-rooms '(("room@conference.example.com" . "mynick")) (let ((msg '(message ((from . "room@conference.example.com/othernick") (type . "chat")) (body nil "Psst")))) (should (jabber-muc-private-message-p msg))))) (ert-deftest jabber-test-muc-private-message-p-groupchat () "Groupchat type message is not a private message." (jabber-muc-test-with-rooms '(("room@conference.example.com" . "mynick")) (let ((msg '(message ((from . "room@conference.example.com/nick") (type . "groupchat")) (body nil "Hello all")))) (should-not (jabber-muc-private-message-p msg))))) ;;; Group 4: jabber-muc-presence-p (ert-deftest jabber-test-muc-presence-p-with-marker () "Presence with muc#user namespace is MUC presence." (let ((jabber-pending-groupchats (make-hash-table)) (jabber-jid-obarray (make-vector 127 0))) (let ((pres '(presence ((from . "room@conference.example.com/nick")) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((affiliation . "member") (role . "participant"))))))) (should (jabber-muc-presence-p pres))))) (ert-deftest jabber-test-muc-presence-p-without-marker () "Presence without muc#user namespace is not MUC presence." (let ((jabber-pending-groupchats (make-hash-table)) (jabber-jid-obarray (make-vector 127 0))) (let ((pres '(presence ((from . "alice@example.com/home"))))) (should-not (jabber-muc-presence-p pres))))) (ert-deftest jabber-test-muc-presence-p-error-pending () "Error presence from pending groupchat is MUC presence." (let ((jabber-pending-groupchats (make-hash-table)) (jabber-jid-obarray (make-vector 127 0))) (puthash (intern "room@conference.example.com" jabber-jid-obarray) "mynick" jabber-pending-groupchats) (let ((pres '(presence ((from . "room@conference.example.com/mynick") (type . "error")) (error ((type . "cancel")))))) (should (jabber-muc-presence-p pres))))) ;;; Group 5: jabber-muc accessor functions (ert-deftest jabber-test-muc-join-set-and-nickname () "jabber-muc-join-set stores room; jabber-muc-nickname retrieves nick." (let ((jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--generation 0) ) (jabber-muc-join-set "room@example.com" 'fake-jc "mynick") (should (string= (jabber-muc-nickname "room@example.com") "mynick")))) (ert-deftest jabber-test-muc-join-set-and-connection () "jabber-muc-connection retrieves the stored connection." (let ((jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--generation 0) ) (jabber-muc-join-set "room@example.com" 'fake-jc "mynick") (should (eq (jabber-muc-connection "room@example.com") 'fake-jc)))) (ert-deftest jabber-test-muc-leave-remove () "jabber-muc-leave-remove removes the room." (let ((jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--generation 0) ) (jabber-muc-join-set "room@example.com" 'fake-jc "mynick") (jabber-muc-leave-remove "room@example.com") (should-not (jabber-muc-joined-p "room@example.com")))) (ert-deftest jabber-test-muc-joined-p () "jabber-muc-joined-p returns t for joined rooms, nil otherwise." (let ((jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--generation 0) ) (should-not (jabber-muc-joined-p "room@example.com")) (jabber-muc-join-set "room@example.com" nil "mynick") (should (jabber-muc-joined-p "room@example.com")))) (ert-deftest jabber-test-muc-active-rooms () "jabber-muc-active-rooms returns list of joined room JIDs." (let ((jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--generation 0) ) (jabber-muc-join-set "room1@example.com" nil "nick1") (jabber-muc-join-set "room2@example.com" nil "nick2") (let ((rooms (jabber-muc-active-rooms))) (should (= (length rooms) 2)) (should (member "room1@example.com" rooms)) (should (member "room2@example.com" rooms))))) (ert-deftest jabber-test-muc-generation-increments () "jabber-muc-generation increments on join and leave." (let ((jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--generation 0) ) (should (= (jabber-muc-generation) 0)) (jabber-muc-join-set "room@example.com" nil "mynick") (should (= (jabber-muc-generation) 1)) (jabber-muc-leave-remove "room@example.com") (should (= (jabber-muc-generation) 2)))) (ert-deftest jabber-test-muc-nickname-unknown-room () "jabber-muc-nickname returns nil for unknown rooms." (let ((jabber-muc--rooms (make-hash-table :test #'equal))) (should-not (jabber-muc-nickname "unknown@example.com")))) (ert-deftest jabber-test-muc-connection-unknown-room () "jabber-muc-connection returns nil for unknown rooms." (let ((jabber-muc--rooms (make-hash-table :test #'equal))) (should-not (jabber-muc-connection "unknown@example.com")))) ;;; Group 6: jabber-muc--classify-message (ert-deftest jabber-test-muc-classify-message-error () "Stanza with error child is classified as :muc-error." (jabber-muc-test-with-rooms '(("room@conference.example.com" . "mynick")) (let ((xml '(message ((from . "room@conference.example.com/othernick") (type . "groupchat")) (error ((type . "cancel")))))) (should (eq :muc-error (jabber-muc--classify-message nil "room@conference.example.com" "othernick" xml)))))) (ert-deftest jabber-test-muc-classify-message-local () "Message from our own nick is classified as :muc-local." (jabber-muc-test-with-rooms '(("room@conference.example.com" . "mynick")) (let ((xml '(message ((from . "room@conference.example.com/mynick") (type . "groupchat")) (body nil "Hello")))) (should (eq :muc-local (jabber-muc--classify-message nil "room@conference.example.com" "mynick" xml)))))) (ert-deftest jabber-test-muc-classify-message-foreign () "Message from another nick is classified as :muc-foreign." (jabber-muc-test-with-rooms '(("room@conference.example.com" . "mynick")) (let ((xml '(message ((from . "room@conference.example.com/othernick") (type . "groupchat")) (body nil "Hello")))) (should (eq :muc-foreign (jabber-muc--classify-message nil "room@conference.example.com" "othernick" xml)))))) (ert-deftest jabber-test-muc-classify-message-uncached-room () "Room not in jabber-muc--rooms with non-nil nick returns :muc-foreign." (let ((jabber-muc--rooms (make-hash-table :test #'equal))) (let ((xml '(message ((from . "room@conference.example.com/othernick") (type . "groupchat")) (body nil "Hello")))) (should (eq :muc-foreign (jabber-muc--classify-message nil "room@conference.example.com" "othernick" xml)))))) ;;; Group 7: jabber-muc--history-message-p (ert-deftest jabber-test-muc-history-message-p-delay () "Delay from=room is detected as MUC history per XEP-0045." (let ((xml '(message ((from . "room@conference.example.com/nick") (type . "groupchat")) (body nil "Old message") (delay ((xmlns . "urn:xmpp:delay") (from . "room@conference.example.com") (stamp . "2023-01-01T00:00:00Z")))))) (should (jabber-muc--history-message-p xml)))) (ert-deftest jabber-test-muc-history-message-p-legacy-delay () "Legacy jabber:x:delay from=room is detected as MUC history." (let ((xml '(message ((from . "room@conference.example.com/nick") (type . "groupchat")) (body nil "Old message") (x ((xmlns . "jabber:x:delay") (from . "room@conference.example.com") (stamp . "20230101T00:00:00")))))) (should (jabber-muc--history-message-p xml)))) (ert-deftest jabber-test-muc-history-message-p-live () "Live message without delay element is not history." (let ((xml '(message ((from . "room@conference.example.com/nick") (type . "groupchat")) (body nil "Live message")))) (should-not (jabber-muc--history-message-p xml)))) (ert-deftest jabber-test-muc-history-message-p-mixed-children () "Delay from=room among mixed sibling elements is detected." (let ((xml '(message ((from . "room@conference.example.com/nick") (type . "groupchat")) (body nil "Old message") (delay ((xmlns . "urn:xmpp:delay") (from . "room@conference.example.com") (stamp . "2023-01-01T00:00:00Z"))) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (status ((code . "100"))))))) (should (jabber-muc--history-message-p xml)))) (ert-deftest jabber-test-muc-history-message-p-bridge-delay () "Delay from a bridge gateway is not history (Matrix/slidge scenario)." (let ((xml '(message ((from . "!room@matrix.example.com/nick") (type . "groupchat")) (body nil "Live bridged message") (delay ((xmlns . "urn:xmpp:delay") (from . "matrix.example.com") (stamp . "2026-04-06T06:09:55Z")))))) (should-not (jabber-muc--history-message-p xml)))) (ert-deftest jabber-test-muc-history-message-p-delay-no-from () "Delay without from attribute is not treated as history." (let ((xml '(message ((from . "room@conference.example.com/nick") (type . "groupchat")) (body nil "Message with anonymous delay") (delay ((xmlns . "urn:xmpp:delay") (stamp . "2023-01-01T00:00:00Z")))))) (should-not (jabber-muc--history-message-p xml)))) (ert-deftest jabber-test-muc-classify-message-error-priority () "Error classification takes priority over matching local nick." (jabber-muc-test-with-rooms '(("room@conference.example.com" . "mynick")) (let ((xml '(message ((from . "room@conference.example.com/mynick") (type . "groupchat")) (error ((type . "cancel")))))) (should (eq :muc-error (jabber-muc--classify-message nil "room@conference.example.com" "mynick" xml)))))) (ert-deftest jabber-test-muc-classify-message-nil-nick () "Nil nick (bare JID) classifies as :muc-foreign, not crash." (jabber-muc-test-with-rooms '(("room@conference.example.com" . "mynick")) (let ((xml '(message ((from . "room@conference.example.com") (type . "groupchat")) (body nil "Room announcement")))) (should (eq :muc-foreign (jabber-muc--classify-message nil "room@conference.example.com" nil xml)))))) ;;; Group 8: jabber-muc--format-affiliation-change (ert-deftest jabber-test-muc-affiliation-promote-member-to-admin () "Promoting member to admin reports promotion." (should (string= "alice has been promoted to admin" (jabber-muc--format-affiliation-change "alice" "member" "admin" "")))) (ert-deftest jabber-test-muc-affiliation-demote-admin-to-member () "Demoting admin to member reports demotion." (should (string= "bob has been demoted to member by op: misconduct" (jabber-muc--format-affiliation-change "bob" "admin" "member" " by op: misconduct")))) (ert-deftest jabber-test-muc-affiliation-grant-membership () "Granting membership from outcast reports grant." (should (string= "carol has been granted membership" (jabber-muc--format-affiliation-change "carol" "outcast" "member" "")))) (ert-deftest jabber-test-muc-affiliation-lose-membership () "Losing membership from member to none reports deprivation." (should (string= "dave has been deprived of membership" (jabber-muc--format-affiliation-change "dave" "member" "none" "")))) (ert-deftest jabber-test-muc-affiliation-owner-to-admin () "Owner demoted to admin reports demotion." (should (string= "frank has been demoted to admin" (jabber-muc--format-affiliation-change "frank" "owner" "admin" "")))) (ert-deftest jabber-test-muc-affiliation-no-match () "Unrecognized affiliation transition returns nil." (should-not (jabber-muc--format-affiliation-change "eve" "admin" "outcast" ""))) ;;; Group 9: jabber-muc--format-role-change (ert-deftest jabber-test-muc-role-change-to-moderator () "Participant promoted to moderator reports grant." (should (string= "alice has been granted moderator privileges" (jabber-muc--format-role-change "alice" "participant" "moderator" "")))) (ert-deftest jabber-test-muc-role-change-moderator-to-participant () "Moderator demoted to participant reports revocation." (should (string= "bob had moderator privileges revoked by admin" (jabber-muc--format-role-change "bob" "moderator" "participant" " by admin")))) (ert-deftest jabber-test-muc-role-change-to-visitor () "Participant changed to visitor reports denied voice." (should (string= "carol has been denied voice" (jabber-muc--format-role-change "carol" "participant" "visitor" "")))) (ert-deftest jabber-test-muc-role-change-to-participant () "Visitor granted voice reports grant." (should (string= "dave has been granted voice" (jabber-muc--format-role-change "dave" "visitor" "participant" "")))) (ert-deftest jabber-test-muc-role-change-visitor-to-moderator () "Visitor promoted to moderator reports grant." (should (string= "eve has been granted moderator privileges" (jabber-muc--format-role-change "eve" "visitor" "moderator" "")))) ;;; Group 10: jabber-muc-report-delta integration (ert-deftest jabber-test-muc-report-delta-new-join () "Nil old-plist produces an enters-room message." (let ((new-plist '(role "participant" affiliation "member"))) (should (string= "nick enters the room (participant, member)" (jabber-muc-report-delta "nick" nil new-plist nil nil))))) (ert-deftest jabber-test-muc-report-delta-no-change () "Same affiliation and role returns nil." (let ((old '(role "participant" affiliation "member")) (new '(role "participant" affiliation "member"))) (should-not (jabber-muc-report-delta "nick" old new nil nil)))) (ert-deftest jabber-test-muc-report-delta-affiliation-change () "Affiliation change delegates to affiliation helper." (let ((old '(role "participant" affiliation "member")) (new '(role "participant" affiliation "admin"))) (should (string= "nick has been promoted to admin" (jabber-muc-report-delta "nick" old new nil nil))))) (ert-deftest jabber-test-muc-report-delta-role-change () "Role change delegates to role helper." (let ((old '(role "participant" affiliation "member")) (new '(role "moderator" affiliation "member"))) (should (string= "nick has been granted moderator privileges" (jabber-muc-report-delta "nick" old new nil nil))))) ;;; Group 11: jabber-muc-create (ert-deftest jabber-test-muc-create-sets-auto-configure () "jabber-muc-create sends join presence with auto-configure." (let ((join-args nil)) (cl-letf (((symbol-function 'jabber-muc--send-join-presence) (lambda (jc group nickname password popup &optional auto-configure) (setq join-args (list jc group nickname password popup auto-configure)))) ((symbol-function 'jabber-bookmarks--publish-one) #'ignore)) (jabber-muc-create 'fake-jc "room@conference.example.com" "mynick")) (should join-args) ;; auto-configure (6th) should be t (should (nth 5 join-args)) ;; popup (5th) should be t (should (nth 4 join-args)))) (ert-deftest jabber-test-muc-auto-configure-opens-config () "Status 201 with auto-configure flag calls jabber-muc-get-config." (let ((config-called nil) (jabber-buffer-connection 'fake-jc) (jabber-group "room@conference.example.com") (jabber-muc--auto-configure t) (jabber-chat-ewoc nil)) (cl-letf (((symbol-function 'jabber-muc-get-config) (lambda (jc group) (setq config-called (cons jc group))))) (jabber-muc--enter-extra-notices "mynick" (list jabber-muc-status-room-created))) (should (equal config-called '(fake-jc . "room@conference.example.com"))) (should-not jabber-muc--auto-configure))) (ert-deftest jabber-test-muc-auto-configure-off-shows-notice () "Status 201 without auto-configure flag inserts ewoc notice." (let ((notice-entered nil) (jabber-muc--auto-configure nil) (jabber-chat-ewoc 'fake-ewoc)) (cl-letf (((symbol-function 'jabber-chat-ewoc-enter) (lambda (data) (setq notice-entered data))) ((symbol-function 'jabber-muc--room-created-message) (lambda () "room created message"))) (jabber-muc--enter-extra-notices "mynick" (list jabber-muc-status-room-created))) (should notice-entered) (should (eq :muc-notice (car notice-entered))))) ;;; Group 12: jabber-muc--validate-disco-result (ert-deftest jabber-test-muc-validate-disco-ok () "Conference identity returns :ok status with features." (let* ((identities (vector "Room" "conference" "text")) (features '("http://jabber.org/protocol/muc" "muc_open")) (result (list (list identities) features))) (let ((v (jabber-muc--validate-disco-result result))) (should (eq 'ok (plist-get v :status))) (should (equal features (plist-get v :features)))))) (ert-deftest jabber-test-muc-validate-disco-not-found () "Item-not-found error returns :not-found status." (let ((result '(error ((type . "cancel")) (item-not-found ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))))) (cl-letf (((symbol-function 'jabber-error-condition) (lambda (_r) 'item-not-found))) (let ((v (jabber-muc--validate-disco-result result))) (should (eq 'not-found (plist-get v :status))))))) (ert-deftest jabber-test-muc-validate-disco-not-conference () "Non-conference identity returns :not-conference status." (let* ((identities (vector "Gateway" "gateway" "xmpp")) (result (list (list identities) '("some-feature")))) (let ((v (jabber-muc--validate-disco-result result))) (should (eq 'not-conference (plist-get v :status)))))) (ert-deftest jabber-test-muc-validate-disco-error () "Generic error returns :error status with message." (let ((result '(error ((type . "cancel")) (forbidden ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))))) (cl-letf (((symbol-function 'jabber-error-condition) (lambda (_r) 'forbidden)) ((symbol-function 'jabber-parse-error) (lambda (_r) "Forbidden"))) (let ((v (jabber-muc--validate-disco-result result))) (should (eq 'error (plist-get v :status))) (should (string= "Forbidden" (plist-get v :error-msg))))))) (ert-deftest jabber-test-muc-validate-disco-no-disco () "Feature-not-implemented returns :no-disco status." (let ((result '(error ((type . "cancel")) (feature-not-implemented ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))))) (cl-letf (((symbol-function 'jabber-error-condition) (lambda (_r) 'feature-not-implemented))) (let ((v (jabber-muc--validate-disco-result result))) (should (eq 'no-disco (plist-get v :status))))))) ;;; Group 13: jabber-muc-create skips disco (ert-deftest jabber-test-muc-create-skips-disco () "jabber-muc-create sends join presence directly without disco." (let ((join-called nil) (disco-called nil)) (cl-letf (((symbol-function 'jabber-muc--send-join-presence) (lambda (&rest _args) (setq join-called t))) ((symbol-function 'jabber-disco-get-info) (lambda (&rest _args) (setq disco-called t))) ((symbol-function 'jabber-bookmarks--publish-one) #'ignore)) (jabber-muc-create 'fake-jc "room@conference.example.com" "mynick")) (should join-called) (should-not disco-called))) ;;; Group 14: OMEMO session prefetch on participant join (defun jabber-muc-test--make-fake-jc () "Return a fake connection object for testing." 'fake-jc) (ert-deftest jabber-muc-test-omemo-prefetch-on-participant-join () "OMEMO sessions are prefetched when a new participant with a real JID joins." (let* ((jc (jabber-muc-test--make-fake-jc)) (group "room@conf.example.com") (prefetch-calls nil) (x-muc '(x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((affiliation . "member") (role . "participant") (jid . "alice@example.com/res"))))) (buf (generate-new-buffer " *test-muc-omemo*"))) (unwind-protect (progn (with-current-buffer buf (setq-local jabber-chat-encryption 'omemo)) (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (_) buf)) ((symbol-function 'jabber-omemo--prefetch-sessions) (lambda (_ jid) (push jid prefetch-calls))) ((symbol-function 'jabber-muc-participant-plist) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-modify-participant) #'ignore) ((symbol-function 'jabber-muc-report-delta) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-create-buffer) (lambda (&rest _) buf)) ((symbol-function 'jabber-maybe-print-rare-time) #'ignore) ((symbol-function 'jabber-chat-ewoc-enter) #'ignore)) (jabber-muc--process-enter jc group "alice" (jabber-jid-symbol "room@conf.example.com/alice") nil x-muc nil nil "me") (should (member "alice@example.com" prefetch-calls)))) (kill-buffer buf)))) (ert-deftest jabber-muc-test-no-omemo-prefetch-when-plaintext () "No OMEMO prefetch when the buffer uses plaintext encryption." (let* ((jc (jabber-muc-test--make-fake-jc)) (group "room@conf.example.com") (prefetch-calls nil) (x-muc '(x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((affiliation . "member") (role . "participant") (jid . "alice@example.com/res"))))) (buf (generate-new-buffer " *test-muc-plain*"))) (unwind-protect (progn (with-current-buffer buf (setq-local jabber-chat-encryption 'plaintext)) (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (_) buf)) ((symbol-function 'jabber-omemo--prefetch-sessions) (lambda (_ jid) (push jid prefetch-calls))) ((symbol-function 'jabber-muc-participant-plist) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-modify-participant) #'ignore) ((symbol-function 'jabber-muc-report-delta) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-create-buffer) (lambda (&rest _) buf)) ((symbol-function 'jabber-maybe-print-rare-time) #'ignore) ((symbol-function 'jabber-chat-ewoc-enter) #'ignore)) (jabber-muc--process-enter jc group "alice" (jabber-jid-symbol "room@conf.example.com/alice") nil x-muc nil nil "me") (should (null prefetch-calls)))) (kill-buffer buf)))) (ert-deftest jabber-muc-test-no-omemo-prefetch-for-self () "OMEMO prefetch is not triggered for self-presence." (let* ((jc (jabber-muc-test--make-fake-jc)) (group "room@conf.example.com") (prefetch-calls nil) (x-muc '(x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((affiliation . "member") (role . "participant") (jid . "me@example.com/res"))))) (buf (generate-new-buffer " *test-muc-self*"))) (unwind-protect (progn (with-current-buffer buf (setq-local jabber-chat-encryption 'omemo)) (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (_) buf)) ((symbol-function 'jabber-omemo--prefetch-sessions) (lambda (_ jid) (push jid prefetch-calls))) ((symbol-function 'jabber-muc-participant-plist) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-modify-participant) #'ignore) ((symbol-function 'jabber-muc-report-delta) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-create-buffer) (lambda (&rest _) buf)) ((symbol-function 'jabber-maybe-print-rare-time) #'ignore) ((symbol-function 'jabber-chat-ewoc-enter) #'ignore) ((symbol-function 'jabber-muc-add-groupchat) #'ignore) ((symbol-function 'jabber-mam-muc-joined) #'ignore) ((symbol-function 'jabber-bookmarks-auto-add-maybe) #'ignore)) ;; "me" is self — status code 110 marks self-presence (jabber-muc--process-enter jc group "me" (jabber-jid-symbol "room@conf.example.com/me") (list jabber-muc-status-self-presence) x-muc nil nil "me") (should (null prefetch-calls)))) (kill-buffer buf)))) (ert-deftest jabber-muc-test-no-omemo-prefetch-without-real-jid () "No OMEMO prefetch when participant has no real JID (anonymous room)." (let* ((jc (jabber-muc-test--make-fake-jc)) (group "room@conf.example.com") (prefetch-calls nil) ;; No jid attribute in item (x-muc '(x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((affiliation . "member") (role . "participant"))))) (buf (generate-new-buffer " *test-muc-anon*"))) (unwind-protect (progn (with-current-buffer buf (setq-local jabber-chat-encryption 'omemo)) (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (_) buf)) ((symbol-function 'jabber-omemo--prefetch-sessions) (lambda (_ jid) (push jid prefetch-calls))) ((symbol-function 'jabber-muc-participant-plist) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-modify-participant) #'ignore) ((symbol-function 'jabber-muc-report-delta) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-create-buffer) (lambda (&rest _) buf)) ((symbol-function 'jabber-maybe-print-rare-time) #'ignore) ((symbol-function 'jabber-chat-ewoc-enter) #'ignore)) (jabber-muc--process-enter jc group "bob" (jabber-jid-symbol "room@conf.example.com/bob") nil x-muc nil nil "me") (should (null prefetch-calls)))) (kill-buffer buf)))) ;;; Group 15: jabber-muc--merge-plist (ert-deftest jabber-test-muc-merge-plist-preserves-old-keys () "Old keys not present in new plist are preserved." (let ((result (jabber-muc--merge-plist '(jid "alice@example.com" role "participant") '(role "moderator")))) (should (string= "alice@example.com" (plist-get result 'jid))) (should (string= "moderator" (plist-get result 'role))))) (ert-deftest jabber-test-muc-merge-plist-overwrites-shared-keys () "New values win on conflict." (let ((result (jabber-muc--merge-plist '(role "participant" affiliation "member") '(role "moderator" affiliation "admin")))) (should (string= "moderator" (plist-get result 'role))) (should (string= "admin" (plist-get result 'affiliation))))) (ert-deftest jabber-test-muc-merge-plist-empty-old () "Nil old plist returns new plist unchanged." (let ((result (jabber-muc--merge-plist nil '(role "participant")))) (should (string= "participant" (plist-get result 'role))))) (ert-deftest jabber-test-muc-modify-participant-preserves-jid () "Presence update without jid keeps the previously known jid." (let ((jabber-muc-participants nil)) ;; Initial presence with full info including jid (jabber-muc-modify-participant "room@conf.example.com" "alice" '(role "participant" affiliation "member" jid "alice@example.com/res")) ;; Subsequent presence (e.g. role change) without jid attribute (jabber-muc-modify-participant "room@conf.example.com" "alice" '(role "moderator" affiliation "member")) (let ((plist (jabber-muc-participant-plist "room@conf.example.com" "alice"))) (should (string= "moderator" (plist-get plist 'role))) (should (string= "alice@example.com/res" (plist-get plist 'jid)))))) ;;; Group 16: XEP-0249 direct MUC invitations (ert-deftest jabber-test-muc-message-p-direct-invite () "XEP-0249 direct invite stanza is detected as a MUC message." (let ((jabber-pending-groupchats (make-hash-table)) (jabber-jid-obarray (make-vector 127 0))) (let ((msg '(message ((from . "alice@example.com/home")) (x ((xmlns . "jabber:x:conference") (jid . "room@conference.example.com")))))) (should (jabber-muc-message-p msg))))) (ert-deftest jabber-test-muc-print-invite-direct () "Direct invite renders with correct group and inviter." (let ((jabber-muc--rooms (make-hash-table :test #'equal))) (with-temp-buffer (let ((msg (list :xml-data '(message ((from . "alice@example.com/home")) (x ((xmlns . "jabber:x:conference") (jid . "room@conference.example.com"))))))) (jabber-muc-print-invite msg nil :insert) (let ((text (buffer-string))) (should (string-match-p "room@conference.example.com" text)) (should (string-match-p "alice@example.com" text)) (should (string-match-p "Accept" text))))))) (ert-deftest jabber-test-muc-print-invite-direct-with-reason () "Direct invite with reason attribute displays the reason." (let ((jabber-muc--rooms (make-hash-table :test #'equal))) (with-temp-buffer (let ((msg (list :xml-data '(message ((from . "alice@example.com/home")) (x ((xmlns . "jabber:x:conference") (jid . "room@conference.example.com") (reason . "Join our discussion"))))))) (jabber-muc-print-invite msg nil :insert) (let ((text (buffer-string))) (should (string-match-p "Join our discussion" text))))))) ;;; Group 17: disco-prioritized autojoin queue (ert-deftest jabber-muc-test-autojoin-insert-sorted () "Rooms are inserted in ascending order by occupant count." (let ((jabber-muc--autojoin-queue nil)) (jabber-muc--autojoin-insert 'jc1 50 "big@muc" "nick1") (jabber-muc--autojoin-insert 'jc1 5 "small@muc" "nick2") (jabber-muc--autojoin-insert 'jc1 20 "mid@muc" "nick3") (let ((rooms (cdr (assq 'jc1 jabber-muc--autojoin-queue)))) (should (= (length rooms) 3)) ;; Sorted: 5, 20, 50 (should (= (caar rooms) 5)) (should (string= (cadar rooms) "small@muc")) (should (= (caadr rooms) 20)) (should (= (caaddr rooms) 50))))) (ert-deftest jabber-muc-test-autojoin-insert-and-next () "Inserting rooms and popping them drains in count order." (let ((jabber-muc--autojoin-queue nil) (jabber-muc--autojoin-timer nil) (joined nil)) (cl-letf (((symbol-function 'jabber-muc--send-join-presence) (lambda (_jc group nick _pw _popup) (push (cons group nick) joined))) ((symbol-function 'jabber-get-conference-data) (lambda (&rest _) nil))) (jabber-muc--autojoin-insert 'jc1 100 "big@muc" "nick1") (jabber-muc--autojoin-insert 'jc1 3 "tiny@muc" "nick2") (jabber-muc--autojoin-insert 'jc1 30 "mid@muc" "nick3") ;; Pop first: smallest count (jabber-muc--autojoin-next 'jc1) (should (equal (car joined) '("tiny@muc" . "nick2"))) ;; Pop second (jabber-muc--autojoin-next 'jc1) (should (equal (car joined) '("mid@muc" . "nick3"))) ;; Pop third (last) (jabber-muc--autojoin-next 'jc1) (should (equal (car joined) '("big@muc" . "nick1"))) ;; Queue entry removed (should-not (assq 'jc1 jabber-muc--autojoin-queue)) ;; Extra pop is a no-op (let ((count (length joined))) (jabber-muc--autojoin-next 'jc1) (should (= (length joined) count)))))) (ert-deftest jabber-muc-test-autojoin-disco-callback-success () "Disco callback inserts room with occupant count." (let ((jabber-muc--autojoin-queue nil) (jabber-muc--autojoin-timer nil) (jabber-muc--autojoin-disco-count nil)) ;; Simulate disco result with 3 occupants (jabber-muc--autojoin-disco-callback 'jc1 '("room@muc" . "nick1") '(["alice" "room@muc/alice" nil] ["bob" "room@muc/bob" nil] ["carol" "room@muc/carol" nil])) ;; Room should be in queue with count 3 (should (jabber-muc--autojoin-queued-p 'jc1 "room@muc")) (let ((entry (car (cdr (assq 'jc1 jabber-muc--autojoin-queue))))) (should (= (car entry) 3))))) (ert-deftest jabber-muc-test-autojoin-disco-callback-error () "Disco error inserts room with most-positive-fixnum count." (let ((jabber-muc--autojoin-queue nil) (jabber-muc--autojoin-timer nil)) ;; First insert a small room (jabber-muc--autojoin-insert 'jc1 2 "small@muc" "nick2") ;; Then disco error arrives for another room (cl-letf (((symbol-function 'jabber-muc--send-join-presence) #'ignore) ((symbol-function 'jabber-get-conference-data) (lambda (&rest _) nil))) (jabber-muc--autojoin-disco-callback 'jc1 '("broken@muc" . "nick1") '(error ((type . "cancel"))))) ;; Error room should be last (count = most-positive-fixnum) (let ((rooms (cdr (assq 'jc1 jabber-muc--autojoin-queue)))) ;; After drain started, small@muc was popped, so only broken@muc remains ;; (or both if drain didn't fire because timer was set) (when rooms (should (= (caar (last rooms)) most-positive-fixnum)))))) (ert-deftest jabber-muc-test-autojoin-dequeue () "Dequeue removes a specific room from the queue." (let ((jabber-muc--autojoin-queue nil)) (jabber-muc--autojoin-insert 'jc1 5 "r1@muc" "n1") (jabber-muc--autojoin-insert 'jc1 10 "r2@muc" "n2") (jabber-muc--autojoin-insert 'jc1 15 "r3@muc" "n3") (jabber-muc--autojoin-dequeue 'jc1 "r2@muc") (let ((rooms (cdr (assq 'jc1 jabber-muc--autojoin-queue)))) (should (= (length rooms) 2)) (should-not (cl-find "r2@muc" rooms :key #'cadr :test #'string=))))) (ert-deftest jabber-muc-test-autojoin-dequeue-last-cleans-entry () "Dequeuing the last room removes the connection entry entirely." (let ((jabber-muc--autojoin-queue nil)) (jabber-muc--autojoin-insert 'jc1 5 "r1@muc" "n1") (jabber-muc--autojoin-dequeue 'jc1 "r1@muc") (should-not (assq 'jc1 jabber-muc--autojoin-queue)))) (ert-deftest jabber-muc-test-autojoin-clear () "Clearing the queue removes all entries for a connection." (let ((jabber-muc--autojoin-queue nil) (jabber-muc--autojoin-timer nil)) (jabber-muc--autojoin-insert 'jc1 5 "r1@muc" "n1") (jabber-muc--autojoin-insert 'jc2 5 "r2@muc" "n2") (jabber-muc--autojoin-clear 'jc1) (should-not (assq 'jc1 jabber-muc--autojoin-queue)) ;; Other connection unaffected (should (assq 'jc2 jabber-muc--autojoin-queue)))) (ert-deftest jabber-muc-test-autojoin-queued-p () "Check if a room is already in the autojoin queue." (let ((jabber-muc--autojoin-queue nil)) (jabber-muc--autojoin-insert 'jc1 5 "r1@muc" "n1") (should (jabber-muc--autojoin-queued-p 'jc1 "r1@muc")) (should-not (jabber-muc--autojoin-queued-p 'jc1 "r2@muc")) (should-not (jabber-muc--autojoin-queued-p 'jc2 "r1@muc")))) (ert-deftest jabber-muc-test-autojoin-next-empty-is-noop () "Calling next with no queue entries does nothing." (let ((jabber-muc--autojoin-queue nil) (jabber-muc--autojoin-timer nil) (joined nil)) (cl-letf (((symbol-function 'jabber-muc--send-join-presence) (lambda (&rest _) (push t joined)))) (jabber-muc--autojoin-next 'jc1) (should (null joined))))) (ert-deftest jabber-muc-test-autojoin-disco-no-drain-while-inflight () "Disco callback does not start drain when a join is in-flight." (let ((jabber-muc--autojoin-queue nil) (jabber-muc--autojoin-timer 'fake-timer) (next-called nil)) (cl-letf (((symbol-function 'jabber-muc--autojoin-next) (lambda (_jc) (setq next-called t)))) (jabber-muc--autojoin-disco-callback 'jc1 '("room@muc" . "nick1") '(["alice" "room@muc/alice" nil])) ;; Should NOT have called next because timer was set (join in-flight) (should-not next-called) ;; But the room should be in the queue (should (jabber-muc--autojoin-queued-p 'jc1 "room@muc"))))) (ert-deftest jabber-muc-test-process-enter-schedules-next () "Self-presence in process-enter schedules autojoin-next via timer." (let* ((jabber-muc--autojoin-queue nil) (jabber-muc--autojoin-timer nil) (jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--generation 0) (jabber-pending-groupchats (make-hash-table)) (jabber-jid-obarray (make-vector 127 0)) (timer-scheduled nil)) (cl-letf (((symbol-function 'run-with-timer) (lambda (_secs _repeat fn &rest _args) (when (eq fn #'jabber-muc--autojoin-next) (setq timer-scheduled t)) 'fake-timer)) ((symbol-function 'jabber-mam-muc-joined) #'ignore) ((symbol-function 'jabber-bookmarks-auto-add-maybe) #'ignore) ((symbol-function 'jabber-muc-participant-plist) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-modify-participant) #'ignore) ((symbol-function 'jabber-muc-report-delta) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-find-buffer) (lambda (_) nil))) (jabber-muc--process-enter 'fake-jc "room@muc" "me" (jabber-jid-symbol "room@muc/me") (list jabber-muc-status-self-presence) '(x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((affiliation . "member") (role . "participant")))) nil nil "me")) (should timer-scheduled))) (provide 'jabber-muc-tests) ;;; jabber-muc-tests.el ends here emacs-jabber/tests/jabber-omemo-message-tests.el000066400000000000000000000735231516610113500222070ustar00rootroot00000000000000;;; jabber-omemo-message-tests.el --- ERT tests for OMEMO message encrypt/decrypt -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-chat) (require 'jabber-omemo) ;;; Test infrastructure (defmacro jabber-omemo-message-test-with-db (&rest body) "Run BODY with a fresh temp SQLite database. Clears OMEMO in-memory caches and tears down on exit." (declare (indent 0) (debug t)) `(let* ((jabber-omemo-message-test--dir (make-temp-file "jabber-omemo-msg-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-omemo-message-test--dir)) (jabber-db--connection nil) (jabber-omemo--device-ids (make-hash-table :test 'equal)) (jabber-omemo--stores (make-hash-table :test 'equal)) (jabber-omemo--device-lists (make-hash-table :test 'equal)) (jabber-omemo--sessions (make-hash-table :test 'equal))) (unwind-protect (progn (jabber-db-ensure-open) ,@body) (jabber-db-close) (when (file-directory-p jabber-omemo-message-test--dir) (delete-directory jabber-omemo-message-test--dir t))))) ;;; Group 1: Fallback body (ert-deftest jabber-omemo-message-test-fallback-body () "Fallback body constant is a non-empty string." (should (stringp jabber-omemo-fallback-body)) (should (> (length jabber-omemo-fallback-body) 0))) ;;; Group 2: Parse encrypted XML (ert-deftest jabber-omemo-message-test-parse-encrypted-basic () "parse-encrypted extracts sid, iv, payload, and keys from XML." (let* ((xml-data `(message ((from . "alice@example.com/phone") (to . "bob@example.com/laptop") (type . "chat")) (body () "fallback text") (encrypted ((xmlns . "eu.siacs.conversations.axolotl")) (header ((sid . "12345")) (key ((rid . "67890") (prekey . "true")) ,(base64-encode-string "encrypted-key-data" t)) (key ((rid . "11111")) ,(base64-encode-string "other-key-data" t)) (iv () ,(base64-encode-string (make-string 12 ?x) t))) (payload () ,(base64-encode-string "ciphertext-data" t))))) (parsed (jabber-omemo--parse-encrypted xml-data))) (should parsed) (should (= 12345 (plist-get parsed :sid))) (should (= 12 (length (plist-get parsed :iv)))) (should (string= "ciphertext-data" (plist-get parsed :payload))) (let ((keys (plist-get parsed :keys))) (should (= 2 (length keys))) (should (= 67890 (car (nth 0 keys)))) (should (plist-get (cdr (nth 0 keys)) :pre-key-p)) (should (string= "encrypted-key-data" (plist-get (cdr (nth 0 keys)) :data))) (should (= 11111 (car (nth 1 keys)))) (should-not (plist-get (cdr (nth 1 keys)) :pre-key-p))))) (ert-deftest jabber-omemo-message-test-parse-encrypted-no-element () "parse-encrypted returns nil when no element." (let ((xml-data '(message ((from . "alice@example.com") (type . "chat")) (body () "hello")))) (should-not (jabber-omemo--parse-encrypted xml-data)))) (ert-deftest jabber-omemo-message-test-parse-encrypted-no-payload () "parse-encrypted handles heartbeat messages (no payload)." (let* ((xml-data `(message ((from . "alice@example.com/phone") (type . "chat")) (encrypted ((xmlns . "eu.siacs.conversations.axolotl")) (header ((sid . "999")) (key ((rid . "888")) ,(base64-encode-string "key-data" t)) (iv () ,(base64-encode-string (make-string 12 0) t)))))) (parsed (jabber-omemo--parse-encrypted xml-data))) (should parsed) (should (= 999 (plist-get parsed :sid))) (should-not (plist-get parsed :payload)) (should (= 1 (length (plist-get parsed :keys)))))) ;;; Group 3: Build encrypted XML (ert-deftest jabber-omemo-message-test-build-encrypted-structure () "build-encrypted-xml produces correct sexp structure." (jabber-omemo-message-test-with-db (let* ((store-blob-a (jabber-omemo-setup-store)) (store-ptr-a (jabber-omemo-deserialize-store store-blob-a)) (store-blob-b (jabber-omemo-setup-store)) (store-ptr-b (jabber-omemo-deserialize-store store-blob-b)) (account "alice@example.com") (peer "bob@example.com") (our-did 42) (peer-did 99)) ;; Set up account state (puthash account store-ptr-a jabber-omemo--stores) (puthash account our-did jabber-omemo--device-ids) ;; Get bundle from B and establish session A->B (let* ((bundle-b (jabber-omemo-get-bundle store-ptr-b)) (pre-keys (plist-get bundle-b :pre-keys)) (pk (car pre-keys)) (session-ptr (jabber-omemo-initiate-session store-ptr-a (plist-get bundle-b :signature) (plist-get bundle-b :signed-pre-key) (plist-get bundle-b :identity-key) (cdr pk) (plist-get bundle-b :signed-pre-key-id) (car pk)))) (jabber-omemo-store-save-session account peer peer-did (jabber-omemo-serialize-session session-ptr)) (puthash (jabber-omemo--session-key account peer peer-did) session-ptr jabber-omemo--sessions) ;; Build the encrypted XML using a mock jc (let* ((jc (list :mock-jc)) (enc-result (jabber-omemo-encrypt-message (encode-coding-string "Hello" 'utf-8)))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) account))) (let ((xml (jabber-omemo--build-encrypted-xml jc (list (cons peer-did session-ptr)) enc-result))) ;; Verify structure (should (eq 'encrypted (car xml))) (should (string= "eu.siacs.conversations.axolotl" (cdr (assq 'xmlns (cadr xml))))) (let ((header (car (jabber-xml-get-children xml 'header)))) (should header) (should (string= "42" (jabber-xml-get-attribute header 'sid))) ;; Should have one key element and an iv (should (jabber-xml-get-children header 'key)) (should (jabber-xml-get-children header 'iv))) ;; Should have a payload (should (jabber-xml-get-children xml 'payload))))))))) ;;; Group 4: detect-encrypted (ert-deftest jabber-omemo-message-test-detect-encrypted-returns-parsed () "detect-encrypted returns (:type omemo :parsed ...) for OMEMO stanza." (let* ((xml-data `(message ((from . "alice@example.com/phone") (type . "chat")) (body () "fallback") (encrypted ((xmlns . "eu.siacs.conversations.axolotl")) (header ((sid . "12345")) (key ((rid . "67890") (prekey . "true")) ,(base64-encode-string "key-data" t)) (iv () ,(base64-encode-string (make-string 12 ?x) t))) (payload () ,(base64-encode-string "ciphertext" t))))) (result (jabber-omemo--detect-encrypted xml-data))) (should result) (should (eq 'omemo (plist-get result :type))) (should (plist-get result :parsed)) (should (= 12345 (plist-get (plist-get result :parsed) :sid))))) (ert-deftest jabber-omemo-message-test-detect-encrypted-returns-nil-for-plain () "detect-encrypted returns nil for plain stanza." (let ((xml-data '(message ((from . "alice@example.com") (type . "chat")) (body () "hello plain")))) (should-not (jabber-omemo--detect-encrypted xml-data)))) (ert-deftest jabber-omemo-message-test-detect-encrypted-muc-echo () "detect-encrypted returns muc-echo plist and consumes cache." (let ((jabber-omemo--sent-muc-plaintexts (make-hash-table :test #'equal))) (puthash "msg-001" "secret text" jabber-omemo--sent-muc-plaintexts) (let* ((xml-data '(message ((from . "room@conf.example.com/me") (id . "msg-001") (type . "groupchat")) (body () "fallback"))) (result (jabber-omemo--detect-encrypted xml-data))) (should result) (should (eq 'muc-echo (plist-get result :type))) (should (string= "secret text" (plist-get result :cached))) ;; Cache entry consumed (should-not (gethash "msg-001" jabber-omemo--sent-muc-plaintexts))))) ;;; Group 5: Trust label formatting (ert-deftest jabber-omemo-message-test-trust-labels () "Trust labels map correctly." (should (string= "undecided" (jabber-omemo--trust-label 0))) (should (string= "TOFU" (jabber-omemo--trust-label 1))) (should (string= "verified" (jabber-omemo--trust-label 2))) (should (string= "UNTRUSTED" (jabber-omemo--trust-label -1)))) ;;; Group 6: Fingerprint formatting (ert-deftest jabber-omemo-message-test-format-fingerprint () "format-fingerprint produces space-separated hex." (let ((key (unibyte-string #xDE #xAD #xBE #xEF))) (should (string= "DE AD BE EF" (jabber-omemo--format-fingerprint key))))) ;;; Group 7: Full encrypt/decrypt round-trip (ert-deftest jabber-omemo-message-test-encrypt-decrypt-roundtrip () "Encrypt and decrypt a message round-trips the plaintext." (jabber-omemo-message-test-with-db (let* ((store-blob-a (jabber-omemo-setup-store)) (store-ptr-a (jabber-omemo-deserialize-store store-blob-a)) (store-blob-b (jabber-omemo-setup-store)) (store-ptr-b (jabber-omemo-deserialize-store store-blob-b)) (plaintext "Hello, OMEMO world!") (plaintext-bytes (encode-coding-string plaintext 'utf-8))) ;; A initiates session with B's bundle (let* ((bundle-b (jabber-omemo-get-bundle store-ptr-b)) (pre-keys (plist-get bundle-b :pre-keys)) (pk (car pre-keys)) (session-a->b (jabber-omemo-initiate-session store-ptr-a (plist-get bundle-b :signature) (plist-get bundle-b :signed-pre-key) (plist-get bundle-b :identity-key) (cdr pk) (plist-get bundle-b :signed-pre-key-id) (car pk)))) ;; A encrypts message (let* ((enc-result (jabber-omemo-encrypt-message plaintext-bytes)) (msg-key (plist-get enc-result :key)) (iv (plist-get enc-result :iv)) (ciphertext (plist-get enc-result :ciphertext)) ;; A encrypts the key for B (encrypted-key (jabber-omemo-encrypt-key session-a->b msg-key)) (key-data (plist-get encrypted-key :data)) (pre-key-p (plist-get encrypted-key :pre-key-p))) ;; B decrypts the key (let* ((session-b (jabber-omemo-make-session)) (decrypted-key (jabber-omemo-decrypt-key session-b store-ptr-b pre-key-p key-data)) ;; B decrypts the message (decrypted-bytes (jabber-omemo-decrypt-message decrypted-key iv ciphertext)) (decrypted-text (decode-coding-string decrypted-bytes 'utf-8))) (should (string= plaintext decrypted-text)))))))) ;;; Group 8: aesgcm URL construction (ert-deftest jabber-omemo-message-test-build-aesgcm-url () "Build aesgcm:// URL from HTTPS URL, IV, and key." (let* ((iv (decode-hex-string "8c3d050e9386ec173861778f")) (key (decode-hex-string "68e9af38a97aaf82faa4063b4d0878a61261534410c8a84331eaac851759f587")) (url (jabber-omemo--build-aesgcm-url "https://download.example.org/file.jpg" iv key))) (should (string= url "aesgcm://download.example.org/file.jpg#8c3d050e9386ec173861778f68e9af38a97aaf82faa4063b4d0878a61261534410c8a84331eaac851759f587")))) (ert-deftest jabber-omemo-message-test-aesgcm-url-round-trip () "Build URL then parse it back, recovering same IV and key." (let* ((enc (jabber-omemo-aesgcm-encrypt (make-string 100 ?x))) (iv (plist-get enc :iv)) (key (plist-get enc :key)) (url (jabber-omemo--build-aesgcm-url "https://host/f.jpg" iv key)) (parsed (jabber-chat--parse-aesgcm-url url))) (should (string= iv (plist-get parsed :iv))) (should (string= key (plist-get parsed :key))) (should (string= "https://host/f.jpg" (plist-get parsed :https-url))))) (ert-deftest jabber-omemo-message-test-aesgcm-file-round-trip () "Encrypt file contents, build URL, parse URL, decrypt, compare." (let* ((original "This is test file content with UTF-8: café") (plaintext (encode-coding-string original 'utf-8)) (enc (jabber-omemo-aesgcm-encrypt plaintext)) (url (jabber-omemo--build-aesgcm-url "https://upload.example.org/abc/test.txt" (plist-get enc :iv) (plist-get enc :key))) (parsed (jabber-chat--parse-aesgcm-url url)) (decrypted (jabber-omemo-aesgcm-decrypt (plist-get parsed :key) (plist-get parsed :iv) (plist-get enc :ciphertext)))) (should (string= plaintext decrypted)) (should (string-prefix-p "aesgcm://" url)) (should (string= "https://upload.example.org/abc/test.txt" (plist-get parsed :https-url))))) ;;; Group 9: aesgcm upload integration (ert-deftest jabber-omemo-message-test-build-aesgcm-url-rejects-non-https () "build-aesgcm-url signals error when given a non-https URL." (let* ((iv (decode-hex-string "8c3d050e9386ec173861778f")) (key (decode-hex-string "68e9af38a97aaf82faa4063b4d0878a61261534410c8a84331eaac851759f587"))) (should-error (jabber-omemo--build-aesgcm-url "aesgcm://host/path#oldfrag" iv key) :type 'error))) (ert-deftest jabber-omemo-message-test-httpupload-transform-nil-without-omemo () "Transform returns nil when encryption is not OMEMO." (let ((jabber-chat-encryption 'plaintext)) (should-not (jabber-omemo--httpupload-transform "/tmp/test.png" #'identity)))) (ert-deftest jabber-omemo-message-test-httpupload-transform-encrypts-with-omemo () "Transform returns (filepath . callback) when OMEMO is active." (let* ((tmp (make-temp-file "omemo-test-" nil ".txt")) (jabber-chat-encryption 'omemo) result) (unwind-protect (progn (with-temp-file tmp (insert "test content")) (setq result (jabber-omemo--httpupload-transform tmp #'identity)) (should (consp result)) (should (stringp (car result))) (should (functionp (cdr result)))) (ignore-errors (delete-file tmp)) (when (and result (stringp (car result))) (ignore-errors (delete-file (car result))))))) (ert-deftest jabber-omemo-message-test-httpupload-send-url-handles-aesgcm () "Send-url override returns non-nil for aesgcm:// URLs." (cl-letf (((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc _jid callback) (funcall callback nil))) ((symbol-function 'jabber-omemo--send-encrypted) (lambda (&rest _) nil)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-jid-user) (lambda (jid) jid))) (should (jabber-omemo--httpupload-send-url 'fake-jc "alice@example.com" "aesgcm://host/file#abc123")))) (ert-deftest jabber-omemo-message-test-httpupload-send-url-skips-https () "Send-url override returns nil for https:// URLs." (should-not (jabber-omemo--httpupload-send-url 'fake-jc "alice@example.com" "https://host/file"))) ;;; Group 10: Trust filtering (ert-deftest jabber-omemo-message-test-trusted-sessions-excludes-untrusted () "trusted-sessions drops devices with trust = -1." (let ((sessions '((100 . fake-ptr-100) (200 . fake-ptr-200) (300 . fake-ptr-300)))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo--session-jid-for-did) (lambda (_jc did) (format "peer%d@example.com" did))) ((symbol-function 'jabber-omemo-store-load-trust) (lambda (_account _jid did) (pcase did (100 (list :identity-key "k1" :trust 1 :first-seen 0)) (200 (list :identity-key "k2" :trust -1 :first-seen 0)) (300 (list :identity-key "k3" :trust 2 :first-seen 0)))))) (let ((result (jabber-omemo--trusted-sessions 'fake-jc sessions))) (should (= 2 (length result))) (should (assq 100 result)) (should-not (assq 200 result)) (should (assq 300 result)))))) (ert-deftest jabber-omemo-message-test-trusted-sessions-keeps-undecided () "trusted-sessions keeps devices with trust = 0 (undecided)." (let ((sessions '((100 . fake-ptr-100)))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo--session-jid-for-did) (lambda (_jc _did) "peer@example.com")) ((symbol-function 'jabber-omemo-store-load-trust) (lambda (_account _jid _did) (list :identity-key "k" :trust 0 :first-seen 0)))) (let ((result (jabber-omemo--trusted-sessions 'fake-jc sessions))) (should (= 1 (length result))))))) (ert-deftest jabber-omemo-message-test-trusted-sessions-keeps-no-trust-record () "trusted-sessions keeps devices with no trust record." (let ((sessions '((100 . fake-ptr-100)))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo--session-jid-for-did) (lambda (_jc _did) "peer@example.com")) ((symbol-function 'jabber-omemo-store-load-trust) (lambda (_account _jid _did) nil))) (let ((result (jabber-omemo--trusted-sessions 'fake-jc sessions))) (should (= 1 (length result))))))) (ert-deftest jabber-omemo-message-test-build-encrypted-rejects-all-untrusted () "build-encrypted-xml signals error when all devices are untrusted." (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo--session-jid-for-did) (lambda (_jc _did) "peer@example.com")) ((symbol-function 'jabber-omemo-store-load-trust) (lambda (_account _jid _did) (list :identity-key "k" :trust -1 :first-seen 0)))) (should-error (jabber-omemo--build-encrypted-xml 'fake-jc '((100 . fake-ptr)) '(:key "k" :iv "i" :ciphertext "c")) :type 'user-error))) ;;; Group 12: Structured decrypt errors (ert-deftest jabber-omemo-message-test-decrypt-error-conditions () "Decrypt error subtypes inherit from `jabber-omemo-error'." (should (memq 'jabber-omemo-error (get 'jabber-omemo-not-for-us 'error-conditions))) (should (memq 'jabber-omemo-error (get 'jabber-omemo-no-session 'error-conditions))) (should (memq 'jabber-omemo-error (get 'jabber-omemo-prekey-failed 'error-conditions)))) (ert-deftest jabber-omemo-message-test-decrypt-stanza-not-for-us () "decrypt-stanza signals `jabber-omemo-not-for-us' when no key for our device." (let ((jabber-omemo--device-ids (make-hash-table :test 'equal))) (puthash "me@example.com" 42 jabber-omemo--device-ids) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (let ((xml-data '(message ((from . "alice@example.com/phone") (type . "chat")))) (parsed (list :sid 12345 :iv (make-string 12 0) :payload "ciphertext" ;; Only a key for device 999, not for us (42). :keys '((999 . (:data "k" :pre-key-p nil)))))) (should-error (jabber-omemo--decrypt-stanza 'fake-jc xml-data parsed) :type 'jabber-omemo-not-for-us))))) (ert-deftest jabber-omemo-message-test-decrypt-stanza-no-session () "decrypt-stanza signals `jabber-omemo-no-session' for non-prekey with no session." (let ((jabber-omemo--device-ids (make-hash-table :test 'equal)) (jabber-omemo--stores (make-hash-table :test 'equal)) (jabber-omemo--sessions (make-hash-table :test 'equal))) (puthash "me@example.com" 42 jabber-omemo--device-ids) ;; Non-nil store entry to skip the lazy DB load path. (puthash "me@example.com" 'fake-store-ptr jabber-omemo--stores) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo-store-load-session) (lambda (_account _jid _did) nil))) (let ((xml-data '(message ((from . "alice@example.com/phone") (type . "chat")))) (parsed (list :sid 999 :iv (make-string 12 0) :payload "ciphertext" ;; pre-key-p nil triggers session lookup. :keys '((42 . (:data "k" :pre-key-p nil)))))) (should-error (jabber-omemo--decrypt-stanza 'fake-jc xml-data parsed) :type 'jabber-omemo-no-session))))) (ert-deftest jabber-omemo-message-test-decrypt-stanza-prekey-failed () "decrypt-stanza re-signals C error as `jabber-omemo-prekey-failed' for prekey." (let ((jabber-omemo--device-ids (make-hash-table :test 'equal)) (jabber-omemo--stores (make-hash-table :test 'equal))) (puthash "me@example.com" 42 jabber-omemo--device-ids) (puthash "me@example.com" 'fake-store-ptr jabber-omemo--stores) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo-make-session) (lambda () 'fake-session-ptr)) ((symbol-function 'jabber-omemo-decrypt-key) (lambda (&rest _) (signal 'jabber-omemo-error '("simulated decrypt failure"))))) (let ((xml-data '(message ((from . "alice@example.com/phone") (type . "chat")))) (parsed (list :sid 999 :iv (make-string 12 0) :payload "ciphertext" :keys '((42 . (:data "k" :pre-key-p t)))))) (should-error (jabber-omemo--decrypt-stanza 'fake-jc xml-data parsed) :type 'jabber-omemo-prekey-failed))))) (ert-deftest jabber-omemo-message-test-decrypt-stanza-non-prekey-error-propagates () "decrypt-stanza propagates `jabber-omemo-error' verbatim for non-prekey messages." (let ((jabber-omemo--device-ids (make-hash-table :test 'equal)) (jabber-omemo--stores (make-hash-table :test 'equal)) (jabber-omemo--sessions (make-hash-table :test 'equal))) (puthash "me@example.com" 42 jabber-omemo--device-ids) (puthash "me@example.com" 'fake-store-ptr jabber-omemo--stores) (puthash (jabber-omemo--session-key "me@example.com" "alice@example.com" 999) 'fake-session-ptr jabber-omemo--sessions) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo-decrypt-key) (lambda (&rest _) (signal 'jabber-omemo-error '("simulated decrypt failure"))))) (let ((xml-data '(message ((from . "alice@example.com/phone") (type . "chat")))) (parsed (list :sid 999 :iv (make-string 12 0) :payload "ciphertext" :keys '((42 . (:data "k" :pre-key-p nil)))))) (let ((err (should-error (jabber-omemo--decrypt-stanza 'fake-jc xml-data parsed) :type 'jabber-omemo-error))) ;; Should be the parent error type, not the prekey-failed subtype. (should-not (eq (car err) 'jabber-omemo-prekey-failed))))))) ;;; Group 13: Decrypt handler error recovery (ert-deftest jabber-omemo-message-test-decrypt-handler-swallows-not-for-us () "decrypt-handler returns xml-data unchanged when stanza is not for us." (cl-letf (((symbol-function 'jabber-omemo--decrypt-stanza) (lambda (&rest _) (signal 'jabber-omemo-not-for-us '(42))))) (let* ((xml-data '(message ((from . "alice@example.com/phone") (type . "chat")) (encrypted nil))) (detected (list :type 'omemo :parsed nil)) (result (jabber-omemo--decrypt-handler 'fake-jc xml-data detected))) (should (eq result xml-data))))) (ert-deftest jabber-omemo-message-test-decrypt-handler-no-publish-on-prekey-failure () "decrypt-handler does NOT republish bundle on prekey failure (Dino-style)." (let ((publish-called nil)) (cl-letf (((symbol-function 'jabber-omemo--decrypt-stanza) (lambda (&rest _) (signal 'jabber-omemo-prekey-failed (list "alice@example.com" 999 "boom")))) ((symbol-function 'jabber-omemo--publish-bundle) (lambda (&rest _) (setq publish-called t))) ((symbol-function 'jabber-omemo--publish-bundle-if-needed) (lambda (&rest _) (setq publish-called t)))) (let ((xml-data '(message ((from . "alice@example.com/phone") (type . "chat")))) (detected (list :type 'omemo :parsed nil))) (should-error (jabber-omemo--decrypt-handler 'fake-jc xml-data detected) :type 'jabber-omemo-prekey-failed) (should-not publish-called))))) (ert-deftest jabber-omemo-message-test-decrypt-handler-propagates-other-errors () "decrypt-handler propagates non-recoverable OMEMO errors unchanged." (cl-letf (((symbol-function 'jabber-omemo--decrypt-stanza) (lambda (&rest _) (signal 'jabber-omemo-no-session '("alice@example.com" 999))))) (let ((xml-data '(message ((from . "alice@example.com/phone") (type . "chat")))) (detected (list :type 'omemo :parsed nil))) (should-error (jabber-omemo--decrypt-handler 'fake-jc xml-data detected) :type 'jabber-omemo-no-session)))) (ert-deftest jabber-omemo-message-test-decrypt-stanza-no-publish-on-prekey-success () "decrypt-stanza does NOT republish bundle on successful prekey decrypt." (jabber-omemo-message-test-with-db (let* ((store-blob-a (jabber-omemo-setup-store)) (store-ptr-a (jabber-omemo-deserialize-store store-blob-a)) (store-blob-b (jabber-omemo-setup-store)) (store-ptr-b (jabber-omemo-deserialize-store store-blob-b)) (account "bob@example.com") (peer "alice@example.com") (our-did 42) (peer-did 99) (publish-called nil)) (puthash account store-ptr-b jabber-omemo--stores) (puthash account our-did jabber-omemo--device-ids) ;; A initiates a session and encrypts a key for B, producing a ;; pre-key message that B will decrypt below. (let* ((bundle-b (jabber-omemo-get-bundle store-ptr-b)) (pre-keys (plist-get bundle-b :pre-keys)) (pk (car pre-keys)) (session-a->b (jabber-omemo-initiate-session store-ptr-a (plist-get bundle-b :signature) (plist-get bundle-b :signed-pre-key) (plist-get bundle-b :identity-key) (cdr pk) (plist-get bundle-b :signed-pre-key-id) (car pk))) (enc (jabber-omemo-encrypt-message (encode-coding-string "hi" 'utf-8))) (msg-key (plist-get enc :key)) (iv (plist-get enc :iv)) (ciphertext (plist-get enc :ciphertext)) (encrypted-key (jabber-omemo-encrypt-key session-a->b msg-key)) (key-data (plist-get encrypted-key :data)) (pre-key-p (plist-get encrypted-key :pre-key-p))) (should pre-key-p) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) account)) ((symbol-function 'jabber-omemo--publish-bundle) (lambda (&rest _) (setq publish-called t))) ((symbol-function 'jabber-omemo--publish-bundle-if-needed) (lambda (&rest _) (setq publish-called t)))) (let ((xml-data `(message ((from . ,(concat peer "/phone")) (type . "chat")))) (parsed (list :sid 12345 :iv iv :payload ciphertext :keys (list (cons our-did (list :data key-data :pre-key-p t)))))) (jabber-omemo--decrypt-stanza 'fake-jc xml-data parsed) (should-not publish-called))))))) (provide 'jabber-omemo-message-tests) ;;; jabber-omemo-message-tests.el ends here emacs-jabber/tests/jabber-omemo-module-tests.el000066400000000000000000000451621516610113500220460ustar00rootroot00000000000000;;; jabber-omemo-module-tests.el --- ERT tests for OMEMO dynamic module -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-omemo-core) ;;; Group 1: Module loading (ert-deftest jabber-omemo-module-test-provides-feature () "The module provides the `jabber-omemo-core' feature." (should (featurep 'jabber-omemo-core))) (ert-deftest jabber-omemo-module-test-functions-bound () "All internal functions are bound after loading." (should (fboundp 'jabber-omemo--setup-store)) (should (fboundp 'jabber-omemo--deserialize-store)) (should (fboundp 'jabber-omemo--serialize-store)) (should (fboundp 'jabber-omemo--get-bundle)) (should (fboundp 'jabber-omemo--rotate-signed-pre-key)) (should (fboundp 'jabber-omemo--refill-pre-keys)) (should (fboundp 'jabber-omemo--encrypt-message)) (should (fboundp 'jabber-omemo--decrypt-message)) (should (fboundp 'jabber-omemo--make-session)) (should (fboundp 'jabber-omemo--initiate-session)) (should (fboundp 'jabber-omemo--serialize-session)) (should (fboundp 'jabber-omemo--deserialize-session)) (should (fboundp 'jabber-omemo--encrypt-key)) (should (fboundp 'jabber-omemo--decrypt-key)) (should (fboundp 'jabber-omemo--heartbeat)) (should (fboundp 'jabber-omemo--aesgcm-decrypt)) (should (fboundp 'jabber-omemo--aesgcm-encrypt))) ;;; Group 2: Store lifecycle (ert-deftest jabber-omemo-module-test-setup-store-returns-unibyte () "setup-store returns a non-empty unibyte string." (let ((blob (jabber-omemo--setup-store))) (should (stringp blob)) (should (not (multibyte-string-p blob))) (should (> (length blob) 0)))) (ert-deftest jabber-omemo-module-test-deserialize-store-returns-user-ptr () "deserialize-store returns a user-ptr." (let* ((blob (jabber-omemo--setup-store)) (ptr (jabber-omemo--deserialize-store blob))) (should (user-ptrp ptr)))) (ert-deftest jabber-omemo-module-test-store-round-trip () "Serializing a deserialized store produces the same blob." (let* ((blob1 (jabber-omemo--setup-store)) (ptr (jabber-omemo--deserialize-store blob1)) (blob2 (jabber-omemo--serialize-store ptr))) (should (string= blob1 blob2)))) ;;; Group 3: Bundle extraction (ert-deftest jabber-omemo-module-test-get-bundle-plist-keys () "get-bundle returns a plist with expected keys." (let* ((blob (jabber-omemo--setup-store)) (ptr (jabber-omemo--deserialize-store blob)) (bundle (jabber-omemo--get-bundle ptr))) (should (plist-get bundle :identity-key)) (should (plist-get bundle :signed-pre-key)) (should (plist-get bundle :signed-pre-key-id)) (should (plist-get bundle :signature)) (should (plist-get bundle :pre-keys)))) (ert-deftest jabber-omemo-module-test-identity-key-length () "Identity key is 33 bytes (0x05 prefix + 32-byte key)." (let* ((blob (jabber-omemo--setup-store)) (ptr (jabber-omemo--deserialize-store blob)) (bundle (jabber-omemo--get-bundle ptr)) (ik (plist-get bundle :identity-key))) (should (= (length ik) 33)) (should (= (aref ik 0) #x05)))) (ert-deftest jabber-omemo-module-test-signed-pre-key-length () "Signed pre-key is 33 bytes." (let* ((blob (jabber-omemo--setup-store)) (ptr (jabber-omemo--deserialize-store blob)) (bundle (jabber-omemo--get-bundle ptr)) (spk (plist-get bundle :signed-pre-key))) (should (= (length spk) 33)))) (ert-deftest jabber-omemo-module-test-signature-length () "Signature is 64 bytes." (let* ((blob (jabber-omemo--setup-store)) (ptr (jabber-omemo--deserialize-store blob)) (bundle (jabber-omemo--get-bundle ptr)) (sig (plist-get bundle :signature))) (should (= (length sig) 64)))) (ert-deftest jabber-omemo-module-test-pre-keys-count () "Pre-keys list has 100 entries." (let* ((blob (jabber-omemo--setup-store)) (ptr (jabber-omemo--deserialize-store blob)) (bundle (jabber-omemo--get-bundle ptr)) (pks (plist-get bundle :pre-keys))) (should (= (length pks) 100)))) (ert-deftest jabber-omemo-module-test-pre-key-format () "Each pre-key is (id . key) with integer id and 33-byte key." (let* ((blob (jabber-omemo--setup-store)) (ptr (jabber-omemo--deserialize-store blob)) (bundle (jabber-omemo--get-bundle ptr)) (pks (plist-get bundle :pre-keys)) (first-pk (car pks))) (should (consp first-pk)) (should (integerp (car first-pk))) (should (= (length (cdr first-pk)) 33)))) ;;; Group 4: Key rotation (ert-deftest jabber-omemo-module-test-rotate-changes-spk-id () "Rotating the signed pre-key changes its ID." (let* ((blob (jabber-omemo--setup-store)) (ptr (jabber-omemo--deserialize-store blob)) (id-before (plist-get (jabber-omemo--get-bundle ptr) :signed-pre-key-id))) (jabber-omemo--rotate-signed-pre-key ptr) (let ((id-after (plist-get (jabber-omemo--get-bundle ptr) :signed-pre-key-id))) (should-not (= id-before id-after))))) (ert-deftest jabber-omemo-module-test-refill-pre-keys () "refill-pre-keys does not error on a fresh store." (let* ((blob (jabber-omemo--setup-store)) (ptr (jabber-omemo--deserialize-store blob))) (jabber-omemo--refill-pre-keys ptr) (should t))) ;;; Group 5: Message encrypt/decrypt (ert-deftest jabber-omemo-module-test-encrypt-returns-plist () "encrypt-message returns plist with :key, :iv, :ciphertext." (let ((result (jabber-omemo--encrypt-message (encode-coding-string "hello" 'utf-8)))) (should (plist-get result :key)) (should (plist-get result :iv)) (should (plist-get result :ciphertext)))) (ert-deftest jabber-omemo-module-test-encrypt-key-length () "Encryption key is 32 bytes (16 AES + 16 auth tag)." (let* ((result (jabber-omemo--encrypt-message (encode-coding-string "test" 'utf-8))) (key (plist-get result :key))) (should (= (length key) 32)))) (ert-deftest jabber-omemo-module-test-encrypt-iv-length () "IV is 12 bytes." (let* ((result (jabber-omemo--encrypt-message (encode-coding-string "test" 'utf-8))) (iv (plist-get result :iv))) (should (= (length iv) 12)))) (ert-deftest jabber-omemo-module-test-decrypt-recovers-plaintext () "Decrypting an encrypted message recovers the original." (let* ((msg (encode-coding-string "Hello there!" 'utf-8)) (enc (jabber-omemo--encrypt-message msg)) (dec (jabber-omemo--decrypt-message (plist-get enc :key) (plist-get enc :iv) (plist-get enc :ciphertext)))) (should (string= msg dec)))) (ert-deftest jabber-omemo-module-test-encrypt-decrypt-round-trip-utf8 () "Round-trip works with UTF-8 content." (let* ((msg (encode-coding-string "Hallo Welt! \u00e4\u00f6\u00fc" 'utf-8)) (enc (jabber-omemo--encrypt-message msg)) (dec (jabber-omemo--decrypt-message (plist-get enc :key) (plist-get enc :iv) (plist-get enc :ciphertext)))) (should (string= msg dec)))) (ert-deftest jabber-omemo-module-test-decrypt-wrong-key-signals-error () "Decrypting with a wrong key signals jabber-omemo-error." (let* ((msg (encode-coding-string "secret" 'utf-8)) (enc (jabber-omemo--encrypt-message msg)) (bad-key (make-string 32 ?x))) (should-error (jabber-omemo--decrypt-message bad-key (plist-get enc :iv) (plist-get enc :ciphertext)) :type 'jabber-omemo-error))) ;;; Group 6: Session lifecycle (ert-deftest jabber-omemo-module-test-initiate-session-returns-user-ptr () "initiate-session returns a user-ptr." (let* ((alice-blob (jabber-omemo--setup-store)) (alice (jabber-omemo--deserialize-store alice-blob)) (bob-blob (jabber-omemo--setup-store)) (bob (jabber-omemo--deserialize-store bob-blob)) (bundle (jabber-omemo--get-bundle bob)) (pk (car (plist-get bundle :pre-keys))) (session (jabber-omemo--initiate-session alice (plist-get bundle :signature) (plist-get bundle :signed-pre-key) (plist-get bundle :identity-key) (cdr pk) (plist-get bundle :signed-pre-key-id) (car pk)))) (should (user-ptrp session)))) (ert-deftest jabber-omemo-module-test-serialize-session-returns-unibyte () "serialize-session returns a non-empty unibyte string." (let* ((alice-blob (jabber-omemo--setup-store)) (alice (jabber-omemo--deserialize-store alice-blob)) (bob-blob (jabber-omemo--setup-store)) (bob (jabber-omemo--deserialize-store bob-blob)) (bundle (jabber-omemo--get-bundle bob)) (pk (car (plist-get bundle :pre-keys))) (session (jabber-omemo--initiate-session alice (plist-get bundle :signature) (plist-get bundle :signed-pre-key) (plist-get bundle :identity-key) (cdr pk) (plist-get bundle :signed-pre-key-id) (car pk))) (blob (jabber-omemo--serialize-session session))) (should (stringp blob)) (should (not (multibyte-string-p blob))) (should (> (length blob) 0)))) (ert-deftest jabber-omemo-module-test-session-round-trip () "Serializing a deserialized session preserves the data." (let* ((alice-blob (jabber-omemo--setup-store)) (alice (jabber-omemo--deserialize-store alice-blob)) (bob-blob (jabber-omemo--setup-store)) (bob (jabber-omemo--deserialize-store bob-blob)) (bundle (jabber-omemo--get-bundle bob)) (pk (car (plist-get bundle :pre-keys))) (session (jabber-omemo--initiate-session alice (plist-get bundle :signature) (plist-get bundle :signed-pre-key) (plist-get bundle :identity-key) (cdr pk) (plist-get bundle :signed-pre-key-id) (car pk))) (blob1 (jabber-omemo--serialize-session session)) (session2 (jabber-omemo--deserialize-session blob1)) (blob2 (jabber-omemo--serialize-session session2))) (should (user-ptrp session2)) (should (string= blob1 blob2)))) (ert-deftest jabber-omemo-module-test-initiate-session-bad-signature () "initiate-session with a bad signature signals an error." (let* ((alice-blob (jabber-omemo--setup-store)) (alice (jabber-omemo--deserialize-store alice-blob)) (bob-blob (jabber-omemo--setup-store)) (bob (jabber-omemo--deserialize-store bob-blob)) (bundle (jabber-omemo--get-bundle bob)) (pk (car (plist-get bundle :pre-keys))) (bad-sig (make-string 64 0))) (should-error (jabber-omemo--initiate-session alice bad-sig (plist-get bundle :signed-pre-key) (plist-get bundle :identity-key) (cdr pk) (plist-get bundle :signed-pre-key-id) (car pk)) :type 'jabber-omemo-error))) ;;; Group 7: Key encrypt/decrypt round-trip (ert-deftest jabber-omemo-module-test-encrypt-key-returns-plist () "encrypt-key returns a plist with :data and :pre-key-p." (let* ((alice-blob (jabber-omemo--setup-store)) (alice (jabber-omemo--deserialize-store alice-blob)) (bob-blob (jabber-omemo--setup-store)) (bob (jabber-omemo--deserialize-store bob-blob)) (bundle (jabber-omemo--get-bundle bob)) (pk (car (plist-get bundle :pre-keys))) (session (jabber-omemo--initiate-session alice (plist-get bundle :signature) (plist-get bundle :signed-pre-key) (plist-get bundle :identity-key) (cdr pk) (plist-get bundle :signed-pre-key-id) (car pk))) (test-key (make-string 32 ?A)) (result (jabber-omemo--encrypt-key session test-key))) (should (plist-get result :data)) (should (plist-member result :pre-key-p)))) (ert-deftest jabber-omemo-module-test-first-message-is-pre-key () "First encrypted key message has :pre-key-p = t." (let* ((alice-blob (jabber-omemo--setup-store)) (alice (jabber-omemo--deserialize-store alice-blob)) (bob-blob (jabber-omemo--setup-store)) (bob (jabber-omemo--deserialize-store bob-blob)) (bundle (jabber-omemo--get-bundle bob)) (pk (car (plist-get bundle :pre-keys))) (session (jabber-omemo--initiate-session alice (plist-get bundle :signature) (plist-get bundle :signed-pre-key) (plist-get bundle :identity-key) (cdr pk) (plist-get bundle :signed-pre-key-id) (car pk))) (test-key (make-string 32 ?B)) (result (jabber-omemo--encrypt-key session test-key))) (should (eq t (plist-get result :pre-key-p))))) (ert-deftest jabber-omemo-module-test-key-encrypt-decrypt-round-trip () "Full Alice/Bob key encrypt/decrypt round-trip." (let* ((alice-blob (jabber-omemo--setup-store)) (alice (jabber-omemo--deserialize-store alice-blob)) (bob-blob (jabber-omemo--setup-store)) (bob (jabber-omemo--deserialize-store bob-blob)) (bundle (jabber-omemo--get-bundle bob)) (pk (car (plist-get bundle :pre-keys))) ;; Alice initiates session with Bob's bundle (alice-session (jabber-omemo--initiate-session alice (plist-get bundle :signature) (plist-get bundle :signed-pre-key) (plist-get bundle :identity-key) (cdr pk) (plist-get bundle :signed-pre-key-id) (car pk))) ;; Alice encrypts a 32-byte key (original-key (make-string 32 ?K)) (encrypted (jabber-omemo--encrypt-key alice-session original-key)) (enc-data (plist-get encrypted :data)) (is-prekey (plist-get encrypted :pre-key-p)) ;; Bob decrypts with a fresh (empty) session (bob-session (jabber-omemo--make-session)) (decrypted (jabber-omemo--decrypt-key bob-session bob is-prekey enc-data))) (should (string= original-key decrypted)))) (ert-deftest jabber-omemo-module-test-consecutive-messages-are-pre-key () "Consecutive messages from initiator stay pre-key until reply." (let* ((alice-blob (jabber-omemo--setup-store)) (alice (jabber-omemo--deserialize-store alice-blob)) (bob-blob (jabber-omemo--setup-store)) (bob (jabber-omemo--deserialize-store bob-blob)) (bundle (jabber-omemo--get-bundle bob)) (pk (car (plist-get bundle :pre-keys))) (alice-session (jabber-omemo--initiate-session alice (plist-get bundle :signature) (plist-get bundle :signed-pre-key) (plist-get bundle :identity-key) (cdr pk) (plist-get bundle :signed-pre-key-id) (car pk))) (key1 (make-string 32 ?A)) (enc1 (jabber-omemo--encrypt-key alice-session key1)) (key2 (make-string 32 ?B)) (enc2 (jabber-omemo--encrypt-key alice-session key2))) ;; Both messages are pre-key since Bob hasn't replied yet (should (eq t (plist-get enc1 :pre-key-p))) (should (eq t (plist-get enc2 :pre-key-p))))) ;;; Group 8: Heartbeat (ert-deftest jabber-omemo-module-test-heartbeat-nil-on-fresh-session () "heartbeat returns nil on a fresh session." (let* ((alice-blob (jabber-omemo--setup-store)) (alice (jabber-omemo--deserialize-store alice-blob)) (bob-blob (jabber-omemo--setup-store)) (bob (jabber-omemo--deserialize-store bob-blob)) (bundle (jabber-omemo--get-bundle bob)) (pk (car (plist-get bundle :pre-keys))) (session (jabber-omemo--initiate-session alice (plist-get bundle :signature) (plist-get bundle :signed-pre-key) (plist-get bundle :identity-key) (cdr pk) (plist-get bundle :signed-pre-key-id) (car pk)))) (should-not (jabber-omemo--heartbeat session alice)))) ;;; Group 9: aesgcm encrypt/decrypt (XEP-0454) (ert-deftest jabber-omemo-module-test-aesgcm-encrypt-returns-plist () "aesgcm-encrypt returns a plist with :key, :iv, :ciphertext." (let ((result (jabber-omemo--aesgcm-encrypt "hello"))) (should (plist-get result :key)) (should (plist-get result :iv)) (should (plist-get result :ciphertext)))) (ert-deftest jabber-omemo-module-test-aesgcm-encrypt-key-length () "aesgcm-encrypt returns a 32-byte key." (let ((result (jabber-omemo--aesgcm-encrypt "test"))) (should (= 32 (length (plist-get result :key)))))) (ert-deftest jabber-omemo-module-test-aesgcm-encrypt-iv-length () "aesgcm-encrypt returns a 12-byte IV." (let ((result (jabber-omemo--aesgcm-encrypt "test"))) (should (= 12 (length (plist-get result :iv)))))) (ert-deftest jabber-omemo-module-test-aesgcm-encrypt-ciphertext-length () "Ciphertext is plaintext length + 16 bytes for GCM tag." (let* ((plaintext "hello world") (result (jabber-omemo--aesgcm-encrypt plaintext))) (should (= (+ (length plaintext) 16) (length (plist-get result :ciphertext)))))) (ert-deftest jabber-omemo-module-test-aesgcm-encrypt-decrypt-round-trip () "Encrypting then decrypting recovers the original plaintext." (let* ((plaintext "The quick brown fox jumps over the lazy dog") (enc (jabber-omemo--aesgcm-encrypt plaintext)) (dec (jabber-omemo--aesgcm-decrypt (plist-get enc :key) (plist-get enc :iv) (plist-get enc :ciphertext)))) (should (string= plaintext dec)))) (ert-deftest jabber-omemo-module-test-aesgcm-encrypt-binary-round-trip () "Encrypt/decrypt round-trip works for binary data." (let* ((plaintext (make-string 256 0)) (_ (dotimes (i 256) (aset plaintext i i))) (enc (jabber-omemo--aesgcm-encrypt plaintext)) (dec (jabber-omemo--aesgcm-decrypt (plist-get enc :key) (plist-get enc :iv) (plist-get enc :ciphertext)))) (should (string= plaintext dec)))) (ert-deftest jabber-omemo-module-test-aesgcm-encrypt-unique-keys () "Each call generates different keys." (let ((r1 (jabber-omemo--aesgcm-encrypt "test")) (r2 (jabber-omemo--aesgcm-encrypt "test"))) (should-not (string= (plist-get r1 :key) (plist-get r2 :key))))) (provide 'jabber-omemo-module-tests) ;;; jabber-omemo-module-tests.el ends here emacs-jabber/tests/jabber-omemo-protocol-tests.el000066400000000000000000000510721516610113500224170ustar00rootroot00000000000000;;; jabber-omemo-protocol-tests.el --- ERT tests for OMEMO protocol logic -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-chat) (require 'jabber-omemo) ;;; Test infrastructure (defmacro jabber-omemo-protocol-test-with-db (&rest body) "Run BODY with a fresh temp SQLite database. Clears OMEMO in-memory caches and tears down on exit." (declare (indent 0) (debug t)) `(let* ((jabber-omemo-protocol-test--dir (make-temp-file "jabber-omemo-proto-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-omemo-protocol-test--dir)) (jabber-db--connection nil) (jabber-omemo--device-ids (make-hash-table :test 'equal)) (jabber-omemo--stores (make-hash-table :test 'equal)) (jabber-omemo--device-lists (make-hash-table :test 'equal)) (jabber-omemo--sessions (make-hash-table :test 'equal))) (unwind-protect (progn (jabber-db-ensure-open) ,@body) (jabber-db-close) (when (file-directory-p jabber-omemo-protocol-test--dir) (delete-directory jabber-omemo-protocol-test--dir t))))) ;;; Group 1: Device list XML (ert-deftest jabber-omemo-protocol-test-parse-device-list () "parse-device-list extracts device IDs from XML items." (let ((items '((item ((id . "current")) (list ((xmlns . "eu.siacs.conversations.axolotl")) (device ((id . "123"))) (device ((id . "456"))) (device ((id . "789")))))))) (should (equal '(123 456 789) (jabber-omemo--parse-device-list items))))) (ert-deftest jabber-omemo-protocol-test-parse-device-list-empty () "parse-device-list handles empty device list." (let ((items '((item ((id . "current")) (list ((xmlns . "eu.siacs.conversations.axolotl"))))))) (should (equal '() (jabber-omemo--parse-device-list items))))) (ert-deftest jabber-omemo-protocol-test-parse-device-list-no-items () "parse-device-list returns nil for no items." (should (equal '() (jabber-omemo--parse-device-list nil)))) (ert-deftest jabber-omemo-protocol-test-build-device-list-xml () "build-device-list-xml produces correct sexp." (let ((xml (jabber-omemo--build-device-list-xml '(100 200)))) (should (eq 'list (car xml))) (should (string= "eu.siacs.conversations.axolotl" (cdr (assq 'xmlns (cadr xml))))) (let ((devices (cddr xml))) (should (= 2 (length devices))) (should (string= "100" (cdr (assq 'id (cadr (nth 0 devices)))))) (should (string= "200" (cdr (assq 'id (cadr (nth 1 devices))))))))) (ert-deftest jabber-omemo-protocol-test-build-parse-device-list-roundtrip () "Building then parsing a device list round-trips the IDs." (let* ((ids '(111 222 333)) (xml (jabber-omemo--build-device-list-xml ids)) (wrapped `((item ((id . "current")) ,xml))) (parsed (jabber-omemo--parse-device-list wrapped))) (should (equal ids parsed)))) ;;; Group 2: Bundle XML (ert-deftest jabber-omemo-protocol-test-build-bundle-xml () "build-bundle-xml produces valid sexp with base64 keys." (jabber-omemo-protocol-test-with-db (let* ((blob (jabber-omemo-setup-store)) (store-ptr (jabber-omemo-deserialize-store blob)) (xml (jabber-omemo--build-bundle-xml store-ptr))) (should (eq 'bundle (car xml))) (should (string= "eu.siacs.conversations.axolotl" (cdr (assq 'xmlns (cadr xml))))) (let ((spk (car (jabber-xml-get-children xml 'signedPreKeyPublic))) (sig (car (jabber-xml-get-children xml 'signedPreKeySignature))) (ik (car (jabber-xml-get-children xml 'identityKey))) (pks (car (jabber-xml-get-children xml 'prekeys)))) (should spk) (should sig) (should ik) (should pks) (should (jabber-xml-get-attribute spk 'signedPreKeyId)) (should (> (length (jabber-xml-get-children pks 'preKeyPublic)) 0)))))) (ert-deftest jabber-omemo-protocol-test-parse-bundle-xml () "parse-bundle-xml returns correct plist keys." (jabber-omemo-protocol-test-with-db (let* ((blob (jabber-omemo-setup-store)) (store-ptr (jabber-omemo-deserialize-store blob)) (xml (jabber-omemo--build-bundle-xml store-ptr)) (parsed (jabber-omemo--parse-bundle-xml xml))) (should (plist-get parsed :signature)) (should (plist-get parsed :signed-pre-key)) (should (plist-get parsed :identity-key)) (should (integerp (plist-get parsed :signed-pre-key-id))) (should (listp (plist-get parsed :pre-keys)))))) (ert-deftest jabber-omemo-protocol-test-bundle-xml-roundtrip () "parse-bundle-xml round-trips with build-bundle-xml." (jabber-omemo-protocol-test-with-db (let* ((blob (jabber-omemo-setup-store)) (store-ptr (jabber-omemo-deserialize-store blob)) (bundle (jabber-omemo-get-bundle store-ptr)) (xml (jabber-omemo--build-bundle-xml store-ptr)) (parsed (jabber-omemo--parse-bundle-xml xml))) (should (string= (plist-get bundle :identity-key) (plist-get parsed :identity-key))) (should (string= (plist-get bundle :signed-pre-key) (plist-get parsed :signed-pre-key))) (should (string= (plist-get bundle :signature) (plist-get parsed :signature))) (should (= (plist-get bundle :signed-pre-key-id) (plist-get parsed :signed-pre-key-id))) (should (= (length (plist-get bundle :pre-keys)) (length (plist-get parsed :pre-keys))))))) (ert-deftest jabber-omemo-protocol-test-parsed-bundle-key-lengths () "Parsed bundle keys have correct byte lengths." (jabber-omemo-protocol-test-with-db (let* ((blob (jabber-omemo-setup-store)) (store-ptr (jabber-omemo-deserialize-store blob)) (xml (jabber-omemo--build-bundle-xml store-ptr)) (parsed (jabber-omemo--parse-bundle-xml xml))) (should (= 33 (length (plist-get parsed :identity-key)))) (should (= 33 (length (plist-get parsed :signed-pre-key)))) (should (= 64 (length (plist-get parsed :signature)))) (dolist (pk (plist-get parsed :pre-keys)) (should (= 33 (length (cdr pk)))))))) ;;; Group 3: Device ID persistence (ert-deftest jabber-omemo-protocol-test-device-id-roundtrip () "save and load device ID round-trips." (jabber-omemo-protocol-test-with-db (jabber-omemo-store-save-device-id "me@example.com" 42) (should (= 42 (jabber-omemo-store-load-device-id "me@example.com"))))) (ert-deftest jabber-omemo-protocol-test-device-id-unknown () "load returns nil for unknown account." (jabber-omemo-protocol-test-with-db (should (null (jabber-omemo-store-load-device-id "nobody@example.com"))))) (ert-deftest jabber-omemo-protocol-test-device-id-upsert () "save overwrites existing device ID." (jabber-omemo-protocol-test-with-db (jabber-omemo-store-save-device-id "me@example.com" 1) (jabber-omemo-store-save-device-id "me@example.com" 2) (should (= 2 (jabber-omemo-store-load-device-id "me@example.com"))))) ;;; Group 4: Store cache (ert-deftest jabber-omemo-protocol-test-get-store-creates-new () "get-store creates new store on first call." (jabber-omemo-protocol-test-with-db (let ((jc (list :bare-jid "me@example.com"))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (let ((ptr (jabber-omemo--get-store jc))) (should (user-ptrp ptr))))))) (ert-deftest jabber-omemo-protocol-test-get-store-cached () "get-store returns cached ptr on second call." (jabber-omemo-protocol-test-with-db (let ((jc (list :bare-jid "me@example.com"))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (let ((ptr1 (jabber-omemo--get-store jc)) (ptr2 (jabber-omemo--get-store jc))) (should (eq ptr1 ptr2))))))) (ert-deftest jabber-omemo-protocol-test-get-store-from-db () "get-store loads from DB on cold start." (jabber-omemo-protocol-test-with-db (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (let ((jc (list :bare-jid "me@example.com"))) (let ((ptr1 (jabber-omemo--get-store jc))) (should (user-ptrp ptr1)) ;; Clear cache to simulate cold start (clrhash jabber-omemo--stores) (let ((ptr2 (jabber-omemo--get-store jc))) (should (user-ptrp ptr2)) ;; Different ptr but loaded from same DB blob (should-not (eq ptr1 ptr2)))))))) ;;; Group 5: Session establishment (integration) (ert-deftest jabber-omemo-protocol-test-establish-session () "establish-session creates and persists a session." (jabber-omemo-protocol-test-with-db (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (let* ((jc (list :bare-jid "me@example.com")) (_store-ptr (jabber-omemo--get-store jc)) (bundle-blob (jabber-omemo-setup-store)) (remote-store (jabber-omemo-deserialize-store bundle-blob)) (bundle-xml (jabber-omemo--build-bundle-xml remote-store)) (parsed (jabber-omemo--parse-bundle-xml bundle-xml)) (session (jabber-omemo--establish-session jc "them@example.com" 999 parsed))) (should (user-ptrp session)) ;; Session should be in cache (should (eq session (jabber-omemo--get-session jc "them@example.com" 999))))))) (ert-deftest jabber-omemo-protocol-test-establish-session-trust () "establish-session stores trust record." (jabber-omemo-protocol-test-with-db (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (let* ((jc (list :bare-jid "me@example.com")) (_store-ptr (jabber-omemo--get-store jc)) (bundle-blob (jabber-omemo-setup-store)) (remote-store (jabber-omemo-deserialize-store bundle-blob)) (bundle-xml (jabber-omemo--build-bundle-xml remote-store)) (parsed (jabber-omemo--parse-bundle-xml bundle-xml))) (jabber-omemo--establish-session jc "them@example.com" 999 parsed) (let ((trust (jabber-omemo-store-load-trust "me@example.com" "them@example.com" 999))) (should trust) (should (= 0 (plist-get trust :trust)))))))) (ert-deftest jabber-omemo-protocol-test-get-session-unknown () "get-session returns nil for unknown device." (jabber-omemo-protocol-test-with-db (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (let ((jc (list :bare-jid "me@example.com"))) (should (null (jabber-omemo--get-session jc "them@example.com" 999))))))) (ert-deftest jabber-omemo-protocol-test-get-session-from-db () "get-session loads from DB when not cached." (jabber-omemo-protocol-test-with-db (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (let* ((jc (list :bare-jid "me@example.com")) (_store-ptr (jabber-omemo--get-store jc)) (bundle-blob (jabber-omemo-setup-store)) (remote-store (jabber-omemo-deserialize-store bundle-blob)) (bundle-xml (jabber-omemo--build-bundle-xml remote-store)) (parsed (jabber-omemo--parse-bundle-xml bundle-xml))) (jabber-omemo--establish-session jc "them@example.com" 999 parsed) ;; Clear session cache (clrhash jabber-omemo--sessions) (let ((loaded (jabber-omemo--get-session jc "them@example.com" 999))) (should (user-ptrp loaded))))))) ;;; Group 6: Bundle publish-if-needed (ert-deftest jabber-omemo-protocol-test-bundle-needs-republish-nil-published () "Republish required when no bundle has been published." (let ((local '(:identity-key "ik" :signed-pre-key "spk" :signed-pre-key-id 1 :pre-keys (1 2 3)))) (should (jabber-omemo--bundle-needs-republish-p local nil)))) (ert-deftest jabber-omemo-protocol-test-bundle-needs-republish-identity-key-mismatch () "Republish required when identity key differs." (let* ((pks (cl-loop for i from 1 to 100 collect (cons i "k"))) (local `(:identity-key "ik-new" :signed-pre-key "spk" :signed-pre-key-id 1 :pre-keys ,pks)) (published `(:identity-key "ik-old" :signed-pre-key "spk" :signed-pre-key-id 1 :pre-keys ,pks))) (should (jabber-omemo--bundle-needs-republish-p local published)))) (ert-deftest jabber-omemo-protocol-test-bundle-needs-republish-spk-id-mismatch () "Republish required when signed-pre-key-id differs." (let* ((pks (cl-loop for i from 1 to 100 collect (cons i "k"))) (local `(:identity-key "ik" :signed-pre-key "spk" :signed-pre-key-id 2 :pre-keys ,pks)) (published `(:identity-key "ik" :signed-pre-key "spk" :signed-pre-key-id 1 :pre-keys ,pks))) (should (jabber-omemo--bundle-needs-republish-p local published)))) (ert-deftest jabber-omemo-protocol-test-bundle-needs-republish-spk-data-mismatch () "Republish required when signed-pre-key data differs." (let* ((pks (cl-loop for i from 1 to 100 collect (cons i "k"))) (local `(:identity-key "ik" :signed-pre-key "spk-new" :signed-pre-key-id 1 :pre-keys ,pks)) (published `(:identity-key "ik" :signed-pre-key "spk-old" :signed-pre-key-id 1 :pre-keys ,pks))) (should (jabber-omemo--bundle-needs-republish-p local published)))) (ert-deftest jabber-omemo-protocol-test-bundle-needs-republish-prekey-count-low () "Republish required when published pre-key count is below threshold." (let* ((local-pks (cl-loop for i from 1 to 100 collect (cons i "k"))) (published-pks (cl-loop for i from 1 to 5 collect (cons i "k"))) (local `(:identity-key "ik" :signed-pre-key "spk" :signed-pre-key-id 1 :pre-keys ,local-pks)) (published `(:identity-key "ik" :signed-pre-key "spk" :signed-pre-key-id 1 :pre-keys ,published-pks))) (should (jabber-omemo--bundle-needs-republish-p local published)))) (ert-deftest jabber-omemo-protocol-test-bundle-needs-republish-up-to-date () "No republish when published bundle matches local and has enough pre-keys." (let* ((pks (cl-loop for i from 1 to 100 collect (cons i "k"))) (local `(:identity-key "ik" :signed-pre-key "spk" :signed-pre-key-id 1 :pre-keys ,pks)) (published `(:identity-key "ik" :signed-pre-key "spk" :signed-pre-key-id 1 :pre-keys ,pks))) (should-not (jabber-omemo--bundle-needs-republish-p local published)))) (ert-deftest jabber-omemo-protocol-test-publish-bundle-if-needed-skips-when-current () "publish-bundle-if-needed does NOT publish when fetched bundle matches local." (let ((jabber-omemo--bundle-publishes-in-flight (make-hash-table :test 'equal)) (publish-called nil) (persist-called nil) (refill-called nil) (pks (cl-loop for i from 1 to 100 collect (cons i "k")))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo--get-device-id) (lambda (_jc) 42)) ((symbol-function 'jabber-omemo--get-store) (lambda (_jc) 'fake-store-ptr)) ((symbol-function 'jabber-omemo-get-bundle) (lambda (_store) (list :identity-key "ik" :signed-pre-key "spk" :signed-pre-key-id 1 :pre-keys pks))) ((symbol-function 'jabber-omemo--fetch-bundle) (lambda (_jc _jid _did callback) (funcall callback (list :identity-key "ik" :signed-pre-key "spk" :signed-pre-key-id 1 :pre-keys pks)))) ((symbol-function 'jabber-omemo-refill-pre-keys) (lambda (_store) (setq refill-called t))) ((symbol-function 'jabber-omemo--persist-store) (lambda (_jc) (setq persist-called t))) ((symbol-function 'jabber-omemo--publish-bundle) (lambda (_jc) (setq publish-called t)))) (jabber-omemo--publish-bundle-if-needed 'fake-jc) (should-not publish-called) (should-not persist-called) (should-not refill-called) ;; In-flight key cleared after callback runs (should (zerop (hash-table-count jabber-omemo--bundle-publishes-in-flight)))))) (ert-deftest jabber-omemo-protocol-test-publish-bundle-if-needed-publishes-when-stale () "publish-bundle-if-needed refills, persists, and publishes when stale." (let ((jabber-omemo--bundle-publishes-in-flight (make-hash-table :test 'equal)) (calls nil) (pks (cl-loop for i from 1 to 100 collect (cons i "k")))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo--get-device-id) (lambda (_jc) 42)) ((symbol-function 'jabber-omemo--get-store) (lambda (_jc) 'fake-store-ptr)) ((symbol-function 'jabber-omemo-get-bundle) (lambda (_store) (list :identity-key "ik-new" :signed-pre-key "spk" :signed-pre-key-id 1 :pre-keys pks))) ((symbol-function 'jabber-omemo--fetch-bundle) (lambda (_jc _jid _did callback) (funcall callback (list :identity-key "ik-old" :signed-pre-key "spk" :signed-pre-key-id 1 :pre-keys pks)))) ((symbol-function 'jabber-omemo-refill-pre-keys) (lambda (store) (push (cons 'refill store) calls))) ((symbol-function 'jabber-omemo--persist-store) (lambda (jc) (push (cons 'persist jc) calls))) ((symbol-function 'jabber-omemo--publish-bundle) (lambda (jc) (push (cons 'publish jc) calls)))) (jabber-omemo--publish-bundle-if-needed 'fake-jc) (should (equal (nreverse calls) '((refill . fake-store-ptr) (persist . fake-jc) (publish . fake-jc)))) ;; In-flight key cleared after callback runs (should (zerop (hash-table-count jabber-omemo--bundle-publishes-in-flight)))))) (ert-deftest jabber-omemo-protocol-test-publish-bundle-if-needed-dedup () "Second concurrent publish-bundle-if-needed call is a no-op while first is in flight." (let ((jabber-omemo--bundle-publishes-in-flight (make-hash-table :test 'equal)) (fetch-count 0) ;; Hold the first fetch's callback so we can fire the second ;; call while the first is still in flight. (held-callback nil)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo--get-device-id) (lambda (_jc) 42)) ((symbol-function 'jabber-omemo--get-store) (lambda (_jc) 'fake-store-ptr)) ((symbol-function 'jabber-omemo-get-bundle) (lambda (_store) nil)) ((symbol-function 'jabber-omemo--fetch-bundle) (lambda (_jc _jid _did callback) (cl-incf fetch-count) (setq held-callback callback))) ((symbol-function 'jabber-omemo-refill-pre-keys) #'ignore) ((symbol-function 'jabber-omemo--persist-store) #'ignore) ((symbol-function 'jabber-omemo--publish-bundle) #'ignore)) ;; First call: fires fetch, callback held. (jabber-omemo--publish-bundle-if-needed 'fake-jc) (should (= 1 fetch-count)) (should (= 1 (hash-table-count jabber-omemo--bundle-publishes-in-flight))) ;; Second call while first is in flight: should NOT fire fetch. (jabber-omemo--publish-bundle-if-needed 'fake-jc) (should (= 1 fetch-count)) ;; Now release the held callback; in-flight slot frees. (funcall held-callback nil) (should (zerop (hash-table-count jabber-omemo--bundle-publishes-in-flight))) ;; Third call after release: fetch fires again. (jabber-omemo--publish-bundle-if-needed 'fake-jc) (should (= 2 fetch-count))))) (provide 'jabber-omemo-protocol-tests) ;;; jabber-omemo-protocol-tests.el ends here emacs-jabber/tests/jabber-omemo-store-tests.el000066400000000000000000000354071516610113500217160ustar00rootroot00000000000000;;; jabber-omemo-store-tests.el --- Tests for jabber-omemo-store -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-omemo-store) ;;; Test infrastructure (defmacro jabber-omemo-store-test-with-db (&rest body) "Run BODY with a fresh temp SQLite database for OMEMO tests. Binds `jabber-db-path' to a temp file and tears down on exit." (declare (indent 0) (debug t)) `(let* ((jabber-omemo-store-test--dir (make-temp-file "jabber-omemo-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-omemo-store-test--dir)) (jabber-db--connection nil)) (unwind-protect (progn (jabber-db-ensure-open) ,@body) (jabber-db-close) (when (file-directory-p jabber-omemo-store-test--dir) (delete-directory jabber-omemo-store-test--dir t))))) ;;; Group 1: Schema creation (ert-deftest jabber-omemo-store-test-schema-creates-tables () "Migration v2 creates all 5 OMEMO tables." (jabber-omemo-store-test-with-db (let ((tables (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM sqlite_master WHERE type='table' AND name LIKE 'omemo_%'")))) (should (member "omemo_store" tables)) (should (member "omemo_sessions" tables)) (should (member "omemo_trust" tables)) (should (member "omemo_skipped_keys" tables)) (should (member "omemo_devices" tables))))) (ert-deftest jabber-omemo-store-test-schema-idempotent () "Calling schema init twice does not error." (jabber-omemo-store-test-with-db (jabber-db--init-schema jabber-db--connection) (should t))) ;;; Group 2: Store blob CRUD (ert-deftest jabber-omemo-store-test-save-load-roundtrip () "Save + load round-trips a unibyte blob." (jabber-omemo-store-test-with-db (let ((blob (unibyte-string 7 42 0 1 127 200 255))) (jabber-omemo-store-save "me@example.com" blob) (should (equal blob (jabber-omemo-store-load "me@example.com")))))) (ert-deftest jabber-omemo-store-test-load-unknown-account () "Load returns nil for unknown account." (jabber-omemo-store-test-with-db (should (null (jabber-omemo-store-load "nobody@example.com"))))) (ert-deftest jabber-omemo-store-test-save-upsert () "Save overwrites existing blob (upsert)." (jabber-omemo-store-test-with-db (let ((blob1 (encode-coding-string "first" 'raw-text)) (blob2 (encode-coding-string "second" 'raw-text))) (jabber-omemo-store-save "me@example.com" blob1) (jabber-omemo-store-save "me@example.com" blob2) (should (equal blob2 (jabber-omemo-store-load "me@example.com")))))) (ert-deftest jabber-omemo-store-test-delete () "Delete removes the store record." (jabber-omemo-store-test-with-db (jabber-omemo-store-save "me@example.com" (encode-coding-string "data" 'raw-text)) (jabber-omemo-store-delete "me@example.com") (should (null (jabber-omemo-store-load "me@example.com"))))) ;;; Group 3: Trust CRUD (ert-deftest jabber-omemo-store-test-trust-save-load-roundtrip () "save-trust + load-trust round-trips." (jabber-omemo-store-test-with-db (let ((key (encode-coding-string "identity-key-bytes" 'raw-text))) (jabber-omemo-store-save-trust "me@example.com" "alice@example.com" 12345 key 1) (let ((rec (jabber-omemo-store-load-trust "me@example.com" "alice@example.com" 12345))) (should rec) (should (equal key (plist-get rec :identity-key))) (should (= 1 (plist-get rec :trust))) (should (integerp (plist-get rec :first-seen))))))) (ert-deftest jabber-omemo-store-test-trust-load-unknown () "load-trust returns nil for unknown device." (jabber-omemo-store-test-with-db (should (null (jabber-omemo-store-load-trust "me@example.com" "alice@example.com" 99999))))) (ert-deftest jabber-omemo-store-test-set-trust-updates-level () "set-trust updates level without changing identity-key or first-seen." (jabber-omemo-store-test-with-db (let ((key (encode-coding-string "key-data" 'raw-text))) (jabber-omemo-store-save-trust "me@example.com" "alice@example.com" 100 key 0) (let ((orig (jabber-omemo-store-load-trust "me@example.com" "alice@example.com" 100))) (jabber-omemo-store-set-trust "me@example.com" "alice@example.com" 100 2) (let ((updated (jabber-omemo-store-load-trust "me@example.com" "alice@example.com" 100))) (should (= 2 (plist-get updated :trust))) (should (equal key (plist-get updated :identity-key))) (should (= (plist-get orig :first-seen) (plist-get updated :first-seen)))))))) (ert-deftest jabber-omemo-store-test-all-trust-multiple () "all-trust returns multiple devices for same JID." (jabber-omemo-store-test-with-db (let ((key1 (encode-coding-string "key1" 'raw-text)) (key2 (encode-coding-string "key2" 'raw-text))) (jabber-omemo-store-save-trust "me@example.com" "alice@example.com" 100 key1 1) (jabber-omemo-store-save-trust "me@example.com" "alice@example.com" 200 key2 0) (let ((all (jabber-omemo-store-all-trust "me@example.com" "alice@example.com"))) (should (= 2 (length all))) (should (cl-find 100 all :key (lambda (p) (plist-get p :device-id)))) (should (cl-find 200 all :key (lambda (p) (plist-get p :device-id)))))))) (ert-deftest jabber-omemo-store-test-trust-levels () "Trust levels: 0 (undecided), 1 (tofu), 2 (verified), -1 (untrusted)." (jabber-omemo-store-test-with-db (let ((key (encode-coding-string "k" 'raw-text))) (dolist (level '(0 1 2 -1)) (jabber-omemo-store-save-trust "me@example.com" "peer@example.com" (+ 1000 level) key level)) (dolist (level '(0 1 2 -1)) (let ((rec (jabber-omemo-store-load-trust "me@example.com" "peer@example.com" (+ 1000 level)))) (should (= level (plist-get rec :trust)))))))) (ert-deftest jabber-omemo-store-test-trust-upsert-preserves-first-seen () "Upserting trust preserves the original first_seen." (jabber-omemo-store-test-with-db (let ((key (encode-coding-string "key-data" 'raw-text))) (jabber-omemo-store-save-trust "me@example.com" "alice@example.com" 100 key 0) (let ((first (plist-get (jabber-omemo-store-load-trust "me@example.com" "alice@example.com" 100) :first-seen))) ;; Upsert with different trust level (jabber-omemo-store-save-trust "me@example.com" "alice@example.com" 100 key 2) (let ((after (plist-get (jabber-omemo-store-load-trust "me@example.com" "alice@example.com" 100) :first-seen))) (should (= first after))))))) ;;; Group 4: Device list CRUD (ert-deftest jabber-omemo-store-test-device-save-load-roundtrip () "save-device + load-devices round-trips." (jabber-omemo-store-test-with-db (jabber-omemo-store-save-device "me@example.com" "alice@example.com" 42) (let ((devs (jabber-omemo-store-load-devices "me@example.com" "alice@example.com"))) (should (= 1 (length devs))) (let ((d (car devs))) (should (= 42 (plist-get d :device-id))) (should (eq t (plist-get d :active))) (should (integerp (plist-get d :last-seen))))))) (ert-deftest jabber-omemo-store-test-device-load-unknown () "load-devices returns empty list for unknown JID." (jabber-omemo-store-test-with-db (should (null (jabber-omemo-store-load-devices "me@example.com" "nobody@example.com"))))) (ert-deftest jabber-omemo-store-test-device-set-active () "set-device-active toggles the flag." (jabber-omemo-store-test-with-db (jabber-omemo-store-save-device "me@example.com" "alice@example.com" 42) (jabber-omemo-store-set-device-active "me@example.com" "alice@example.com" 42 nil) (let ((d (car (jabber-omemo-store-load-devices "me@example.com" "alice@example.com")))) (should-not (plist-get d :active))) (jabber-omemo-store-set-device-active "me@example.com" "alice@example.com" 42 t) (let ((d (car (jabber-omemo-store-load-devices "me@example.com" "alice@example.com")))) (should (eq t (plist-get d :active)))))) (ert-deftest jabber-omemo-store-test-device-delete () "delete-device removes the record." (jabber-omemo-store-test-with-db (jabber-omemo-store-save-device "me@example.com" "alice@example.com" 42) (jabber-omemo-store-delete-device "me@example.com" "alice@example.com" 42) (should (null (jabber-omemo-store-load-devices "me@example.com" "alice@example.com"))))) (ert-deftest jabber-omemo-store-test-device-last-seen () "last-seen is set on save." (jabber-omemo-store-test-with-db (jabber-omemo-store-save-device "me@example.com" "alice@example.com" 42) (let* ((d (car (jabber-omemo-store-load-devices "me@example.com" "alice@example.com"))) (ts (plist-get d :last-seen)) (now (truncate (float-time)))) (should (<= (abs (- ts now)) 2))))) ;;; Group 5: Session CRUD (ert-deftest jabber-omemo-store-test-session-save-load-roundtrip () "save-session + load-session round-trips." (jabber-omemo-store-test-with-db (let ((blob (encode-coding-string "session-data\x00\x01" 'raw-text))) (jabber-omemo-store-save-session "me@example.com" "alice@example.com" 42 blob) (should (equal blob (jabber-omemo-store-load-session "me@example.com" "alice@example.com" 42)))))) (ert-deftest jabber-omemo-store-test-session-load-unknown () "load-session returns nil for unknown." (jabber-omemo-store-test-with-db (should (null (jabber-omemo-store-load-session "me@example.com" "alice@example.com" 99))))) (ert-deftest jabber-omemo-store-test-session-delete () "delete-session removes the session." (jabber-omemo-store-test-with-db (let ((blob (encode-coding-string "session" 'raw-text))) (jabber-omemo-store-save-session "me@example.com" "alice@example.com" 42 blob) (jabber-omemo-store-delete-session "me@example.com" "alice@example.com" 42) (should (null (jabber-omemo-store-load-session "me@example.com" "alice@example.com" 42)))))) (ert-deftest jabber-omemo-store-test-session-all () "all-sessions lists all devices for a peer." (jabber-omemo-store-test-with-db (let ((b1 (encode-coding-string "s1" 'raw-text)) (b2 (encode-coding-string "s2" 'raw-text))) (jabber-omemo-store-save-session "me@example.com" "alice@example.com" 42 b1) (jabber-omemo-store-save-session "me@example.com" "alice@example.com" 99 b2) (let ((all (jabber-omemo-store-all-sessions "me@example.com" "alice@example.com"))) (should (= 2 (length all))) (should (cl-find 42 all :key (lambda (p) (plist-get p :device-id)))) (should (cl-find 99 all :key (lambda (p) (plist-get p :device-id)))))))) ;;; Group 6: Skipped key CRUD (ert-deftest jabber-omemo-store-test-skipped-key-save-load-roundtrip () "save + load round-trips a skipped key." (jabber-omemo-store-test-with-db (let ((dh (encode-coding-string "dh-key-data" 'raw-text)) (mk (encode-coding-string "msg-key-data" 'raw-text))) (jabber-omemo-store-save-skipped-key "me@example.com" "alice@example.com" 42 dh 7 mk) (should (equal mk (jabber-omemo-store-load-skipped-key "me@example.com" "alice@example.com" 42 dh 7)))))) (ert-deftest jabber-omemo-store-test-skipped-key-load-unknown () "load returns nil for unknown skipped key." (jabber-omemo-store-test-with-db (should (null (jabber-omemo-store-load-skipped-key "me@example.com" "alice@example.com" 42 (encode-coding-string "x" 'raw-text) 0))))) (ert-deftest jabber-omemo-store-test-skipped-key-delete () "delete removes a skipped key after use." (jabber-omemo-store-test-with-db (let ((dh (encode-coding-string "dh" 'raw-text)) (mk (encode-coding-string "mk" 'raw-text))) (jabber-omemo-store-save-skipped-key "me@example.com" "alice@example.com" 42 dh 7 mk) (jabber-omemo-store-delete-skipped-key "me@example.com" "alice@example.com" 42 dh 7) (should (null (jabber-omemo-store-load-skipped-key "me@example.com" "alice@example.com" 42 dh 7)))))) (ert-deftest jabber-omemo-store-test-skipped-key-delete-old () "delete-old-skipped-keys removes by age." (jabber-omemo-store-test-with-db (let ((dh (encode-coding-string "dh" 'raw-text)) (mk (encode-coding-string "mk" 'raw-text)) (now (truncate (float-time)))) ;; Insert an old key by directly using SQL (sqlite-execute jabber-db--connection "\ INSERT INTO omemo_skipped_keys (account, jid, device_id, dh_key, message_number, message_key, created_at) VALUES (?, ?, ?, ?, ?, ?, ?)" (list "me@example.com" "alice@example.com" 42 dh 1 mk (- now 7200))) ;; Insert a recent key (jabber-omemo-store-save-skipped-key "me@example.com" "alice@example.com" 42 dh 2 mk) ;; Delete keys older than 1 hour (jabber-omemo-store-delete-old-skipped-keys "me@example.com" 3600) ;; Old key gone, recent key remains (should (null (jabber-omemo-store-load-skipped-key "me@example.com" "alice@example.com" 42 dh 1))) (should (jabber-omemo-store-load-skipped-key "me@example.com" "alice@example.com" 42 dh 2))))) (provide 'jabber-omemo-store-tests) ;;; jabber-omemo-store-tests.el ends here emacs-jabber/tests/jabber-omemo-trust-tests.el000066400000000000000000000124101516610113500217300ustar00rootroot00000000000000;;; jabber-omemo-trust-tests.el --- Tests for OMEMO trust UI -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-omemo-store) ;; Load the trust UI without triggering jabber-omemo's C module requirement. ;; We mock the declare-function targets instead. (unless (fboundp 'jabber-omemo--format-fingerprint) (defun jabber-omemo--format-fingerprint (identity-key) "Test stub: format IDENTITY-KEY as hex pairs." (mapconcat (lambda (byte) (format "%02X" byte)) identity-key " "))) (unless (fboundp 'jabber-omemo--trust-label) (defun jabber-omemo--trust-label (level) "Test stub: return label for trust LEVEL." (pcase level (0 "undecided") (1 "TOFU") (2 "verified") (-1 "UNTRUSTED") (_ (format "unknown(%d)" level))))) (unless (fboundp 'jabber-connection-bare-jid) (defun jabber-connection-bare-jid (_jc) "alice@example.com")) (unless (fboundp 'jabber-jid-user) (defun jabber-jid-user (jid) (car (split-string jid "/")))) (unless (fboundp 'jabber-read-account) (defun jabber-read-account () 'test-jc)) (require 'jabber-omemo-trust) ;;; Group 1: trust label mapping (ert-deftest jabber-omemo-trust-test-label-undecided () "Trust level 0 maps to undecided." (should (string= "undecided" (jabber-omemo--trust-label 0)))) (ert-deftest jabber-omemo-trust-test-label-tofu () "Trust level 1 maps to TOFU." (should (string= "TOFU" (jabber-omemo--trust-label 1)))) (ert-deftest jabber-omemo-trust-test-label-verified () "Trust level 2 maps to verified." (should (string= "verified" (jabber-omemo--trust-label 2)))) (ert-deftest jabber-omemo-trust-test-label-untrusted () "Trust level -1 maps to UNTRUSTED." (should (string= "UNTRUSTED" (jabber-omemo--trust-label -1)))) (ert-deftest jabber-omemo-trust-test-label-unknown () "Unknown trust level shows the number." (should (string= "unknown(99)" (jabber-omemo--trust-label 99)))) ;;; Group 2: fingerprint formatting (ert-deftest jabber-omemo-trust-test-format-fingerprint () "Fingerprint formats as space-separated uppercase hex pairs." (let ((key (unibyte-string #xDE #xAD #xBE #xEF))) (should (string= "DE AD BE EF" (jabber-omemo--format-fingerprint key))))) (ert-deftest jabber-omemo-trust-test-format-fingerprint-empty () "Empty key produces empty string." (should (string= "" (jabber-omemo--format-fingerprint "")))) ;;; Group 3: key type stripping (ert-deftest jabber-omemo-trust-test-strip-key-type () "Strip 0x05 prefix from identity key." (let ((key (unibyte-string #x05 #xAB #xCD))) (should (equal (unibyte-string #xAB #xCD) (jabber-omemo-trust--strip-key-type key))))) (ert-deftest jabber-omemo-trust-test-strip-key-type-no-prefix () "Leave key unchanged when no 0x05 prefix." (let ((key (unibyte-string #xAB #xCD))) (should (equal key (jabber-omemo-trust--strip-key-type key))))) ;;; Group 4: entries function (ert-deftest jabber-omemo-trust-test-entries-shape () "Entries returns list of (ID VECTOR) from trust records." (cl-letf (((symbol-function 'jabber-omemo-store-all-trust) (lambda (_acct _jid) (list (list :device-id 12345 :identity-key (unibyte-string #x05 #xAB #xCD) :trust 1 :first-seen 1710000000) (list :device-id 67890 :identity-key (unibyte-string #x05 #xEF #x01) :trust 2 :first-seen nil))))) (let ((jabber-omemo-trust--account "alice@example.com") (jabber-omemo-trust--peer "bob@example.com")) (let ((entries (jabber-omemo-trust--entries))) (should (= 2 (length entries))) ;; First entry: 05 stripped, fingerprint is just AB CD (let ((entry (car entries))) (should (= 12345 (car entry))) (should (vectorp (cadr entry))) (should (string= "12345" (aref (cadr entry) 0))) (should (string= "TOFU" (aref (cadr entry) 1))) (should (string= "AB CD" (aref (cadr entry) 2))) (should (not (string= "" (aref (cadr entry) 3))))) ;; Second entry (let ((entry (cadr entries))) (should (= 67890 (car entry))) (should (string= "verified" (aref (cadr entry) 1))) (should (string= "" (aref (cadr entry) 3)))))))) (ert-deftest jabber-omemo-trust-test-entries-empty () "Entries returns nil for no trust records." (cl-letf (((symbol-function 'jabber-omemo-store-all-trust) (lambda (_acct _jid) nil))) (let ((jabber-omemo-trust--account "alice@example.com") (jabber-omemo-trust--peer "bob@example.com")) (should (null (jabber-omemo-trust--entries)))))) ;;; Group 5: column format (ert-deftest jabber-omemo-trust-test-column-format () "Mode sets a 4-column tabulated-list-format." (with-temp-buffer (jabber-omemo-trust-mode) (should (= 4 (length tabulated-list-format))) (should (string= "Device ID" (car (aref tabulated-list-format 0)))) (should (string= "Trust" (car (aref tabulated-list-format 1)))) (should (string= "Fingerprint" (car (aref tabulated-list-format 2)))) (should (string= "First Seen" (car (aref tabulated-list-format 3)))))) (provide 'jabber-omemo-trust-tests) ;;; jabber-omemo-trust-tests.el ends here emacs-jabber/tests/jabber-openpgp-legacy-tests.el000066400000000000000000000044011516610113500223500ustar00rootroot00000000000000;;; jabber-openpgp-legacy-tests.el --- Tests for XEP-0027 legacy OpenPGP -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-xml) ;; Load the module under test. It has top-level side effects that need ;; jabber-disco and jabber-chat, so stub what is missing. (unless (fboundp 'jabber-disco-advertise-feature) (defun jabber-disco-advertise-feature (_feature) nil)) (unless (fboundp 'jabber-chat-register-decrypt-handler) (defun jabber-chat-register-decrypt-handler (_id &rest _props) nil)) (unless (fboundp 'jabber-chat--set-body) (defun jabber-chat--set-body (xml-data text) (let ((body-el (car (jabber-xml-get-children xml-data 'body)))) (if body-el (setcar (cddr body-el) text) (nconc xml-data (list `(body () ,text))))) xml-data)) (defvar jabber-presence-element-functions nil) (defvar jabber-presence-chain nil) (require 'jabber-openpgp-legacy) ;;; Group 1: detect-encrypted (ert-deftest jabber-openpgp-legacy-test-detect-encrypted-returns-stripped () "detect-encrypted returns stripped armor text for XEP-0027 stanza." (let ((xml-data `(message ((from . "alice@example.com/res") (type . "chat")) (body () "This message is encrypted.") (x ((xmlns . "jabber:x:encrypted")) "hQEOA7Le...")))) (should (string= "hQEOA7Le..." (jabber-openpgp-legacy--detect-encrypted xml-data))))) (ert-deftest jabber-openpgp-legacy-test-detect-encrypted-returns-nil () "detect-encrypted returns nil for plain stanza." (let ((xml-data '(message ((from . "alice@example.com") (type . "chat")) (body () "hello plain")))) (should-not (jabber-openpgp-legacy--detect-encrypted xml-data)))) (ert-deftest jabber-openpgp-legacy-test-detect-encrypted-non-string-child () "detect-encrypted returns nil when x element child is not a string." (let ((xml-data '(message ((from . "alice@example.com")) (x ((xmlns . "jabber:x:encrypted")) (inner ()))))) (should-not (jabber-openpgp-legacy--detect-encrypted xml-data)))) (provide 'jabber-openpgp-legacy-tests) ;;; jabber-openpgp-legacy-tests.el ends here emacs-jabber/tests/jabber-presence-tests.el000066400000000000000000000314231516610113500212460ustar00rootroot00000000000000;;; jabber-presence-tests.el --- Tests for jabber-presence -*- lexical-binding: t; -*- (require 'ert) ;; Pre-define variables expected at load time. (defvar jabber-body-printers nil) (defvar jabber-message-chain nil) (defvar jabber-presence-chain nil) (defvar jabber-iq-chain nil) (require 'jabber-presence) ;;; Group 1: jabber--roster-valid-push-p (ert-deftest jabber-presence-test-valid-push-nil-from () "Absent from attribute is valid." (let ((state '(:username "alice" :server "example.com" :resource "emacs"))) (should (jabber--roster-valid-push-p nil state)))) (ert-deftest jabber-presence-test-valid-push-bare-server () "From matching bare server is valid." (let ((state '(:username "alice" :server "example.com" :resource "emacs"))) (should (jabber--roster-valid-push-p "example.com" state)))) (ert-deftest jabber-presence-test-valid-push-bare-jid () "From matching bare JID is valid." (let ((state '(:username "alice" :server "example.com" :resource "emacs"))) (should (jabber--roster-valid-push-p "alice@example.com" state)))) (ert-deftest jabber-presence-test-valid-push-full-jid () "From matching full JID is valid." (let ((state '(:username "alice" :server "example.com" :resource "emacs"))) (should (jabber--roster-valid-push-p "alice@example.com/emacs" state)))) (ert-deftest jabber-presence-test-invalid-push-wrong-server () "From with wrong server is invalid." (let ((state '(:username "alice" :server "example.com" :resource "emacs"))) (should-not (jabber--roster-valid-push-p "evil.com" state)))) (ert-deftest jabber-presence-test-invalid-push-wrong-jid () "From with wrong JID is invalid." (let ((state '(:username "alice" :server "example.com" :resource "emacs"))) (should-not (jabber--roster-valid-push-p "bob@example.com" state)))) (ert-deftest jabber-presence-test-invalid-push-wrong-resource () "From with wrong resource is invalid." (let ((state '(:username "alice" :server "example.com" :resource "emacs"))) (should-not (jabber--roster-valid-push-p "alice@example.com/phone" state)))) ;;; Group 2: jabber--roster-process-item (defmacro jabber-presence-test-with-obarray (&rest body) "Run BODY with a fresh `jabber-jid-obarray'." (declare (indent 0)) `(let ((jabber-jid-obarray (make-vector 127 0))) ,@body)) (ert-deftest jabber-presence-test-process-item-new () "New roster item returns (new . sym) and sets properties." (jabber-presence-test-with-obarray (let* ((item '(item ((jid . "bob@example.com") (name . "Bob") (subscription . "both")) (group () "Friends"))) (result (jabber--roster-process-item item nil nil))) (should (eq (car result) 'new)) (let ((sym (cdr result))) (should (equal (get sym 'name) "Bob")) (should (equal (get sym 'subscription) "both")) (should (equal (get sym 'groups) '("Friends"))))))) (ert-deftest jabber-presence-test-process-item-changed () "Existing roster item returns (changed . sym)." (jabber-presence-test-with-obarray (let* ((jid (intern "bob@example.com" jabber-jid-obarray)) (roster (list jid)) (item '(item ((jid . "bob@example.com") (name . "Bobby") (subscription . "both")))) (result (jabber--roster-process-item item roster nil))) (should (eq (car result) 'changed)) (should (eq (cdr result) jid)) (should (equal (get jid 'name) "Bobby"))))) (ert-deftest jabber-presence-test-process-item-deleted () "Item with subscription=remove returns (deleted . sym)." (jabber-presence-test-with-obarray (let* ((item '(item ((jid . "bob@example.com") (subscription . "remove")))) (result (jabber--roster-process-item item nil nil))) (should (eq (car result) 'deleted))))) (ert-deftest jabber-presence-test-process-item-initial-clears-plist () "Initial push clears existing plist properties." (jabber-presence-test-with-obarray (let* ((jid (intern "bob@example.com" jabber-jid-obarray)) (item '(item ((jid . "bob@example.com") (name . "Bob") (subscription . "both"))))) (put jid 'show "away") (put jid 'connected t) (jabber--roster-process-item item nil t) ;; Stale properties should be gone. (should-not (get jid 'show)) (should-not (get jid 'connected)) ;; Fresh properties should be set. (should (equal (get jid 'name) "Bob"))))) (ert-deftest jabber-presence-test-process-item-multiple-groups () "Multiple group elements are collected." (jabber-presence-test-with-obarray (let* ((item '(item ((jid . "bob@example.com") (subscription . "both")) (group () "Friends") (group () "Coworkers"))) (result (jabber--roster-process-item item nil nil))) (should (equal (get (cdr result) 'groups) '("Friends" "Coworkers")))))) (ert-deftest jabber-presence-test-process-item-ask-property () "The ask attribute is stored on the symbol." (jabber-presence-test-with-obarray (let* ((item '(item ((jid . "bob@example.com") (subscription . "none") (ask . "subscribe")))) (result (jabber--roster-process-item item nil nil))) (should (equal (get (cdr result) 'ask) "subscribe"))))) (ert-deftest jabber-presence-test-process-item-no-groups () "Item with no group children yields nil groups property." (jabber-presence-test-with-obarray (let* ((item '(item ((jid . "bob@example.com") (name . "Bob") (subscription . "both")))) (result (jabber--roster-process-item item nil nil))) (should-not (get (cdr result) 'groups))))) (ert-deftest jabber-presence-test-process-item-no-name () "Item with no name attribute yields nil name but sets subscription." (jabber-presence-test-with-obarray (let* ((item '(item ((jid . "bob@example.com") (subscription . "to")))) (result (jabber--roster-process-item item nil nil))) (should-not (get (cdr result) 'name)) (should (equal (get (cdr result) 'subscription) "to"))))) ;;; Group 3: jabber-presence--extract-metadata (ert-deftest jabber-presence-test-extract-metadata-all-fields () "All fields are extracted from a fully populated presence stanza." (let* ((xml '(presence ((from . "bob@example.com/phone")) (show () "away") (status () "On the phone") (priority () "5") (error ((type . "modify")) (bad-request ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))))) (result (jabber-presence--extract-metadata xml))) (should (equal (plist-get result :show) "away")) (should (equal (plist-get result :status) "On the phone")) (should (equal (plist-get result :priority) 5)) (should (consp (plist-get result :error))))) (ert-deftest jabber-presence-test-extract-metadata-missing-elements () "Missing child elements yield nil (or 0 for priority)." (let* ((xml '(presence ((from . "bob@example.com")))) (result (jabber-presence--extract-metadata xml))) (should (null (plist-get result :show))) (should (null (plist-get result :status))) (should (equal (plist-get result :priority) 0)) (should (null (plist-get result :error))))) (ert-deftest jabber-presence-test-extract-metadata-only-status () "Only the status element is present." (let* ((xml '(presence ((from . "bob@example.com")) (status () "BRB"))) (result (jabber-presence--extract-metadata xml))) (should (null (plist-get result :show))) (should (equal (plist-get result :status) "BRB")) (should (equal (plist-get result :priority) 0)) (should (null (plist-get result :error))))) (ert-deftest jabber-presence-test-extract-metadata-negative-priority () "Negative priority is parsed correctly." (let* ((xml '(presence ((from . "bob@example.com")) (priority () "-1"))) (result (jabber-presence--extract-metadata xml))) (should (equal (plist-get result :priority) -1)))) ;;; Group 4: jabber-presence--update-resource (ert-deftest jabber-presence-test-update-resource-normal-presence () "Normal presence sets connected, show, status, priority on resource plist." (jabber-presence-test-with-obarray (let* ((buddy (intern "bob@example.com" jabber-jid-obarray)) (metadata '(:show "away" :status "BRB" :priority 5 :error nil)) (result (jabber-presence--update-resource buddy nil "phone" metadata)) (newstatus (car result)) (rplist (cdr result))) (should (equal newstatus "away")) (should (eq (plist-get rplist 'connected) t)) (should (equal (plist-get rplist 'show) "away")) (should (equal (plist-get rplist 'status) "BRB")) (should (equal (plist-get rplist 'priority) 5))))) (ert-deftest jabber-presence-test-update-resource-unavailable () "Unavailable presence clears connected and show on resource plist." (jabber-presence-test-with-obarray (let* ((buddy (intern "bob@example.com" jabber-jid-obarray)) (metadata '(:show nil :status "Goodbye" :priority 0 :error nil)) (result (jabber-presence--update-resource buddy "unavailable" "phone" metadata)) (newstatus (car result)) (rplist (cdr result))) (should (null newstatus)) (should (null (plist-get rplist 'connected))) (should (null (plist-get rplist 'show))) (should (equal (plist-get rplist 'status) "Goodbye"))))) (ert-deftest jabber-presence-test-update-resource-bare-jid-unavailable () "Bare JID unavailable clears all buddy resources and properties." (jabber-presence-test-with-obarray (let* ((buddy (intern "bob@example.com" jabber-jid-obarray))) (put buddy 'resources '(("phone" connected t show "away"))) (put buddy 'connected t) (put buddy 'show "away") (let* ((metadata '(:show nil :status "Gone" :priority 0 :error nil)) (result (jabber-presence--update-resource buddy "unavailable" "" metadata)) (newstatus (car result)) (rplist (cdr result))) (should (null newstatus)) (should (null rplist)) (should (null (get buddy 'resources))) (should (null (get buddy 'connected))) (should (null (get buddy 'show))) (should (equal (get buddy 'status) "Gone")))))) (ert-deftest jabber-presence-test-update-resource-error () "Error presence sets show to error and connected to nil." (jabber-presence-test-with-obarray (let* ((buddy (intern "bob@example.com" jabber-jid-obarray)) (metadata '(:show nil :status "something" :priority 0 :error nil)) (result (jabber-presence--update-resource buddy "error" "phone" metadata)) (newstatus (car result)) (rplist (cdr result))) (should (equal newstatus "error")) (should (null (plist-get rplist 'connected))) (should (equal (plist-get rplist 'show) "error")) (should (equal (plist-get rplist 'status) "something"))))) (ert-deftest jabber-presence-test-update-resource-subscribed () "Subscribed type sets newstatus without modifying resource plist." (jabber-presence-test-with-obarray (let* ((buddy (intern "bob@example.com" jabber-jid-obarray)) (metadata '(:show nil :status nil :priority 0 :error nil)) (result (jabber-presence--update-resource buddy "subscribed" "phone" metadata)) (newstatus (car result))) (should (equal newstatus "subscribed"))))) (ert-deftest jabber-presence-test-update-resource-default-show () "Normal presence with nil show defaults show to empty string." (jabber-presence-test-with-obarray (let* ((buddy (intern "bob@example.com" jabber-jid-obarray)) (metadata '(:show nil :status "Online" :priority 0 :error nil)) (result (jabber-presence--update-resource buddy nil "laptop" metadata)) (newstatus (car result)) (rplist (cdr result))) (should (equal newstatus "")) (should (equal (plist-get rplist 'show) ""))))) (ert-deftest jabber-presence-test-update-resource-unsubscribe () "Unsubscribe type returns (\"unsubscribe\" . nil)." (jabber-presence-test-with-obarray (let* ((buddy (intern "bob@example.com" jabber-jid-obarray)) (metadata '(:show nil :status nil :priority 0 :error nil)) (result (jabber-presence--update-resource buddy "unsubscribe" "phone" metadata)) (newstatus (car result))) (should (equal newstatus "unsubscribe"))))) (provide 'jabber-presence-tests) ;;; jabber-presence-tests.el ends here emacs-jabber/tests/jabber-pubsub-tests.el000066400000000000000000000247161516610113500207510ustar00rootroot00000000000000;;; jabber-pubsub-tests.el --- Tests for jabber-pubsub -*- lexical-binding: t; -*- (require 'ert) ;; Pre-define variables that other modules expect at load time: (defvar jabber-body-printers nil) (defvar jabber-message-chain nil) (defvar jabber-presence-chain nil) (defvar jabber-iq-chain nil) (defvar jabber-jid-obarray (make-vector 127 0)) (require 'jabber-pubsub) ;;; Group 1: publish-options helper (ert-deftest jabber-pubsub-test-publish-options-single () "Single option produces correct XML structure." (let ((result (jabber-pubsub--publish-options '(("pubsub#access_model" . "open"))))) (should (eq (car result) 'publish-options)) (let* ((x (nth 2 result)) (fields (cl-remove-if-not (lambda (c) (and (listp c) (eq (car c) 'field))) (cddr x)))) ;; FORM_TYPE + one option = 2 fields (should (= (length fields) 2)) ;; First field is FORM_TYPE hidden (should (string= (cdr (assq 'var (cadr (nth 0 fields)))) "FORM_TYPE")) (should (string= (cdr (assq 'type (cadr (nth 0 fields)))) "hidden")) ;; Second field is our option (should (string= (cdr (assq 'var (cadr (nth 1 fields)))) "pubsub#access_model"))))) (ert-deftest jabber-pubsub-test-publish-options-multiple () "Multiple options produce multiple fields." (let ((result (jabber-pubsub--publish-options '(("pubsub#access_model" . "open") ("pubsub#max_items" . "100"))))) (let* ((x (nth 2 result)) (fields (cl-remove-if-not (lambda (c) (and (listp c) (eq (car c) 'field))) (cddr x)))) ;; FORM_TYPE + two options = 3 fields (should (= (length fields) 3))))) (ert-deftest jabber-pubsub-test-publish-options-form-type () "FORM_TYPE hidden field value is pubsub#publish-options." (let* ((result (jabber-pubsub--publish-options '(("foo" . "bar")))) (x (nth 2 result)) (form-type-field (nth 2 x)) (value-elem (nth 2 form-type-field))) (should (string= (nth 2 value-elem) "http://jabber.org/protocol/pubsub#publish-options")))) ;;; Group 2: event handler dispatch (ert-deftest jabber-pubsub-test-dispatch-matching-node () "Dispatches to registered handler for matching node." (let ((jabber-pubsub-node-handlers nil) (called-with nil)) (push (cons "urn:xmpp:omemo:2:bundles" (lambda (_jc from node items) (setq called-with (list from node items)))) jabber-pubsub-node-handlers) (jabber-pubsub--process-event nil `(message ((from . "alice@example.com")) (event ((xmlns . ,jabber-pubsub-event-xmlns)) (items ((node . "urn:xmpp:omemo:2:bundles")) (item ((id . "1")) (bundle () "data")))))) (should called-with) (should (string= (nth 0 called-with) "alice@example.com")) (should (string= (nth 1 called-with) "urn:xmpp:omemo:2:bundles")))) (ert-deftest jabber-pubsub-test-dispatch-no-event () "Ignores messages without element." (let ((jabber-pubsub-node-handlers (list (cons "some-node" (lambda (&rest _) (error "Should not be called"))))) (result nil)) (jabber-pubsub--process-event nil '(message ((from . "alice@example.com")) (body () "hello"))) (should-not result))) (ert-deftest jabber-pubsub-test-dispatch-wrong-xmlns () "Ignores events with wrong xmlns." (let ((jabber-pubsub-node-handlers (list (cons "some-node" (lambda (&rest _) (error "Should not be called")))))) (jabber-pubsub--process-event nil '(message ((from . "alice@example.com")) (event ((xmlns . "urn:wrong:xmlns")) (items ((node . "some-node")) (item ((id . "1")) (data () "x")))))))) (ert-deftest jabber-pubsub-test-dispatch-unregistered-node () "Ignores events with unregistered node." (let ((jabber-pubsub-node-handlers nil)) ;; Should not error (jabber-pubsub--process-event nil `(message ((from . "alice@example.com")) (event ((xmlns . ,jabber-pubsub-event-xmlns)) (items ((node . "unknown:node")) (item ((id . "1")) (data () "x")))))))) (ert-deftest jabber-pubsub-test-dispatch-purge () "Handles events." (let ((jabber-pubsub-node-handlers nil) (called-with nil)) (push (cons "urn:xmpp:omemo:2:bundles" (lambda (_jc from node items) (setq called-with (list from node items)))) jabber-pubsub-node-handlers) (jabber-pubsub--process-event nil `(message ((from . "alice@example.com")) (event ((xmlns . ,jabber-pubsub-event-xmlns)) (purge ((node . "urn:xmpp:omemo:2:bundles")))))) (should called-with) (should (string= (nth 1 called-with) "urn:xmpp:omemo:2:bundles")))) ;;; Group 3: IQ XML structure (defvar jabber-pubsub-test--captured-args nil "Captured arguments from mocked `jabber-send-iq'.") (defmacro jabber-pubsub-test-with-mock-iq (&rest body) "Execute BODY with `jabber-send-iq' mocked to capture its arguments." `(let ((jabber-pubsub-test--captured-args nil)) (cl-letf (((symbol-function 'jabber-send-iq) (lambda (jc to type query &rest _rest) (setq jabber-pubsub-test--captured-args (list :jc jc :to to :type type :query query))))) ,@body))) (ert-deftest jabber-pubsub-test-publish-iq-structure () "Publish builds correct IQ set with pubsub xmlns." (jabber-pubsub-test-with-mock-iq (jabber-pubsub-publish 'fake-jc "pubsub.example.com" "mynode" "item1" '(payload () "data")) (let ((args jabber-pubsub-test--captured-args)) (should (equal (plist-get args :to) "pubsub.example.com")) (should (string= (plist-get args :type) "set")) (let ((query (plist-get args :query))) (should (eq (car query) 'pubsub)) (should (string= (cdr (assq 'xmlns (cadr query))) jabber-pubsub-xmlns)) ;; Check publish element (let ((publish (nth 2 query))) (should (eq (car publish) 'publish)) (should (string= (cdr (assq 'node (cadr publish))) "mynode")) ;; Check item (let ((item (nth 2 publish))) (should (eq (car item) 'item)) (should (string= (cdr (assq 'id (cadr item))) "item1")))))))) (ert-deftest jabber-pubsub-test-publish-with-options () "Publish with options includes ." (jabber-pubsub-test-with-mock-iq (jabber-pubsub-publish 'fake-jc nil "mynode" "item1" '(payload () "data") '(("pubsub#access_model" . "open"))) (let* ((query (plist-get jabber-pubsub-test--captured-args :query)) (children (cddr query)) (pub-opts (cl-find 'publish-options children :key #'car))) (should pub-opts)))) (ert-deftest jabber-pubsub-test-retract-iq-structure () "Retract builds correct IQ set without notify attribute." (jabber-pubsub-test-with-mock-iq (jabber-pubsub-retract 'fake-jc "pubsub.example.com" "mynode" "item1") (let* ((args jabber-pubsub-test--captured-args) (query (plist-get args :query))) (should (string= (plist-get args :type) "set")) (should (eq (car query) 'pubsub)) (let ((retract (nth 2 query))) (should (eq (car retract) 'retract)) (should (string= (cdr (assq 'node (cadr retract))) "mynode")) (should-not (assq 'notify (cadr retract))) (let ((item (nth 2 retract))) (should (string= (cdr (assq 'id (cadr item))) "item1"))))))) (ert-deftest jabber-pubsub-test-retract-with-notify () "Retract with NOTIFY adds notify=\"true\" attribute." (jabber-pubsub-test-with-mock-iq (jabber-pubsub-retract 'fake-jc "pubsub.example.com" "mynode" "item1" t) (let* ((query (plist-get jabber-pubsub-test--captured-args :query)) (retract (nth 2 query))) (should (string= (cdr (assq 'notify (cadr retract))) "true")) (let ((item (nth 2 retract))) (should (string= (cdr (assq 'id (cadr item))) "item1")))))) (ert-deftest jabber-pubsub-test-request-iq-structure () "Request items builds correct IQ get." (jabber-pubsub-test-with-mock-iq (jabber-pubsub-request 'fake-jc "pubsub.example.com" "mynode" #'ignore) (let* ((args jabber-pubsub-test--captured-args) (query (plist-get args :query))) (should (string= (plist-get args :type) "get")) (let ((items (nth 2 query))) (should (eq (car items) 'items)) (should (string= (cdr (assq 'node (cadr items))) "mynode")))))) (ert-deftest jabber-pubsub-test-delete-node-iq-structure () "Delete node builds correct IQ set with owner xmlns." (jabber-pubsub-test-with-mock-iq (jabber-pubsub-delete-node 'fake-jc "pubsub.example.com" "mynode") (let* ((args jabber-pubsub-test--captured-args) (query (plist-get args :query))) (should (string= (plist-get args :type) "set")) (should (string= (cdr (assq 'xmlns (cadr query))) jabber-pubsub-owner-xmlns)) (let ((delete (nth 2 query))) (should (eq (car delete) 'delete)) (should (string= (cdr (assq 'node (cadr delete))) "mynode")))))) (ert-deftest jabber-pubsub-test-configure-node-iq-structure () "Configure node builds correct IQ set with data form." (jabber-pubsub-test-with-mock-iq (jabber-pubsub-configure-node 'fake-jc "pubsub.example.com" "mynode" '(("pubsub#access_model" . "open"))) (let* ((args jabber-pubsub-test--captured-args) (query (plist-get args :query))) (should (string= (plist-get args :type) "set")) (should (string= (cdr (assq 'xmlns (cadr query))) jabber-pubsub-owner-xmlns)) (let* ((configure (nth 2 query)) (x-form (nth 2 configure)) (fields (cl-remove-if-not (lambda (c) (and (listp c) (eq (car c) 'field))) (cddr x-form)))) (should (eq (car configure) 'configure)) (should (string= (cdr (assq 'node (cadr configure))) "mynode")) ;; FORM_TYPE + 1 option (should (= (length fields) 2)) ;; Check FORM_TYPE value (let* ((ft-field (car fields)) (ft-value (nth 2 (nth 2 ft-field)))) (should (string= ft-value "http://jabber.org/protocol/pubsub#node_config"))))))) (provide 'jabber-pubsub-tests) ;;; jabber-pubsub-tests.el ends here emacs-jabber/tests/jabber-receipts-tests.el000066400000000000000000000475231516610113500212700ustar00rootroot00000000000000;;; jabber-receipts-tests.el --- Tests for jabber-receipts -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-receipts) (require 'jabber-db) ;;; Group 1: Send hook (ert-deftest jabber-receipts-test-send-hook-adds-elements () "Send hook appends request and markable elements." (let ((result (jabber-receipts--send-hook "hello" "msg-001"))) (should (assq 'request result)) (should (assq 'markable result)))) (ert-deftest jabber-receipts-test-send-hook-correct-xmlns () "Send hook elements have correct xmlns attributes." (let* ((result (jabber-receipts--send-hook "test" "id-1")) (request (assq 'request result)) (markable (assq 'markable result))) (should (string= "urn:xmpp:receipts" (cdr (assq 'xmlns (cadr request))))) (should (string= "urn:xmpp:chat-markers:0" (cdr (assq 'xmlns (cadr markable))))))) ;;; Group 2: Incoming receipt handling (ert-deftest jabber-receipts-test-handle-xep0184-received () "Incoming XEP-0184 received stanza updates delivered_at in DB." (let ((updated-id nil) (updated-col nil)) (cl-letf (((symbol-function 'jabber-db-update-receipt) (lambda (_acct _peer id col _ts) (setq updated-id id updated-col col))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "me@example.com")) ((symbol-function 'jabber-chat-get-buffer) (lambda (_from &optional _jc) "*test-chat*"))) (jabber-receipts--handle-message 'fake-jc '(message ((from . "them@example.com") (type . "chat")) (received ((xmlns . "urn:xmpp:receipts") (id . "msg-001")))))) (should (equal updated-id "msg-001")) (should (equal updated-col "delivered_at")))) (ert-deftest jabber-receipts-test-handle-xep0333-displayed () "Incoming XEP-0333 displayed stanza updates displayed_at in DB." (let ((updated-id nil) (updated-col nil)) (cl-letf (((symbol-function 'jabber-db-update-receipt) (lambda (_acct _peer id col _ts) (setq updated-id id updated-col col))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "me@example.com")) ((symbol-function 'jabber-chat-get-buffer) (lambda (_from &optional _jc) "*test-chat*"))) (jabber-receipts--handle-message 'fake-jc '(message ((from . "them@example.com") (type . "chat")) (displayed ((xmlns . "urn:xmpp:chat-markers:0") (id . "msg-002")))))) (should (equal updated-id "msg-002")) (should (equal updated-col "displayed_at")))) (ert-deftest jabber-receipts-test-handle-ignores-non-receipt () "Messages without receipt elements are ignored." (let ((updated nil)) (cl-letf (((symbol-function 'jabber-db-update-receipt) (lambda (&rest _args) (setq updated t))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "me@example.com"))) (jabber-receipts--handle-message 'fake-jc '(message ((from . "them@example.com") (type . "chat")) (body nil "hello")))) (should-not updated))) ;;; Group 3: Sending receipts back (ert-deftest jabber-receipts-test-send-received-on-request () "Incoming message with triggers response." (let ((sent-sexp nil)) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc sexp) (setq sent-sexp sexp))) ((symbol-function 'jabber-db-update-receipt) #'ignore) ((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "me@example.com")) ((symbol-function 'jabber-chat-get-buffer) (lambda (_from &optional _jc) "*test-chat*"))) (let ((jabber-chat-send-receipts t)) (jabber-receipts--handle-message 'fake-jc '(message ((from . "them@example.com") (id . "msg-100") (type . "chat")) (body nil "hello") (request ((xmlns . "urn:xmpp:receipts"))))))) (should sent-sexp) ;; Verify it's a stanza (should (eq 'message (car sent-sexp))) (let ((children (cddr sent-sexp))) (should (assq 'received children))))) (ert-deftest jabber-receipts-test-no-received-when-disabled () "No sent when jabber-chat-send-receipts is nil." (let ((sent-sexp nil)) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc sexp) (setq sent-sexp sexp))) ((symbol-function 'jabber-db-update-receipt) #'ignore) ((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "me@example.com")) ((symbol-function 'jabber-chat-get-buffer) (lambda (_from &optional _jc) "*test-chat*"))) (let ((jabber-chat-send-receipts nil)) (jabber-receipts--handle-message 'fake-jc '(message ((from . "them@example.com") (id . "msg-100") (type . "chat")) (body nil "hello") (request ((xmlns . "urn:xmpp:receipts"))))))) (should-not sent-sexp))) (ert-deftest jabber-receipts-test-no-received-without-request () "No sent for messages without element." (let ((sent-sexp nil)) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc sexp) (setq sent-sexp sexp))) ((symbol-function 'jabber-db-update-receipt) #'ignore) ((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "me@example.com")) ((symbol-function 'jabber-chat-get-buffer) (lambda (_from &optional _jc) "*test-chat*"))) (let ((jabber-chat-send-receipts t)) (jabber-receipts--handle-message 'fake-jc '(message ((from . "them@example.com") (id . "msg-100") (type . "chat")) (body nil "hello"))))) (should-not sent-sexp))) (ert-deftest jabber-receipts-test-no-received-for-markable-only () "No sent for messages with only but no ." (let ((sent-sexp nil)) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc sexp) (setq sent-sexp sexp))) ((symbol-function 'jabber-db-update-receipt) #'ignore) ((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "me@example.com")) ((symbol-function 'jabber-chat-get-buffer) (lambda (_from &optional _jc) "*test-chat*"))) (let ((jabber-chat-send-receipts t)) (jabber-receipts--handle-message 'fake-jc `(message ((from . "them@example.com") (id . "msg-100") (type . "chat")) (body nil "hello") (markable ((xmlns . ,jabber-chat-markers-xmlns))))))) (should-not sent-sexp))) (ert-deftest jabber-receipts-test-markable-sets-pending-id () "Incoming markable message sets pending displayed ID." (cl-letf (((symbol-function 'jabber-db-update-receipt) #'ignore) ((symbol-function 'jabber-send-sexp-if-connected) #'ignore) ((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "me@example.com")) ((symbol-function 'jabber-chat-get-buffer) (lambda (_from &optional _jc) (buffer-name)))) (with-temp-buffer (setq-local jabber-receipts--pending-displayed-id nil) (let ((jabber-chat-send-receipts t)) (jabber-receipts--handle-message 'fake-jc `(message ((from . "them@example.com") (id . "msg-200") (type . "chat")) (body nil "hello") (markable ((xmlns . ,jabber-chat-markers-xmlns)))))) (should (equal "msg-200" jabber-receipts--pending-displayed-id))))) ;;; Group 4: Header-line update (ert-deftest jabber-receipts-test-header-line-delivered () "Header-line shows delivered with correct face." (with-temp-buffer (setq-local jabber-chat-receipt-message "") (jabber-receipts--update-header-line "delivered_at" 1700000000) (should (string-match-p "delivered" jabber-chat-receipt-message)) (should (eq 'jabber-chat-delivered (get-text-property 0 'face jabber-chat-receipt-message))))) (ert-deftest jabber-receipts-test-header-line-seen () "Header-line shows seen with correct face." (with-temp-buffer (setq-local jabber-chat-receipt-message "") (jabber-receipts--update-header-line "displayed_at" 1700000000) (should (string-match-p "seen" jabber-chat-receipt-message)) (should (eq 'jabber-chat-seen (get-text-property 0 'face jabber-chat-receipt-message))))) (ert-deftest jabber-receipts-test-header-line-no-downgrade () "Header-line does not downgrade from seen to delivered." (with-temp-buffer (setq-local jabber-chat-receipt-message "") (jabber-receipts--update-header-line "displayed_at" 1700000000) (should (string-match-p "seen" jabber-chat-receipt-message)) ;; Now try to downgrade to delivered (jabber-receipts--update-header-line "delivered_at" 1700000001) (should (string-match-p "seen" jabber-chat-receipt-message)) (should-not (string-match-p "delivered" jabber-chat-receipt-message)))) ;;; Group 5: EWOC cascade (ert-deftest jabber-receipts-test-ewoc-cascade-promotes-delivered () "Cascade promotes all prior :delivered nodes to :displayed." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (m1 (list :local (list :id "m1" :status :delivered :timestamp (encode-time 0 0 10 1 1 2026)))) (m2 (list :local (list :id "m2" :status :delivered :timestamp (encode-time 0 1 10 1 1 2026)))) (m3 (list :local (list :id "m3" :status :displayed :timestamp (encode-time 0 2 10 1 1 2026)))) (_n1 (ewoc-enter-last jabber-chat-ewoc m1)) (_n2 (ewoc-enter-last jabber-chat-ewoc m2)) (n3 (ewoc-enter-last jabber-chat-ewoc m3))) (let ((inhibit-read-only t)) (jabber-receipts--cascade-displayed n3)) (should (eq :displayed (plist-get (cadr m1) :status))) (should (eq :displayed (plist-get (cadr m2) :status)))))) (ert-deftest jabber-receipts-test-ewoc-cascade-stops-at-displayed () "Cascade stops walking when it hits an already-displayed node." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (m1 (list :local (list :id "m1" :status :delivered :timestamp (encode-time 0 0 10 1 1 2026)))) (m2 (list :local (list :id "m2" :status :displayed :timestamp (encode-time 0 1 10 1 1 2026)))) (m3 (list :local (list :id "m3" :status :delivered :timestamp (encode-time 0 2 10 1 1 2026)))) (m4 (list :local (list :id "m4" :status :displayed :timestamp (encode-time 0 3 10 1 1 2026)))) (_n1 (ewoc-enter-last jabber-chat-ewoc m1)) (_n2 (ewoc-enter-last jabber-chat-ewoc m2)) (_n3 (ewoc-enter-last jabber-chat-ewoc m3)) (n4 (ewoc-enter-last jabber-chat-ewoc m4))) (let ((inhibit-read-only t)) (jabber-receipts--cascade-displayed n4)) ;; m3 promoted (should (eq :displayed (plist-get (cadr m3) :status))) ;; m2 was already displayed, stops there (should (eq :displayed (plist-get (cadr m2) :status))) ;; m1 NOT promoted (before the already-displayed m2) (should (eq :delivered (plist-get (cadr m1) :status)))))) (ert-deftest jabber-receipts-test-ewoc-cascade-skips-foreign () "Cascade skips :foreign nodes and only promotes :local ones." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (m1 (list :local (list :id "m1" :status :delivered :timestamp (encode-time 0 0 10 1 1 2026)))) (m2 (list :foreign (list :id "m2" :timestamp (encode-time 0 1 10 1 1 2026)))) (m3 (list :local (list :id "m3" :status :displayed :timestamp (encode-time 0 2 10 1 1 2026)))) (_n1 (ewoc-enter-last jabber-chat-ewoc m1)) (_n2 (ewoc-enter-last jabber-chat-ewoc m2)) (n3 (ewoc-enter-last jabber-chat-ewoc m3))) (let ((inhibit-read-only t)) (jabber-receipts--cascade-displayed n3)) (should (eq :displayed (plist-get (cadr m1) :status))) ;; foreign node untouched (should-not (plist-get (cadr m2) :status))))) (ert-deftest jabber-receipts-test-ewoc-cascade-skips-sent () "Cascade does not promote :sent nodes (not yet delivered)." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (m1 (list :local (list :id "m1" :status :sent :timestamp (encode-time 0 0 10 1 1 2026)))) (m2 (list :local (list :id "m2" :status :delivered :timestamp (encode-time 0 1 10 1 1 2026)))) (m3 (list :local (list :id "m3" :status :displayed :timestamp (encode-time 0 2 10 1 1 2026)))) (_n1 (ewoc-enter-last jabber-chat-ewoc m1)) (_n2 (ewoc-enter-last jabber-chat-ewoc m2)) (n3 (ewoc-enter-last jabber-chat-ewoc m3))) (let ((inhibit-read-only t)) (jabber-receipts--cascade-displayed n3)) (should (eq :displayed (plist-get (cadr m2) :status))) ;; :sent stays :sent (should (eq :sent (plist-get (cadr m1) :status)))))) ;;; Group 6: DB cascade (ert-deftest jabber-receipts-test-db-cascade-marks-all-delivered () "DB cascade marks all delivered outgoing messages as displayed." (let* ((dir (make-temp-file "jabber-receipts-test" t)) (jabber-db-path (expand-file-name "test.sqlite" dir)) (jabber-db--connection nil) (jabber-backlog-days 3.0) (jabber-backlog-number 10)) (unwind-protect (progn (jabber-db-ensure-open) ;; Store 3 outgoing messages (jabber-db-store-message "me@example.com" "them@example.com" "out" "chat" "msg1" 1000 nil "id-1" ) (jabber-db-store-message "me@example.com" "them@example.com" "out" "chat" "msg2" 1001 nil "id-2" ) (jabber-db-store-message "me@example.com" "them@example.com" "out" "chat" "msg3" 1002 nil "id-3" ) ;; Mark all as delivered (jabber-db-update-receipt "me@example.com" "them@example.com" "id-1" "delivered_at" 1010) (jabber-db-update-receipt "me@example.com" "them@example.com" "id-2" "delivered_at" 1011) (jabber-db-update-receipt "me@example.com" "them@example.com" "id-3" "delivered_at" 1012) ;; Cascade displayed from msg3 (jabber-db-cascade-displayed "me@example.com" "them@example.com" 2000 1002) ;; All 3 should have displayed_at (let ((rows (sqlite-select jabber-db--connection "SELECT stanza_id, displayed_at FROM message ORDER BY timestamp"))) (should (= 3 (length rows))) (should (= 2000 (cadr (nth 0 rows)))) (should (= 2000 (cadr (nth 1 rows)))) (should (= 2000 (cadr (nth 2 rows)))))) (jabber-db-close) (when (file-directory-p dir) (delete-directory dir t))))) (ert-deftest jabber-receipts-test-db-cascade-skips-undelivered () "DB cascade skips messages without delivered_at." (let* ((dir (make-temp-file "jabber-receipts-test" t)) (jabber-db-path (expand-file-name "test.sqlite" dir)) (jabber-db--connection nil) (jabber-backlog-days 3.0) (jabber-backlog-number 10)) (unwind-protect (progn (jabber-db-ensure-open) (jabber-db-store-message "me@example.com" "them@example.com" "out" "chat" "msg1" 1000 nil "id-1" ) (jabber-db-store-message "me@example.com" "them@example.com" "out" "chat" "msg2" 1001 nil "id-2" ) (jabber-db-store-message "me@example.com" "them@example.com" "out" "chat" "msg3" 1002 nil "id-3" ) ;; Only mark msg1 and msg3 as delivered (msg2 undelivered) (jabber-db-update-receipt "me@example.com" "them@example.com" "id-1" "delivered_at" 1010) (jabber-db-update-receipt "me@example.com" "them@example.com" "id-3" "delivered_at" 1012) ;; Cascade displayed from msg3 (jabber-db-cascade-displayed "me@example.com" "them@example.com" 2000 1002) (let ((rows (sqlite-select jabber-db--connection "SELECT stanza_id, displayed_at FROM message ORDER BY timestamp"))) ;; msg1 displayed (delivered + before ref-ts) (should (= 2000 (cadr (nth 0 rows)))) ;; msg2 NOT displayed (not delivered) (should (null (cadr (nth 1 rows)))) ;; msg3 displayed (delivered + at ref-ts) (should (= 2000 (cadr (nth 2 rows)))))) (jabber-db-close) (when (file-directory-p dir) (delete-directory dir t))))) ;;; Group 7: MUC guards and edge cases (ert-deftest jabber-receipts-test-groupchat-skips-receipt-processing () "Groupchat messages do not trigger receipt updates." (let ((updated nil)) (cl-letf (((symbol-function 'jabber-db-update-receipt) (lambda (&rest _args) (setq updated t))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "me@example.com"))) (jabber-receipts--handle-message 'fake-jc '(message ((from . "room@conference.example.com/nick") (type . "groupchat")) (received ((xmlns . "urn:xmpp:receipts") (id . "msg-001")))))) (should-not updated))) (ert-deftest jabber-receipts-test-nil-type-does-not-crash () "Messages without type attribute do not crash." (let ((updated-id nil)) (cl-letf (((symbol-function 'jabber-db-update-receipt) (lambda (_acct _peer id _col _ts) (setq updated-id id))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "me@example.com")) ((symbol-function 'jabber-chat-get-buffer) (lambda (_from &optional _jc) "*test-chat*"))) (jabber-receipts--handle-message 'fake-jc '(message ((from . "them@example.com")) (received ((xmlns . "urn:xmpp:receipts") (id . "msg-nil-type")))))) (should (equal updated-id "msg-nil-type")))) (ert-deftest jabber-receipts-test-xep0333-received-marker () "XEP-0333 marker updates delivered_at." (let ((updated-id nil) (updated-col nil)) (cl-letf (((symbol-function 'jabber-db-update-receipt) (lambda (_acct _peer id col _ts) (setq updated-id id updated-col col))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_j) "me@example.com")) ((symbol-function 'jabber-chat-get-buffer) (lambda (_from &optional _jc) "*test-chat*"))) (jabber-receipts--handle-message 'fake-jc '(message ((from . "them@example.com") (type . "chat")) (received ((xmlns . "urn:xmpp:chat-markers:0") (id . "msg-333")))))) (should (equal updated-id "msg-333")) (should (equal updated-col "delivered_at")))) (ert-deftest jabber-receipts-test-send-hook-muc-no-request () "Send hook in MUC groupchat adds markable but no request." (with-temp-buffer (setq-local jabber-group "room@conference.example.com") (let ((result (jabber-receipts--send-hook "hello" "msg-001"))) (should (assq 'markable result)) (should-not (assq 'request result))))) (provide 'jabber-receipts-tests) ;;; jabber-receipts-tests.el ends here emacs-jabber/tests/jabber-roster-tests.el000066400000000000000000000261421516610113500207620ustar00rootroot00000000000000;;; jabber-roster-tests.el --- Tests for jabber-roster -*- lexical-binding: t; -*- (require 'ert) ;; Pre-define variables that jabber-muc.el expects at load time: (defvar jabber-body-printers nil) (defvar jabber-message-chain nil) (defvar jabber-presence-chain nil) (defvar jabber-iq-chain nil) (defvar jabber-jid-obarray (make-vector 127 0)) (require 'jabber-roster) (require 'jabber-muc) (defmacro jabber-muc-test-with-rooms (rooms &rest body) "Run BODY with ROOMS as active groupchats. ROOMS is an alist of (group . nickname). Each room gets a single entry with JC=nil." (declare (indent 1)) `(let ((jabber-muc--rooms (make-hash-table :test #'equal))) (dolist (r ,rooms) (puthash (car r) (list (cons nil (cdr r))) jabber-muc--rooms)) ,@body)) ;;; Group 1: jabber-roster-sort-by-status (ert-deftest jabber-test-roster-sort-by-status-online-vs-away () "Online user sorts before away user." (let ((jabber-sort-order '("chat" "" "away" "dnd" "xa")) (a (make-symbol "alice@example.com")) (b (make-symbol "bob@example.com"))) (put a 'show "") (put b 'show "away") (should (< (jabber-roster-sort-by-status a b) 0)))) (ert-deftest jabber-test-roster-sort-by-status-same () "Same status returns 0." (let ((jabber-sort-order '("chat" "" "away" "dnd" "xa")) (a (make-symbol "alice@example.com")) (b (make-symbol "bob@example.com"))) (put a 'show "away") (put b 'show "away") (should (= (jabber-roster-sort-by-status a b) 0)))) (ert-deftest jabber-test-roster-sort-by-status-offline-last () "Offline (nil show) sorts after online." (let ((jabber-sort-order '("chat" "" "away" "dnd" "xa")) (a (make-symbol "alice@example.com")) (b (make-symbol "bob@example.com"))) (put a 'show nil) (put b 'show "") (should (> (jabber-roster-sort-by-status a b) 0)))) ;;; Group 2: jabber-roster-sort-by-displayname (ert-deftest jabber-test-roster-sort-by-displayname-order () "Alphabetical ordering by display name." (let ((jabber-jid-obarray (make-vector 127 0)) (a (intern "alice@example.com" (make-vector 127 0))) (b (intern "bob@example.com" (make-vector 127 0)))) (put a 'name "Alice") (put b 'name "Bob") (should (< (jabber-roster-sort-by-displayname a b) 0)))) (ert-deftest jabber-test-roster-sort-by-displayname-equal () "Same name returns 0." (let ((jabber-jid-obarray (make-vector 127 0)) (a (intern "alice@example.com" (make-vector 127 0))) (b (intern "alice2@example.com" (make-vector 127 0)))) (put a 'name "Alice") (put b 'name "Alice") (should (= (jabber-roster-sort-by-displayname a b) 0)))) ;;; Group 3: jabber-roster-sort-by-group (ert-deftest jabber-test-roster-sort-by-group-different () "Different groups sort alphabetically." (let ((a (make-symbol "alice@example.com")) (b (make-symbol "bob@example.com"))) (put a 'groups '("Friends")) (put b 'groups '("Work")) (should (< (jabber-roster-sort-by-group a b) 0)))) (ert-deftest jabber-test-roster-sort-by-group-same () "Same group returns 0." (let ((a (make-symbol "alice@example.com")) (b (make-symbol "bob@example.com"))) (put a 'groups '("Friends")) (put b 'groups '("Friends")) (should (= (jabber-roster-sort-by-group a b) 0)))) (ert-deftest jabber-test-roster-sort-by-group-no-group () "No group falls back to empty string." (let ((a (make-symbol "alice@example.com")) (b (make-symbol "bob@example.com"))) (put a 'groups nil) (put b 'groups '("Work")) (should (< (jabber-roster-sort-by-group a b) 0)))) ;;; Group 4: jabber-fix-status (ert-deftest jabber-test-fix-status-trailing-newlines () "Trailing newlines are removed." (let ((jabber-remove-newlines nil)) (should (string= (jabber-fix-status "Hello\n\n") "Hello")))) (ert-deftest jabber-test-fix-status-internal-newlines-removed () "Internal newlines removed when jabber-remove-newlines is t." (let ((jabber-remove-newlines t)) (should (string= (jabber-fix-status "line1\nline2") "line1 line2")))) (ert-deftest jabber-test-fix-status-internal-newlines-kept () "Internal newlines kept when jabber-remove-newlines is nil." (let ((jabber-remove-newlines nil)) (should (string= (jabber-fix-status "line1\nline2") "line1\nline2")))) (ert-deftest jabber-test-fix-status-nil () "Nil input returns nil." (should (null (jabber-fix-status nil)))) ;;; Group 5: jabber-roster-filter-display (ert-deftest jabber-test-roster-filter-show-offline () "All buddies shown when jabber-show-offline-contacts is t." (let ((jabber-show-offline-contacts t) (a (make-symbol "alice@example.com")) (b (make-symbol "bob@example.com"))) (put a 'connected t) (put b 'connected nil) (should (= (length (jabber-roster-filter-display (list a b))) 2)))) (ert-deftest jabber-test-roster-filter-hide-offline () "Only connected buddies shown when jabber-show-offline-contacts is nil." (let ((jabber-show-offline-contacts nil) (a (make-symbol "alice@example.com")) (b (make-symbol "bob@example.com"))) (put a 'connected t) (put b 'connected nil) (should (= (length (jabber-roster-filter-display (list a b))) 1)) (should (eq (car (jabber-roster-filter-display (list a b))) a)))) (ert-deftest jabber-test-roster-filter-empty-list () "Empty input returns empty list." (let ((jabber-show-offline-contacts t)) (should (null (jabber-roster-filter-display nil))))) ;;; Group 6: jabber-roster-separator (ert-deftest jabber-test-roster-separator-has-face () "Separator string has jabber-separator face." (let ((sep (jabber-roster-separator))) (should (eq (get-text-property 0 'face sep) 'jabber-separator)))) (ert-deftest jabber-test-roster-separator-is-intangible () "Separator string has cursor-intangible property." (let ((sep (jabber-roster-separator))) (should (get-text-property 0 'cursor-intangible sep)))) (ert-deftest jabber-test-roster-separator-nonempty () "Separator string is at least 1 character." (let ((sep (jabber-roster-separator))) (should (>= (length sep) 1)))) ;;; Group 7: jabber-roster-mode (ert-deftest jabber-test-roster-mode-derived-from-special () "jabber-roster-mode derives from special-mode." (with-temp-buffer (jabber-roster-mode) (should (derived-mode-p 'special-mode)))) (ert-deftest jabber-test-roster-mode-read-only () "Roster buffer is read-only." (with-temp-buffer (jabber-roster-mode) (should buffer-read-only))) (ert-deftest jabber-test-roster-mode-no-line-numbers () "Line numbers are disabled in roster mode." (with-temp-buffer (jabber-roster-mode) (should (null display-line-numbers)))) (ert-deftest jabber-test-roster-mode-margins () "Left margin is set." (with-temp-buffer (jabber-roster-mode) (should (= left-margin-width 1)))) (ert-deftest jabber-test-roster-mode-no-fringes () "Fringes are disabled." (with-temp-buffer (jabber-roster-mode) (should (= left-fringe-width 0)) (should (= right-fringe-width 0)))) (ert-deftest jabber-test-roster-mode-imenu () "imenu index function is set." (with-temp-buffer (jabber-roster-mode) (should (eq imenu-create-index-function #'jabber-roster-imenu-create-index)))) ;;; Group 8: jabber-roster-mode keymap (ert-deftest jabber-test-roster-keymap-delete-bindings () "d, D, and C-k all bind to delete." (should (eq (lookup-key jabber-roster-mode-map "d") #'jabber-roster-delete-at-point)) (should (eq (lookup-key jabber-roster-mode-map "D") #'jabber-roster-delete-at-point)) (should (eq (lookup-key jabber-roster-mode-map (kbd "C-k")) #'jabber-roster-delete-at-point))) (ert-deftest jabber-test-roster-keymap-help-bindings () "h, H, and ? all bind to jabber-roster-menu." (should (eq (lookup-key jabber-roster-mode-map "h") #'jabber-roster-menu)) (should (eq (lookup-key jabber-roster-mode-map "H") #'jabber-roster-menu)) (should (eq (lookup-key jabber-roster-mode-map "?") #'jabber-roster-menu))) (ert-deftest jabber-test-roster-keymap-inherits-common () "Roster keymap inherits C-c C-c from jabber-common-keymap." (should (eq (lookup-key jabber-roster-mode-map (kbd "C-c C-c")) #'jabber-chat-menu))) ;;; Group 9: Face definitions (ert-deftest jabber-test-roster-faces-use-inherit () "Modernized roster faces use :inherit." (dolist (face-spec '((jabber-roster-user-online . success) (jabber-roster-user-away . warning) (jabber-roster-user-xa . shadow) (jabber-roster-user-dnd . error) (jabber-roster-user-error . error) (jabber-roster-user-offline . shadow) (jabber-roster-groupchat . font-lock-type-face) (jabber-roster-groupchat-nick . shadow) (jabber-roster-unread . font-lock-warning-face))) (let* ((face (car face-spec)) (expected-parent (cdr face-spec)) (spec (face-default-spec face))) (should (facep face)) (when expected-parent (let* ((attrs (cdar spec)) (inherit (plist-get attrs :inherit))) (should (eq inherit expected-parent))))))) ;;; Group 10: jabber-roster-imenu-create-index (ert-deftest jabber-test-roster-imenu-contacts () "Imenu indexes contact groups and JIDs." (jabber-muc-test-with-rooms nil (with-temp-buffer (let ((line1 "Friends") (line2 "alice@example.com")) (insert (propertize line1 'jabber-group "Friends") "\n") (insert (propertize line2 'jabber-jid "alice@example.com") "\n")) (let ((index (jabber-roster-imenu-create-index))) (should (assoc "Contacts" index)) (let ((contacts (cdr (assoc "Contacts" index)))) (should (assoc "Friends" contacts)) (should (assoc "alice@example.com" contacts))))))) (ert-deftest jabber-test-roster-imenu-groupchats () "Imenu indexes groupchat JIDs under Groupchats." (jabber-muc-test-with-rooms '(("room@conference.example.com" . "mynick")) (with-temp-buffer (insert (propertize "Groupchats" 'jabber-group "Groupchats") "\n") (insert (propertize "room@conference.example.com" 'jabber-jid "room@conference.example.com") "\n") (let ((index (jabber-roster-imenu-create-index))) (should (assoc "Groupchats" index)) (let ((gcs (cdr (assoc "Groupchats" index)))) (should (assoc "Groupchats" gcs)) (should (assoc "room@conference.example.com" gcs))))))) (ert-deftest jabber-test-roster-imenu-empty-buffer () "Empty buffer returns nil index." (jabber-muc-test-with-rooms nil (with-temp-buffer (should (null (jabber-roster-imenu-create-index)))))) ;;; Group 11: Deferred refresh (ert-deftest jabber-test-roster-needs-refresh-default-nil () "Deferred refresh flag starts as nil." (should (null jabber-roster--needs-refresh))) (ert-deftest jabber-test-roster-last-muc-generation-default-zero () "MUC generation counter starts at zero." (should (= jabber-roster--last-muc-generation 0))) (provide 'jabber-roster-tests) ;;; jabber-roster-tests.el ends here emacs-jabber/tests/jabber-sm-tests.el000066400000000000000000000606071516610113500200670ustar00rootroot00000000000000;;; jabber-sm-tests.el --- Tests for jabber-sm -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-xml) (require 'jabber-sm) ;;; Counter arithmetic (ert-deftest jabber-sm-test-inc-counter () "Incrementing a counter adds one." (should (= (jabber-sm--inc-counter 0) 1)) (should (= (jabber-sm--inc-counter 41) 42))) (ert-deftest jabber-sm-test-inc-counter-wraps () "Counter wraps at 2^32." (should (= (jabber-sm--inc-counter (1- (expt 2 32))) 0))) (ert-deftest jabber-sm-test-counter-delta () "Forward distance between counters." (should (= (jabber-sm--counter-delta 5 3) 2)) (should (= (jabber-sm--counter-delta 0 (1- (expt 2 32))) 1))) (ert-deftest jabber-sm-test-counter-<= () "Counter comparison with wraparound." (should (jabber-sm--counter-<= 3 5)) (should (jabber-sm--counter-<= 3 3)) (should-not (jabber-sm--counter-<= 5 3)) ;; Wraparound: counter near max is "before" counter near 0 (should (jabber-sm--counter-<= (- (expt 2 32) 2) 1))) ;;; Predicates (ert-deftest jabber-sm-test-r-p () "Detect SM element." (should (jabber-sm--r-p '(r ((xmlns . "urn:xmpp:sm:3"))))) (should-not (jabber-sm--r-p '(r ((xmlns . "wrong"))))) (should-not (jabber-sm--r-p '(a ((xmlns . "urn:xmpp:sm:3")))))) (ert-deftest jabber-sm-test-a-p () "Detect SM element." (should (jabber-sm--a-p '(a ((xmlns . "urn:xmpp:sm:3") (h . "5"))))) (should-not (jabber-sm--a-p '(r ((xmlns . "urn:xmpp:sm:3")))))) (ert-deftest jabber-sm-test-enabled-p () "Detect SM element." (should (jabber-sm--enabled-p '(enabled ((xmlns . "urn:xmpp:sm:3") (id . "abc") (resume . "true")))))) (ert-deftest jabber-sm-test-resumed-p () "Detect SM element." (should (jabber-sm--resumed-p '(resumed ((xmlns . "urn:xmpp:sm:3") (h . "5") (previd . "abc")))))) (ert-deftest jabber-sm-test-failed-p () "Detect SM element." (should (jabber-sm--failed-p '(failed ((xmlns . "urn:xmpp:sm:3")))))) ;;; State-data reset (ert-deftest jabber-sm-test-reset () "Reset clears all SM keys to defaults." (let* ((sd (list :username "test" :sm-enabled t :sm-outbound-count 42)) (result (jabber-sm--reset sd))) (should-not (plist-get result :sm-enabled)) (should (= (plist-get result :sm-outbound-count) 0)) (should (= (plist-get result :sm-inbound-count) 0)) (should (null (plist-get result :sm-outbound-queue))) ;; Non-SM keys preserved (should (equal (plist-get result :username) "test")))) ;;; Features check (ert-deftest jabber-sm-test-features-have-sm () "Detect SM in stream features." (let ((sd (list :stream-features '(features ((xmlns . "http://etherx.jabber.org/streams")) (bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind"))) (sm ((xmlns . "urn:xmpp:sm:3"))))))) (should (jabber-sm--features-have-sm-p sd)))) (ert-deftest jabber-sm-test-features-no-sm () "No SM in stream features." (let ((sd (list :stream-features '(features ((xmlns . "http://etherx.jabber.org/streams")) (bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind"))))))) (should-not (jabber-sm--features-have-sm-p sd)))) (ert-deftest jabber-sm-test-features-nil () "Nil stream features." (should-not (jabber-sm--features-have-sm-p '(:stream-features nil)))) ;;; Stanza counting (ert-deftest jabber-sm-test-count-outbound-message () "Outbound message increments counter and queues." (let* ((sd (list :sm-enabled t :sm-outbound-count 0 :sm-outbound-queue nil)) (msg '(message ((to . "bob@example.com")) (body () "hi"))) (result (jabber-sm--count-outbound sd msg))) (should (= (plist-get result :sm-outbound-count) 1)) (should (= (length (plist-get result :sm-outbound-queue)) 1)) (should (equal (cdar (plist-get result :sm-outbound-queue)) msg)))) (ert-deftest jabber-sm-test-count-outbound-iq () "Outbound iq increments counter." (let* ((sd (list :sm-enabled t :sm-outbound-count 5 :sm-outbound-queue nil)) (iq '(iq ((type . "get") (id . "1")) (query ((xmlns . "test"))))) (result (jabber-sm--count-outbound sd iq))) (should (= (plist-get result :sm-outbound-count) 6)))) (ert-deftest jabber-sm-test-count-outbound-disabled () "No counting when SM is disabled." (let* ((sd (list :sm-enabled nil :sm-outbound-count 0 :sm-outbound-queue nil)) (msg '(message ((to . "bob@example.com")) (body () "hi"))) (result (jabber-sm--count-outbound sd msg))) (should (= (plist-get result :sm-outbound-count) 0)) (should (null (plist-get result :sm-outbound-queue))))) (ert-deftest jabber-sm-test-count-outbound-non-stanza () "SM elements are not counted." (let* ((sd (list :sm-enabled t :sm-outbound-count 0 :sm-outbound-queue nil)) (r '(r ((xmlns . "urn:xmpp:sm:3")))) (result (jabber-sm--count-outbound sd r))) (should (= (plist-get result :sm-outbound-count) 0)))) (ert-deftest jabber-sm-test-count-inbound () "Inbound stanza increments counter." (let* ((sd (list :sm-enabled t :sm-inbound-count 0)) (msg '(message ((from . "bob@example.com")) (body () "hi"))) (result (jabber-sm--count-inbound nil sd msg))) (should (= (plist-get result :sm-inbound-count) 1)))) (ert-deftest jabber-sm-test-count-inbound-disabled () "No counting when SM is disabled." (let* ((sd (list :sm-enabled nil :sm-inbound-count 0)) (msg '(message ((from . "bob@example.com")) (body () "hi"))) (result (jabber-sm--count-inbound nil sd msg))) (should (= (plist-get result :sm-inbound-count) 0)))) (ert-deftest jabber-sm-test-proactive-ack () "Proactive ack is sent when inbound counter hits the interval." (let* ((jabber-sm-ack-interval 3) (sd (list :sm-enabled t :sm-inbound-count 2)) (msg '(message ((from . "bob@example.com")) (body () "hi"))) (ack-sent nil)) (cl-letf (((symbol-function 'jabber-sm--send-ack) (lambda (_jc _sd) (setq ack-sent t)))) (jabber-sm--count-inbound 'fake-jc sd msg)) (should ack-sent))) (ert-deftest jabber-sm-test-proactive-ack-not-at-interval () "No proactive ack when counter is not at the interval boundary." (let* ((jabber-sm-ack-interval 3) (sd (list :sm-enabled t :sm-inbound-count 0)) (msg '(message ((from . "bob@example.com")) (body () "hi"))) (ack-sent nil)) (cl-letf (((symbol-function 'jabber-sm--send-ack) (lambda (_jc _sd) (setq ack-sent t)))) (jabber-sm--count-inbound 'fake-jc sd msg)) (should-not ack-sent))) (ert-deftest jabber-sm-test-proactive-ack-disabled () "No proactive ack when jabber-sm-ack-interval is nil." (let* ((jabber-sm-ack-interval nil) (sd (list :sm-enabled t :sm-inbound-count 2)) (msg '(message ((from . "bob@example.com")) (body () "hi"))) (ack-sent nil)) (cl-letf (((symbol-function 'jabber-sm--send-ack) (lambda (_jc _sd) (setq ack-sent t)))) (jabber-sm--count-inbound 'fake-jc sd msg)) (should-not ack-sent))) ;;; Queue pruning and ack processing (ert-deftest jabber-sm-test-prune-queue () "Prune removes entries with count <= h." (let* ((queue (list (cons 1 'a) (cons 2 'b) (cons 3 'c) (cons 4 'd))) (result (jabber-sm--prune-queue queue 2))) (should (= (length result) 2)) (should (= (caar result) 3)))) (ert-deftest jabber-sm-test-prune-queue-empty () "Prune on empty queue returns empty." (should (null (jabber-sm--prune-queue nil 5)))) (ert-deftest jabber-sm-test-process-ack () "Processing prunes queue and updates last-acked." (let* ((sd (list :sm-enabled t :sm-outbound-count 3 :sm-outbound-queue (list (cons 1 'a) (cons 2 'b) (cons 3 'c)) :sm-last-acked 0)) (ack '(a ((xmlns . "urn:xmpp:sm:3") (h . "2")))) (result (jabber-sm--process-ack sd ack))) (should (= (plist-get result :sm-last-acked) 2)) (should (= (length (plist-get result :sm-outbound-queue)) 1)) (should (= (caar (plist-get result :sm-outbound-queue)) 3)))) ;;; FSM routing helper (ert-deftest jabber-sm-test-maybe-enable-with-sm () "Route to :sm-enable when SM is available." (let ((jabber-sm-enable t) (sd (list :stream-features '(features ((xmlns . "http://etherx.jabber.org/streams")) (sm ((xmlns . "urn:xmpp:sm:3"))))))) (should (eq (car (jabber-sm--maybe-enable-or-establish sd)) :sm-enable)))) (ert-deftest jabber-sm-test-maybe-enable-without-sm () "Route to :session-established when SM is not in features." (let ((jabber-sm-enable t) (sd (list :stream-features '(features ((xmlns . "http://etherx.jabber.org/streams")))))) (should (eq (car (jabber-sm--maybe-enable-or-establish sd)) :session-established)))) (ert-deftest jabber-sm-test-maybe-enable-disabled () "Route to :session-established when SM is disabled by user." (let ((jabber-sm-enable nil) (sd (list :stream-features '(features ((xmlns . "http://etherx.jabber.org/streams")) (sm ((xmlns . "urn:xmpp:sm:3"))))))) (should (eq (car (jabber-sm--maybe-enable-or-establish sd)) :session-established)))) ;;; Enable/resume XML generation (ert-deftest jabber-sm-test-make-enable-xml () "Enable XML matches expected format." (should (string-match-p "enable" (jabber-sm--make-enable-xml))) (should (string-match-p "resume='true'" (jabber-sm--make-enable-xml)))) (ert-deftest jabber-sm-test-make-resume-xml () "Resume XML includes h and previd." (let ((xml (jabber-sm--make-resume-xml 42 "session-123"))) (should (string-match-p "h='42'" xml)) (should (string-match-p "previd='session-123'" xml)))) (ert-deftest jabber-sm-test-parse-enabled () "Parse stanza with resume=true." (let ((info (jabber-sm--parse-enabled '(enabled ((xmlns . "urn:xmpp:sm:3") (id . "abc-123") (resume . "true") (max . "300")))))) (should (equal (plist-get info :id) "abc-123")) (should (plist-get info :resume)) (should (= (plist-get info :max) 300)))) (ert-deftest jabber-sm-test-parse-enabled-resume-1 () "Parse stanza with resume=1." (let ((info (jabber-sm--parse-enabled '(enabled ((xmlns . "urn:xmpp:sm:3") (id . "xyz") (resume . "1")))))) (should (plist-get info :resume)))) (ert-deftest jabber-sm-test-parse-enabled-no-resume () "Parse stanza without resume attribute." (let ((info (jabber-sm--parse-enabled '(enabled ((xmlns . "urn:xmpp:sm:3") (id . "xyz-456")))))) (should (equal (plist-get info :id) "xyz-456")) (should-not (plist-get info :resume)) (should-not (plist-get info :max)))) (ert-deftest jabber-sm-test-apply-enabled-with-resume () "Apply enabled info with resume granted." (let* ((sd (list :sm-enabled nil :sm-id nil :sm-resume-max nil)) (info (list :id "abc" :resume '("true") :max 300)) (result (jabber-sm--apply-enabled sd info))) (should (eq (plist-get result :sm-enabled) t)) (should (equal (plist-get result :sm-id) "abc")) (should (= (plist-get result :sm-resume-max) 300)))) (ert-deftest jabber-sm-test-apply-enabled-no-resume () "Apply enabled info without resume: sm-id stays nil." (let* ((sd (list :sm-enabled nil :sm-id nil :sm-resume-max nil)) (info (list :id "abc" :resume nil :max nil)) (result (jabber-sm--apply-enabled sd info))) (should (eq (plist-get result :sm-enabled) t)) (should-not (plist-get result :sm-id)))) ;;; Resume handling (ert-deftest jabber-sm-test-handle-resumed () "Handle prunes queue and returns stanzas to resend." (let* ((msg-a '(message ((to . "a@x")) (body () "a"))) (msg-b '(message ((to . "b@x")) (body () "b"))) (msg-c '(message ((to . "c@x")) (body () "c"))) (sd (list :sm-enabled t :sm-outbound-queue (list (cons 1 msg-a) (cons 2 msg-b) (cons 3 msg-c)) :sm-last-acked 0 :sm-resumed nil :sm-resuming t)) (resumed '(resumed ((xmlns . "urn:xmpp:sm:3") (h . "1") (previd . "abc")))) (result (jabber-sm--handle-resumed sd resumed))) ;; state-data updated (should (= (plist-get (car result) :sm-last-acked) 1)) (should (= (plist-get (car result) :sm-outbound-count) 1)) (should (null (plist-get (car result) :sm-outbound-queue))) (should (eq (plist-get (car result) :sm-resumed) t)) (should-not (plist-get (car result) :sm-resuming)) ;; stanzas to resend: entries 2 and 3 (should (= (length (cdr result)) 2)) (should (equal (car (cdr result)) msg-b)) (should (equal (cadr (cdr result)) msg-c)))) (ert-deftest jabber-sm-test-handle-resumed-all-acked () "All stanzas acked means nothing to resend." (let* ((sd (list :sm-enabled t :sm-outbound-queue (list (cons 1 'a) (cons 2 'b)) :sm-last-acked 0 :sm-resumed nil :sm-resuming t)) (resumed '(resumed ((xmlns . "urn:xmpp:sm:3") (h . "5") (previd . "abc")))) (result (jabber-sm--handle-resumed sd resumed))) (should (null (cdr result))))) (ert-deftest jabber-sm-test-handle-resumed-counter-reset () "Outbound counter resets to server h, preventing drift on resend." (let* ((msg-a '(message ((to . "a@x")) (body () "a"))) (msg-b '(message ((to . "b@x")) (body () "b"))) (msg-c '(message ((to . "c@x")) (body () "c"))) (sd (list :sm-enabled t :sm-outbound-count 10 :sm-outbound-queue (list (cons 8 msg-a) (cons 9 msg-b) (cons 10 msg-c)) :sm-last-acked 7 :sm-resumed nil :sm-resuming t)) (resumed '(resumed ((xmlns . "urn:xmpp:sm:3") (h . "8") (previd . "s1")))) (result (jabber-sm--handle-resumed sd resumed)) (new-sd (car result)) (to-resend (cdr result))) ;; Counter must reset to server's h so resent stanzas start from 8 (should (= (plist-get new-sd :sm-outbound-count) 8)) ;; Two stanzas to resend (9 and 10 were unacked) (should (= (length to-resend) 2)) ;; After resending, count-outbound increments from 8 to 9, 10 ;; rather than from 10 to 11, 12 (the old drift bug) (let ((after-resend new-sd)) (dolist (sexp to-resend) (setq after-resend (jabber-sm--count-outbound after-resend sexp))) (should (= (plist-get after-resend :sm-outbound-count) 10))))) ;;; Ack XML generation (ert-deftest jabber-sm-test-make-ack-xml () "Ack XML includes h value." (should (string-match-p "h='7'" (jabber-sm--make-ack-xml 7)))) (ert-deftest jabber-sm-test-make-request-xml () "Request XML is well-formed." (should (string-match-p " classify as quote." (should (eq 'quote (jabber-styling--classify-block "> quoted text")))) (ert-deftest jabber-styling-test-classify-pre-open () "Lines starting with ``` with extra text classify as pre-open." (should (eq 'pre-open (jabber-styling--classify-block "```python")))) (ert-deftest jabber-styling-test-classify-pre-close () "Bare ``` line classifies as pre-close." (should (eq 'pre-close (jabber-styling--classify-block "```")))) (ert-deftest jabber-styling-test-classify-pre-close-not-open () "```python should not close a pre block." (should (not (eq 'pre-close (jabber-styling--classify-block "```python"))))) ;;; Group 2: jabber-styling--parse-spans (ert-deftest jabber-styling-test-span-bold () "Asterisks produce bold span." (let ((spans (jabber-styling--parse-spans "*bold*"))) (should (equal '((0 6 jabber-styling-bold)) spans)))) (ert-deftest jabber-styling-test-span-italic () "Underscores produce italic span." (let ((spans (jabber-styling--parse-spans "_italic_"))) (should (equal '((0 8 jabber-styling-italic)) spans)))) (ert-deftest jabber-styling-test-span-strike () "Tildes produce strikethrough span." (let ((spans (jabber-styling--parse-spans "~strike~"))) (should (equal '((0 8 jabber-styling-strike)) spans)))) (ert-deftest jabber-styling-test-span-pre () "Backticks produce preformatted span." (let ((spans (jabber-styling--parse-spans "`code`"))) (should (equal '((0 6 jabber-styling-pre)) spans)))) (ert-deftest jabber-styling-test-span-mid-line () "Span in the middle of text after whitespace." (let ((spans (jabber-styling--parse-spans "hello *world* end"))) (should (equal '((6 13 jabber-styling-bold)) spans)))) (ert-deftest jabber-styling-test-span-multiple () "Multiple different spans on one line." (let ((spans (jabber-styling--parse-spans "*bold* and _italic_"))) (should (equal 2 (length spans))) (should (equal '(0 6 jabber-styling-bold) (nth 0 spans))) (should (equal '(11 19 jabber-styling-italic) (nth 1 spans))))) (ert-deftest jabber-styling-test-span-lazy-matching () "Lazy matching: *a* b *c* produces two separate bold spans." (let ((spans (jabber-styling--parse-spans "*a* b *c*"))) (should (equal 2 (length spans))) (should (equal '(0 3 jabber-styling-bold) (nth 0 spans))) (should (equal '(6 9 jabber-styling-bold) (nth 1 spans))))) (ert-deftest jabber-styling-test-span-strong-plain-star () "Spec example: *strong*plain* produces one bold span." (let ((spans (jabber-styling--parse-spans "*strong*plain*"))) (should (equal 1 (length spans))) (should (equal '(0 8 jabber-styling-bold) (car spans))))) (ert-deftest jabber-styling-test-span-empty-rejected () "Empty span ** is not valid." (let ((spans (jabber-styling--parse-spans "**"))) (should (null spans)))) (ert-deftest jabber-styling-test-span-triple-star () "*** produces bold with * as content (lazy match, spec ambiguous)." (let ((spans (jabber-styling--parse-spans "***"))) (should (equal '((0 3 jabber-styling-bold)) spans)))) (ert-deftest jabber-styling-test-span-quad-star () "**** produces bold with ** as content (lazy match, spec ambiguous)." (let ((spans (jabber-styling--parse-spans "****"))) (should (equal '((0 3 jabber-styling-bold)) spans)))) (ert-deftest jabber-styling-test-span-no-close () "Unclosed span produces no styling." (let ((spans (jabber-styling--parse-spans "*no close"))) (should (null spans)))) (ert-deftest jabber-styling-test-span-whitespace-after-open () "Opening directive followed by whitespace is invalid." (let ((spans (jabber-styling--parse-spans "* not bold*"))) (should (null spans)))) (ert-deftest jabber-styling-test-span-whitespace-before-close () "Closing directive preceded by whitespace is invalid." (let ((spans (jabber-styling--parse-spans "*not bold *"))) (should (null spans)))) (ert-deftest jabber-styling-test-span-not-after-nonwhitespace () "Opening directive after non-whitespace char is not valid." (let ((spans (jabber-styling--parse-spans "foo*bar*"))) (should (null spans)))) (ert-deftest jabber-styling-test-span-after-directive () "Opening directive after another opening directive is valid." (let ((spans (jabber-styling--parse-spans "*_bold-italic_*"))) (should (>= (length spans) 1)))) ;;; Group 3: jabber-styling--parse-blocks (ert-deftest jabber-styling-test-blocks-plain () "Single plain line." (let ((blocks (jabber-styling--parse-blocks "hello\n"))) (should (equal '((plain 0 6)) blocks)))) (ert-deftest jabber-styling-test-blocks-quote () "Block quote line." (let ((blocks (jabber-styling--parse-blocks "> quoted\n"))) (should (equal '((quote 0 9)) blocks)))) (ert-deftest jabber-styling-test-blocks-pre () "Preformatted code block with exact ``` closing." (let ((blocks (jabber-styling--parse-blocks "```\ncode here\n```\n"))) (should (equal 1 (length blocks))) (should (eq 'pre (caar blocks))))) (ert-deftest jabber-styling-test-blocks-pre-language-no-close () "```python does not close a pre block opened by ```." (let ((blocks (jabber-styling--parse-blocks "```\ncode\n```python\n```\n"))) ;; Should be one pre block (``` to final ```) (should (equal 1 (length blocks))) (should (eq 'pre (caar blocks))))) (ert-deftest jabber-styling-test-blocks-pre-unclosed () "Unclosed preformatted block extends to end." (let ((blocks (jabber-styling--parse-blocks "```\ncode\nmore\n"))) (should (equal 1 (length blocks))) (should (eq 'pre (caar blocks))))) (ert-deftest jabber-styling-test-blocks-mixed () "Mixed block types." (let ((blocks (jabber-styling--parse-blocks "> quote\nplain\n"))) (should (equal 2 (length blocks))) (should (eq 'quote (car (nth 0 blocks)))) (should (eq 'plain (car (nth 1 blocks)))))) ;;; Group 4: jabber-styling--strip-quote-prefix (ert-deftest jabber-styling-test-strip-quote-space () "Strip > followed by space." (should (equal "text" (jabber-styling--strip-quote-prefix "> text")))) (ert-deftest jabber-styling-test-strip-quote-no-space () "Strip > not followed by space." (should (equal "text" (jabber-styling--strip-quote-prefix ">text")))) (ert-deftest jabber-styling-test-strip-quote-bare () "Strip bare >." (should (equal "" (jabber-styling--strip-quote-prefix ">")))) ;;; Group 5: jabber-styling--apply-region (integration) (ert-deftest jabber-styling-test-apply-bold-face () "Bold text gets jabber-styling-bold face." (with-temp-buffer (insert "hello *world* end") (jabber-styling--apply-region (point-min) (point-max)) (goto-char 7) ;; inside *world* (let ((face (get-text-property (point) 'face))) (should (memq 'jabber-styling-bold (if (listp face) face (list face))))))) (ert-deftest jabber-styling-test-apply-quote-face () "Quote lines get jabber-styling-quote face." (with-temp-buffer (insert "> quoted text\n") (jabber-styling--apply-region (point-min) (point-max)) (goto-char 2) (let ((face (get-text-property (point) 'face))) (should (memq 'jabber-styling-quote (if (listp face) face (list face))))))) (ert-deftest jabber-styling-test-apply-pre-block-face () "Pre block gets jabber-styling-pre-block face." (with-temp-buffer (insert "```\ncode\n```\n") (jabber-styling--apply-region (point-min) (point-max)) (goto-char 5) ;; inside code (let ((face (get-text-property (point) 'face))) (should (memq 'jabber-styling-pre-block (if (listp face) face (list face))))))) (ert-deftest jabber-styling-test-no-spans-in-pre () "Spans inside preformatted blocks are not styled." (with-temp-buffer (insert "```\n*not bold*\n```\n") (jabber-styling--apply-region (point-min) (point-max)) (goto-char 6) ;; inside *not bold* (let ((face (get-text-property (point) 'face))) (should (not (memq 'jabber-styling-bold (if (listp face) face (list face)))))))) (ert-deftest jabber-styling-test-apply-bold-inside-quote () "Bold spans inside block quotes are styled." (with-temp-buffer (insert "> *bold* text\n") (jabber-styling--apply-region (point-min) (point-max)) ;; Position 3 is inside *bold* (after "> ") (goto-char 3) (let ((face (get-text-property (point) 'face))) (should (memq 'jabber-styling-bold (if (listp face) face (list face))))))) (ert-deftest jabber-styling-test-apply-lazy-two-bolds () "Lazy matching produces two bold spans in buffer." (with-temp-buffer (insert "*a* and *b*") (jabber-styling--apply-region (point-min) (point-max)) ;; Position 2 (inside *a*) (goto-char 2) (let ((face (get-text-property (point) 'face))) (should (memq 'jabber-styling-bold (if (listp face) face (list face))))) ;; Position 10 (inside *b*) (goto-char 10) (let ((face (get-text-property (point) 'face))) (should (memq 'jabber-styling-bold (if (listp face) face (list face))))) ;; Position 5 (plain " and ") should not be bold (goto-char 5) (let ((face (get-text-property (point) 'face))) (should (not (memq 'jabber-styling-bold (if (listp face) face (list face)))))))) ;;; Group 6: jabber-styling--remove-faces (ert-deftest jabber-styling-test-remove-faces-bold () "Remove-faces strips jabber-styling-bold from a region." (with-temp-buffer (insert (propertize "bold" 'face 'jabber-styling-bold)) (jabber-styling--remove-faces (point-min) (point-max)) (should (null (get-text-property 1 'face))))) (ert-deftest jabber-styling-test-remove-faces-preserves-other () "Remove-faces preserves non-styling faces." (with-temp-buffer (insert (propertize "text" 'face '(jabber-styling-bold jabber-chat-text-foreign))) (jabber-styling--remove-faces (point-min) (point-max)) (should (equal 'jabber-chat-text-foreign (get-text-property 1 'face))))) (ert-deftest jabber-styling-test-remove-faces-multiple () "Remove-faces strips multiple styling faces, keeps the rest." (with-temp-buffer (insert (propertize "text" 'face '(jabber-styling-bold jabber-styling-italic shadow))) (jabber-styling--remove-faces (point-min) (point-max)) (should (equal 'shadow (get-text-property 1 'face))))) (ert-deftest jabber-styling-test-remove-faces-no-styling () "Remove-faces is a no-op when no styling faces are present." (with-temp-buffer (insert (propertize "text" 'face 'shadow)) (jabber-styling--remove-faces (point-min) (point-max)) (should (equal 'shadow (get-text-property 1 'face))))) (ert-deftest jabber-styling-test-remove-then-reapply () "Remove-faces followed by apply-region re-applies styling cleanly." (with-temp-buffer (insert "*bold* text") (jabber-styling--apply-region (point-min) (point-max)) ;; First verify bold is applied (should (memq 'jabber-styling-bold (let ((f (get-text-property 2 'face))) (if (listp f) f (list f))))) ;; Remove and re-apply (jabber-styling--remove-faces (point-min) (point-max)) (should (null (get-text-property 2 'face))) (jabber-styling--apply-region (point-min) (point-max)) (should (memq 'jabber-styling-bold (let ((f (get-text-property 2 'face))) (if (listp f) f (list f))))))) (provide 'jabber-styling-tests) ;;; jabber-styling-tests.el ends here emacs-jabber/tests/jabber-transient-tests.el000066400000000000000000000037701516610113500214550ustar00rootroot00000000000000;;; jabber-transient-tests.el --- Tests for transient menu integration -*- lexical-binding: t; -*- (require 'ert) (require 'jabber) (require 'jabber-autoloads) (require 'transient) ;;; Helpers (defun jabber-test--extract-suffix-commands (layout) "Recursively extract command symbols from transient LAYOUT." (let (commands) (cond ((null layout) nil) ((and (listp layout) (symbolp (car layout)) (memq (car layout) '(transient-suffix transient-switch transient-option))) ;; Suffix entry: (:key ... :command CMD ...) (let ((cmd (plist-get (cdr layout) :command))) (when (and cmd (symbolp cmd)) (push cmd commands)))) ((vectorp layout) (dotimes (i (length layout)) (setq commands (nconc commands (jabber-test--extract-suffix-commands (aref layout i)))))) ((listp layout) (dolist (elt layout) (setq commands (nconc commands (jabber-test--extract-suffix-commands elt)))))) commands)) ;;; Tests (ert-deftest jabber-test-transient-suffixes-defined () "Every command in a jabber transient menu must be fboundp. Catches the bug where a transient suffix references a command whose module is neither required nor autoloaded." (let ((prefixes '(jabber-chat-operations-menu jabber-chat-encryption-menu jabber-chat-menu jabber-roster-context-menu jabber-info-menu jabber-muc-menu jabber-service-menu jabber-roster-menu)) (missing nil)) (dolist (prefix prefixes) (let ((layout (get prefix 'transient--layout))) (dolist (cmd (jabber-test--extract-suffix-commands layout)) (unless (fboundp cmd) (push (format "%s (in %s)" cmd prefix) missing))))) (should (null missing)))) (provide 'jabber-transient-tests) ;;; jabber-transient-tests.el ends here emacs-jabber/tests/jabber-util-tests.el000066400000000000000000000233231516610113500204170ustar00rootroot00000000000000;;; jabber-util-tests.el --- Tests for jabber-util -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-util) (defvar jabber-jid-obarray (make-vector 127 0)) ;;; Group 1: JID functions (ert-deftest jabber-test-jid-username-normal () "Extract username from full JID." (should (string= (jabber-jid-username "alice@example.com/home") "alice"))) (ert-deftest jabber-test-jid-username-bare () "Extract username from bare JID." (should (string= (jabber-jid-username "alice@example.com") "alice"))) (ert-deftest jabber-test-jid-username-no-at () "Return nil for server-only JID." (should (null (jabber-jid-username "example.com")))) (ert-deftest jabber-test-jid-user-full () "Extract bare JID from full JID." (should (string= (jabber-jid-user "alice@example.com/home") "alice@example.com"))) (ert-deftest jabber-test-jid-user-bare () "Bare JID returned unchanged." (should (string= (jabber-jid-user "alice@example.com") "alice@example.com"))) (ert-deftest jabber-test-jid-user-transport () "Transport JID (no @) returns the server part." (should (string= (jabber-jid-user "transport.example.com") "transport.example.com"))) (ert-deftest jabber-test-jid-server-normal () "Extract server from normal JID." (should (string= (jabber-jid-server "alice@example.com/home") "example.com"))) (ert-deftest jabber-test-jid-server-bare () "Extract server from bare JID." (should (string= (jabber-jid-server "alice@example.com") "example.com"))) (ert-deftest jabber-test-jid-server-no-at () "Extract server from server-only JID." (should (string= (jabber-jid-server "example.com") "example.com"))) (ert-deftest jabber-test-jid-resource-present () "Extract resource from full JID." (should (string= (jabber-jid-resource "alice@example.com/home") "home"))) (ert-deftest jabber-test-jid-resource-absent () "Return nil when no resource." (should (null (jabber-jid-resource "alice@example.com")))) (ert-deftest jabber-test-jid-resource-multiple-slashes () "Resource can contain slashes." (should (string= (jabber-jid-resource "alice@example.com/home/desk") "home/desk"))) (ert-deftest jabber-test-jid-symbol-string () "Intern a JID string into jabber-jid-obarray." (let ((jabber-jid-obarray (make-vector 127 0))) (let ((sym (jabber-jid-symbol "Alice@Example.COM/Home"))) (should (symbolp sym)) (should (string= (symbol-name sym) "alice@example.com"))))) (ert-deftest jabber-test-jid-symbol-passthrough () "Symbol input passes through unchanged." (let ((jabber-jid-obarray (make-vector 127 0))) (let ((sym 'already-a-symbol)) (should (eq (jabber-jid-symbol sym) sym))))) ;;; Group 2: time functions (ert-deftest jabber-test-encode-time-format () "Encode a known time value to XEP-0082 string." (let ((time (encode-time '(0 0 0 1 1 2024 nil -1 0)))) (should (string= (jabber-encode-time time) "2024-01-01T00:00:00Z")))) (ert-deftest jabber-test-parse-legacy-time () "Parse legacy ccyymmddThh:mm:ss format." (let ((result (jabber-parse-legacy-time "20240101T12:30:45"))) (should result) ;; jabber-parse-legacy-time interprets as local time (let ((expected (encode-time '(45 30 12 1 1 2024 nil -1 nil)))) (should (= (float-time result) (float-time expected)))))) (ert-deftest jabber-test-encode-legacy-time () "Encode a time value to legacy format in UTC." (let ((time (encode-time '(45 30 12 1 1 2024 nil -1 0)))) (should (string= (jabber-encode-legacy-time time) "20240101T12:30:45")))) (ert-deftest jabber-test-legacy-time-encode-produces-utc () "Legacy encode outputs UTC representation." ;; Encode a known UTC time and verify the output (let ((time (encode-time '(0 0 15 25 2 2024 nil -1 0)))) (should (string= (jabber-encode-legacy-time time) "20240225T15:00:00")))) (ert-deftest jabber-test-parse-time-encode-time-roundtrip () "XEP-0082 parse then encode roundtrip." (let* ((stamp "2024-02-25T23:32:40Z") (parsed (jabber-parse-time stamp)) (encoded (jabber-encode-time parsed))) (should (string= encoded "2024-02-25T23:32:40Z")))) ;;; Group 3: IQ helpers (ert-deftest jabber-test-iq-query-normal () "Extract query child from IQ stanza." (let ((iq '(iq ((type . "result")) (query ((xmlns . "jabber:iq:roster")) (item ((jid . "bob@example.com"))))))) (should (eq (jabber-xml-node-name (jabber-iq-query iq)) 'query)))) (ert-deftest jabber-test-iq-query-skips-error () "Query extraction skips error child." (let ((iq '(iq ((type . "error")) (query ((xmlns . "jabber:iq:roster"))) (error ((type . "cancel")))))) (should (eq (jabber-xml-node-name (jabber-iq-query iq)) 'query)))) (ert-deftest jabber-test-iq-query-no-children () "Return nil when IQ has no query child." (let ((iq '(iq ((type . "result"))))) (should (null (jabber-iq-query iq))))) (ert-deftest jabber-test-iq-error-present () "Extract error child from IQ stanza." (let ((iq '(iq ((type . "error")) (query nil) (error ((type . "cancel")) (item-not-found ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))))) (should (eq (jabber-xml-node-name (jabber-iq-error iq)) 'error)))) (ert-deftest jabber-test-iq-error-absent () "Return nil when IQ has no error." (let ((iq '(iq ((type . "result")) (query nil)))) (should (null (jabber-iq-error iq))))) (ert-deftest jabber-test-iq-xmlns () "Extract namespace of query child." (let ((iq '(iq ((type . "get")) (query ((xmlns . "jabber:iq:roster")))))) (should (string= (jabber-iq-xmlns iq) "jabber:iq:roster")))) ;;; Group 4: jabber-x-delay (ert-deftest jabber-test-x-delay-xep0203 () "Parse XEP-0203 delay element." (let ((delay '(delay ((xmlns . "urn:xmpp:delay") (stamp . "2024-02-25T23:32:40Z"))))) (should (jabber-x-delay delay)))) (ert-deftest jabber-test-x-delay-xep0091 () "Parse XEP-0091 legacy delay element." (let ((delay '(x ((xmlns . "jabber:x:delay") (stamp . "20240225T23:32:40"))))) (should (jabber-x-delay delay)))) (ert-deftest jabber-test-x-delay-none () "Return nil when no delay info present." (let ((node '(body ((xmlns . "jabber:client"))))) (should (null (jabber-x-delay node))))) ;;; Group 5: error parsing (ert-deftest jabber-test-parse-error-new-style () "Parse new-style error with type and condition." (let ((err '(error ((type . "cancel")) (item-not-found ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))))) (should (string= (jabber-parse-error err) "Item not found")))) (ert-deftest jabber-test-parse-error-new-style-with-text () "Parse new-style error with text." (let ((err '(error ((type . "cancel")) (item-not-found ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))) (text ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")) "The item was not found")))) (should (string-match-p "Item not found" (jabber-parse-error err))) (should (string-match-p "The item was not found" (jabber-parse-error err))))) (ert-deftest jabber-test-parse-error-legacy () "Parse legacy error with code." (let ((err '(error ((code . "404")) "Not found"))) (should (string-match-p "Not found" (jabber-parse-error err))))) (ert-deftest jabber-test-error-condition () "Extract condition symbol from error." (let ((err '(error ((type . "cancel")) (item-not-found ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))))) (should (eq (jabber-error-condition err) 'item-not-found)))) (ert-deftest jabber-test-stream-error-condition () "Extract condition from stream error." (let ((err '(stream:error nil (host-unknown ((xmlns . "urn:ietf:params:xml:ns:xmpp-streams")))))) (should (eq (jabber-stream-error-condition err) 'host-unknown)))) (ert-deftest jabber-test-parse-stream-error () "Parse stream error to human-readable string." (let ((err '(stream:error nil (host-unknown ((xmlns . "urn:ietf:params:xml:ns:xmpp-streams")))))) (should (string= (jabber-parse-stream-error err) "Host unknown")))) (ert-deftest jabber-test-parse-stream-error-with-text () "Parse stream error with text child." (let ((err '(stream:error nil (host-unknown ((xmlns . "urn:ietf:params:xml:ns:xmpp-streams"))) (text nil "No such host")))) (should (string-match-p "Host unknown" (jabber-parse-stream-error err))) (should (string-match-p "No such host" (jabber-parse-stream-error err))))) ;;; Group 6: other pure functions (ert-deftest jabber-test-unhex () "Decode hex-encoded UTF-8 string." (should (string= (jabber-unhex "hello%20world") "hello world"))) (ert-deftest jabber-test-string>-numerical-greater () "Larger number returns t." (should (string>-numerical "200" "100"))) (ert-deftest jabber-test-string>-numerical-less () "Smaller number returns nil." (should-not (string>-numerical "50" "100"))) (ert-deftest jabber-test-string>-numerical-equal () "Equal numbers return nil." (should-not (string>-numerical "100" "100"))) (ert-deftest jabber-test-string>-numerical-longer () "Longer string (more digits) is greater." (should (string>-numerical "1000" "999"))) (ert-deftest jabber-test-signal-error () "jabber-signal-error signals jabber-error condition." (should-error (jabber-signal-error "Cancel" 'item-not-found "Not found") :type 'jabber-error)) (ert-deftest jabber-test-tree-map () "Apply function to all atoms in a tree." (should (equal (jabber-tree-map #'1+ '(1 (2 3) 4)) '(2 (3 4) 5)))) (provide 'jabber-util-tests) ;;; jabber-util-tests.el ends here emacs-jabber/tests/jabber-xml-tests.el000066400000000000000000000236671516610113500202550ustar00rootroot00000000000000;;; jabber-xml-tests.el --- Tests for jabber-xml -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-xml) ;;; Group 1: jabber-escape-xml / jabber-unescape-xml (ert-deftest jabber-test-escape-xml-special-chars () "Escape ampersand, angle brackets, quotes and apostrophes." (should (string= (jabber-escape-xml "&<>\"'") "&<>"'"))) (ert-deftest jabber-test-escape-xml-plain-string () "Plain strings pass through unchanged." (should (string= (jabber-escape-xml "hello world") "hello world"))) (ert-deftest jabber-test-escape-xml-nil () "Non-string input is returned as-is." (should (eq (jabber-escape-xml nil) nil))) (ert-deftest jabber-test-escape-xml-control-chars () "Control characters are replaced with spaces." (should (string= (jabber-escape-xml "\x01\x02") " "))) (ert-deftest jabber-test-escape-xml-form-feed () "Form feed is replaced with newline." (should (string= (jabber-escape-xml "a\fb") "a\nb"))) (ert-deftest jabber-test-unescape-xml-entities () "Unescape XML entities back to characters." (should (string= (jabber-unescape-xml "&<>"'") "&<>\"'"))) (ert-deftest jabber-test-unescape-xml-nil () "Non-string input is returned as-is." (should (eq (jabber-unescape-xml nil) nil))) (ert-deftest jabber-test-escape-unescape-roundtrip () "Escaping then unescaping produces the original string." (let ((input "Tom & Jerry say \"hi\" & 'bye'")) (should (string= (jabber-unescape-xml (jabber-escape-xml input)) input)))) ;;; Group 2: jabber-sexp2xml (ert-deftest jabber-test-sexp2xml-self-closing () "Self-closing tag with no children." (should (string= (jabber-sexp2xml '(br nil)) "
"))) (ert-deftest jabber-test-sexp2xml-with-attributes () "Tag with attributes and no children." (should (string= (jabber-sexp2xml '(stream ((to . "example.com") (xmlns . "jabber:client")))) ""))) (ert-deftest jabber-test-sexp2xml-with-children () "Tag with text children." (should (string= (jabber-sexp2xml '(body nil "Hello")) "Hello"))) (ert-deftest jabber-test-sexp2xml-nested () "Nested tags." (should (string= (jabber-sexp2xml '(message ((to . "bob@example.com")) (body nil "Hi"))) "Hi"))) (ert-deftest jabber-test-sexp2xml-string-input () "String input is XML-escaped." (should (string= (jabber-sexp2xml "a"))) ;;; Group 3: node accessors (ert-deftest jabber-test-xml-node-name () "Extract tag name from node." (should (eq (jabber-xml-node-name '(message ((type . "chat")) "hi")) 'message))) (ert-deftest jabber-test-xml-node-name-nil () "Non-list input returns nil." (should (eq (jabber-xml-node-name "string") nil))) (ert-deftest jabber-test-xml-node-attributes () "Extract attributes alist from node." (should (equal (jabber-xml-node-attributes '(iq ((type . "get") (id . "1")))) '((type . "get") (id . "1"))))) (ert-deftest jabber-test-xml-node-children () "Extract children from node." (should (equal (jabber-xml-node-children '(body nil "Hello")) '("Hello")))) (ert-deftest jabber-test-xml-node-children-empty-string-bug () "Work around old xml.el bug where children are ((\"\"))." (should (null (jabber-xml-node-children '(tag nil ("")))))) ;;; Group 4: jabber-xml-get-children (ert-deftest jabber-test-xml-get-children-found () "Find children by tag name." (let ((node '(iq nil (query nil "data") (error nil "oops")))) (should (equal (jabber-xml-get-children node 'query) '((query nil "data")))))) (ert-deftest jabber-test-xml-get-children-missing () "Return nil when tag not found." (let ((node '(iq nil (query nil)))) (should (null (jabber-xml-get-children node 'error))))) (ert-deftest jabber-test-xml-get-children-multiple () "Return all children with matching tag." (let ((node '(parent nil (item nil "a") (item nil "b")))) (should (= (length (jabber-xml-get-children node 'item)) 2)))) ;;; Group 5: jabber-xml-get-attribute / jabber-xml-get-xmlns (ert-deftest jabber-test-xml-get-attribute-present () "Get attribute value when present." (should (string= (jabber-xml-get-attribute '(iq ((type . "result"))) 'type) "result"))) (ert-deftest jabber-test-xml-get-attribute-missing () "Return nil when attribute not found." (should (null (jabber-xml-get-attribute '(iq ((type . "result"))) 'id)))) (ert-deftest jabber-test-xml-get-attribute-nil-node () "Return nil for non-cons node." (should (null (jabber-xml-get-attribute nil 'type)))) (ert-deftest jabber-test-xml-get-xmlns-present () "Get xmlns attribute." (should (string= (jabber-xml-get-xmlns '(query ((xmlns . "jabber:iq:roster")))) "jabber:iq:roster"))) (ert-deftest jabber-test-xml-get-xmlns-absent () "Return nil when xmlns not present." (should (null (jabber-xml-get-xmlns '(query nil))))) ;;; Group 6: jabber-xml-child-with-xmlns (ert-deftest jabber-test-xml-child-with-xmlns-found () "Find child element by xmlns." (let ((node '(message nil (x ((xmlns . "jabber:x:oob")) (url () "http://example.com")) (body () "text")))) (should (equal (jabber-xml-node-name (jabber-xml-child-with-xmlns node "jabber:x:oob")) 'x)))) (ert-deftest jabber-test-xml-child-with-xmlns-missing () "Return nil when no child has the given xmlns." (let ((node '(message nil (body () "text")))) (should-not (jabber-xml-child-with-xmlns node "jabber:x:oob")))) (ert-deftest jabber-test-xml-child-with-xmlns-nil-node () "Return nil for nil node." (should-not (jabber-xml-child-with-xmlns nil "jabber:x:oob"))) (ert-deftest jabber-test-xml-child-with-xmlns-skips-strings () "String children are skipped without error." (let ((node '(body nil "just text"))) (should-not (jabber-xml-child-with-xmlns node "some:ns")))) ;;; Group 7: jabber-xml-path (ert-deftest jabber-test-xml-path-symbol () "Navigate to child by symbol name." (let ((xml '(iq nil (query nil "data")))) (should (equal (jabber-xml-path xml '(query)) '(query nil "data"))))) (ert-deftest jabber-test-xml-path-string () "String step extracts character data." (let ((xml '(body nil "Hello"))) (should (string= (jabber-xml-path xml '("")) "Hello")))) (ert-deftest jabber-test-xml-path-multi-step () "Multi-step path navigation." (let ((xml '(iq nil (query nil (item ((jid . "bob@example.com"))))))) (should (equal (jabber-xml-node-name (jabber-xml-path xml '(query item))) 'item)))) (ert-deftest jabber-test-xml-path-cons-namespace () "Navigate using cons (namespace . name) step." (let ((xml '(message nil (delay ((xmlns . "urn:xmpp:delay") (stamp . "2024-01-01T00:00:00Z")))))) (should (equal (jabber-xml-node-name (jabber-xml-path xml '(("urn:xmpp:delay" . "delay")))) 'delay)))) (ert-deftest jabber-test-xml-path-missing () "Return nil for non-existent path." (let ((xml '(iq nil (query nil)))) (should (null (jabber-xml-path xml '(error)))))) ;;; Group 8: jabber-xml-skip-tag-forward (ert-deftest jabber-test-skip-tag-forward-self-closing () "Skip past a self-closing tag." (with-temp-buffer (insert "
") (goto-char (point-min)) (should (eq (catch 'unfinished (jabber-xml-skip-tag-forward)) t)) (should (= (point) (point-max))))) (ert-deftest jabber-test-skip-tag-forward-paired () "Skip past a paired open/close tag." (with-temp-buffer (insert "Hello") (goto-char (point-min)) (should (eq (catch 'unfinished (jabber-xml-skip-tag-forward)) t)) (should (= (point) (point-max))))) (ert-deftest jabber-test-skip-tag-forward-nested () "Skip past nested tags." (with-temp-buffer (insert "Hi") (goto-char (point-min)) (should (eq (catch 'unfinished (jabber-xml-skip-tag-forward)) t)) (should (= (point) (point-max))))) (ert-deftest jabber-test-skip-tag-forward-cdata () "Skip past CDATA section." (with-temp-buffer (insert "]]>") (goto-char (point-min)) (should (catch 'unfinished (jabber-xml-skip-tag-forward))) (should (= (point) (point-max))))) (ert-deftest jabber-test-skip-tag-forward-incomplete () "Throw unfinished for incomplete tag." (with-temp-buffer (insert "Hi") (goto-char (point-min)) (should-not (catch 'unfinished (jabber-xml-skip-tag-forward))))) ;;; Group 9: jabber-xml-parse-next-stanza (ert-deftest jabber-test-parse-next-stanza-complete () "Parse a complete XML stanza." (with-temp-buffer (insert "Hi") (let ((result (jabber-xml-parse-next-stanza))) (should result) (should (eq (jabber-xml-node-name (car result)) 'message))))) (ert-deftest jabber-test-parse-next-stanza-incomplete () "Return nil for incomplete stanza." (with-temp-buffer (insert "Hi") (should (null (jabber-xml-parse-next-stanza))))) (ert-deftest jabber-test-parse-next-stanza-empty () "Return nil for empty buffer." (with-temp-buffer (should (null (jabber-xml-parse-next-stanza))))) (provide 'jabber-xml-tests) ;;; jabber-xml-tests.el ends here emacs-jabber/tests/jabberd.el000066400000000000000000000150131516610113500164450ustar00rootroot00000000000000;;; tests/jabberd.el --- -*- lexical-binding: t; -*- ;; Test the client by capturing its input and output into a virtual ;; jabber server. This is not a test in itself, but a framework for ;; actual tests. (require 'jabber) (defvar jabberd-sm-enabled nil "Non-nil when SM has been enabled for the current test session.") (defvar jabberd-sm-session-id "jabberd-sm-session-1" "The SM session ID assigned by the virtual server.") (defvar jabberd-stanza-handlers '(jabberd-sm jabberd-sasl jabberd-iq) "List of stanza handler hooks. These functions are called in order with two arguments, the client FSM and the stanza, until one function returns non-nil, indicating that it has handled the stanza.") (defvar jabberd-iq-get-handlers '(("jabber:iq:roster" . jabberd-iq-empty-success) ("jabber:iq:auth" . jabberd-iq-auth-get)) "Alist of handlers for IQ get stanzas. The key is the namespace of the request (a string), and the value is a function to handle the request. The function takes two arguments, the client FSM and the stanza.") (defvar jabberd-iq-set-handlers '(("urn:ietf:params:xml:ns:xmpp-bind" . jabberd-iq-bind) ("urn:ietf:params:xml:ns:xmpp-session" . jabberd-iq-empty-success) ("jabber:iq:auth" . jabberd-iq-empty-success)) "Alist of handlers for IQ set stanzas. The key is the namespace of the request (a string), and the value is a function to handle the request. The function takes two arguments, the client FSM and the stanza.") (defun jabberd-connect () (setq jabberd-sm-enabled nil) (setq *jabber-virtual-server-function* #'jabberd-handle) (jabber-connect "romeo" "montague.net" nil nil "foo" nil nil 'virtual)) (defun jabberd-handle (fsm text) ;; First, parse stanzas from text into sexps. (let (stanzas) (with-temp-buffer (insert text) (goto-char (point-min)) ;; Skip processing directive (when (looking-at "<\\?xml[^?]*\\?>") (delete-region (match-beginning 0) (match-end 0))) (catch 'unfinished (while t (push (if (prog1 (looking-at ". (when (string-match "version=[\"']" stanza) (jabberd-send fsm '(features ((xmlns . "http://etherx.jabber.org/streams")) ;; Interesting implementation details ;; of jabber.el permit us to send all ;; features at once, without caring about ;; which step we are at. (mechanisms ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl")) (mechanism () "DIGEST-MD5")) (bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind"))) (session ((xmlns . "urn:ietf:params:xml:ns:xmpp-session"))) (sm ((xmlns . "urn:xmpp:sm:3"))))))) (t (run-hook-with-args-until-success 'jabberd-stanza-handlers fsm stanza)))))) (defun jabberd-send (fsm stanza) (jabber-log-xml fsm "receive" stanza) (fsm-send fsm (list :stanza stanza))) (defun jabberd-sasl (fsm stanza) "Pretend to authenticate the client by SASL." (when (eq (jabber-xml-node-name stanza) 'auth) (jabberd-send fsm '(success ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl")))) t)) (defun jabberd-iq (fsm stanza) "Handle IQs from the client." (when (eq (jabber-xml-node-name stanza) 'iq) (jabber-xml-let-attributes (type _id) stanza (cond ((member type '("get" "set")) (let* ((table (if (string= type "get") jabberd-iq-get-handlers jabberd-iq-set-handlers)) (ns (jabber-iq-xmlns stanza)) (function (cdr (assoc ns table)))) (when function (funcall function fsm stanza))))) t))) (defun jabberd-iq-empty-success (fsm stanza) "Send an empty IQ result to STANZA." (jabber-xml-let-attributes (id) stanza (jabberd-send fsm `(iq ((type . "result") (id . ,id)))))) (defun jabberd-iq-bind (fsm stanza) "Do resource binding for the virtual server." (let ((id (jabber-xml-get-attribute stanza 'id))) (jabberd-send fsm `(iq ((type . "result") (id . ,id)) (bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind")) (jid () "romeo@montague.net/Orchard")))))) (defun jabberd-iq-auth-get (fsm stanza) (jabber-xml-let-attributes (id) stanza (jabberd-send fsm `(iq ((type . "result") (id . ,id)) (query ((xmlns . "jabber:iq:auth")) (username) (password) (digest) (resource)))))) (defun jabberd-sm (fsm stanza) "Handle SM stanzas from the client." (let ((name (jabber-xml-node-name stanza)) (xmlns (jabber-xml-get-xmlns stanza))) (when (equal xmlns "urn:xmpp:sm:3") (cond ((eq name 'enable) (setq jabberd-sm-enabled t) (jabberd-send fsm `(enabled ((xmlns . "urn:xmpp:sm:3") (id . ,jabberd-sm-session-id) (resume . "true") (max . "300")))) t) ((eq name 'r) ;; Server responds with (we haven't received stanzas) (jabberd-send fsm '(a ((xmlns . "urn:xmpp:sm:3") (h . "0")))) t) ((eq name 'a) ;; Client sent us an ack, nothing to do t) ((eq name 'resume) (let ((previd (jabber-xml-get-attribute stanza 'previd))) (if (and jabberd-sm-enabled (equal previd jabberd-sm-session-id)) (jabberd-send fsm `(resumed ((xmlns . "urn:xmpp:sm:3") (h . ,(jabber-xml-get-attribute stanza 'h)) (previd . ,jabberd-sm-session-id)))) (jabberd-send fsm '(failed ((xmlns . "urn:xmpp:sm:3")) (item-not-found ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))))) t))))) (provide 'jabberd) emacs-jabber/tests/load-all.el000066400000000000000000000003541516610113500165430ustar00rootroot00000000000000;; Test that all files can be loaded -*- lexical-binding: t; -*- (let* ((default-directory (expand-file-name (getenv "top_builddir"))) (elc-files (file-expand-wildcards "*.elc" t))) (dolist (f elc-files) (load f nil t))) emacs-jabber/tests/nick-change-fail.el000066400000000000000000000060161516610113500201370ustar00rootroot00000000000000;; -*- lexical-binding: t; -*- ;; When the user tries to change nickname in an MUC room, and the ;; server denies this, we should detect this instead of believing ;; that the user was thrown out of the room. (require 'jabberd) (defconst ncf-room-name "orchard@romeo-and-juliet.shakespeare.lit" "The MUC room used for this test.") (defun ncf-presence (fsm stanza) "Stanza handler. This function is a very simple MUC implementation. It allows a user to enter the room named by `ncf-room-name' with the nick \"Romeo\"." (jabber-xml-let-attributes (to) stanza (when (and (eq (jabber-xml-node-name stanza) 'presence) (string= (jabber-jid-user to) ncf-room-name)) (let ((nick (jabber-jid-resource to))) ;; Allow only the nick Romeo (if (string= nick "Romeo") (jabberd-send fsm `(presence ((from . ,to)) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((affiliation . "none") (role . "participant")))))) (jabberd-send fsm `(presence ((from . ,to) (type . "error")) (x ((xmlns . "http://jabber.org/protocol/muc#user"))) (error ((code . "409") (type . "cancel")) (conflict ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))))))))) (add-hook 'jabberd-stanza-handlers #'ncf-presence) (add-hook 'jabber-post-connect-hooks #'ncf-do) (setq jabber-muc-disable-disco-check t) (setq jabber-debug-log-xml t) (defvar ncf-done nil) ;; We need an extra variable for the error, as errors from timers are ;; ignored. (defvar ncf-error nil) (defun ncf-assert (assert-this format &rest args) (unless assert-this (let ((msg (apply #'format format args))) (setq ncf-error msg) (error "%s" msg)))) (defun ncf-do (jc) (setq ncf-done t) (jabber-muc-join jc ncf-room-name "Romeo") ;; We need a delay here, so that the client can process the response ;; stanza. (sit-for 0.01) (let ((buffer (jabber-muc-get-buffer ncf-room-name))) (ncf-assert (get-buffer buffer) "Couldn't enter MUC room") (ncf-assert (jabber-muc-joined-p ncf-room-name) "Entering room not recorded") ;; Now, do an unallowed nickname change. (jabber-muc-join jc ncf-room-name "Mercutio") (sit-for 0.01) ;; We should still consider ourselves to be in the room as Romeo (ncf-assert (jabber-muc-joined-p ncf-room-name) "We thought we left the room, but we didn't") (ncf-assert (string= (jabber-muc-nickname ncf-room-name) "Romeo") "We thought we changed nickname, but we didn't"))) (jabberd-connect) (with-timeout (5 (error "Timeout")) (while (not ncf-done) (sit-for 0.1))) (when ncf-error (princ (format "nick-change-fail test FAILED: %s " ncf-error)) (princ "Conversation was:\n") (with-current-buffer "*-jabber-xml-log-romeo@montague.net-*" (princ (buffer-string))) (let ((muc-buffer (get-buffer (jabber-muc-get-buffer ncf-room-name)))) (if muc-buffer (with-current-buffer muc-buffer (princ "Contents of groupchat buffer:\n") (princ (buffer-string))) (princ "Groupchat buffer not created.\n"))) (kill-emacs 1)) emacs-jabber/tests/parse-date.el000066400000000000000000000056411516610113500171070ustar00rootroot00000000000000;;; parse-date.el --- Tests for time parsing -*- lexical-binding: t; -*- (require 'jabber-util) (require 'ert) (ert-deftest jabber-parse-time () "Test parsing date string to list value." (let ((expected '(26075 52760))) (should (equal expected (jabber-parse-time "2024-02-25T23:32:40"))) (should (equal expected (jabber-parse-time "2024-02-25T23:32:40Z"))) (should (equal expected (jabber-parse-time "2024-02-25T23:32:40+00:00"))) (should (equal expected (jabber-parse-time "2024-02-25T23:32:40-00:00"))))) (ert-deftest jabber-parse-fractional-seconds () "Test parsing date string with fractional seconds." (let ((expected '(240506851241242650476544 . 140737488355328))) (should (equal expected (jabber-parse-time "2024-02-25T23:32:40.500"))) (should (equal expected (jabber-parse-time "2024-02-25T23:32:40.500Z"))) (should (equal expected (jabber-parse-time "2024-02-25T23:32:40.500+00:00"))) (should (equal expected (jabber-parse-time "2024-02-25T23:32:40.500-00:00"))))) (ert-deftest jabber-parse-time-float () "Test parsing date string to float." (let ((min-expected 1708903960.549999) (max-expected 1708903960.550001)) (should (< min-expected (float-time (jabber-parse-time "2024-02-25T23:32:40.550")) max-expected)) (should (< min-expected (float-time (jabber-parse-time "2024-02-25T23:32:40.550Z")) max-expected)) (should (< min-expected (float-time (jabber-parse-time "2024-02-25T23:32:40.550+00:00")) max-expected)) (should (< min-expected (float-time (jabber-parse-time "2024-02-25T23:32:40.550-00:00")) max-expected)))) (ert-deftest jabber-parse-time-bignum () "Test parsing date string bignum format." ;; going forward timestamps will use bignum rather than lists (skip-unless (not (version< emacs-version "29.1"))) (let (current-time-list (expected 1708903960)) (should (= expected (jabber-parse-time "2024-02-25T23:32:40"))) (should (= expected (jabber-parse-time "2024-02-25T23:32:40Z"))) (should (= expected (jabber-parse-time "2024-02-25T23:32:40+00:00"))) (should (= expected (jabber-parse-time "2024-02-25T23:32:40-00:00"))) (should (= (- expected 3600) (jabber-parse-time "2024-02-25T23:32:40+01:00"))) (should (= (+ expected 3600) (jabber-parse-time "2024-02-25T23:32:40-01:00"))))) (ert-deftest jabber-parse-time-cons () "Test parsing date string with fractional seconds to bignum format." ;; going forward timestamps will use bignum rather than lists (skip-unless (not (version< emacs-version "29.1"))) (let (current-time-list (expected '(240506851241242650476544 . 140737488355328))) (should (equal expected (jabber-parse-time "2024-02-25T23:32:40.500"))) (should (equal expected (jabber-parse-time "2024-02-25T23:32:40.500Z"))) (should (equal expected (jabber-parse-time "2024-02-25T23:32:40.500+00:00"))) (should (equal expected (jabber-parse-time "2024-02-25T23:32:40.500-00:00"))))) (ert-run-tests-batch "^jabber-") emacs-jabber/tests/parse-next-stanza.el000066400000000000000000000010521516610113500204360ustar00rootroot00000000000000;; Tests for jabber-xml-parse-next-stanza -*- lexical-binding: t; -*- (require 'jabber-xml) (defun parse-it (text) (with-temp-buffer (insert text) (jabber-xml-parse-next-stanza))) (unless (equal (parse-it "") '((presence ((from . "foo@example.com/resource") (type . "unavailable") (to . "bar@example.com"))))) (error "Testcase 1 failed")) (unless (equal (parse-it "ANONYMOUSDIGEST-MD5PLAIN") (error "Testcase 1 failed")) ;; 2. XML with CDATA (unless (parses-p "]]>") (error "Testcase 2 failed")))