pax_global_header00006660000000000000000000000064152353170200014510gustar00rootroot0000000000000052 comment=fc127ac13d1ec3b8cafe0bafd42f9461bcb92750 emacs-jabber-0.13.1/000077500000000000000000000000001523531702000141055ustar00rootroot00000000000000emacs-jabber-0.13.1/.elpaignore000066400000000000000000000001561523531702000162350ustar00rootroot00000000000000tests src/picomemo/.github src/picomemo/test src/picomemo/example src/picomemo/.clang-format *.nix flake.lock emacs-jabber-0.13.1/.gitignore000066400000000000000000000002231523531702000160720ustar00rootroot00000000000000*.elc *.eln *~ \#* *.tar* *.zip jabber-autoloads.el /jabber-pkg.el jabber.info .worktrees/ refs/ .test-results/ src/*.so lisp/*.so .ccls-cache *.mdemacs-jabber-0.13.1/AGENTS.md000066400000000000000000000050041523531702000154070ustar00rootroot00000000000000# emacs-jabber XMPP client for GNU Emacs 29.1+. Sources `lisp/`, ERT `tests/`, optional OMEMO module `src/`. Runtime deps: `fsm`, `keymap-popup`. ## Architecture - `jabber-core.el` owns `jabber-connection` FSM; `jabber-conn.el` owns transport. Preserve connect, auth, bind, Stream Management, resume, disconnect. - `jabber-stanza.el` dispatches IQ/message/presence via `jabber-iq-chain`, `jabber-message-chain`, `jabber-presence-chain`. Add protocol behavior on the right chain. - Keep modules layered. `jabber-chatbuffer.el` must stay independent of `jabber-chat.el` (chat already depends on it). - Separate parsing/decisions from network, SQLite, process, buffer, timer, and notification effects. Async callbacks must prove connection, process, and buffer still live. ## Protocol and data safety - Read the XEP first. Cover applicable MUST/SHOULD, keep namespaces and fallbacks, add focused stanza tests. Update `doap.xml` when support status changes. - SQLite holds history and encryption state. Schema changes need forward migration via `jabber-db--migrate`, fresh schema/version, query updates, and migration tests. Never rebuild the DB destructively. - OMEMO/OpenPGP are security-sensitive. Preserve encrypted-stanza dedup: Double Ratchet must not process the same ciphertext twice. Never replace valid stored text with a failed-decryption placeholder. - Never expose credentials, message plaintext, keys, or trust data in logs, errors, fixtures, or test artifacts. ## Elisp - Lexical binding. Public `jabber-`; internal `jabber--` or `jabber-MODULE--`. - Thin interactive commands. Small pure helpers; effects at module boundaries. - `defvar-local` for buffer state. Every `defcustom` needs accurate `:type` and `:group`. - `require` real deps. `declare-function` only for verified load cycles or the external OMEMO module. - Focused diffs. ERT for stanza, reconnection, persistence, encryption changes. ## Verification Makefile enters Nix dev env when available. ```sh make test # Parallel ERT + OMEMO module make lint # check-declare, checkdoc, package-lint, relint, test compile make module # OMEMO dynamic module make dev # Autoloads, compile, module, lint, isolated + one-shot tests make release-check # Local gates + Debian dh_elpa build and installed tests ``` Run `make dev`. Tests use temporary DBs only; never open a user's live Jabber DB (batch sets `jabber-db-path` nil). Run `make release-check` before any release tag; do not tag or push a release without it. emacs-jabber-0.13.1/CHANGELOG.org000066400000000000000000000500401523531702000161040ustar00rootroot00000000000000#+TITLE: Changelog * [0.13.1] #+date: 2026-08-07 ** Fixes - Correct outgoing MUC message-correction target lookup - Keep global Jabber menu bindings available during package loading - Preserve chat message bodies after live source reloads * [0.13.0] #+date: 2026-08-05 ** Added - XEP-0201 message threads with persistent sessions, local titles, child threads, and account-scoped routing - XEP-0004 forms for MUC configuration and ad-hoc commands - Unauthenticated SOCKS5 account =:proxy= support; destination names are resolved by the proxy, and authentication and other proxy protocols are not supported ** Changed - Chat-state notifications follow their owning message-thread session - Thread buffer labels and headers show root-message previews - Test loading no longer depends on generated autoloads and prefers newer source files over stale byte-code - Compose, registration, search, and vCard editing use text-first buffers and grouped command menus instead of widget.el - Added contribution instructions ** Fixes - Live MUC reactions use the correct account-scoped room buffer - Replayed empty OMEMO messages stay hidden - Delivery-receipt status follows the latest message - Autoaway applies the configured away and extended-away priorities - MUC mentions treat nicknames literally - Direct invitations and transient reconnects preserve per-account room passwords in memory; explicit leave clears that session state * [0.12.5] #+date: 2026-07-28 ** Fixes - Stop archived OMEMO failures from flooding =*Messages*= - Preserve unsent messages across connection recovery - Improve privacy and interoperability for receipts, blocking, bookmarks, MAM, and reactions * [0.12.4] #+date: 2026-07-26 ** Added - Debian package build and installed-package tests to release checks ** Changed - Hardened OMEMO message corrections and real-time text handling ** Fixes - Reproducible autoload generation for Debian packages - Load Org faces before rendering styled messages * [0.12.3] #+date: 2026-07-25 ** Added - Distinct theme-aware nickname colors in group chats - Save images that Emacs cannot display ** Fixes - More reliable keepalive monitoring with multiple accounts - Nickname completion works with custom delimiters * [0.12.2] #+date: 2026-07-13 ** Added - Open chats from desktop notifications ** Fixes - More reliable encrypted chats during session migration and out-of-order delivery * [0.12.1] #+date: 2026-07-11 ** Added - Press RET on a reply to jump to the original message - Replies show and preserve more context, including after reloading a chat ** Fixes - More reliable encrypted chats after reconnects and out-of-order messages - Safer inline image display, with manual loading available by pressing RET on an image URL - Manual image sizes are preserved when chats are redrawn * [0.12.0] #+date: 2026-07-08 ** Added - Fontified fenced code blocks in chats - Inline reply context when messages do not include fallback quotes ** Changed - More reliable encrypted chats after reconnects, archive catchup, and replayed messages - Improved reply and correction handling ** Fixes - Failed encrypted message corrections no longer replace the original message - Reply quotes and corrected replies preserve their context more consistently * [0.11.1] #+date: 2026-06-26 ** Added - See who reacted to a message via help-echo - Help-echo for the item at point now shows automatically ** Fixes - Stop repeated error stanzas from spamming and reopening chat buffers - Preserve scroll position when a chat buffer refreshes * [0.11.0] #+date: 2026-06-13 ** Added - Message reactions and MUC typing indicators - Nix flake development environment ** Changed - OMEMO native module setup no longer auto-builds or auto-fetches sources ** Fixes - Avoid Prosody disconnects by sending CSI only when the server advertises it - Recreate missing chat and MUC buffers from unread activity - Stop emitting malformed presence and vCard stanzas with nil children - Improve HTTP upload, message archive, reactions, receipts, and chat buffer reliability * [0.10.10] #+date: 2026-05-30 ** Added - Roster contact popup can edit contact name and groups - Roster account picker can clear scoped view with “All accounts” - Chat operations menu exposes MUC actions from room buffers ** Fixes - Suppress alerts for self-sent carbons and own MUC messages * [0.10.9] #+date: 2026-05-15 ** Fixes - Styling face leak on message send - Modeline presence hook name - SRV weighted-select entry duplication ** Added - =bug-reference-mode= auto-setup for chat buffers - Android picomemo compilation - Presence status in completing-read annotations - Per-account roster scoping * [0.10.8] #+date: 2026-05-11 ** Changed - Roster replaced with keymap-popup interface - Dissolved jabber-menu.el into home modules ** Improved - Improved test suite * [0.10.7] #+date: 2026-05-09 ** Fixes - SM: Fixed silent message loss on ack stall with watchdog recovery - SM: IQ stanzas bypass back-pressure gate ** Improved - Keymap-popup menus show dynamic values with faces * [0.10.6] #+date: 2026-04-30 ** Changed - Replaced transient.el with keymap-popup.el for all menus - Roster, bookmarks, and OMEMO trust mode maps now double as popup keymaps, eliminating duplicate key definitions - Chat operations menu shows context-appropriate entries (1:1 vs MUC) - New dependency: keymap-popup (GNU ELPA) * [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-0.13.1/CONTRIBUTING.org000066400000000000000000000015341523531702000165300ustar00rootroot00000000000000#+title: Contributing to emacs-jabber * Changes - Base changes on =master=. - Keep commits focused. - Add or update tests for changed behavior. - Run =make dev= before submission. * Patches Create a patch series: #+begin_src sh git format-patch --cover-letter origin/master #+end_src Send it to =patches@thanosapollo.org=: #+begin_src sh git send-email --to=patches@thanosapollo.org 000*.patch #+end_src Use =[PATCH emacs-jabber] Short description= as the subject. For a revised series, use =[PATCH v2 emacs-jabber]= and summarize changes since the previous version. * Bugs Send bug reports to =bugs@thanosapollo.org= with =[BUG emacs-jabber] Short description= as the subject. Include the emacs-jabber version, Emacs version, reproduction steps, and relevant backtrace. * Discussion - Join =jabber-el@conference.hmm.st= for development discussions. emacs-jabber-0.13.1/Makefile000066400000000000000000000206041523531702000155470ustar00rootroot00000000000000.PHONY: all build dev autoload module compile lint lint-check-declare lint-checkdoc \ lint-test-autoloads \ lint-package-lint lint-relint lint-test-compile lint-native-comp \ clean clean-elc clean-module install uninstall check test test-oneshot test-debian \ release-check load \ do-build do-dev do-compile do-lint do-module do-test do-test-oneshot do-test-summary \ do-lint-check-declare do-lint-checkdoc do-lint-native-comp NIX := $(shell command -v nix 2>/dev/null) ENV_MAKE = $(MAKE) --no-print-directory ifeq ($(JABBER_ENV_WRAPPED),) ifneq ($(NIX),) ENV_MAKE = nix develop path:$(CURDIR) --command env JABBER_ENV_WRAPPED=1 $(MAKE) --no-print-directory endif endif EMACS_CMD ?= emacs EMACS_OPTS ?= -Q --batch EMACSCLIENT ?= emacsclient JOBS ?= $(shell nproc 2>/dev/null || echo 4) TEST_RESULTS := .test-results TESTS ?= tests/jabber-test-activity.el \ tests/jabber-test-ahc.el \ tests/jabber-test-autoaway.el \ tests/jabber-test-avatar.el \ tests/jabber-test-blocking.el \ tests/jabber-test-bookmarks.el \ tests/jabber-test-carbons.el \ tests/jabber-test-chat.el \ tests/jabber-test-chatbuffer.el \ tests/jabber-test-chatstates.el \ tests/jabber-test-conn.el \ tests/jabber-test-csi.el \ tests/jabber-test-db.el \ tests/jabber-test-disco.el \ tests/jabber-test-httpupload.el \ tests/jabber-test-image.el \ tests/jabber-test-keepalive.el \ tests/jabber-test-mam.el \ tests/jabber-test-menu.el \ tests/jabber-test-message-correct.el \ tests/jabber-test-message-reply.el \ tests/jabber-test-message-thread.el \ tests/jabber-test-modeline.el \ tests/jabber-test-moderation.el \ tests/jabber-test-muc.el \ tests/jabber-test-notifications.el \ tests/jabber-test-omemo-message.el \ tests/jabber-test-omemo-module.el \ tests/jabber-test-omemo-protocol.el \ tests/jabber-test-omemo-store.el \ tests/jabber-test-omemo-trust.el \ tests/jabber-test-openpgp.el \ tests/jabber-test-openpgp-legacy.el \ tests/jabber-test-presence.el \ tests/jabber-test-pubsub.el \ tests/jabber-test-vcard-avatars.el \ tests/jabber-test-reactions.el \ tests/jabber-test-receipts.el \ tests/jabber-test-reload.el \ tests/jabber-test-roster.el \ tests/jabber-test-rtt.el \ tests/jabber-test-sm.el \ tests/jabber-test-srv.el \ tests/jabber-test-styling.el \ tests/jabber-test-time.el \ tests/jabber-test-util.el \ tests/jabber-test-widgetless.el \ tests/jabber-test-xdata.el \ tests/jabber-test-xml.el TEST_STAMPS := $(patsubst tests/%.el,$(TEST_RESULTS)/%.stamp,$(TESTS)) all: build build: @$(ENV_MAKE) do-build do-build: do-compile do-module dev: @$(ENV_MAKE) do-dev do-dev: do-compile do-module do-lint $(MAKE) do-test $(MAKE) do-test-oneshot autoload: $(EMACS_CMD) $(EMACS_OPTS) -L lisp \ --eval="(loaddefs-generate \"lisp\" \"lisp/jabber-autoloads.el\")" module: @$(ENV_MAKE) do-module do-module: $(MAKE) -C src compile: @$(ENV_MAKE) do-compile do-compile: autoload $(EMACS_CMD) $(EMACS_OPTS) -L . -L lisp \ --eval="(setq print-length nil load-prefer-newer t)" \ -f batch-byte-compile lisp/*.el lint-check-declare: @$(ENV_MAKE) do-lint-check-declare do-lint-check-declare: for file in admin/*.el lisp/*.el ; do \ $(EMACS_CMD) $(EMACS_OPTS) --eval="(check-declare-file \"$$file\")" ; \ done lint-checkdoc: @$(ENV_MAKE) do-lint-checkdoc do-lint-checkdoc: for file in admin/*.el lisp/*.el ; do \ case "$$file" in lisp/jabber-autoloads.el) continue;; esac; \ $(EMACS_CMD) $(EMACS_OPTS) --eval="(checkdoc-file \"$$file\")" ; \ done lint-package-lint: $(EMACS_CMD) $(EMACS_OPTS) \ --eval='(package-initialize)' --eval="(require 'package-lint)" \ --eval="(setq package-lint-main-file \"lisp/jabber.el\")" \ -f 'package-lint-batch-and-exit' $(wildcard lisp/*.el) lint-relint: $(EMACS_CMD) $(EMACS_OPTS) \ --eval='(package-initialize)' --eval="(require 'relint)" \ -f 'relint-batch' "lisp" lint-test-compile: $(EMACS_CMD) $(EMACS_OPTS) -L admin -L lisp -L tests \ -f batch-byte-compile admin/*.el tests/*.el lint-test-autoloads: @$(EMACS_CMD) $(EMACS_OPTS) --script admin/check-test-autoloads tests/*.el lint-native-comp: autoload @$(ENV_MAKE) 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) $(EMACS_OPTS) -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: @$(ENV_MAKE) do-lint do-lint: do-lint-check-declare do-lint-checkdoc lint-package-lint lint-relint \ lint-test-compile lint-test-autoloads test: @$(ENV_MAKE) -j$(JOBS) -Otarget do-test do-test: autoload do-module @rm -rf $(TEST_RESULTS) @mkdir -p $(TEST_RESULTS) @$(MAKE) --no-print-directory -j$(JOBS) -Otarget do-test-summary # jabber-db-path is preset to nil so no test can ever open the user's # real database; tests that need storage let-bind it to a temp file. $(TEST_RESULTS)/%.stamp: tests/%.el @output=$$($(EMACS_CMD) $(EMACS_OPTS) -L admin -L lisp -L tests \ --eval="(setq jabber-db-path nil load-prefer-newer t)" \ -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:-0} tests)\n"; \ echo "$$output" | grep ' FAILED'; \ printf "FAIL %s\n" "$${n:-1}" > $@; \ else \ printf "\033[32m OK\033[0m $< ($$n tests)\n"; \ printf "OK %s\n" "$$n" > $@; \ fi test-oneshot: @$(ENV_MAKE) do-test-oneshot test-debian: ./admin/test-debian # Run the complete local and Debian gates before version commits and tags. release-check: dev @if [ -n "$(NIX)" ]; then nix flake check; fi $(MAKE) test-debian # Mirror Debian's dh_elpa_test: load every test file into one Emacs # process and run the whole suite twice. Surfaces cross-test state # pollution and in-place mutation of shared literals that the per-file # `do-test' runs (one Emacs per file) cannot see. do-test-oneshot: autoload do-module $(EMACS_CMD) $(EMACS_OPTS) -L admin -L lisp -L tests -l ert \ --eval="(setq jabber-db-path nil load-prefer-newer t)" \ --eval="(require 'jabber)" \ $(addprefix -l ,$(TESTS)) \ --eval="(let ((bad 0)) \ (dotimes (_ 2) \ (setq bad (+ bad (ert-stats-completed-unexpected \ (ert-run-tests-batch t))))) \ (kill-emacs (if (zerop bad) 0 1)))" 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 @$(EMACSCLIENT) --eval "(progn \ (load-file \"$(CURDIR)/admin/jabber-reload.el\") \ (jabber-reload \"$(CURDIR)\"))" > /dev/null @printf "\033[32mLoaded all lisp/*.el into Emacs\033[0m\n" clean-elc: find . -name '*.elc' -delete find . -name '.#*' -delete find . -name '#*#' -delete clean-module: $(MAKE) -C src clean clean: clean-elc clean-module rm -rf $(TEST_RESULTS) prefix ?= /usr/local datarootdir ?= $(prefix)/share lispdir ?= $(datarootdir)/emacs/site-lisp/jabber check: $(MAKE) test $(MAKE) test-oneshot 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-0.13.1/README.org000066400000000000000000000114041523531702000155530ustar00rootroot00000000000000#+TITLE: jabber.el - The XMPP client for Emacs #+TEXINFO_DIR_NAME: * jabber.el: (jabber) #+TEXINFO_DIR_DESC: jabber.el - The XMPP client for Emacs #+TEXINFO_DIR_CATEGORY: 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/about/][git.thanosapollo.org]] * Requirements + Emacs 29.1 or later, compiled with dynamic module support + [[https://elpa.gnu.org/packages/fsm.html][fsm]] 0.2.0 or later + [[https://elpa.gnu.org/packages/keymap-popup.html][keymap-popup]] 0.2 or later ** OMEMO encryption (optional) OMEMO end-to-end encryption uses a native C module built from the vendored [[https://github.com/mierenhoop/picomemo][picomemo]] source. Build dependencies: a C compiler, =pkg-config=, and Mbed TLS 3.0 or later (=mbedcrypto=). Build the module manually from the jabber source or ELPA/package directory: #+begin_src sh cd /path/to/jabber-source-or-elpa-dir make module #+end_src The resulting =jabber-omemo-core.so= (or =.dylib= on macOS) lands beside the Elisp files and is loaded automatically. If the module is missing, OMEMO use signals =OMEMO module not compiled=. * 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+) Emacs honors package-vc build commands such as =:make= only when =package-vc-allow-build-commands= allows the package. #+begin_src emacs-lisp (setq package-vc-allow-build-commands '(jabber)) (use-package jabber :ensure nil :vc (:url "https://git.thanosapollo.org/emacs-jabber" :branch "master" :rev :newest :lisp-dir "lisp" :doc "README.org" :make "module") :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 ** straight.el #+begin_src emacs-lisp (use-package jabber :straight `(jabber :type git :host nil :repo "https://git.thanosapollo.org/emacs-jabber" :branch "master" :files ("lisp/*.el" "lisp/jabber-omemo-core.so" "lisp/jabber-omemo-core.dylib") :pre-build ,(pcase system-type ('berkeley-unix '(("gmake" "module" "CC=clang"))) ('darwin '(("make" "module" "CC=clang"))) (_ '(("make" "module"))))) :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 ** Nix The repository ships a =flake.nix= with Emacs, test, lint, and native-module build dependencies. #+begin_src sh make test make module #+end_src To enter the same environment manually: #+begin_src sh nix develop #+end_src To run the isolated Nix checks: #+begin_src sh nix flake check #+end_src * Configuration ** Authentication 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 ** SOCKS5 proxy An account can connect through an unauthenticated SOCKS5 proxy: #+begin_src emacs-lisp (setq jabber-account-list '(("user@example.org" (:proxy . (:type socks5 :host "127.0.0.1" :port 9050))))) #+end_src The destination hostname is sent to the proxy rather than resolved locally. Proxy connections bypass SRV lookup and use the JID domain on port 5222, or =:network-server= and =:port= when those are configured. STARTTLS is supported. Direct TLS discovery, proxy authentication, and other proxy protocols are not supported for proxied accounts. ** Bug references #+begin_src emacs-lisp (add-hook 'jabber-chat-mode-hook #'bug-reference-mode) ;; Customize references (setq jabber-bug-reference-alist '(("jabber-el@conference\\.hmm\\.st" "\\(#\\([0-9]+\\)\\)" "https://todos.thanosapollo.org/r/emacs-jabber/%s"))) #+end_src * Basic commands + Use =M-x jabber-roster= or =C-x C-j C-r= to get started. emacs-jabber-0.13.1/admin/000077500000000000000000000000001523531702000151755ustar00rootroot00000000000000emacs-jabber-0.13.1/admin/check-test-autoloads000077500000000000000000000056621523531702000211570ustar00rootroot00000000000000;;; check-test-autoloads --- Reject generated autoload dependencies -*- lexical-binding: t; -*- (defconst jabber-check-test-autoloads--operations '(load load-file require)) (defun jabber-check-test-autoloads--target-p (value) "Return non-nil when VALUE names the generated Jabber autoload file." (cond ((symbolp value) (string= (symbol-name value) "jabber-autoloads")) ((stringp value) (string-match-p "\\(?:\\`\\|/\\)jabber-autoloads\\(?:\\.el[cn]?\\)?\\'" value)) ((consp value) (or (jabber-check-test-autoloads--target-p (car value)) (jabber-check-test-autoloads--target-p (cdr value)))))) (defun jabber-check-test-autoloads--dependency-p (form) "Return non-nil when FORM directly loads generated Jabber autoloads." (and (consp form) (not (eq (car form) 'quote)) (or (and (memq (car form) jabber-check-test-autoloads--operations) (or (jabber-check-test-autoloads--target-p (cadr form)) (and (eq (car form) 'require) (jabber-check-test-autoloads--target-p (caddr form))))) (jabber-check-test-autoloads--dependency-p (car form)) (jabber-check-test-autoloads--dependency-p (cdr form))))) (defun jabber-check-test-autoloads--read (source) "Read one Elisp form from SOURCE." (car (read-from-string source))) (defun jabber-check-test-autoloads--self-test () "Verify reader-sensitive rejection and allowance fixtures." (dolist (fixture '("(load\n ;; )\n \"jabber-autoloads.el\")" "(load-file\n ;; )\n \"jabber-autoloads.el\")" "(require\n ;; )\n 'jabber-autoloads)" "(load \"jabber-\\x61utoloads.el\")" "(load-file \"jabber-\\141utoloads.el\")" "(require 'jabber-\\autoloads)" "(ignore-errors (require 'unrelated \"jabber-autoloads.el\"))" "(ignore-errors (require '#:jabber-autoloads))")) (unless (jabber-check-test-autoloads--dependency-p (jabber-check-test-autoloads--read fixture)) (error "Autoload dependency check missed fixture: %s" fixture))) (when (jabber-check-test-autoloads--dependency-p '(string-suffix-p "jabber-autoloads.el" file)) (error "Autoload dependency check rejected filename inspection"))) (defun jabber-check-test-autoloads--file-p (file) "Return non-nil when FILE directly loads generated Jabber autoloads." (with-temp-buffer (insert-file-contents file) (catch 'found (condition-case nil (while t (when (jabber-check-test-autoloads--dependency-p (read (current-buffer))) (throw 'found t))) (end-of-file nil))))) (jabber-check-test-autoloads--self-test) (let (failed) (dolist (file command-line-args-left) (when (jabber-check-test-autoloads--file-p file) (message "%s: tests must not load generated jabber-autoloads" file) (setq failed t))) (kill-emacs (if failed 1 0))) ;;; check-test-autoloads ends here emacs-jabber-0.13.1/admin/jabber-reload.el000066400000000000000000000227431523531702000202200ustar00rootroot00000000000000;;; jabber-reload.el --- Reload Jabber source files safely -*- lexical-binding: t; -*- ;;; Commentary: ;; Reload Jabber in source dependency order while restoring live function and ;; keymap bindings if any file fails to load. ;;; Code: (require 'cl-lib) (require 'seq) (defconst jabber-reload--load-time-forms '(and condition-case condition-case-unless-debug cond eval-and-compile eval-when-compile if let let* or progn unless when)) (defun jabber-reload--source-files (root) "Return reloadable Jabber source files below ROOT." (seq-remove (lambda (file) (string-suffix-p "/jabber-autoloads.el" file)) (sort (file-expand-wildcards (expand-file-name "lisp/*.el" root)) #'string<))) (defun jabber-reload--read-forms (file) "Read and return all Lisp forms in FILE." (with-temp-buffer (insert-file-contents file) (let (done forms) (while (not done) (let ((start (point))) (condition-case error-data (push (read (current-buffer)) forms) (end-of-file (if (jabber-reload--ignorable-tail-p start) (setq done t) (signal (car error-data) (cdr error-data))))))) (nreverse forms)))) (defun jabber-reload--ignorable-tail-p (start) "Return non-nil when buffer text after START is whitespace or comments." (save-excursion (goto-char start) (with-syntax-table emacs-lisp-mode-syntax-table (forward-comment (point-max))) (eobp))) (defun jabber-reload--quoted-symbol (form) "Return the symbol quoted by FORM, or nil." (when (and (consp form) (eq (car form) 'quote) (symbolp (cadr form))) (cadr form))) (defun jabber-reload--load-time-children (form) "Return load-time child forms of FORM." (pcase (car-safe form) ((or 'let 'let*) (append (delq nil (mapcar (lambda (binding) (and (consp binding) (cadr binding))) (cadr form))) (cddr form))) ((or 'condition-case 'condition-case-unless-debug) (cons (caddr form) (mapcan #'cdr (cdddr form)))) ('cond (apply #'append (cdr form))) ((pred (lambda (head) (memq head jabber-reload--load-time-forms))) (cdr form)))) (defun jabber-reload--requires (form) "Return features required while evaluating FORM at top level." (if (eq (car-safe form) 'require) (let ((feature (jabber-reload--quoted-symbol (cadr form)))) (and feature (list feature))) (mapcan #'jabber-reload--requires (jabber-reload--load-time-children form)))) (defun jabber-reload--provide (form) "Return the feature provided directly by FORM, or nil." (when (eq (car-safe form) 'provide) (jabber-reload--quoted-symbol (cadr form)))) (defun jabber-reload--map-symbol (form) "Return the keymap variable declared by FORM, or nil." (pcase (car-safe form) ((or 'defvar-keymap 'keymap-popup-define) (cadr form)) ('define-derived-mode (intern (concat (symbol-name (cadr form)) "-map"))) ('defvar (let ((symbol (cadr form))) (when (and (symbolp symbol) (string-match-p "\\(?:-map\\|keymap\\)\\'" (symbol-name symbol))) symbol))))) (defun jabber-reload--record (file) "Return source metadata for FILE." (let* ((forms (jabber-reload--read-forms file)) (provides (delq nil (mapcar #'jabber-reload--provide forms))) (requires (delete-dups (mapcan #'jabber-reload--requires forms))) (maps (delete-dups (delq nil (mapcar #'jabber-reload--map-symbol forms))))) (list :file file :provides provides :requires requires :maps maps))) (defun jabber-reload--provider-alist (records) "Return an alist mapping features to files in RECORDS." (let (providers) (dolist (record records providers) (dolist (feature (plist-get record :provides)) (when-let* ((previous (alist-get feature providers))) (error "Feature %s is provided by %s and %s" feature previous (plist-get record :file))) (push (cons feature (plist-get record :file)) providers))))) (defun jabber-reload--dependencies (records providers) "Return file dependencies from RECORDS and PROVIDERS." (mapcar (lambda (record) (let* ((file (plist-get record :file)) (dependencies (delq nil (mapcar (lambda (feature) (alist-get feature providers)) (plist-get record :requires))))) (cons file (delete file (delete-dups dependencies))))) records)) (defun jabber-reload--topological-order (files dependencies) "Order FILES according to DEPENDENCIES." (let ((remaining (copy-sequence files)) ordered) (while remaining (let ((ready (seq-filter (lambda (file) (not (seq-intersection (alist-get file dependencies nil nil #'equal) remaining))) remaining))) (unless ready (error "Reload dependency cycle: %s" (mapconcat #'file-name-nondirectory remaining ", "))) (setq ordered (append ordered ready) remaining (seq-difference remaining ready)))) ordered)) (defun jabber-reload--plan (root) "Return a dependency-ordered reload plan for ROOT." (let* ((records (mapcar #'jabber-reload--record (jabber-reload--source-files root))) (providers (jabber-reload--provider-alist records)) (files (mapcar (lambda (record) (plist-get record :file)) records))) (list :files (jabber-reload--topological-order files (jabber-reload--dependencies records providers)) :maps (delete-dups (mapcan (lambda (record) (copy-sequence (plist-get record :maps))) records))))) (defun jabber-reload--snapshot-maps (maps) "Return the current binding state of MAPS." (mapcar (lambda (symbol) (list symbol (boundp symbol) (and (boundp symbol) (symbol-value symbol)))) maps)) (defun jabber-reload--snapshot-functions () "Return the current function state of interned Jabber symbols." (let (snapshots) (mapatoms (lambda (symbol) (when (string-prefix-p "jabber-" (symbol-name symbol)) (let ((bound (fboundp symbol))) (push (list symbol bound (and bound (symbol-function symbol))) snapshots))))) snapshots)) (defun jabber-reload--restore-functions (snapshots) "Restore Jabber function SNAPSHOTS and remove new definitions." (let ((saved-symbols (mapcar #'car snapshots))) (mapatoms (lambda (symbol) (when (and (string-prefix-p "jabber-" (symbol-name symbol)) (fboundp symbol) (not (memq symbol saved-symbols))) (fmakunbound symbol))))) (dolist (snapshot snapshots) (if (cadr snapshot) (fset (car snapshot) (caddr snapshot)) (fmakunbound (car snapshot))))) (defun jabber-reload--restore-maps (snapshots) "Restore keymap SNAPSHOTS." (dolist (snapshot snapshots) (if (cadr snapshot) (set (car snapshot) (caddr snapshot)) (makunbound (car snapshot))))) (defun jabber-reload--capture-buffer-maps (maps) "Capture live buffers using a conventional old map from MAPS." (let (buffers) (dolist (buffer (buffer-list) buffers) (with-current-buffer buffer (let ((symbol (intern-soft (concat (symbol-name major-mode) "-map")))) (when (and (memq symbol maps) (boundp symbol) (eq (current-local-map) (symbol-value symbol))) (push (list buffer symbol (current-local-map)) buffers))))))) (defun jabber-reload--set-buffer-maps (buffers old) "Set BUFFERS to their saved or current map bindings. When OLD is non-nil, restore the saved map objects." (dolist (entry buffers) (when (buffer-live-p (car entry)) (with-current-buffer (car entry) (use-local-map (if old (caddr entry) (symbol-value (cadr entry)))))))) (defun jabber-reload--validate-maps (maps) "Signal an error unless MAPS are bound to keymaps." (dolist (symbol maps) (unless (and (boundp symbol) (keymapp (symbol-value symbol))) (error "Reload did not define keymap %s" symbol)))) ;;;###autoload (defun jabber-reload (root) "Reload the Jabber checkout at ROOT in dependency order. Restore Jabber function and keymap bindings if any file fails." (let* ((plan (jabber-reload--plan root)) (files (plist-get plan :files)) (maps (plist-get plan :maps)) (functions (jabber-reload--snapshot-functions)) (snapshots (jabber-reload--snapshot-maps maps)) (buffers (jabber-reload--capture-buffer-maps maps)) (old-binding (lookup-key ctl-x-map (kbd "C-j"))) succeeded) (unwind-protect (progn (mapc #'makunbound maps) (mapc #'load-file files) (jabber-reload--validate-maps maps) (jabber-reload--set-buffer-maps buffers nil) (setq succeeded t) (list :loaded (length files) :rebound (length buffers))) (unless succeeded (jabber-reload--restore-functions functions) (jabber-reload--restore-maps snapshots) (define-key ctl-x-map (kbd "C-j") old-binding) (jabber-reload--set-buffer-maps buffers t))))) (provide 'jabber-reload) ;; Local Variables: ;; no-update-autoloads: t ;; End: ;;; jabber-reload.el ends here emacs-jabber-0.13.1/admin/test-debian000077500000000000000000000031631523531702000173250ustar00rootroot00000000000000#!/bin/sh set -eu root=$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd) image=${DEBIAN_IMAGE:-debian@sha256:7469781d68f44940c9494eeba6e7ab89063947f794320d61c193bf027aeb7761} packaging_ref=${DEBIAN_PACKAGING_REF:-60cf56e3e0e5e20a8c27c60ca745f255b031d66c} command -v docker >/dev/null 2>&1 || { echo "docker is required for the Debian test" >&2 exit 1 } docker run --rm \ -e DEBIAN_FRONTEND=noninteractive \ -e DEBIAN_PACKAGING_REF="$packaging_ref" \ -v "$root:/source:ro" \ "$image" \ sh -eu -c ' apt-get update apt-get install -y --no-install-recommends \ autopkgtest build-essential ca-certificates debhelper devscripts dh-elpa \ elpa-fsm elpa-keymap-popup git gpg libmbedtls-dev pkgconf git config --global --add safe.directory /source mkdir -p /build/source /build/packaging git -C /source ls-files -z --cached --others --exclude-standard | tar -C /source --null -T - -cf - | tar -xf - -C /build/source git -C /build/packaging init -q git -C /build/packaging fetch -q --depth=1 \ https://salsa.debian.org/emacsen-team/emacs-jabber.git \ "$DEBIAN_PACKAGING_REF" git -C /build/packaging checkout -q --detach FETCH_HEAD cp -a /build/packaging/debian /build/source/ cd /build/source make lint-test-autoloads dpkg-buildpackage --build=binary --no-sign rm -f lisp/jabber-autoloads.el apt-get install -y /build/*.deb dh_elpa_test --autopkgtest autoload_file=$(find /usr/share/emacs/site-lisp -name jabber-autoloads.el \ -print -quit) test -n "$autoload_file" if grep -q jabber-reload "$autoload_file"; then echo "jabber-reload leaked into the installed autoload file" >&2 exit 1 fi ' emacs-jabber-0.13.1/doap.xml000066400000000000000000000634651523531702000155700ustar00rootroot00000000000000 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 partial 1.0 Explicit user-created chat and groupchat threads are supported; unthreaded messages remain in their parent conversation. 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 partial 1.0 Real-time message editing is supported; activation negotiation with event="init" is not implemented. partial 1.1.0 0.10.0 Query and paginated retrieval. No preferences or metadata support. partial 0.4.0 0.10.0 1:1 received and displayed markers. No MUC marker tracking. 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 stamped on all outgoing messages; stanza-id parsing for MAM deduplication and reply targets. No disco feature announcement or referenced-stanza support. 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, including one-time pre-key removal after use, session recovery on pre-key decrypt failure, periodic signed pre-key rotation, and out-of-order message recovery via persisted skipped ratchet keys. MUC: send and receive in non-anonymous rooms; no affiliation list fetch for offline members. partial 1.0.1 0.13.0 Uses the XEP hue as a base with a deterministic display offset of at most 18 degrees to distinguish nearby nick colors. 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 partial Message Reactions are persisted and displayed from backlog; restriction discovery is not implemented and MUC actor identity remains provisional. complete 0.1.0 0.10.0 complete 0.2.0 0.10.0 1.2.0 partial 0.10.0 Body correction and MUC sender continuity checks are implemented; complete payload replacement is not. With legacy OMEMO, the corrected body is encrypted but the XEP-0308 replacement target remains outside the encrypted payload and is not end-to-end authenticated. 0.13.1 2026-08-07 0.13.0 2026-08-05 0.12.5 2026-07-28 0.12.4 2026-07-26 0.12.3 2026-07-25 0.12.2 2026-07-13 0.12.1 2026-07-11 0.12.0 2026-07-08 0.11.1 2026-06-26 0.11.0 2026-06-13 0.10.10 2026-05-30 0.10.9 2026-05-15 0.10.8 2026-05-11 0.10.7 2026-05-09 0.10.6 2026-04-30 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-0.13.1/flake.lock000066400000000000000000000010671523531702000160450ustar00rootroot00000000000000{ "nodes": { "nixpkgs": { "locked": { "lastModified": 1781074563, "narHash": "sha256-md8WlXOlfnIeHeOScMTTHFyf2d6iaTwPl2apR5EQ3P4=", "owner": "NixOS", "repo": "nixpkgs", "rev": "9ae611a455b90cf061d8f332b977e387bda8e1ca", "type": "github" }, "original": { "owner": "NixOS", "ref": "nixos-unstable", "repo": "nixpkgs", "type": "github" } }, "root": { "inputs": { "nixpkgs": "nixpkgs" } } }, "root": "root", "version": 7 } emacs-jabber-0.13.1/flake.nix000066400000000000000000000135341523531702000157150ustar00rootroot00000000000000{ description = "XMPP client for Emacs"; inputs.nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; outputs = { self, nixpkgs }: let systems = [ # Note: Most of the testing I've done is x86_64-linux and # aarch64-linux. If you find any issues with darwin feel free # to report/submit a PR. "x86_64-linux" "aarch64-linux" "x86_64-darwin" "aarch64-darwin" ]; forAllSystems = nixpkgs.lib.genAttrs systems; keymapPopupVersion = "0.4.1"; # Build everything for one concrete Emacs. Called once per # variant (full build, and emacs-nox) so the test matrix can # exercise both. mkVariant = pkgs: emacs: let lib = pkgs.lib; emacsPackages = pkgs.emacsPackagesFor emacs; source = lib.cleanSourceWith { src = ./.; filter = path: type: let name = baseNameOf path; in !(name == ".test-results" || lib.hasSuffix ".elc" name || lib.hasSuffix ".so" name || lib.hasSuffix ".dylib" name || lib.hasSuffix "~" name); }; keymapPopup = emacsPackages.trivialBuild { pname = "keymap-popup"; version = keymapPopupVersion; src = pkgs.fetchurl { url = "https://elpa.gnu.org/packages/keymap-popup-${keymapPopupVersion}.tar"; hash = "sha256-O2t6v0b8xknkevzXu6uu+M/ZiqPhcN/g5MytxKF4DkU="; }; packageRequires = [ ]; }; emacsWithPackages = emacsPackages.emacsWithPackages (epkgs: [ epkgs.fsm keymapPopup epkgs.package-lint epkgs.relint ]); moduleCFlags = "-I${emacs}/include -fPIC -Wall -Wno-pointer-sign -Wno-unused-function -I."; omemoModule = pkgs.stdenv.mkDerivation { pname = "emacs-jabber-omemo-module"; version = "git"; src = source; nativeBuildInputs = [ pkgs.gnumake pkgs.pkg-config ]; buildInputs = [ pkgs.mbedtls ]; dontConfigure = true; buildPhase = '' runHook preBuild mkdir -p out CFLAGS="${moduleCFlags}" make -C src INSTALL_DIR="$PWD/out" runHook postBuild ''; installPhase = '' runHook preInstall mkdir -p $out/lib/emacs-jabber cp out/jabber-omemo-core.* $out/lib/emacs-jabber/ runHook postInstall ''; }; # Run a Makefile test target in a sandbox that mirrors a # buildd: clean HOME/XDG, the module built from source. mkTests = { pname, target }: pkgs.stdenv.mkDerivation { inherit pname; version = "git"; src = source; nativeBuildInputs = [ emacsWithPackages pkgs.gnumake pkgs.pkg-config ]; buildInputs = [ pkgs.mbedtls ]; dontConfigure = true; buildPhase = '' runHook preBuild export HOME="$TMPDIR/home" export XDG_CACHE_HOME="$TMPDIR/cache" export XDG_CONFIG_HOME="$TMPDIR/config" export XDG_DATA_HOME="$TMPDIR/share" export XDG_STATE_HOME="$TMPDIR/state" mkdir -p "$HOME" "$XDG_CACHE_HOME" "$XDG_CONFIG_HOME" \ "$XDG_DATA_HOME" "$XDG_STATE_HOME" CFLAGS="${moduleCFlags}" \ EMACS_CMD=emacs \ JABBER_ENV_WRAPPED=1 \ make ${target} runHook postBuild ''; installPhase = '' runHook preInstall mkdir -p $out touch $out/tests-passed runHook postInstall ''; }; in { inherit emacs emacsWithPackages keymapPopup omemoModule; # Per-file: one Emacs per test file (fast, good isolation). tests = mkTests { pname = "emacs-jabber-tests"; target = "test"; }; # Combined: every file in one Emacs, suite run twice -- mirrors # dh_elpa_test and catches cross-test state pollution. testsOneshot = mkTests { pname = "emacs-jabber-tests-oneshot"; target = "test-oneshot"; }; }; mkJabber = system: let pkgs = import nixpkgs { inherit system; }; in { inherit pkgs; full = mkVariant pkgs pkgs.emacs31-pgtk; # emacs-nox has no image support and does not preload many # libraries (e.g. `image'); this is what Debian ships, so it # catches build-only-on-nox bugs the full build hides. nox = mkVariant pkgs pkgs.emacs-nox; }; in { packages = forAllSystems (system: let jabber = mkJabber system; in { default = jabber.full.omemoModule; omemo-module = jabber.full.omemoModule; }); checks = forAllSystems (system: let jabber = mkJabber system; in { omemo-module = jabber.full.omemoModule; # Test matrix: {full, nox} x {per-file, combined-twice}. test = jabber.full.tests; test-nox = jabber.nox.tests; test-oneshot = jabber.full.testsOneshot; test-oneshot-nox = jabber.nox.testsOneshot; }); devShells = forAllSystems (system: let jabber = mkJabber system; in { default = jabber.pkgs.mkShell { packages = with jabber.pkgs; [ cacert gcc git gnumake jabber.full.emacsWithPackages mbedtls pkg-config ]; shellHook = '' export EMACS_CMD=emacs export CFLAGS="-I${jabber.full.emacs}/include''${CFLAGS:+ $CFLAGS}" ''; }; }); }; } emacs-jabber-0.13.1/lisp/000077500000000000000000000000001523531702000150545ustar00rootroot00000000000000emacs-jabber-0.13.1/lisp/jabber-activity.el000066400000000000000000000462251523531702000204660ustar00rootroot00000000000000;;; 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 'fsm) (require 'seq) (require 'jabber-core) (require 'jabber-util) (require 'jabber-chat) (require 'jabber-muc) (require 'jabber-muc-nick-completion) (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 that turns a list of JIDs into an alist of JID -> string." :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 "Whether to confirm exiting Emacs when there are unread messages." :type 'boolean) (defcustom jabber-activity-banned nil "List of regexps of banned JIDs." :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 (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (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--connection-for-jid (jid) "Return a suitable connection for a 1:1 chat with JID." (let ((sym (jabber-jid-symbol jid))) (or (seq-find (lambda (jc) (memq sym (plist-get (fsm-get-state-data jc) :roster))) jabber-connections) (and (bound-and-true-p jabber-buffer-connection) (memq jabber-buffer-connection jabber-connections) jabber-buffer-connection) (and (null (cdr jabber-connections)) (car jabber-connections))))) (defun jabber-activity--switch-to-missing-private-muc (jid) "Create and switch to a private MUC buffer for JID, if possible." (when-let* ((group (jabber-jid-user jid)) (nickname (jabber-jid-resource jid)) (jc (jabber-muc-connection group))) (switch-to-buffer (jabber-muc-private-create-buffer jc group nickname)))) (defun jabber-activity--switch-to-missing-muc (jid) "Create and switch to a MUC buffer for JID, if possible." (let ((old-buffer (current-buffer))) (jabber-muc-switch-to jid) (unless (eq old-buffer (current-buffer)) (current-buffer)))) (defun jabber-activity--switch-to-missing-chat (jid) "Create and switch to a 1:1 chat buffer for JID, if possible." (when-let* ((jc (jabber-activity--connection-for-jid jid))) (jabber-chat-with jc jid))) (defun jabber-activity--switch-to-missing-buffer (jid) "Create and switch to a missing activity buffer for JID, if possible." (cond ((jabber-muc-sender-p jid) (jabber-activity--switch-to-missing-private-muc jid)) ((jabber-muc-joined-p jid) (jabber-activity--switch-to-missing-muc jid)) (t (jabber-activity--switch-to-missing-chat 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-list)))) (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 FROM to mode line when `jabber-activity-show-p' approves it." (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 detected in TEXT 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 WHO to the mode line on subscription requests. NEWSTATUS is the presence type of the incoming stanza." (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) (unless (jabber-activity--switch-to-missing-buffer jid) (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-0.13.1/lisp/jabber-ahc-presence.el000066400000000000000000000111211523531702000211520ustar00rootroot00000000000000;;; 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 ;;; Commentary: ;; XEP-0146 remote-control commands for setting presence. ;;; Code: (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-0.13.1/lisp/jabber-ahc.el000066400000000000000000000400431523531702000173550ustar00rootroot00000000000000;;; 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 'keymap-popup) (require 'jabber-disco) (require 'jabber-xdata) (require 'jabber-xdata-form) (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-local jabber-ahc--submit-to nil "JID receiving commands from the current ad-hoc session.") (defvar-local jabber-ahc--has-form nil "Whether the current ad-hoc step supplied an editable data form.") (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) "Dispatch an inbound ad-hoc-command IQ over JC. XML-DATA is the IQ stanza." (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 (defconst jabber-ahc--command-page-size 4 "Number of discovered commands displayed on one popup page.") (defvar-local jabber-ahc--command-items nil "Discovered commands available in the current buffer.") (defvar-local jabber-ahc--command-connection nil "Connection used to discover commands in the current buffer.") (defvar-local jabber-ahc--command-target nil "JID queried for commands in the current buffer.") (defvar-local jabber-ahc--command-page 0 "Index of the displayed command page in the current buffer.") (defvar jabber-ahc-command-list-map) (defun jabber-ahc-get-list (jc to) "Request list of ad-hoc commands from TO. 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-disco-get-items jc to jabber-ahc-xmlns #'jabber-ahc--command-list-result (list (current-buffer) to))) (defun jabber-ahc--command-list-map (jc to items) "Prepare and return the popup map for XEP-0050 ITEMS from TO over JC." (setq-local jabber-ahc--command-items (seq-filter (lambda (item) (and (aref item 1) (aref item 2))) items)) (setq-local jabber-ahc--command-connection jc) (setq-local jabber-ahc--command-target to) (setq-local jabber-ahc--command-page 0) jabber-ahc-command-list-map) (defun jabber-ahc--command-at (slot) "Return command at zero-based SLOT on the current page." (nth (+ slot (* jabber-ahc--command-page jabber-ahc--command-page-size)) jabber-ahc--command-items)) (defun jabber-ahc--command-description (slot) "Return the description for command SLOT on the current page." (when-let* ((item (jabber-ahc--command-at slot))) (or (aref item 0) (aref item 2)))) (defun jabber-ahc--execute-slot (slot) "Execute command SLOT on the current page." (when-let* ((item (jabber-ahc--command-at slot))) (jabber-ahc-execute-command (jabber-ahc--resolve-connection jabber-ahc--command-connection) (aref item 1) (aref item 2)))) (defun jabber-ahc-execute-command-1 () "Execute the first command on the current page." (interactive) (jabber-ahc--execute-slot 0)) (defun jabber-ahc-execute-command-2 () "Execute the second command on the current page." (interactive) (jabber-ahc--execute-slot 1)) (defun jabber-ahc-execute-command-3 () "Execute the third command on the current page." (interactive) (jabber-ahc--execute-slot 2)) (defun jabber-ahc-execute-command-4 () "Execute the fourth command on the current page." (interactive) (jabber-ahc--execute-slot 3)) (defun jabber-ahc-command-previous-page () "Show the previous discovered-command page." (interactive) (setq-local jabber-ahc--command-page (max 0 (1- jabber-ahc--command-page)))) (defun jabber-ahc-command-next-page () "Show the next discovered-command page." (interactive) (setq-local jabber-ahc--command-page (min (1- (jabber-ahc--command-page-count)) (1+ jabber-ahc--command-page)))) (defun jabber-ahc--command-page-count () "Return the number of discovered-command pages." (ceiling (length jabber-ahc--command-items) jabber-ahc--command-page-size)) (defun jabber-ahc--command-has-next-page-p () "Return non-nil when another discovered-command page exists." (< (* (1+ jabber-ahc--command-page) jabber-ahc--command-page-size) (length jabber-ahc--command-items))) (keymap-popup-define jabber-ahc-command-list-map "Discovered XEP-0050 commands." :exit-key "C-g" :description (lambda () (format "Commands for %s" jabber-ahc--command-target)) :group "Commands" "1" ((lambda () (jabber-ahc--command-description 0)) jabber-ahc-execute-command-1 :if (lambda () (jabber-ahc--command-at 0))) "2" ((lambda () (jabber-ahc--command-description 1)) jabber-ahc-execute-command-2 :if (lambda () (jabber-ahc--command-at 1))) "3" ((lambda () (jabber-ahc--command-description 2)) jabber-ahc-execute-command-3 :if (lambda () (jabber-ahc--command-at 2))) "4" ((lambda () (jabber-ahc--command-description 3)) jabber-ahc-execute-command-4 :if (lambda () (jabber-ahc--command-at 3))) :group "Navigation" "[" ("Previous page" jabber-ahc-command-previous-page :stay-open t :if (lambda () (> jabber-ahc--command-page 0))) "]" ("Next page" jabber-ahc-command-next-page :stay-open t :if (lambda () (jabber-ahc--command-has-next-page-p)))) (defun jabber-ahc--command-list-result (jc context result) "Display XEP-0050 command RESULT for JC using CONTEXT. CONTEXT contains the originating buffer and queried JID." (let ((buffer (car context)) (to (cadr context))) (cond ((eq (car-safe result) 'error) (message "Command discovery failed: %s" (jabber-parse-error result))) ((not (buffer-live-p buffer)) (message "Command list arrived after its buffer was closed")) ((null result) (message "No ad-hoc commands found for %s" to)) (t (with-current-buffer buffer (pop-to-buffer buffer) (keymap-popup (jabber-ahc--command-list-map jc to result))))))) (defun jabber-ahc-execute-command (jc to node) "Execute ad-hoc command NODE on TO. 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--xdata (query) "Return QUERY's XEP-0004 child, if any." (seq-find (lambda (x) (string= (jabber-xml-get-attribute x 'xmlns) jabber-xdata-xmlns)) (jabber-xml-get-children query 'x))) (defun jabber-ahc--action-names (actions) "Return the actions permitted by XEP-0050 ACTIONS." (if (null actions) '("complete" "cancel") (append (cl-loop for child in (jabber-xml-node-children actions) for name = (symbol-name (jabber-xml-node-name child)) when (member name '("prev" "next" "complete")) collect name) '("cancel")))) (defun jabber-ahc--default-action (actions names) "Return the default action from ACTIONS, constrained to NAMES." (let ((default (if actions (jabber-xml-get-attribute actions 'execute) "complete"))) (and (member default names) default))) (defun jabber-ahc--action-key (name default) "Return the popup key for action NAME, given DEFAULT." (if (equal name default) "RET" (alist-get name '(("prev" . "p") ("next" . "n") ("complete" . "c") ("cancel" . "q")) nil nil #'equal))) (defun jabber-ahc--action-command (name context) "Return a command that submits action NAME using CONTEXT." (lambda () (interactive) (jabber-ahc-submit (intern name) context))) (defun jabber-ahc--menu-actions (actions context) "Return popup action plists for XEP-0050 ACTIONS using CONTEXT." (let* ((names (delete-dups (jabber-ahc--action-names actions))) (default (jabber-ahc--default-action actions names))) (mapcar (lambda (name) (list :key (jabber-ahc--action-key name default) :label (capitalize name) :command (jabber-ahc--action-command name context) :submits-form (and (member name '("next" "complete")) t))) names))) (defun jabber-ahc--render-notes (notes) "Insert XEP-0050 NOTES at point." (dolist (note notes) (let ((type (jabber-xml-get-attribute note 'type))) (when (member type '("warn" "error")) (insert (capitalize type) ": ")) (insert (or (car (jabber-xml-node-children note)) "") "\n"))) (when notes (insert "\n"))) (defun jabber-ahc--open-form (xdata actions context) "Open editable XDATA with XEP-0050 ACTIONS using CONTEXT." (pop-to-buffer (current-buffer)) (jabber-xdata-form-open (if xdata (jabber-xdata-parse xdata) '(:title "Ad-hoc command" :fields nil)) (jabber-ahc--menu-actions actions context))) (defun jabber-ahc-display (jc xml-data) "Render the ad-hoc-command result IQ XML-DATA on connection JC." (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 (jabber-ahc--xdata query)) (inhibit-read-only t)) (insert (pcase status ("executing" "Executing command\n\n") ("completed" "Command completed\n\n") ("canceled" "Command canceled\n\n") (_ ""))) (jabber-ahc--render-notes notes) (cond ((and xdata (string= (jabber-xml-get-attribute xdata 'type) "result")) (jabber-xdata-render-result xdata)) ((string= status "executing") (jabber-ahc--open-form xdata actions (list :connection jc :to from :node node :sessionid sessionid :has-form (not (null xdata)))))))) (defun jabber-ahc--resolve-connection (jc) "Return the active connection corresponding to JC." (or (and (jabber-connection-active-p jc) jc) (when-let* ((replacement (and jc (ignore-errors (jabber-find-active-connection jc)))) ((jabber-connection-active-p replacement))) replacement) (user-error "The Jabber connection is no longer active"))) (defun jabber-ahc-submit (action &optional context) "Submit ad-hoc command ACTION using captured CONTEXT." (let* ((context (or context (list :connection jabber-buffer-connection :to jabber-ahc--submit-to :node jabber-ahc-node :sessionid jabber-ahc-sessionid :has-form jabber-ahc--has-form))) (jc (jabber-ahc--resolve-connection (plist-get context :connection))) (submission (when (and (plist-get context :has-form) (memq action '(next complete))) (jabber-xdata-form-submit-form)))) (jabber-send-iq jc (plist-get context :to) "set" `(command ((xmlns . ,jabber-ahc-xmlns) (sessionid . ,(plist-get context :sessionid)) (node . ,(plist-get context :node)) (action . ,(symbol-name action))) ,@(and submission (list submission))) #'jabber-process-data #'jabber-ahc-display #'jabber-process-data "Command execution failed"))) (provide 'jabber-ahc) ;;; jabber-ahc.el ends here. emacs-jabber-0.13.1/lisp/jabber-alert.el000066400000000000000000000517211523531702000177360ustar00rootroot00000000000000;;; 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-buffer-registry) (require 'jabber-presence-display) (require 'jabber-util) (require 'jabber-xml) (require 'jabber-muc-protocol) (require 'jabber-muc-state) (defgroup jabber-alerts nil "Auditory and visual alerts for Jabber events." :group 'jabber) (defcustom jabber-alert-message-hooks '(jabber-message-echo) "Hooks run when a new message arrives. Arguments are FROM, BUFFER, TEXT and TITLE. FROM is the JID of the sender. BUFFER is an existing buffer where the message can be read, or nil when none is open. 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'. `jabber-message-scroll' is available as an opt-in hook for users who want incoming messages to move point in nonselected windows. 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) "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. `jabber-muc-scroll' is available as an opt-in hook for users who want incoming MUC messages to move point in nonselected windows. 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) (defvar jabber-alert-chat-send-function nil "Function used by automatic answers to send a one-to-one message.") (defvar jabber-alert-muc-personal-p-function nil "Function deciding whether a MUC message addresses the local nick.") ;; Global reference declarations (defvar jabber-xml-data) ; jabber.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) (defun jabber-message-default-message (from buffer _text) "Return the default alert string for a message from FROM in BUFFER." (when (or jabber-message-alert-same-buffer (not (and (buffer-live-p buffer) (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'. FROM selects the per-JID sound override; TITLE gates the action." (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 live BUFFER for a new message when TITLE is non-nil." (when (and title (buffer-live-p buffer)) (display-buffer buffer))) (defun jabber-message-switch (_from buffer _text title) "Switch to live BUFFER for a new message when TITLE is non-nil." (when (and title (buffer-live-p buffer)) (switch-to-buffer buffer))) (defun jabber-message-scroll (_from buffer _text _title) "Move point to the end of BUFFER in all nonselected windows showing it. This hook is opt-in; it is not enabled by default." ;; 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. (when (buffer-live-p buffer) (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) "Return the default alert string for a MUC message from NICK in GROUP. BUFFER is the MUC buffer." (when (or jabber-message-alert-same-buffer (not (and (buffer-live-p buffer) (memq (selected-window) (get-buffer-window-list buffer))))) (if nick (unless (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 non-nil)." (when title (funcall jabber-play-sound-file jabber-alert-muc-wave))) (defun jabber-muc-display (_nick _group buffer _text title) "Display BUFFER where a new MUC message has arrived (when TITLE is non-nil)." (when (and title (buffer-live-p buffer)) (display-buffer buffer))) (defun jabber-muc-switch (_nick _group buffer _text title) "Switch to BUFFER where a new MUC message has arrived (when TITLE non-nil)." (when (and title (buffer-live-p buffer)) (switch-to-buffer buffer))) (defun jabber-muc-scroll (_nick _group buffer _text _title) "Move point to the end of BUFFER in nonselected windows showing it. This hook is opt-in; it is not enabled by default." (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 describing the WHO presence change from OLDSTATUS to NEWSTATUS. 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) "Like `jabber-presence-default-message' but only when a chat buffer is open. 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. OLDSTATUS, NEWSTATUS and STATUSTEXT match the parent function's signature. This function is not called directly, but can be used as the value for `jabber-alert-presence-message-function'." (when (jabber-buffer-registry-find 'chat (jabber-jid-user (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'. WHO selects the per-JID sound override; PROPOSED-ALERT gates the action." (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))))) ;;; Info alert hooks (defun jabber-info-default-message (infotype buffer) "Construct an info-alert message for INFOTYPE about BUFFER. INFOTYPE is a symbol naming the kind of info request that completed. Uses `jabber-info-message-alist' to find the message text." (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'. PROPOSED-ALERT gates the action." (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 is non-nil." (when proposed-alert (display-buffer buffer))) (defun jabber-info-switch (_infotype buffer proposed-alert) "Switch to BUFFER of completed request when PROPOSED-ALERT is non-nil." (when proposed-alert (switch-to-buffer buffer))) ;;; Personal alert hooks (defmacro define-jabber-personal-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 (defun ,func (nick group buffer text title) (if (and jabber-alert-muc-personal-p-function (funcall jabber-alert-muc-personal-p-function text group)) (,name nick group buffer text title))) (cl-pushnew (quote ,func) (get 'jabber-alert-muc-hooks 'custom-options)))))) (define-obsolete-function-alias 'define-personal-jabber-alert 'define-jabber-personal-alert "0.11.0") (define-jabber-personal-alert jabber-muc-beep) (define-jabber-personal-alert jabber-muc-wave) (define-jabber-personal-alert jabber-muc-echo) (define-jabber-personal-alert jabber-muc-switch) (define-jabber-personal-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 automatically a 1:1 TEXT from FROM via `jabber-autoanswer-alist'. BUFFER is the chat buffer; PROPOSED-ALERT gates the action." (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)))))) (when (and message jabber-alert-chat-send-function) (funcall jabber-alert-chat-send-function 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) "Auto-reply to MUC TEXT from NICK in GROUP using `jabber-autoanswer-alist'. BUFFER is the MUC buffer; PROPOSED-ALERT gates the action." (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)))))) (when (and message jabber-alert-chat-send-function) (funcall jabber-alert-chat-send-function 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-0.13.1/lisp/jabber-autoaway.el000066400000000000000000000211311523531702000204510ustar00rootroot00000000000000;;; 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) "Log to *Messages* via `message' with ARGS when verbose mode is on." (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 () "Idle-tick handler: mark as idle or schedule next check." ;; 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) "Switch presence to away (or XA when XA is non-nil) and schedule unidle check." (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-xa-priority jabber-autoaway-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 () "Check idle time and return to active presence if user came back." (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-0.13.1/lisp/jabber-avatar.el000066400000000000000000000164071523531702000201070ustar00rootroot00000000000000;;; 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 jabber-avatar sha1-sum mime-type url base64-data height width bytes) (define-obsolete-function-alias 'make-avatar 'make-jabber-avatar "0.11.0") (define-obsolete-function-alias 'copy-avatar 'copy-jabber-avatar "0.11.0") (define-obsolete-function-alias 'avatar-p 'jabber-avatar-p "0.11.0") (define-obsolete-function-alias 'avatar-sha1-sum 'jabber-avatar-sha1-sum "0.11.0") (define-obsolete-function-alias 'avatar-mime-type 'jabber-avatar-mime-type "0.11.0") (define-obsolete-function-alias 'avatar-url 'jabber-avatar-url "0.11.0") (define-obsolete-function-alias 'avatar-base64-data 'jabber-avatar-base64-data "0.11.0") (define-obsolete-function-alias 'avatar-height 'jabber-avatar-height "0.11.0") (define-obsolete-function-alias 'avatar-width 'jabber-avatar-width "0.11.0") (define-obsolete-function-alias 'avatar-bytes 'jabber-avatar-bytes "0.11.0") (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-jabber-avatar :mime-type type :sha1-sum sha1-sum :base64-data base64-data :bytes bytes))) (defun jabber-avatar-image (avatar) "Create an image from AVATAR sized to fit configured avatar bounds. Return nil if images of this type are not supported." (condition-case nil (jabber-image-create (with-temp-buffer (set-buffer-multibyte nil) (insert (jabber-avatar-base64-data avatar)) (base64-decode-region (point-min) (point-max)) (buffer-string)) (jabber-avatar-mime-type avatar) jabber-avatar-max-width jabber-avatar-max-height) (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 (jabber-avatar-sha1-sum avatar)) (base64-data (jabber-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 ((jabber-avatar-p avatar) (setq hash (jabber-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 (jabber-image-create-from-file file jabber-avatar-max-width jabber-avatar-max-height) (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)))) (provide 'jabber-avatar) ;;; jabber-avatar.el ends here emacs-jabber-0.13.1/lisp/jabber-blocking.el000066400000000000000000000174421523531702000204210ustar00rootroot00000000000000;;; 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 'cl-lib) (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.") (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-chatting-with) ; jabber-chat.el (defun jabber-blocking--item-jids (query) "Return the JIDs in blocking QUERY." (delq nil (mapcar (lambda (item) (jabber-xml-get-attribute item 'jid)) (jabber-xml-get-children query 'item)))) (defun jabber-blocking--apply-push (current query) "Apply blocking push QUERY to CURRENT and return the new list." (pcase (jabber-xml-node-name query) ('block (delete-dups (append current (jabber-blocking--item-jids query)))) ('unblock (let ((jids (jabber-blocking--item-jids query))) (and jids (cl-remove-if (lambda (jid) (member jid jids)) current)))) (_ current))) (defun jabber-blocking--valid-push-p (from state-data) "Return non-nil when FROM can push blocking state for STATE-DATA." (let ((bare (concat (plist-get state-data :username) "@" (plist-get state-data :server)))) (or (null from) (string= from (plist-get state-data :server)) (string= from bare) (string= from (concat bare "/" (plist-get state-data :resource)))))) (defun jabber-blocking--process-push (jc xml-data) "Process an XEP-0191 blocking push in XML-DATA on JC." (let* ((state-data (fsm-get-state-data jc)) (from (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id)) (query (jabber-iq-query xml-data))) (when (and (jabber-blocking--valid-push-p from state-data) (memq (jabber-xml-node-name query) '(block unblock))) (plist-put state-data :blocking-list (jabber-blocking--apply-push (plist-get state-data :blocking-list) query)) (jabber-send-iq jc from "result" nil nil nil nil nil id)))) ;;;###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))) (plist-put (fsm-get-state-data jc) :blocking-list jids) (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))))) (add-to-list 'jabber-iq-set-xmlns-alist (cons jabber-blocking-xmlns #'jabber-blocking--process-push)) (jabber-disco-advertise-feature jabber-blocking-xmlns) (provide 'jabber-blocking) ;;; jabber-blocking.el ends here emacs-jabber-0.13.1/lisp/jabber-bookmarks.el000066400000000000000000000751371523531702000206260ustar00rootroot00000000000000;;; 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 'fsm) (require 'jabber-disco) (require 'jabber-lifecycle) (require 'jabber-private) (require 'jabber-pubsub) (require 'jabber-muc-state) (require 'keymap-popup) (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 ;; MUC owns bookmark integration, so reverse room operations stay lazy. (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)) (autoload 'jabber-muc-join "jabber-muc") (autoload 'jabber-muc-leave "jabber-muc") (autoload 'jabber-muc-get-buffer "jabber-muc") ;; 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) "Look up bookmark plist for CONFERENCE-JID in RESULT. If KEY is non-nil, return that field; otherwise the full plist." (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 the XML NODE 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 :extensions EXTENSIONS), 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)))) :extensions (car (jabber-xml-get-children conf 'extensions)))))) (defun jabber-bookmarks2--build-conference (plist) "Build an XEP-0402 element from bookmark PLIST. PLIST keys: :name, :autojoin, :nick, :password, :extensions. 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)))) ,@(when (plist-get plist :extensions) (list (plist-get plist :extensions))))) ;;; 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 on JC 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 on JC 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. FROM is the event sender. ITEMS is the list of and child elements from the event. Legacy accounts ignore these events." (when (and (string= from (jabber-connection-bare-jid jc)) (not (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))))))) (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--prefetch (jc) "Populate the bookmarks cache for a new session on JC." (jabber-get-bookmarks jc #'ignore)) (defun jabber-bookmarks--detect-and-fetch (jc cont &optional refresh) "Detect bookmark protocol on JC via disco and fetch via CONT. 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 for JC 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 XML-DATA for XEP-0402 bookmarks on JC. 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 for JC 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 RESULT for JC. Parse conference elements into plists, update cache, then call 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 when JC is on 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))) ;;; Bookmark editor (keymap-popup-define jabber-bookmarks-edit-map "Edit bookmark at point." :description (lambda () (format "Edit: %s" (propertize (or (tabulated-list-get-id) "(none)") 'face 'font-lock-constant-face))) :group "Edit" "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)) (defun jabber-bookmarks--edit-menu () "Show bookmark edit menu." (interactive) (keymap-popup jabber-bookmarks-edit-map)) (keymap-popup-define jabber-bookmarks-mode-map "Bookmarks commands." :parent tabulated-list-mode-map :group "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-menu) "g" ("Refresh" revert-buffer)) (keymap-set jabber-bookmarks-mode-map "h" #'jabber-bookmarks-menu) (keymap-set jabber-bookmarks-mode-map "?" #'jabber-bookmarks-menu) (defun jabber-bookmarks--column-format () "Compute `tabulated-list-format' based on window width." (let* ((w (max 0 (- (window-width) (* 5 2)))) ; subtract padding (5 cols * 2) (jid-w (max 20 (floor (* w 0.35)))) (name-w (max 12 (floor (* w 0.20)))) (autojoin-w (max 8 (floor (* w 0.10)))) (nick-w (max 12 (floor (* w 0.20)))) (password-w (max 8 (- 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) (jabber-bookmarks--refresh-buffer)) 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 (setq tabulated-list-format (jabber-bookmarks--column-format)) (tabulated-list-init-header) (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))))))) (defun jabber-bookmarks-edit () "Edit bookmark at point." (interactive) (keymap-popup jabber-bookmarks-edit-map)) (defun jabber-bookmarks-menu () "Show bookmarks commands." (interactive) (keymap-popup jabber-bookmarks-mode-map)) ;;; Disconnect cleanup (defun jabber-bookmarks--on-disconnect () "Pre-disconnect hook. Clear bookmark caches." (clrhash jabber-bookmarks) (clrhash jabber-bookmarks--legacy-accounts)) (add-hook 'jabber-pre-disconnect-hook #'jabber-bookmarks--on-disconnect) (add-hook 'jabber-lifecycle-session-bootstrap-functions #'jabber-bookmarks--prefetch 10) (provide 'jabber-bookmarks) ;;; jabber-bookmarks.el ends here emacs-jabber-0.13.1/lisp/jabber-browse.el000066400000000000000000000102571523531702000201270ustar00rootroot00000000000000;;; 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) (defconst jabber-browse-xmlns "jabber:iq:browse" "XEP-0011 Jabber Browsing namespace.") (defun jabber-get-browse (jc to) "Send a browse infoquery request to TO. 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-0.13.1/lisp/jabber-buffer-registry.el000066400000000000000000000052321523531702000217420ustar00rootroot00000000000000;;; jabber-buffer-registry.el --- Chat buffer lookup registry -*- 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: ;; Provides lookup by chat kind without depending on chat rendering modules. ;;; Code: (defvar jabber-buffer-registry--buffers (make-hash-table :test #'equal) "Hash table mapping chat kinds and peer keys to live buffers.") (defvar-local jabber-buffer-registry--keys nil "Registry keys owned by the current buffer.") (defun jabber-buffer-registry--key (kind peer) "Return the registry key for chat KIND and PEER." (cons kind peer)) (defun jabber-buffer-registry--remove-current () "Remove registry entries owned by the current buffer." (dolist (key jabber-buffer-registry--keys) (when (eq (gethash key jabber-buffer-registry--buffers) (current-buffer)) (remhash key jabber-buffer-registry--buffers))) (setq jabber-buffer-registry--keys nil)) (defun jabber-buffer-registry-register (kind peer &optional buffer) "Register BUFFER under chat KIND and PEER. BUFFER defaults to the current buffer." (with-current-buffer (or buffer (current-buffer)) (let ((key (jabber-buffer-registry--key kind peer))) (puthash key (current-buffer) jabber-buffer-registry--buffers) (unless (member key jabber-buffer-registry--keys) (push key jabber-buffer-registry--keys)) (add-hook 'kill-buffer-hook #'jabber-buffer-registry--remove-current nil t) (current-buffer)))) (defun jabber-buffer-registry-find (kind peer) "Return the live buffer registered under chat KIND and PEER." (let* ((key (jabber-buffer-registry--key kind peer)) (buffer (gethash key jabber-buffer-registry--buffers))) (if (buffer-live-p buffer) buffer (remhash key jabber-buffer-registry--buffers) nil))) (provide 'jabber-buffer-registry) ;;; jabber-buffer-registry.el ends here emacs-jabber-0.13.1/lisp/jabber-carbons.el000066400000000000000000000062321523531702000202530ustar00rootroot00000000000000;;; 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-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) "Callback when the carbons enable IQ succeeded. JC is the Jabber connection. XML-DATA is the IQ response." (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) "Callback when the carbons enable IQ failed. XML-DATA is the IQ error stanza." (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-0.13.1/lisp/jabber-chat-commands.el000066400000000000000000000236571523531702000213540ustar00rootroot00000000000000;;; jabber-chat-commands.el --- Chat buffer feature commands -*- 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. ;;; Commentary: ;; Assemble commands from chat feature modules after their providers load. ;;; Code: (require 'keymap-popup) (require 'jabber-blocking) (require 'jabber-chat) (require 'jabber-chatbuffer) (require 'jabber-httpupload) (require 'jabber-info) (require 'jabber-mam) (require 'jabber-message-correct) (require 'jabber-message-reply) (require 'jabber-message-thread) (require 'jabber-moderation) (require 'jabber-muc) (require 'jabber-muc-menu) (require 'jabber-presence) (require 'jabber-reactions) (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-trust" ()) (defvar jabber-chat-encryption-menu-map) (defvar jabber-chat-operations-menu-map) (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: ") (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) (when (buffer-live-p buffer) (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))))))) (defun jabber-chat-encryption-set-omemo () "Set encryption to OMEMO for this chat buffer." (interactive) (require 'jabber-omemo) (unless (eq (bound-and-true-p jabber-omemo--available) t) (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)) (keymap-popup-define jabber-chat-encryption-menu-map "Select encryption for this chat buffer." :description (lambda () (format "Encryption (current: %s)" (propertize (symbol-name jabber-chat-encryption) 'face (if (eq jabber-chat-encryption 'plaintext) 'shadow 'success)))) "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-encryption-menu () "Select encryption for this chat buffer." (interactive) (keymap-popup jabber-chat-encryption-menu-map)) (defun jabber-chat-show-fingerprints () "Display OMEMO fingerprints for the current chat peer." (interactive) (require 'jabber-omemo-trust) (jabber-omemo-fingerprints)) (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)) (symbol (jabber-jid-symbol jid))) (jabber-roster-change jabber-buffer-connection symbol (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)))) (defun jabber-chat-muc-actions-menu () "Show MUC actions for the current chat buffer." (interactive) (keymap-popup jabber-muc-menu-map)) (keymap-popup-define jabber-chat-operations-menu-map :description (lambda () (let ((peer (or (bound-and-true-p jabber-group) (bound-and-true-p jabber-chatting-with)))) (if peer (format "Operations for %s" (propertize peer 'face 'font-lock-constant-face)) "Chat operations"))) :group "Encryption" "e" ("Encryption" jabber-chat-encryption-menu) "f" ("Fingerprints" jabber-chat-show-fingerprints) :group "Files" "a" ("Attach file" jabber-chat-attach-file) :group "Contact" "I" ("Get info" jabber-chat-get-info :if (lambda () (bound-and-true-p jabber-chatting-with))) "A" ("Add contact" jabber-chat-add-contact :if (lambda () (bound-and-true-p jabber-chatting-with))) "D" ("Remove contact" jabber-chat-remove-contact :if (lambda () (bound-and-true-p jabber-chatting-with))) "B" ("Block/unblock user" jabber-blocking-toggle-chat-peer :if (lambda () (bound-and-true-p jabber-chatting-with))) :group "Messages" "E" ("Edit last message" jabber-correct-last-message) "r" ("Reply to message" jabber-chat-reply) "t" ("Reply in thread" jabber-message-thread-open :if #'jabber-message-thread-available-p) "T" ("Send draft as new thread" jabber-message-thread-start :if #'jabber-message-thread-available-p) "l" ("Browse threads..." jabber-message-thread-browse :if #'jabber-message-thread-available-p) :group "MUC" "m" ("MUC Actions" jabber-chat-muc-actions-menu :if (lambda () (bound-and-true-p jabber-group))) "M" ("Retract message at point" jabber-moderation-retract :if (lambda () (bound-and-true-p jabber-group))) "X" ("Retract all by occupant" jabber-moderation-retract-by-occupant :if (lambda () (bound-and-true-p jabber-group))) :group "Buffer" "L" ("Set thread title..." jabber-message-thread-set-title :if (lambda () (bound-and-true-p jabber-message-thread-id))) "n" ((lambda () (format "Message count: %s" (propertize (number-to-string (jabber-chat-buffer-msg-count)) 'face 'keymap-popup-value))) jabber-chat-set-msg-count :stay-open) "R" ("Refresh" jabber-chat-buffer-refresh) "S" ("Sync & refresh" jabber-mam-sync-buffer)) (defun jabber-chat-set-msg-count (count) "Set the message count for the current chat buffer to COUNT." (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)) (keymap-popup jabber-chat-operations-menu-map)) (defun jabber-chat-operations-menu () "Chat buffer operations." (interactive) (keymap-popup jabber-chat-operations-menu-map)) (defconst jabber-chat-command-bindings '(("RET" . jabber-chat-goto-reply-target-or-send) ("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-m" . jabber-muc-menu) ("C-c C-r" . jabber-chat-reply) ("C-c C-k" . jabber-chat-cancel-reply) ("+" . jabber-chat-image-enlarge-or-self-insert) ("=" . jabber-chat-image-enlarge-or-self-insert) ("-" . jabber-chat-image-shrink-or-self-insert) ("0" . jabber-chat-image-reset-size-or-self-insert) ("!" . jabber-reactions-react-at-point-or-insert)) "Feature command bindings added to `jabber-chat-mode-map'.") (dolist (binding jabber-chat-command-bindings) (keymap-set jabber-chat-mode-map (car binding) (cdr binding))) (keymap-set jabber-chat-mode-map "C-c C-t" #'jabber-message-thread-open) (provide 'jabber-chat-commands) ;;; jabber-chat-commands.el ends here emacs-jabber-0.13.1/lisp/jabber-chat.el000066400000000000000000003451111523531702000175450ustar00rootroot00000000000000;;; 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-buffer-registry) (require 'jabber-chatbuffer) (require 'jabber-db) (require 'jabber-message-reply) (require 'jabber-message-thread) (require 'jabber-reactions) (require 'ewoc) (require 'goto-addr) (require 'seq) (require 'subr-x) (require 'url-parse) (require 'url-queue) (require 'hex-util) (require 'jabber-image) (require 'jabber-muc-protocol) (require 'jabber-muc-state) (require 'jabber-presence-display) ;; For the `image-property' setf-expander (not preloaded on emacs-nox). (require 'image) (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 'roster "When to automatically fetch and display image URLs inline. t means auto-display in every chat buffer. nil means never fetch automatically. The symbol `roster' means auto-display only in one-to-one chats whose peer is on the roster; in MUC buffers and chats with unknown peers, image URLs stay clickable and RET loads them. Automatic display is further limited to the image types in `jabber-chat-image-auto-types' and the size limit in `jabber-image-max-bytes'." :type '(choice (const :tag "All chat buffers" t) (const :tag "Roster contacts only" roster) (const :tag "Never (load with RET)" nil))) (defcustom jabber-chat-image-auto-types '(png jpeg gif webp) "Image types eligible for automatic inline display. The type is detected from the downloaded bytes, never from the URL. Images of other types stay clickable URLs; loading them with RET bypasses this list but not `jabber-image-max-bytes'." :type '(repeat (symbol :tag "Image type"))) (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 (if (char-displayable-p ?🔒) "🔒" "[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-chat--body-start nil "Buffer position where the current message body starts. Bound dynamically during ewoc rendering so that printer-chain functions can style or fontify only the body region.") (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.") (defvar jabber-chat-local-message-functions nil "Functions called after a new outgoing message enters its chat buffer. Each function receives the message plist while its owning buffer is current.") (defvar jabber-chat--sending-correction nil "Non-nil while send hooks run for an XEP-0308 correction stanza. Hooks holding state for the next composed message (e.g. pending reply data) should stay inert instead of consuming it.") (defvar jabber-chat--send-hook-stanza nil "The outgoing stanza, bound while `jabber-chat-send-hooks' run. Lets late hooks (e.g. the DB store) read elements that earlier hooks attached, without changing the (BODY ID) hook signature.") (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. When STANZA is an XEP-0308 correction, the hooks run with `jabber-chat--sending-correction' bound non-nil so that hooks holding state for the next composed message stay inert." (let ((jabber-chat--send-hook-stanza stanza) (jabber-chat--sending-correction (and (jabber-xml-child-with-xmlns stanza "urn:xmpp:message-correct:0") t))) (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)))))) (defun jabber-chat--root-reply-element (id jid) "Return a root reply element for ID and optional JID." `(reply ((xmlns . "urn:xmpp:reply:0") ,@(and jid (list (cons 'to jid))) (id . ,id)))) (defun jabber-chat--captured-thread (stanza correction-p) "Return the thread captured from STANZA or buffer state. CORRECTION-P keeps unrelated pending composition state untouched." (or (jabber-message-thread-protocol-fields stanza) (and (not correction-p) jabber-message-reply--thread) (and (not correction-p) jabber-message-thread-id (list :thread-id jabber-message-thread-id :thread-parent-id jabber-message-thread-parent-id)) (and (not correction-p) (when-let* ((thread-id (jabber-chat--ensure-session-thread))) (list :thread-id thread-id :thread-parent-id nil))))) (defun jabber-chat--parent-session-buffer-p () "Return non-nil in an ordinary one-to-one parent chat buffer." (and (bound-and-true-p jabber-chatting-with) (not (bound-and-true-p jabber-group)) (not (bound-and-true-p jabber-muc-private-p)) (not jabber-message-thread-id))) (defun jabber-chat--store-session-thread (thread-id &optional jc) "Make THREAD-ID current in this parent chat buffer and persist it. JC, when non-nil, identifies the account connection." (when (and thread-id (jabber-chat--parent-session-buffer-p)) (let ((account (jabber-connection-bare-jid (or jc jabber-buffer-connection))) (peer (jabber-jid-user jabber-chatting-with))) (unless (equal thread-id jabber-message-thread-session-id) (setq jabber-message-thread-session-id thread-id) (jabber-db-set-chat-thread account peer thread-id)) thread-id))) (defun jabber-chat--ensure-session-thread () "Return this parent chat's session ID, creating it when needed." (when (jabber-chat--parent-session-buffer-p) (or jabber-message-thread-session-id (jabber-chat--store-session-thread (jabber-message-thread--generate-id))))) (defun jabber-chat--retire-session-thread (&optional jc) "Retire this parent chat's current session and persist that on JC." (when (and jabber-message-thread-session-id (jabber-chat--parent-session-buffer-p)) (let ((account (jabber-connection-bare-jid (or jc jabber-buffer-connection))) (peer (jabber-jid-user jabber-chatting-with))) (setq jabber-message-thread-session-id nil) (jabber-db-set-chat-thread account peer nil)))) (defun jabber-chat--session-send-hook (_body _id) "Attach the parent chat session when no explicit thread is present." (unless (or (bound-and-true-p jabber-chat--sending-correction) (and (bound-and-true-p jabber-chat--send-hook-stanza) (jabber-message-thread-protocol-has-core-p jabber-chat--send-hook-stanza))) (when-let* ((thread-id (jabber-chat--ensure-session-thread))) (jabber-message-thread-protocol-elements thread-id nil)))) (defun jabber-chat--buffer-account-p (buffer jc) "Return non-nil when BUFFER belongs to JC's account." (and (buffer-live-p buffer) (when-let* ((buffer-jc (buffer-local-value 'jabber-buffer-connection buffer))) (equal (jabber-connection-bare-jid buffer-jc) (jabber-connection-bare-jid jc))))) (defun jabber-chat--adopt-parent-session (jc chat-buffer xml-data from msg-plist) "Adopt a live parent session from MSG-PLIST in CHAT-BUFFER. JC identifies the receiving account. XML-DATA and FROM distinguish live direct messages from archive traffic." (when (and (jabber-chat--buffer-account-p chat-buffer jc) (not (plist-get msg-plist :thread-parent-id)) (not (plist-get msg-plist :delayed)) (not (jabber-xml-get-attribute xml-data 'jabber-mam--origin)) (not (jabber-muc-sender-p from))) (with-current-buffer chat-buffer (jabber-chat--store-session-thread (or (plist-get msg-plist :thread-id) (jabber-message-thread--generate-id)) jc)))) (defun jabber-chat--reply-fallback-length (body) "Return the pending reply fallback length valid for BODY." (and jabber-message-reply--fallback-text (not (string-empty-p jabber-message-reply--fallback-text)) (string-prefix-p jabber-message-reply--fallback-text body) (length jabber-message-reply--fallback-text))) (defun jabber-chat--captured-reply-elements (body correction-p) "Return one pending reply extension for BODY unless CORRECTION-P." (unless correction-p (cond (jabber-message-reply--id (jabber-message-reply--elements jabber-message-reply--id jabber-message-reply--jid (jabber-chat--reply-fallback-length body))) (jabber-message-thread--root-reply-id (list (jabber-chat--root-reply-element jabber-message-thread--root-reply-id jabber-message-thread--root-reply-jid)))))) (defun jabber-chat--send-context-state (correction-p) "Return restorable one-shot state unless CORRECTION-P." (unless correction-p (list :reply-id jabber-message-reply--id :reply-jid jabber-message-reply--jid :fallback-text jabber-message-reply--fallback-text :reply-thread jabber-message-reply--thread :root-reply-id jabber-message-thread--root-reply-id :root-reply-jid jabber-message-thread--root-reply-jid))) (defun jabber-chat--clear-send-context () "Clear one-shot reply state after capturing an asynchronous send." (setq jabber-message-reply--id nil jabber-message-reply--jid nil jabber-message-reply--fallback-text nil jabber-message-reply--thread nil jabber-message-thread--root-reply-id nil jabber-message-thread--root-reply-jid nil)) (defun jabber-chat--capture-send-context (body extra-elements) "Capture one-shot reply and thread state for an asynchronous send. BODY determines the XEP-0428 fallback range. EXTRA-ELEMENTS take precedence over buffer-local thread state." (let* ((stanza `(message () ,@extra-elements)) (correction-p (jabber-xml-child-with-xmlns stanza "urn:xmpp:message-correct:0")) (thread (jabber-chat--captured-thread stanza correction-p)) (thread-elements (unless (or correction-p (jabber-message-thread-protocol-has-core-p stanza)) (jabber-message-thread-protocol-elements (plist-get thread :thread-id) (plist-get thread :thread-parent-id)))) (reply-elements (jabber-chat--captured-reply-elements body correction-p)) (state (jabber-chat--send-context-state correction-p))) (unless correction-p (jabber-chat--clear-send-context)) (list :extra-elements (append (copy-tree extra-elements) thread-elements reply-elements) :state state))) (defun jabber-chat--restore-send-context (context) "Restore one-shot state from failed asynchronous send CONTEXT. Do not overwrite a newer reply selection." (when-let* ((state (plist-get context :state))) (unless (or jabber-message-reply--id jabber-message-thread--root-reply-id) (setq jabber-message-reply--id (plist-get state :reply-id) jabber-message-reply--jid (plist-get state :reply-jid) jabber-message-reply--fallback-text (plist-get state :fallback-text) jabber-message-reply--thread (plist-get state :reply-thread) jabber-message-thread--root-reply-id (plist-get state :root-reply-id) jabber-message-thread--root-reply-jid (plist-get state :root-reply-jid))))) ;; Optional providers load at their action boundary. MUC paths run only after ;; MUC has established their buffer data. The remaining reverse calls load ;; through autoloads because their providers require chat. (declare-function jabber-omemo--send-chat "jabber-omemo" (jc body &optional extra-elements success-callback failure-callback)) (declare-function jabber-openpgp--send-chat "jabber-openpgp" (jc body &optional extra-elements success-callback failure-callback)) (declare-function jabber-openpgp-legacy--send-chat "jabber-openpgp-legacy" (jc body &optional extra-elements)) (declare-function jabber-omemo-aesgcm-decrypt "jabber-omemo" (key iv ciphertext)) (declare-function jabber-muc-private-create-buffer "jabber-muc" (jc group nickname)) (declare-function jabber-muc-private-find-buffer "jabber-muc" (group nickname)) (declare-function jabber-muc-print-prompt "jabber-muc" (msg &optional local dont-print-nick-p)) (declare-function jabber-muc-system-prompt "jabber-muc" (&rest _ignore)) (defvar jabber-backlog-days) (defvar jabber-backlog-number) (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 buffers &optional new-occupant-id account peer legacy-authorized-p)) (autoload 'jabber-message-correct--replace-id "jabber-message-correct") (autoload 'jabber-message-correct--apply "jabber-message-correct") (defvar jabber-group) ; jabber-muc.el (defvar jabber-muc-printers) ; jabber-muc.el (declare-function jabber-mam-chat-opened "jabber-mam" (jc peer)) (autoload 'jabber-mam-chat-opened "jabber-mam") (declare-function jabber-chatstates--clear-typing "jabber-chatstates" ()) (autoload 'jabber-chatstates--clear-typing "jabber-chatstates") (defvar jabber-oob-xmlns) ; jabber-xml.el ;; (defconst jabber-chat--forward-xmlns "urn:xmpp:forward:0" "XEP-0297 forwarded stanza namespace.") (defconst jabber-chat--carbons-xmlns "urn:xmpp:carbons:2" "XEP-0280 Message Carbons namespace.") (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-buffer-registry-find '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-buffer-registry-register 'chat (jabber-jid-user chat-with)) (setq-local jabber-message-thread-session-id (jabber-db-get-chat-thread (jabber-connection-bare-jid jc) (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) nil nil nil nil (not jabber-message-thread-use-buffers)))) (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)))) (jabber-chat-buffer-recenter-input)) ;; 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))) (unless (jabber-chat-ewoc-duplicate-p node-data) ;; 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)))) (jabber-chat-ewoc-register-node node node-data))))) (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-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 (seq-find (lambda (child) (and (memq (jabber-xml-node-name child) '(sent received)) (string= (jabber-xml-get-xmlns child) jabber-chat--carbons-xmlns))) (jabber-xml-node-children xml-data)))) (when wrapper (let* ((type (jabber-xml-node-name wrapper)) (fwd (jabber-xml-child-with-xmlns wrapper jabber-chat--forward-xmlns)) (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 . EXISTING-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 (and to (jabber-chat--find-buffer-on-connection jc to))))) ('received (cons inner-msg nil))))))))) (defun jabber-chat--reaction-only-p (xml-data) "Return non-nil when XML-DATA is a reaction-only stanza." (jabber-reactions--reaction-only-p xml-data)) (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 (jabber-chat--reply-fields xml-data) (jabber-message-thread--fields xml-data)))))) (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 on XML-DATA with error handling. JC is the Jabber connection. PARSED is the parsed message plist. 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.") (defvar jabber-chat--decrypt-consumed-p nil "Non-nil when a decrypt handler consumed state before failing.") (defvar jabber-chat--decrypt-retryable-failure-p nil "Non-nil when a decrypt failure may be retried safely.") ;;; Decrypt dedup cache (defvar jabber-chat--decrypt-cache (make-hash-table :test #'equal) "Decryption outcomes for recently seen encrypted stanzas. Keys bind the account and sender to encrypted payload identity. Values pair the outer stanza context with the decrypted outcome. Ratchet decryption is stateful, so repeated ciphertext must never reach the ratchet twice. A repeat with changed outer behavior is rejected instead of replaying plaintext under the changed wrapper. Failures before state consumption remain retryable. Outcomes after state consumption are cached so ciphertext never reaches the ratchet twice.") (defun jabber-chat--decrypt-cache-canonical-xml (node) "Return a stable representation of XML NODE." (if (not (consp node)) node (let ((attrs (sort (copy-tree (jabber-xml-node-attributes node)) (lambda (a b) (string< (symbol-name (car a)) (symbol-name (car b))))))) (cons (jabber-xml-node-name node) (cons attrs (mapcar #'jabber-chat--decrypt-cache-canonical-xml (jabber-xml-node-children node))))))) (defun jabber-chat--decrypt-cache-muc-user-child (child) "Return canonical MUC user CHILD, or nil for archive-only item data." (if (and (consp child) (equal (jabber-xml-get-xmlns child) jabber-muc-xmlns-user)) (let ((children (cl-remove-if (lambda (node) (and (consp node) (eq (jabber-xml-node-name node) 'item))) (jabber-xml-node-children child)))) (when children (cons (jabber-xml-node-name child) (cons (jabber-xml-node-attributes child) children)))) child)) (defun jabber-chat--decrypt-cache-canonical-stanza (xml-data) "Return the behavior context form for encrypted XML-DATA." (let* ((attrs (copy-tree (jabber-xml-node-attributes xml-data))) (groupchat (equal (cdr (assq 'type attrs)) "groupchat")) (attrs (if groupchat (assq-delete-all 'to attrs) attrs)) (children (delq nil (mapcar (if groupchat #'jabber-chat--decrypt-cache-muc-user-child #'identity) (jabber-xml-node-children xml-data))))) (jabber-chat--decrypt-cache-canonical-xml (cons (jabber-xml-node-name xml-data) (cons attrs children))))) (defun jabber-chat--decrypt-cache-key (jc xml-data) "Return the ciphertext dedup key for XML-DATA received on JC." (when-let* ((from (jabber-xml-get-attribute xml-data 'from)) (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")))) (list (jabber-connection-bare-jid jc) from (secure-hash 'sha256 (prin1-to-string (jabber-chat--decrypt-cache-canonical-xml encrypted)))))) (defun jabber-chat--decrypt-cache-context (xml-data) "Return a digest of XML-DATA's behaviorally relevant wrapper." (secure-hash 'sha256 (prin1-to-string (jabber-chat--decrypt-cache-canonical-stanza xml-data)))) (defun jabber-chat--decrypt-cache-put (key value) "Store decrypt VALUE for ciphertext identity KEY." (puthash key value jabber-chat--decrypt-cache)) (defun jabber-chat--decrypt-outcome (xml-data) "Return the cacheable decrypt outcome for XML-DATA. The body string when the stanza carries text, `no-body' when it has none, nil when decryption failed (placeholder body)." (let ((body (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'body)))))) (cond ((null body) 'no-body) ((jabber--decrypt-failure-body-p body) nil) (t body)))) (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. A cached outcome reaches its handler at most once per session: repeated deliveries are served from `jabber-chat--decrypt-cache' instead of re-running the ratchet. Failures before state consumption remain retryable and may reach the handler again. Outcomes after state consumption are cached; payload failures leave a placeholder body while empty failures stay bodyless. Handlers may additionally schedule their own repair (see `jabber-omemo--recover-prekey-failure'). 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)) (if (null (jabber-xml-get-attribute xml-data 'from)) xml-data (let* ((key (and (jabber-xml-encrypted-p xml-data) (jabber-chat--decrypt-cache-key jc xml-data))) (context (and key (jabber-chat--decrypt-cache-context xml-data))) (cached (and key (gethash key jabber-chat--decrypt-cache))) (outcome (plist-get cached :outcome))) (cond ((and cached (not (equal context (plist-get cached :context)))) (jabber-chat--set-body xml-data (format "[%s: could not decrypt]" (plist-get cached :label)))) ((eq outcome 'failed) (jabber-chat--set-body xml-data (format "[%s: could not decrypt]" (plist-get cached :label)))) ((eq outcome 'no-body) xml-data) ((stringp outcome) (jabber-chat--set-body xml-data outcome)) (t (jabber-chat--dispatch-decrypt jc xml-data key context)))))) (defun jabber-chat--dispatch-decrypt (jc xml-data key context) "Run the first matching decrypt handler on XML-DATA over JC. When KEY is non-nil and a handler ran, record the outcome in `jabber-chat--decrypt-cache'. Returns XML-DATA." ;; First-match-wins: the dispatcher stops at the first handler whose ;; :detect returns non-nil, so re-entrancy guards are unnecessary. (cl-loop for (_id . props) in (jabber-chat--sorted-decrypt-handlers) for parsed = (funcall (plist-get props :detect) xml-data) when parsed return (let* ((jabber-chat--decrypt-consumed-p nil) (jabber-chat--decrypt-retryable-failure-p nil) (result (jabber-chat--try-decrypt jc xml-data parsed props)) (outcome (jabber-chat--decrypt-outcome result))) (when (and key (not jabber-chat--decrypt-retryable-failure-p)) (when (or outcome jabber-chat--decrypt-consumed-p) (jabber-chat--decrypt-cache-put key (list :context context :outcome (or outcome 'failed) :label (plist-get props :error-label))))) result) 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 is the Jabber connection, used to detect self-authored carbons. _XML-DATA is reserved for future use by OMEMO." (let* ((body-text (plist-get msg-plist :body)) (self-p (string= (jabber-jid-user from) (jabber-connection-bare-jid jc))) (alert-buffer (or chat-buffer (and (not error-p) (not self-p) (plist-get msg-plist :thread-id) (jabber-chat--find-buffer-on-connection jc from))))) (when chat-buffer (with-current-buffer chat-buffer (jabber-chat-buffer-with-scrolltobottom (jabber-chatstates--clear-typing) (jabber-maybe-print-rare-time (jabber-chat-ewoc-enter (list (if error-p :error :foreign) msg-plist)))))) (when (and (not error-p) (not self-p)) (let ((inhibit-message (and chat-buffer (buffer-local-value 'jabber-chat-mam-syncing chat-buffer)))) (dolist (hook '(jabber-message-hooks jabber-alert-message-hooks)) (run-hook-with-args hook from alert-buffer body-text (funcall jabber-alert-message-function from alert-buffer body-text))))))) (defun jabber-chat--find-buffer (from) "Return an existing chat buffer for FROM, or nil; never create one." (if (jabber-muc-sender-p from) (jabber-muc-private-find-buffer (jabber-jid-user from) (jabber-jid-resource from)) (jabber-chat-find-buffer from))) (defun jabber-chat--buffer-peer-p (buffer from muc-private-p) "Return non-nil when BUFFER is the chat for FROM and MUC-PRIVATE-P." (and (buffer-live-p buffer) (with-current-buffer buffer (and (eq major-mode 'jabber-chat-mode) (bound-and-true-p jabber-chatting-with) (not (bound-and-true-p jabber-message-thread-id)) (if muc-private-p (and (bound-and-true-p jabber-muc-private-p) (equal jabber-chatting-with from)) (and (not (bound-and-true-p jabber-group)) (not (bound-and-true-p jabber-muc-private-p)) (equal (jabber-jid-user jabber-chatting-with) (jabber-jid-user from)))))))) (defun jabber-chat--find-buffer-on-connection (jc from) "Return FROM's existing chat buffer on JC, or nil; never create one." (let* ((muc-private-p (jabber-muc-sender-p from)) (registered (jabber-chat--find-buffer from))) (if (jabber-chat--buffer-account-p registered jc) registered (seq-find (lambda (buffer) (and (jabber-chat--buffer-account-p buffer jc) (jabber-chat--buffer-peer-p buffer from muc-private-p))) (buffer-list))))) (defun jabber-chat--log-error (from msg-plist) "Log the error in MSG-PLIST from FROM to the echo area when no buffer is open." (message "jabber: error from %s: %s" (jabber-jid-displayname from) (or (plist-get msg-plist :error-text) "Unknown error"))) (defun jabber-chat--error-node-matches-p (node from text) "Return non-nil when ewoc NODE is an :error from FROM with TEXT." (and node (let ((data (ewoc-data node))) (and (eq (car data) :error) (listp (cadr data)) (equal (plist-get (cadr data) :from) from) (equal (plist-get (cadr data) :error-text) text))))) (defun jabber-chat--enter-error-collapsed (msg-plist) "Insert MSG-PLIST as an :error node, collapsing a repeat of the last error. When the most recent ewoc node is an identical error, bump its repeat count and redraw it instead of adding a new line." (let ((last (ewoc-nth jabber-chat-ewoc -1)) (from (plist-get msg-plist :from)) (text (plist-get msg-plist :error-text))) (if (jabber-chat--error-node-matches-p last from text) (let* ((data (ewoc-data last)) (count (1+ (or (plist-get (cadr data) :count) 1)))) (setcar (cdr data) (plist-put (cadr data) :count count)) (jabber-chat-ewoc-invalidate last)) (jabber-maybe-print-rare-time (jabber-chat-ewoc-enter (list :error msg-plist)))))) (defun jabber-chat--display-error (jc from msg-plist) "Show MSG-PLIST's error from FROM on JC without creating a buffer. If a chat buffer for FROM exists, insert the error there, collapsing a repeat of the previous identical error. Otherwise log to the echo area." (if-let* ((buffer (jabber-chat--find-buffer-on-connection jc from))) (with-current-buffer buffer (jabber-chat-buffer-with-scrolltobottom (jabber-chat--enter-error-collapsed msg-plist))) (jabber-chat--log-error from msg-plist))) (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))) (unless (jabber-chat--reaction-only-p xml-data) (let* ((replace-id (jabber-message-correct--replace-id xml-data)) (account (jabber-connection-bare-jid jc)) (counterpart (if (equal (jabber-jid-user from) account) (jabber-xml-get-attribute xml-data 'to) from)) (peer (jabber-jid-user counterpart)) (thread-target (if replace-id 'correction (if (and (plist-get msg-plist :thread-id) (not (jabber-muc-sender-p from))) (jabber-message-thread-display-target jc peer "chat" msg-plist) 'parent)))) (cond ((and replace-id (not jabber-chat-mam-syncing)) (jabber-message-correct--apply replace-id (plist-get msg-plist :body) from nil (lambda (original) (let ((targets (jabber-message-thread-update-targets-for-row jc peer "chat" (plist-get original :row-id)))) (cond ((eq targets 'closed) nil) (targets targets) (t (delq nil (list (or carbon-buffer (jabber-chat--find-buffer-on-connection jc from)))))))) (jabber-db--extract-occupant-id xml-data) account peer)) (error-p (jabber-chat--display-error jc from msg-plist)) ((run-hook-with-args-until-success 'jabber-chat-printers msg-plist :foreign :printp) (let ((chat-buffer (cond ((eq thread-target 'parent) (if (jabber-xml-get-attribute xml-data 'jabber-mam--origin) (jabber-chat--find-buffer-on-connection jc counterpart) (jabber-chat--select-buffer jc counterpart carbon-buffer))) ((eq thread-target 'closed) nil) ((listp thread-target) thread-target) (t thread-target)))) (jabber-chat--display-message jc xml-data chat-buffer nil from msg-plist) (when (eq thread-target 'parent) (jabber-chat--adopt-parent-session jc chat-buffer xml-data from msg-plist))))) (when is-carbon (jabber-chat--store-carbon jc xml-data))))))) (defun jabber-chat--local-message-buffer (jc msg-plist) "Return MSG-PLIST's live local-echo buffer on JC, or nil." (let* ((source (current-buffer)) (thread-id (plist-get msg-plist :thread-id)) (peer (and (bound-and-true-p jabber-chatting-with) (jabber-jid-user jabber-chatting-with))) (account (jabber-connection-bare-jid jc)) (location (and thread-id peer (plist-get msg-plist :id) (jabber-db-message-thread-location account peer "chat" (plist-get msg-plist :id) nil)))) (cond ((and thread-id (not jabber-message-thread-use-buffers)) (or (jabber-message-thread--parent-buffer account peer "chat") source)) ((or (null thread-id) (plist-get location :root)) source) (location (jabber-message-thread-find-buffer account peer "chat" thread-id)) ((equal thread-id (bound-and-true-p jabber-message-thread-id)) source) (t (or (jabber-message-thread-find-buffer account peer "chat" thread-id) source))))) (defun jabber-chat--display-local-message (jc msg-plist) "Display local MSG-PLIST in its canonical live buffer on JC." (when-let* ((buffer (jabber-chat--local-message-buffer jc msg-plist))) (with-current-buffer buffer (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) (when node (run-hook-with-args 'jabber-chat-local-message-functions msg-plist)) node))))) (defun jabber-chat-send (jc body &optional extra-elements success-callback failure-callback) "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 (require 'jabber-omemo) (jabber-omemo--send-chat jc body extra-elements success-callback failure-callback)) ('openpgp (require 'jabber-openpgp) (jabber-openpgp--send-chat jc body extra-elements success-callback failure-callback)) ('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) (jabber-chat--display-local-message jc msg-plist))) ;; ...and send it... (jabber-send-sexp jc stanza-to-send) (when success-callback (funcall success-callback)))))) (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. When GLOBAL is non-nil (prefix arg), set the default value instead of the buffer-local one. 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 for MESSAGE. This matches MESSAGE's :muc-notification text against `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 when XML-DATA carries 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)))) (defconst jabber-chat--reply-xmlns "urn:xmpp:reply:0" "XEP-0461 message replies namespace.") (defconst jabber-chat--fallback-xmlns "urn:xmpp:fallback:0" "XEP-0428 fallback indication namespace.") (defun jabber-chat--fallback-offset (value) "Return VALUE as a non-negative integer, or nil." (and (stringp value) (string-match-p "\\`[0-9]+\\'" value) (string-to-number value))) (defun jabber-chat--reply-fallback-element (xml-data) "Return the XEP-0428 element for replies in XML-DATA. A stanza may carry several fallback elements with different `for' attributes; a non-reply one must not mask the reply one." (seq-find (lambda (child) (and (eq (jabber-xml-node-name child) 'fallback) (equal (jabber-xml-get-xmlns child) jabber-chat--fallback-xmlns) (equal (jabber-xml-get-attribute child 'for) jabber-chat--reply-xmlns))) (jabber-xml-node-children xml-data))) (defun jabber-chat--reply-fallback-range (xml-data) "Return the XEP-0461 fallback body range in XML-DATA. Return `all' when the fallback applies to the whole body: no child, or one without offsets (XEP-0428: missing start/end attributes mean the entire element; Dino emits bare for full quotes)." (when-let* ((fallback (jabber-chat--reply-fallback-element xml-data))) (if-let* ((body (car (jabber-xml-get-children fallback 'body)))) (let ((start (jabber-xml-get-attribute body 'start)) (end (jabber-xml-get-attribute body 'end))) (if (or start end) (when-let* ((from (jabber-chat--fallback-offset start)) (to (jabber-chat--fallback-offset end))) (list from to)) 'all)) 'all))) (defconst jabber-chat--sid-xmlns "urn:xmpp:sid:0" "XEP-0359 unique and stable stanza IDs namespace.") (defun jabber-chat--origin-id-send-hook (_body id) "Return an XEP-0359 element carrying ID. Stamps every outgoing message so peers replying to us can reference a stable id instead of the message id attribute." (and id (list `(origin-id ((xmlns . ,jabber-chat--sid-xmlns) (id . ,id)))))) (add-hook 'jabber-chat-send-hooks #'jabber-chat--origin-id-send-hook) (add-hook 'jabber-chat-send-hooks #'jabber-chat--session-send-hook 80) (defun jabber-chat--stanza-id-element (xml-data &optional expected-by) "Return the first valid XEP-0359 child in XML-DATA. When EXPECTED-BY is non-nil, accept only elements whose `by' attribute matches it. Occupants can inject stanza-id elements with arbitrary `by' values, so groupchat callers must pass the room JID." (seq-find (lambda (child) (and (eq (jabber-xml-node-name child) 'stanza-id) (string= (jabber-xml-get-xmlns child) jabber-chat--sid-xmlns) (jabber-xml-get-attribute child 'id) (let ((by (jabber-xml-get-attribute child 'by))) (and by (or (null expected-by) (string= by expected-by)))))) (jabber-xml-node-children xml-data))) (defun jabber-chat--origin-id (xml-data) "Return the XEP-0359 id in XML-DATA, or nil. Shares its namespace with , so match on the node name." (let ((el (seq-find (lambda (child) (and (eq (jabber-xml-node-name child) 'origin-id) (string= (jabber-xml-get-xmlns child) jabber-chat--sid-xmlns))) (jabber-xml-node-children xml-data)))) (and el (jabber-xml-get-attribute el 'id)))) (defun jabber-chat--server-id (xml-data) "Return the trusted XEP-0359 stanza-id in XML-DATA, or nil. In groupchat, only the room itself may assign the stanza-id \(XEP-0461). Elsewhere the archive JID is not known here, so any `by' is accepted." (let* ((from (jabber-xml-get-attribute xml-data 'from)) (type (jabber-xml-get-attribute xml-data 'type)) (sid-el (jabber-chat--stanza-id-element xml-data (and (equal type "groupchat") from (jabber-jid-user from))))) (and sid-el (jabber-xml-get-attribute sid-el 'id)))) (defun jabber-chat--reply-fields (xml-data) "Return XEP-0461 reply fields in XML-DATA as a plist, or nil." (and-let* ((reply-el (jabber-xml-child-with-xmlns xml-data jabber-chat--reply-xmlns))) (list :reply-to-id (jabber-xml-get-attribute reply-el 'id) :reply-to-jid (jabber-xml-get-attribute reply-el 'to) :fallback-range (jabber-chat--reply-fallback-range xml-data)))) (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)))) (append (list :id (jabber-xml-get-attribute xml-data 'id) :server-id (jabber-chat--server-id xml-data) :origin-id (jabber-chat--origin-id xml-data) :from (jabber-xml-get-attribute xml-data 'from) :body (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data '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)) :unstyled (and (jabber-xml-child-with-xmlns xml-data "urn:xmpp:styling:0") t)) (jabber-chat--reply-fields xml-data) (jabber-message-thread--fields xml-data)))) (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--reaction-sender () "Return the local sender key for reaction display." (jabber-reactions--local-sender)) (defun jabber-chat--reaction-entry-string (entry) "Return propertized reaction summary text for ENTRY. The text carries a `help-echo' naming who reacted, shown as a tooltip on mouse hover and reachable from the keyboard with \\[display-local-help]." (propertize (format "%d%s" (plist-get entry :count) (plist-get entry :reaction)) 'face (if (plist-get entry :chosen) 'jabber-reaction-chosen 'jabber-reaction) 'help-echo (jabber-reactions--entry-help-echo entry))) (defun jabber-chat--insert-reactions (msg) "Insert compact reaction summaries for MSG." (unless (plist-get msg :retracted) (when-let* ((entries (jabber-reactions--display-entries (plist-get msg :reactions) (jabber-chat--reaction-sender)))) (insert "\n" (string-join (mapcar #'jabber-chat--reaction-entry-string entries) " "))))) (defun jabber-chat--insert-thread-summary (msg) "Insert a compact thread marker for MSG." (when (jabber-message-thread-available-p) (when-let* ((summary (plist-get msg :thread-summary))) (let* ((count (plist-get summary :reply-count)) (label (format "[%d %s]" count (if (= count 1) "Reply" "Replies")))) (insert "\n") (insert-text-button label 'face (if (plist-get summary :unread) '(:inherit link :weight bold) 'shadow) 'follow-link t 'help-echo "Open thread" 'action (lambda (button) (jabber-message-thread-open (save-excursion (goto-char (button-start button)) (jabber-message-thread--message-at-point))))))))) (defun jabber-chat--reply-context-label (msg) "Return a compact reply context label for MSG, or nil. Only replies without a fallback quote get a label; when the quote is in the body the reply context is already visible inline." (and (plist-get msg :reply-to-id) (null (plist-get msg :fallback-range)) (let ((who (and-let* ((jid (plist-get msg :reply-to-jid))) (if (jabber-muc-sender-p jid) (jabber-jid-resource jid) (jabber-jid-displayname jid))))) (if (and who (not (string-empty-p who))) (format "reply to %s" who) "reply")))) (defun jabber-chat--first-line-snippet (text limit) "Return the first line of TEXT, truncated to LIMIT characters." (let ((line (car (split-string text "\n")))) (if (> (length line) limit) (concat (substring line 0 limit) "…") line))) (defun jabber-chat--reply-context-snippet (msg) "Return a snippet of the original body MSG replies to, or nil. Looks the referenced message up in the local database." (and-let* ((reply-id (plist-get msg :reply-to-id)) (jabber-buffer-connection) (peer (or (bound-and-true-p jabber-group) jabber-chatting-with)) (body (jabber-db-reply-target-body (jabber-connection-bare-jid jabber-buffer-connection) (jabber-jid-user peer) reply-id (and (bound-and-true-p jabber-group) t)))) (jabber-chat--first-line-snippet body 80))) (defun jabber-chat--insert-reply-context (msg) "Insert reply context line for MSG when it needs one. When the referenced message is in the local database, quote a snippet of it after the label." (when-let* ((label (jabber-chat--reply-context-label msg))) (let ((snippet (jabber-chat--reply-context-snippet msg))) (insert (propertize (if snippet (format "%s: %s\n" label snippet) (concat label "\n")) 'face 'shadow))))) (defun jabber-chat--reply-target-at-point () "Return the :reply-to-id of the rendered message at point, or nil. Only meaningful in the message area, above the input divider." (and jabber-chat-ewoc (markerp jabber-point-insert) (< (point) jabber-point-insert) (when-let* ((node (ewoc-locate jabber-chat-ewoc (point))) (msg (cadr (ewoc-data node)))) (and (listp msg) (plist-get msg :reply-to-id))))) (defun jabber-chat-goto-reply-target () "Move point to the message the reply at point references." (interactive) (let ((target (jabber-chat--reply-target-at-point))) (unless target (user-error "No reply at point")) (let ((node (jabber-chat-ewoc-find-by-id target))) (unless node (user-error "The original message is not in this buffer")) (goto-char (ewoc-location node)) (require 'pulse) (pulse-momentary-highlight-region (ewoc-location node) (or (and-let* ((next (ewoc-next jabber-chat-ewoc node))) (ewoc-location next)) jabber-point-insert))))) (defun jabber-chat-goto-reply-target-or-send () "Jump to the replied-to message at point, or send the input. On a rendered reply, move point to the original message; anywhere else, behave like `jabber-chat-buffer-send'." (interactive) (if (jabber-chat--reply-target-at-point) (jabber-chat-goto-reply-target) (jabber-chat-buffer-send))) (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) (jabber-chat--insert-reply-context msg) (let ((jabber-chat--body-start (point))) (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) (jabber-chat--insert-reactions msg) (jabber-chat--insert-thread-summary 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) (jabber-chat--insert-reply-context msg) (let ((jabber-chat--body-start (point))) (run-hook-with-args 'jabber-chat-printers msg :foreign :insert)) (when (plist-get msg :edited) (insert (propertize " (edited)" 'face 'shadow))) (jabber-chat--insert-reactions msg) (jabber-chat--insert-thread-summary msg) (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) (jabber-chat--insert-reply-context msg) (let ((jabber-chat--body-start (point))) (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) (jabber-chat--insert-reactions msg) (jabber-chat--insert-thread-summary 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) (jabber-chat--insert-reply-context msg) (let ((jabber-chat--body-start (point))) (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))) (jabber-chat--insert-reactions msg) (jabber-chat--insert-thread-summary msg)) (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. TIMESTAMP overrides MSG's :timestamp when non-nil. DELAYED selects the delayed-message face. When DONT-PRINT-NICK-P is non-nil, omit the nickname." (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. TIMESTAMP overrides MSG's :timestamp when non-nil. DELAYED selects the delayed-message face. When DONT-PRINT-NICK-P is non-nil, omit the nickname." (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)) (count (plist-get msg :count))) (insert (propertize (concat "Error: " (or error-text "Unknown error") (and count (> count 1) (format " (×%d)" count))) 'face 'jabber-chat-error) "\n"))) (defun jabber-chat-print-subject (msg _who mode) "Print subject from message plist MSG, if any, in display MODE." (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) "Dispatch MSG/WHO/MODE through `jabber-body-printers' until one succeeds." (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. WHO and MODE follow the `jabber-body-printers' contract." (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 in display MODE. Skip 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--aesgcm-image-result-from-body (encrypted key iv allowed-types) "Decrypt ENCRYPTED and return an image result. KEY, IV, and ALLOWED-TYPES follow `jabber-chat--aesgcm-image-from-body'." (cond ((null encrypted) (list :error 'response)) ((not (jabber-image--size-ok-p encrypted)) (list :error 'size)) (t (condition-case err (jabber-image--result-from-data (jabber-omemo-aesgcm-decrypt key iv encrypted) allowed-types) (error (list :error 'decrypt :message (error-message-string err))))))) (defun jabber-chat--aesgcm-image-from-body (encrypted key iv allowed-types) "Decrypt ENCRYPTED with KEY and IV and build an inline image. Return nil when ENCRYPTED is missing or exceeds `jabber-image-max-bytes', decryption fails, or the plaintext fails the ALLOWED-TYPES check per `jabber-image-from-data'." (let ((result (jabber-chat--aesgcm-image-result-from-body encrypted key iv allowed-types))) (when (eq (plist-get result :error) 'decrypt) (message "aesgcm: decryption failed: %s" (plist-get result :message))) (plist-get result :image))) (defun jabber-chat--fetch-aesgcm-image-result (url allowed-types callback &rest cbargs) "Fetch URL and call CALLBACK with a decrypted image result and CBARGS. ALLOWED-TYPES restricts the decoded image types; nil permits any." (let ((parsed (jabber-chat--parse-aesgcm-url url))) (if (null parsed) (apply callback (list :error 'url) cbargs) (require 'jabber-omemo) (url-queue-retrieve (plist-get parsed :https-url) (lambda (status key iv types cb args) (let ((url-buffer (current-buffer)) (result (if (plist-get status :error) (list :error 'fetch) (jabber-chat--aesgcm-image-result-from-body (jabber-image--response-body) key iv types)))) (kill-buffer url-buffer) (apply cb result args))) (list (plist-get parsed :key) (plist-get parsed :iv) allowed-types callback cbargs) 'silent 'inhibit-cookies)))) (defun jabber-chat--fetch-aesgcm-image (url allowed-types callback &rest cbargs) "Fetch and decrypt an aesgcm:// image URL. Downloads via HTTPS, decrypts with AES-256-GCM, and calls CALLBACK with the created image (or nil) followed by CBARGS. ALLOWED-TYPES and `jabber-image-max-bytes' are enforced per `jabber-image-from-data'." (apply #'jabber-chat--fetch-aesgcm-image-result url allowed-types (lambda (result cb args) (apply cb (plist-get result :image) args)) callback cbargs)) (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 when URL has an image-like 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.") (define-key jabber-chat-url-keymap "+" #'jabber-chat-image-enlarge) (define-key jabber-chat-url-keymap "=" #'jabber-chat-image-enlarge) (define-key jabber-chat-url-keymap "-" #'jabber-chat-image-shrink) (define-key jabber-chat-url-keymap "0" #'jabber-chat-image-reset-size) (defvar jabber-chat--image-cache (make-hash-table :test 'equal) "Session-local cache mapping image URLs to Emacs image objects.") (defvar jabber-chat--image-scale-cache (make-hash-table :test 'equal) "Session-local cache mapping image URLs to manual resize scales. Lets a manual resize survive redraws that regenerate the URL text.") (defconst jabber-chat--image-scale-step 1.25 "Multiplier used by inline image resize commands.") (defconst jabber-chat--image-min-scale 0.25 "Smallest inline image scale factor.") (defconst jabber-chat--image-max-scale 4.0 "Largest inline image scale factor.") (defun jabber-chat-copy-url () "Copy the URL at point to the kill ring and display it." (interactive) (if-let* ((url (or (get-text-property (point) 'jabber-chat-file-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--image-url-bounds (&optional position) "Return (BEG END URL) for the image URL at POSITION, or nil. POSITION defaults to point." (let* ((position (or position (point))) (url (get-text-property position 'jabber-chat-image-url))) (when url (list (or (previous-single-property-change (1+ position) 'jabber-chat-image-url) (point-min)) (or (next-single-property-change position 'jabber-chat-image-url) (point-max)) url)))) (defun jabber-chat--load-image-at-point () "Fetch and display the image URL at point inline. Bypasses `jabber-chat-display-images' and `jabber-chat-image-auto-types' as an explicit user action, but not `jabber-image-max-bytes'." (pcase-let ((`(,beg ,end ,url) (jabber-chat--image-url-bounds))) (cond ((null url) (user-error "No image URL at point")) ((not (display-graphic-p)) (user-error "Cannot display images on a text terminal")) ((equal (jabber-chat--image-fetch-state beg) url) (message "Image fetch already in progress")) ((jabber-chat--restore-cached-image url beg end)) (t (let ((inhibit-read-only t)) (jabber-chat--start-image-fetch url beg end nil t)) (message "Loading image..."))))) (defun jabber-chat-url-action-at-point (&optional arg) "Load the image URL at point inline, or download the URL at point. An image URL that is not yet displayed is fetched and shown inline. Displayed images, file URLs, and any URL with prefix ARG are downloaded to a file, decrypting aesgcm:// URLs after download." (interactive "P") (let ((file-url (get-text-property (point) 'jabber-chat-file-url)) (image-url (get-text-property (point) 'jabber-chat-image-url))) (cond (file-url (jabber-chat-download-url file-url)) ((null image-url) (user-error "No downloadable URL at point")) ((or arg (get-text-property (point) 'display)) (jabber-chat-download-url image-url)) (t (jabber-chat--load-image-at-point))))) (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." (require 'jabber-omemo) (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--clamp-image-scale (scale) "Clamp SCALE to the allowed inline image scale range." (min jabber-chat--image-max-scale (max jabber-chat--image-min-scale scale))) (defun jabber-chat--base-image-size (image) "Return IMAGE's base max size as (WIDTH . HEIGHT)." (cons (or (image-property image :max-width) jabber-image-max-width) (or (image-property image :max-height) jabber-image-max-height))) (defun jabber-chat--scaled-image (image scale) "Return a copy of IMAGE scaled by SCALE. The original IMAGE object is not modified." (let* ((scaled (copy-sequence image)) (size (jabber-chat--base-image-size image)) (scale (jabber-chat--clamp-image-scale scale))) (setf (image-property scaled :max-width) (max 1 (round (* (car size) scale)))) (setf (image-property scaled :max-height) (max 1 (round (* (cdr size) scale)))) scaled)) (defun jabber-chat--apply-image-display (image beg end url &optional scale) "Display IMAGE over URL text from BEG to END. Preserve the underlying URL text so refresh/redraw can redisplay it. SCALE defaults to 1.0 and is stored on the displayed range." (let* ((scale (jabber-chat--clamp-image-scale (or scale 1.0))) (display-image (jabber-chat--scaled-image image scale)) (inhibit-read-only t)) (add-text-properties beg end (list 'display display-image 'jabber-chat-image-url url 'jabber-chat-image-base image 'jabber-chat-image-scale scale 'jabber-chat-image-fetching nil)) (jabber-chat--add-url-keymap beg end) ;; The goto-address overlay's link face would draw an underline ;; beneath the image, and its mouse-face would highlight it. (dolist (ov (overlays-in beg end)) (when (overlay-get ov 'goto-address) (overlay-put ov 'face nil) (overlay-put ov 'mouse-face nil))) display-image)) (defun jabber-chat--cache-image (url image) "Cache IMAGE for URL and return IMAGE." (puthash url image jabber-chat--image-cache) image) (defun jabber-chat--restore-cached-image (url beg end) "Apply cached image for URL to text from BEG to END. Reuse any remembered manual resize scale. Return non-nil when a cached image was applied." (when-let* ((image (gethash url jabber-chat--image-cache))) (jabber-chat--apply-image-display image beg end url (gethash url jabber-chat--image-scale-cache)))) (defun jabber-chat--image-range-at-point (&optional position) "Return inline image data at POSITION as a plist, or nil. The plist contains :beg, :end, :url, :image, and :scale." (let ((position (or position (point)))) (and-let* ((display (get-text-property position 'display)) (image (or (get-text-property position 'jabber-chat-image-base) display)) (bounds (jabber-chat--image-url-bounds position))) (pcase-let ((`(,beg ,end ,url) bounds)) (list :beg beg :end end :url url :image image :scale (or (get-text-property position 'jabber-chat-image-scale) 1.0)))))) (defun jabber-chat--resize-image-at-point (scale-fn) "Resize inline image at point using SCALE-FN." (if-let* ((range (jabber-chat--image-range-at-point))) (let* ((old-scale (plist-get range :scale)) (new-scale (jabber-chat--clamp-image-scale (funcall scale-fn old-scale)))) (jabber-chat--apply-image-display (plist-get range :image) (plist-get range :beg) (plist-get range :end) (plist-get range :url) new-scale) (puthash (plist-get range :url) new-scale jabber-chat--image-scale-cache) (message "Image scale: %.0f%%" (* 100 new-scale))) (user-error "No inline image at point"))) (defun jabber-chat-image-enlarge () "Enlarge the inline image at point." (interactive) (jabber-chat--resize-image-at-point (lambda (scale) (* scale jabber-chat--image-scale-step)))) (defun jabber-chat-image-shrink () "Shrink the inline image at point." (interactive) (jabber-chat--resize-image-at-point (lambda (scale) (/ scale jabber-chat--image-scale-step)))) (defun jabber-chat-image-reset-size () "Reset the inline image at point to its default size." (interactive) (jabber-chat--resize-image-at-point (lambda (_) 1.0))) (defun jabber-chat--image-command-or-self-insert (command n) "Call image COMMAND at point, or fall back to `self-insert-command'. N is passed to `self-insert-command' when point is not on an inline image." (if (jabber-chat--image-range-at-point) (call-interactively command) (self-insert-command n))) (defun jabber-chat-image-enlarge-or-self-insert (n) "Enlarge image at point, or insert the typed character N times." (interactive "p") (jabber-chat--image-command-or-self-insert #'jabber-chat-image-enlarge n)) (defun jabber-chat-image-shrink-or-self-insert (n) "Shrink image at point, or insert the typed character N times." (interactive "p") (jabber-chat--image-command-or-self-insert #'jabber-chat-image-shrink n)) (defun jabber-chat-image-reset-size-or-self-insert (n) "Reset image at point, or insert the typed character N times." (interactive "p") (jabber-chat--image-command-or-self-insert #'jabber-chat-image-reset-size n)) (defun jabber-chat--image-displayed-p (beg url) "Return non-nil when BEG already displays URL image." (and (get-text-property beg 'display) (equal (get-text-property beg 'jabber-chat-image-url) url))) (defun jabber-chat--add-url-keymap (beg end) "Put the chat URL keymap on text from BEG to END." (add-text-properties beg end (list 'local-map jabber-chat-url-keymap 'keymap jabber-chat-url-keymap 'rear-nonsticky t))) (defun jabber-chat--mark-image-fetching (beg end url) "Mark URL text from BEG to END as an image fetch attempt." (add-text-properties beg end (list 'jabber-chat-image-url url 'jabber-chat-image-fetching url)) (jabber-chat--add-url-keymap beg end)) (defun jabber-chat--url-markers-valid-p (beg end url buffer) "Return non-nil when markers BEG and END still delimit URL in BUFFER. Must be called with BUFFER current." (and (markerp beg) (markerp end) (eq (marker-buffer beg) buffer) (eq (marker-buffer end) buffer) (marker-position beg) (marker-position end) (<= beg end) (equal (buffer-substring-no-properties beg end) url))) (defun jabber-chat--replace-url-with-image (image url beg end buffer) "Display fetched IMAGE over URL text between markers BEG and END. Cache IMAGE by URL. When IMAGE is nil, mark the URL text in BUFFER as a failed fetch so the automatic scan does not retry it; manual loading with RET still may." (when image (jabber-chat--cache-image url image)) (when (buffer-live-p buffer) (with-current-buffer buffer (when (jabber-chat--url-markers-valid-p beg end url buffer) (let ((inhibit-read-only t)) (cond (image (jabber-chat--apply-image-display image beg end url)) ((not (jabber-chat--image-displayed-p beg url)) (put-text-property beg end 'jabber-chat-image-fetching 'failed)))))))) (defun jabber-chat--offer-image-save (url data) "Offer to save fetched DATA from URL without another download." (when (y-or-n-p "Cannot display image; save it instead? ") (let* ((parsed (and (string-prefix-p "aesgcm://" url) (jabber-chat--parse-aesgcm-url url))) (save-url (if parsed (plist-get parsed :https-url) url)) (dest (jabber-chat--download-destination save-url))) (jabber-chat--record-download-directory dest) (with-temp-file dest (set-buffer-multibyte nil) (insert data)) (message "Downloaded %s" dest)))) (defun jabber-chat--handle-image-result (result url beg end buffer manual) "Handle fetched image RESULT for URL between BEG and END in BUFFER. When MANUAL is non-nil, offer retained bytes after a decode failure." (when (and (buffer-live-p buffer) (with-current-buffer buffer (jabber-chat--url-markers-valid-p beg end url buffer))) (jabber-chat--replace-url-with-image (plist-get result :image) url beg end buffer) (when (and manual (eq (plist-get result :error) 'decode) (plist-get result :data)) (jabber-chat--offer-image-save url (plist-get result :data))))) (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 (MODE = :insert). 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--auto-display-images-p () "Return non-nil when this buffer may auto-display inline images. Implements `jabber-chat-display-images': nil means never, `roster' means only one-to-one chats with roster contacts, any other non-nil value means always." (pcase jabber-chat-display-images ('nil nil) ('roster (and jabber-chatting-with (jabber-roster-contact-p jabber-buffer-connection jabber-chatting-with))) (_ t))) (defun jabber-chat--image-fetch-state (beg) "Return the image fetch state at BEG. nil when never attempted, the URL string while a fetch is in flight, or the symbol `failed' after an unsuccessful attempt." (get-text-property beg 'jabber-chat-image-fetching)) (defun jabber-chat--isolate-image-url (beg end) "Ensure the URL between BEG and END starts on its own line. Return the possibly shifted bounds as a cons cell." (cond ((or (= beg (point-min)) (eq (char-before beg) ?\n)) (cons beg end)) (t (save-excursion (goto-char beg) (insert "\n")) (cons (1+ beg) (1+ end))))) (defun jabber-chat--start-image-fetch (url beg end allowed-types &optional manual) "Fetch image URL and display it over BEG..END in the current buffer. ALLOWED-TYPES restricts decoding per `jabber-image-from-data'; nil permits any supported type. MANUAL is non-nil for a fetch explicitly requested by the user." (jabber-chat--mark-image-fetching beg end url) (let ((beg (copy-marker beg)) (end (copy-marker end)) (buf (current-buffer))) (if (string-prefix-p "aesgcm://" url) (jabber-chat--fetch-aesgcm-image-result url allowed-types #'jabber-chat--handle-image-result url beg end buf manual) (jabber-image--fetch-result url allowed-types #'jabber-chat--handle-image-result url beg end buf manual)))) (defun jabber-chat--scan-image-url (url beg end auto) "Process one image URL between BEG and END found by the scan. Mark it clickable, restore a cached image when available, and when AUTO is non-nil start a fetch restricted to `jabber-chat-image-auto-types'." (jabber-chat--add-url-keymap beg end) (put-text-property beg end 'jabber-chat-image-url url) (unless (jabber-chat--image-displayed-p beg url) (unless (jabber-chat--restore-cached-image url beg end) (when (and auto (null (jabber-chat--image-fetch-state beg))) (jabber-chat--start-image-fetch url beg end jabber-chat-image-auto-types))))) (defun jabber-chat-display-buffer-images () "Scan buffer for image URLs and display permitted ones inline. URL text is preserved; images that `jabber-chat-display-images' does not auto-display stay clickable and load with RET." (interactive) (save-excursion (let ((inhibit-read-only t) (limit (and (markerp jabber-point-insert) jabber-point-insert)) (auto (jabber-chat--auto-display-images-p))) (when (display-graphic-p) (goto-char (point-min)) (while (re-search-forward jabber-chat--image-url-re limit t) (let* ((url (match-string-no-properties 0)) (bounds (jabber-chat--isolate-image-url (match-beginning 0) (match-end 0)))) (jabber-chat--scan-image-url url (car bounds) (cdr bounds) auto))))))) (defun jabber-chat-goto-address (_msg _who mode) "Call function `goto-address' on the newly written text (MODE = :insert)." (when (eq mode :insert) (condition-case err (let ((end (point)) (start (or jabber-chat--body-start (point-min)))) (when (< start end) (goto-address-fontify start end) ;; Clip overlays that leaked past end. During ewoc ;; invalidation the body text abuts the next node with no ;; separator, so bounds-of-thing-at-point can extend into ;; the next message. (dolist (ov (overlays-in start end)) (when (and (overlay-get ov 'goto-address) (> (overlay-end ov) end)) (move-overlay ov (overlay-start ov) 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 in MSG (MODE = :insert) for download. 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) (jabber-chat--add-url-keymap beg end)))))))))))) (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. Runs only when MODE is :insert. 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) (jabber-chat--add-url-keymap beg url-end) (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 stanza to TO with SUBJECT, BODY and TYPE. 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))) (jabber-mam-chat-opened jc (jabber-jid-user 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 OTHER-WINDOW, 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")))) (setq jabber-alert-chat-send-function #'jabber-chat-send) (provide 'jabber-chat) ;;; jabber-chat.el ends here emacs-jabber-0.13.1/lisp/jabber-chatbuffer.el000066400000000000000000001006261523531702000207370ustar00rootroot00000000000000;;; 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-buffer-registry) (require 'jabber-input) (require 'jabber-core) (require 'jabber-db) (require 'jabber-muc-protocol) (require 'help-at-pt) (defcustom jabber-scrolltobottom-all nil "Non-nil means explicit input recentering affects all chat windows. When `jabber-chat-buffer-recenter-input' is called, recenter all visible windows displaying the current chat buffer whose window point is in the input area, at or after `jabber-point-insert'. The default nil preserves the current behavior of recentering only one visible window. Receive-time message insertion does not automatically adjust windows." :type 'boolean :group 'jabber-chat) (defun jabber-chat-buffer--recenter-input-p (window) "Return non-nil when WINDOW should recenter to the input area." (and (window-live-p window) (with-current-buffer (window-buffer window) (and (markerp jabber-point-insert) (eq (marker-buffer jabber-point-insert) (window-buffer window)) (>= (window-point window) jabber-point-insert))))) (defun jabber-chat-buffer--recenter-input-window (window) "Recenter WINDOW so the input area is at the bottom." (with-selected-window window (let ((resize-mini-windows nil)) (save-excursion (goto-char jabber-point-insert) (recenter -1))))) (defun jabber-chat-buffer--recenter-input-all () "Recenter all visible `current-buffer' windows following the input area." (dolist (window (get-buffer-window-list (current-buffer) nil 'visible)) (when (jabber-chat-buffer--recenter-input-p window) (jabber-chat-buffer--recenter-input-window window)))) (defun jabber-chat-buffer-recenter-input () "Recenter visible `current-buffer' window(s) to the input area." (if jabber-scrolltobottom-all (jabber-chat-buffer--recenter-input-all) (when-let* ((window (get-buffer-window (current-buffer)))) (when (jabber-chat-buffer--recenter-input-p window) (jabber-chat-buffer--recenter-input-window window))))) (defun jabber-chat-buffer-with-scrolltobottom (&rest values) "Return the last of VALUES without scroll side effects." (car (last values))) (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-header-line-format-override nil "Buffer-specific chat header format, or nil to use the default.") (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.") (declare-function jabber-muc-nick-completion-at-point "jabber-muc-nick-completion" ()) (autoload 'jabber-muc-nick-completion-at-point "jabber-muc-nick-completion") (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 (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))) (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 operations menu.") (defun jabber-chat-buffer-msg-count () "Return the effective message count for this buffer." (or jabber-chat-buffer-msg-count jabber-backlog-number)) ;; 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 "S-" #'jabber-chat-newline "TAB" #'completion-at-point "" #'backward-button) (defcustom jabber-chat-display-help-at-point t "When non-nil, show local help at point in chat buffers automatically. After Emacs has been idle for `help-at-pt-timer-delay' seconds, the `help-echo' text at point -- such as who reacted to a message -- is printed in the echo area. The same information is always available on demand with \\[display-local-help] and, in a graphical frame, as a mouse tooltip, regardless of this setting. Changing this takes effect in newly created chat buffers." :type 'boolean :group 'jabber-chat) (defun jabber-chat--enable-help-at-point () "Display `help-echo' at point automatically in the current chat buffer. Reuse the shared `help-at-pt' idle timer and scope it to this buffer with a buffer-local `help-at-pt-display-when-idle', leaving other buffers unaffected." (setq-local help-at-pt-display-when-idle '(help-echo)) (help-at-pt-set-timer)) (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) (when jabber-chat-display-help-at-point (jabber-chat--enable-help-at-point)) (put 'jabber-chat-mode 'flyspell-mode-predicate #'jabber-chat-mode-flyspell-verify)) ;;; bug-reference integration (defcustom jabber-bug-reference-alist '(("jabber-el@conference\\.hmm\\.st" "\\(#\\([0-9]+\\)\\)" "https://todos.thanosapollo.org/r/emacs-jabber/%s")) "Alist mapping JID patterns to `bug-reference-mode' configurations. Each entry has the form (JID-REGEXP BUG-REGEXP URL-FORMAT). JID-REGEXP is matched against the MUC room JID (e.g. \"emacs@conference.jabber.org\") or 1:1 chat partner bare JID. BUG-REGEXP and URL-FORMAT are set as `bug-reference-bug-regexp' and `bug-reference-url-format' respectively. To activate bug references in chat buffers, add `bug-reference-mode' to `jabber-chat-mode-hook': (add-hook \\='jabber-chat-mode-hook #\\='bug-reference-mode)" :type '(repeat (list (regexp :tag "JID regexp") (regexp :tag "Bug regexp") (choice :tag "URL format" (string :tag "Format string") (function :tag "Function")))) :group 'jabber-chat) (defun jabber-bug-reference--try-setup (jid) "Try to configure `bug-reference-mode' for JID. Match JID against `jabber-bug-reference-alist' and set the buffer-local bug-reference variables on the first match." (catch 'done (dolist (entry jabber-bug-reference-alist) (when (string-match-p (nth 0 entry) jid) (setq-local bug-reference-bug-regexp (nth 1 entry)) (setq-local bug-reference-url-format (nth 2 entry)) (throw 'done t))))) (defun jabber-bug-reference-setup () "Try setting up `bug-reference-mode' for Jabber chat buffers. Added to `bug-reference-auto-setup-functions' so that activating `bug-reference-mode' in a chat buffer automatically configures the bug regexp and URL format from `jabber-bug-reference-alist'." (when (derived-mode-p 'jabber-chat-mode) (when-let* ((jid (jabber-chat--peer-jid))) (jabber-bug-reference--try-setup jid)))) (add-hook 'bug-reference-auto-setup-functions #'jabber-bug-reference-setup) (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 101) ;; 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 (eq (bound-and-true-p jabber-omemo--available) t) (setq jabber-chat-encryption 'plaintext)))) (jabber-chat-encryption--update-header)) ;; Chat owns rendering while depending on this lower-level buffer module. (declare-function jabber-chat--insert-backlog-chunked "jabber-chat" (buffer entries callback &optional generation)) (declare-function jabber-chat-display-buffer-images "jabber-chat" ()) (autoload 'jabber-chat--insert-backlog-chunked "jabber-chat") (autoload 'jabber-chat-display-buffer-images "jabber-chat") (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 ALL-CHATS, regenerate all `jabber-chat-mode' buffers; otherwise regenerate the current buffer display. Scroll 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 (or jabber-chat-header-line-format-override (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) (jabber-chat-buffer-recenter-input))) (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-buffer--shift-undo-list (shift) "Translate buffer positions in `buffer-undo-list' by SHIFT." (unless (or (zerop shift) (atom buffer-undo-list)) (let ((list buffer-undo-list) elt) (while list (setq elt (car list)) (cond ((integerp elt) (setcar list (+ elt shift))) ((or (atom elt) (markerp (car elt))) nil) ((integerp (car elt)) (setcar elt (+ (car elt) shift)) (setcdr elt (+ (cdr elt) shift))) ((stringp (car elt)) (setcdr elt (+ (cdr elt) (* (if (natnump (cdr elt)) 1 -1) shift)))) ((null (car elt)) (let ((cons (nthcdr 3 elt))) (setcar cons (+ (car cons) shift)) (setcdr cons (+ (cdr cons) shift))))) (setq list (cdr list)))))) (defun jabber-chat-ewoc--muc-data-p (data) "Return non-nil when DATA is a MUC message entry." (memq (car-safe data) '(:muc-local :muc-foreign :muc-error))) (defun jabber-chat-ewoc--client-id-key (msg id muc-p) "Return the index key for MSG client ID ID. MUC-P makes client IDs sender-scoped." (if (and muc-p (plist-get msg :from)) (list :muc (plist-get msg :from) id) id)) (defun jabber-chat-ewoc-duplicate-p (data) "Return non-nil when message DATA is already displayed." (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))) (id-key (and id (jabber-chat-ewoc--client-id-key msg id (jabber-chat-ewoc--muc-data-p data))))) (or (and id-key (gethash id-key jabber-chat--msg-nodes)) (and sid (gethash sid jabber-chat--msg-nodes))))) (defun jabber-chat-ewoc-register-node (node data) "Register EWOC NODE under the message identities in DATA." (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))) (id-key (and id (jabber-chat-ewoc--client-id-key msg id (jabber-chat-ewoc--muc-data-p data))))) (when id-key (puthash id-key node jabber-chat--msg-nodes)) (when sid (puthash sid node jabber-chat--msg-nodes)) node)) (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." (unless (jabber-chat-ewoc-duplicate-p data) (let ((preinsert-point (and (markerp jabber-point-insert) (marker-position jabber-point-insert)))) (let ((node (let ((buffer-undo-list t)) (ewoc-enter-last jabber-chat-ewoc data)))) (when preinsert-point (jabber-chat-buffer--shift-undo-list (- jabber-point-insert preinsert-point))) (jabber-chat-ewoc-register-node node data))))) (defun jabber-chat-ewoc--msg-matches-id-p (msg stanza-id) "Return non-nil when MSG has STANZA-ID as :id, :origin-id or :server-id." (and (listp msg) (or (equal stanza-id (plist-get msg :id)) (equal stanza-id (plist-get msg :origin-id)) (equal stanza-id (plist-get msg :server-id))))) (defun jabber-chat-ewoc--find-by-id-scan (stanza-id &optional sender) "Scan `jabber-chat-ewoc' for STANZA-ID, optionally from SENDER." (let ((node (and jabber-chat-ewoc (ewoc-nth jabber-chat-ewoc 0))) found) (while (and node (not found)) (let ((msg (cadr (ewoc-data node)))) (if (and (jabber-chat-ewoc--msg-matches-id-p msg stanza-id) (or (null sender) (equal sender (plist-get msg :from)))) (setq found node) (setq node (ewoc-next jabber-chat-ewoc node))))) found)) (defun jabber-chat-ewoc--backfill-node-ids (node) "Backfill non-nil message IDs from NODE into `jabber-chat--msg-nodes'." (let* ((msg (cadr (ewoc-data node))) (id (and (listp msg) (plist-get msg :id))) (sid (and (listp msg) (plist-get msg :server-id))) (id-key (and id (jabber-chat-ewoc--client-id-key msg id (jabber-chat-ewoc--muc-data-p (ewoc-data node)))))) (when id-key (puthash id-key node jabber-chat--msg-nodes)) (when sid (puthash sid node jabber-chat--msg-nodes)))) (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) (or (gethash stanza-id jabber-chat--msg-nodes) (when-let* ((node (jabber-chat-ewoc--find-by-id-scan stanza-id))) (jabber-chat-ewoc--backfill-node-ids node) node)))) (defun jabber-chat-ewoc-find-by-id-and-sender (stanza-id sender) "Return the ewoc node for STANZA-ID sent by full JID SENDER." (when (and stanza-id sender jabber-chat--msg-nodes) (or (gethash (list :muc sender stanza-id) jabber-chat--msg-nodes) (when-let* ((node (jabber-chat-ewoc--find-by-id-scan stanza-id sender))) (jabber-chat-ewoc--backfill-node-ids node) node)))) (defun jabber-chat-ewoc-unregister-node (node) "Remove all message index entries that refer to ewoc NODE." (when jabber-chat--msg-nodes (let (keys) (maphash (lambda (key value) (when (eq value node) (push key keys))) jabber-chat--msg-nodes) (dolist (key keys) (remhash key 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))) ;;; View preservation across refresh ;; ;; This mirrors ERC's `erc--scrolltobottom-all' (erc-goodies.el): for each ;; visible window, a window at the prompt is recentered to keep the prompt ;; at the bottom, and a window reading history is left where it was. ;; ;; ERC appends, so a history reader's `window-start' and point are never ;; disturbed and its save/restore is only insurance. A refresh rebuilds ;; the whole ewoc, destroying every `window-start' marker and collapsing ;; point, so we must restore actively. Two adaptations follow: ;; ;; - Raw positions don't survive the rebuild, so we anchor on a stable ;; stanza id -- the topmost visible message -- and put that message back ;; at `window-start' once the ewoc is rebuilt. ;; - We restore every visible window, not just the selected one. ERC's ;; selected-window-only mode is safe only because append leaves the rest ;; untouched; for us, skipping a window means the rebuild clobbers it. ;; ;; The one place we cannot match ERC: it keeps a history reader's exact ;; point, but our rebuild collapses it (and a message's rendered length ;; can change across reload), so we settle point on the anchored message. (defun jabber-chat-buffer--node-stanza-id (node) "Return the stable index key of message ewoc NODE, or nil." (and node (let* ((data (ewoc-data node)) (msg (cadr data))) (and (listp msg) (if (jabber-chat-ewoc--muc-data-p data) (or (plist-get msg :server-id) (when-let* ((id (plist-get msg :id))) (jabber-chat-ewoc--client-id-key msg id t))) (or (plist-get msg :id) (plist-get msg :server-id))))))) (defun jabber-chat-buffer--window-anchor (window) "Return a view anchor for WINDOW. The anchor is the symbol `bottom' when the window follows the input area, or a (`msg' . STANZA-ID) cons naming the topmost visible message so the view can be restored after the ewoc is rebuilt." (if (jabber-chat-buffer--recenter-input-p window) 'bottom ;; window-start may sit on a rare-time or typing node that won't ;; survive the rebuild; step forward to the first message node. (let ((node (and jabber-chat-ewoc (ewoc-locate jabber-chat-ewoc (window-start window))))) (while (and node (not (jabber-chat-buffer--node-stanza-id node))) (setq node (ewoc-next jabber-chat-ewoc node))) (if-let* ((id (jabber-chat-buffer--node-stanza-id node))) (cons 'msg id) 'bottom)))) (defun jabber-chat-buffer--capture-view () "Capture per-window view anchors for the current buffer. Returns an alist mapping each window showing the buffer to the anchor from `jabber-chat-buffer--window-anchor'. Call before a refresh clears the ewoc." (mapcar (lambda (window) (cons window (jabber-chat-buffer--window-anchor window))) (get-buffer-window-list (current-buffer) nil 'visible))) (defun jabber-chat-buffer--restore-bottom (window) "Force WINDOW to the input area, moving point there, then recenter. For use when point may have collapsed to the top during the rebuild, i.e. the anchored message is no longer loaded. Unlike the `bottom' anchor path, this overwrites point, so do not call it for a window that was composing a message." (when (markerp jabber-point-insert) (set-window-point window jabber-point-insert) (jabber-chat-buffer--recenter-input-window window))) (defun jabber-chat-buffer--restore-view (anchors) "Restore per-window view from ANCHORS captured before a refresh. Windows that followed the input area return to the bottom; windows that were reading history are scrolled back to their anchored message, or to the bottom when that message is no longer loaded." (dolist (entry anchors) (let ((window (car entry)) (anchor (cdr entry))) (when (window-live-p window) (pcase anchor ('bottom ;; Point sits in the input area (after the footer) and so ;; survived the clear; recenter without moving it to preserve ;; a half-typed message's cursor. (jabber-chat-buffer--recenter-input-window window)) (`(msg . ,id) (if-let* ((node (if (stringp id) (jabber-chat-ewoc-find-by-id id) (gethash id jabber-chat--msg-nodes)))) (let ((pos (ewoc-location node))) (set-window-start window pos) (set-window-point window pos)) (jabber-chat-buffer--restore-bottom window)))))))) ;;; Buffer refresh (defun jabber-chat-buffer--refresh-complete (anchors) "Finish a chat buffer refresh after backlog insertion completes. ANCHORS is the per-window view captured by `jabber-chat-buffer--capture-view' before the ewoc was cleared." (jabber-chat-display-buffer-images) (jabber-chat-buffer--restore-view anchors)) (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. Each window's view is captured before the clear and restored after the reload, so a reader scrolled up in history is not yanked to the top." (interactive) (cl-incf jabber-chat--backlog-generation) (let ((generation jabber-chat--backlog-generation) (count (jabber-chat-buffer-msg-count)) (anchors (jabber-chat-buffer--capture-view)) (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 (if (bound-and-true-p jabber-message-thread-id) (jabber-db-thread-backlog account peer (or (bound-and-true-p jabber-message-thread-type) msg-type "chat") jabber-message-thread-id count) (jabber-db-backlog account peer count nil resource msg-type (and (boundp 'jabber-message-thread-use-buffers) (not jabber-message-thread-use-buffers)))))) (if (null entries) (progn (setq jabber-chat-earliest-backlog (float-time)) (jabber-chat-buffer--restore-view anchors)) (setq jabber-chat-earliest-backlog (float-time (plist-get (car (last entries)) :timestamp))) (jabber-chat--insert-backlog-chunked (current-buffer) entries (lambda () (jabber-chat-buffer--refresh-complete anchors)) generation))))) ;;; Cleanup on disconnect (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* ((kind (if (string= type "groupchat") 'muc 'chat)) (buffer (jabber-buffer-registry-find kind 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 (ACCOUNT PEER TYPE) entries." (dolist (entry peers) (pcase-let* ((`(,account ,peer ,type) entry) (parent-buffers (seq-filter (lambda (candidate) (with-current-buffer candidate (and (eq major-mode 'jabber-chat-mode) (not (bound-and-true-p jabber-message-thread-id)) (bound-and-true-p jabber-buffer-connection) (equal account (jabber-connection-bare-jid jabber-buffer-connection)) (if (string= type "groupchat") (equal peer (bound-and-true-p jabber-group)) (and (not (bound-and-true-p jabber-group)) (equal peer (and (bound-and-true-p jabber-chatting-with) (jabber-jid-user jabber-chatting-with)))))))) (buffer-list)))) (dolist (thread-buffer (buffer-list)) (with-current-buffer thread-buffer (when (and (bound-and-true-p jabber-message-thread-id) (bound-and-true-p jabber-buffer-connection) (equal account (jabber-connection-bare-jid jabber-buffer-connection)) (equal peer (bound-and-true-p jabber-message-thread-peer)) (equal type (bound-and-true-p jabber-message-thread-type))) (when (get-buffer-window thread-buffer t) (jabber-db-mark-message-thread-read account peer type jabber-message-thread-id)) (jabber-chat-buffer-refresh)))) (dolist (parent-buffer parent-buffers) (when (buffer-live-p parent-buffer) (with-current-buffer parent-buffer (jabber-chat-buffer-refresh))))))) (add-hook 'jabber-mam-sync-complete-functions #'jabber-chat--handle-mam-sync-complete) (add-hook 'jabber-post-disconnect-hook #'jabber-chatbuffer--kill-stale) (provide 'jabber-chatbuffer) ;;; jabber-chatbuffer.el ends here emacs-jabber-0.13.1/lisp/jabber-chatstates.el000066400000000000000000000457701523531702000210010ustar00rootroot00000000000000;;; 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 'subr-x) (require 'jabber-buffer-registry) (require 'jabber-util) (require 'ewoc) (require 'jabber-core) (require 'jabber-chat) (require 'jabber-chatbuffer) (require 'jabber-disco) (require 'jabber-message-thread) (require 'jabber-muc) (require 'jabber-muc-state) (require 'jabber-reactions) (require 'jabber-xml) (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--ewoc-node nil "Ewoc node for the typing indicator, or nil.") (defvar-local jabber-chatstates--muc-composers nil "Ordered list of MUC occupants currently composing in this buffer.") (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-ewoc (state) "Show or remove the typing indicator ewoc node for STATE." (let ((inhibit-read-only t)) (if (eq state 'composing) (progn (when (and jabber-chatstates--ewoc-node (not (jabber-chatstates--live-ewoc-node-p jabber-chatstates--ewoc-node))) (setq jabber-chatstates--ewoc-node nil)) (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))))))) (jabber-chatstates--delete-typing-node)))) (defun jabber-chatstates--composing-state-p (state) "Return non-nil when STATE is the XEP-0085 composing state." (eq state 'composing)) (defun jabber-chatstates--muc-add-composer (composers nick) "Return COMPOSERS with NICK appended once, preserving order." (if (member nick composers) composers (append composers (list nick)))) (defun jabber-chatstates--muc-remove-composer (composers nick) "Return COMPOSERS without NICK, preserving order." (remove nick composers)) (defun jabber-chatstates--muc-composers-for-state (composers nick state) "Return COMPOSERS updated for NICK's chat STATE." (if (jabber-chatstates--composing-state-p state) (jabber-chatstates--muc-add-composer composers nick) (jabber-chatstates--muc-remove-composer composers nick))) (defun jabber-chatstates--format-muc-composers (composers) "Return typing text for COMPOSERS, or nil when no one is composing." (pcase composers ('nil nil) (`(,nick) (format "%s is typing..." nick)) (_ (format "%s are typing..." (string-join composers ", "))))) (defun jabber-chatstates--live-ewoc-node-p (node) "Return non-nil when NODE still has a live EWOC marker." (condition-case err (and-let* ((marker (ewoc-location node))) (marker-buffer marker)) (error (message "Jabber: stale chat state ewoc node: %s" (error-message-string err)) nil))) (defun jabber-chatstates--delete-typing-node () "Remove the current typing indicator node without changing state." (when jabber-chatstates--ewoc-node (when (jabber-chatstates--live-ewoc-node-p jabber-chatstates--ewoc-node) (jabber-chat-ewoc-delete jabber-chatstates--ewoc-node)) (setq jabber-chatstates--ewoc-node nil))) (defun jabber-chatstates--muc-reinsert-typing () "Reinsert the current buffer's MUC typing indicator at the bottom." (jabber-chatstates--delete-typing-node) (when-let* ((message (jabber-chatstates--format-muc-composers jabber-chatstates--muc-composers))) (setq jabber-chatstates--ewoc-node (jabber-chat-ewoc-enter (list :typing message))))) (defun jabber-chatstates--update-muc-ewoc () "Refresh the current buffer's MUC typing indicator at the bottom." (let ((inhibit-read-only t)) (jabber-chatstates--muc-reinsert-typing))) (defun jabber-chatstates--muc-remove-nick (nick) "Remove MUC NICK from the current buffer's composer state." (setq jabber-chatstates--muc-composers (jabber-chatstates--muc-remove-composer jabber-chatstates--muc-composers nick))) (defun jabber-chatstates--muc-clear-nick (nick) "Remove MUC NICK from the current buffer's typing indicator." (jabber-chatstates--muc-remove-nick nick) (jabber-chatstates--update-muc-ewoc)) (defun jabber-chatstates--clear-typing () "Remove the typing indicator ewoc node if present." (jabber-chatstates--delete-typing-node)) (defun jabber-chatstates--clear-send-typing () "Remove direct-chat typing state while preserving active MUC composers." (unless jabber-chatstates--muc-composers (jabber-chatstates--clear-typing))) (defun jabber-chatstates--message-state (xml-data) "Return the chat state symbol from XML-DATA, or nil." (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=))) (defun jabber-chatstates--muc-self-nick-p (group nick jc) "Return non-nil when NICK is our nickname in GROUP on JC." (and-let* ((self-nick (jabber-muc-nickname group jc))) (string= nick self-nick))) (defun jabber-chatstates--enable-send-hooks (groupchat-p) "Enable local chat-state hooks, excluding gone for GROUPCHAT-P." (setq jabber-chatstates-requested t) (add-hook 'post-command-hook #'jabber-chatstates-after-change nil t) (add-hook 'kill-buffer-hook #'jabber-chatstates-stop-timer nil t) (unless groupchat-p (add-hook 'kill-buffer-hook #'jabber-chatstates-send-gone nil t))) (defun jabber-chatstates--direct-parent-sends-p (parent-buffer) "Return non-nil when PARENT-BUFFER negotiated chat-state sending." (and (buffer-live-p parent-buffer) (buffer-local-value 'jabber-chatstates-requested parent-buffer) (memq #'jabber-chatstates-after-change (buffer-local-value 'post-command-hook parent-buffer)))) (defun jabber-chatstates--thread-buffer-setup (parent-buffer) "Set up chat-state sending using PARENT-BUFFER's conversation." (cond ((bound-and-true-p jabber-group) (when jabber-chatstates-confirm (jabber-chatstates--enable-send-hooks t))) (t (setq jabber-chatstates-requested (and (buffer-live-p parent-buffer) (buffer-local-value 'jabber-chatstates-requested parent-buffer))) (when (and jabber-chatstates-confirm (jabber-chatstates--direct-parent-sends-p parent-buffer)) (jabber-chatstates--enable-send-hooks nil))))) (add-hook 'jabber-message-thread-buffer-created-functions #'jabber-chatstates--thread-buffer-setup) (defun jabber-chatstates--handle-muc-state (buffer jc from state) "Apply incoming MUC chat STATE from FROM on JC in BUFFER." (let ((group (jabber-jid-user from)) (nick (jabber-jid-resource from))) (when (and group nick) (with-current-buffer buffer (unless (eq state 'gone) (unless (jabber-chatstates--muc-self-nick-p group nick jc) (when (and state jabber-chatstates-confirm (bound-and-true-p jabber-message-thread-id)) (jabber-chatstates--enable-send-hooks t)) (setq jabber-chatstates--muc-composers (jabber-chatstates--muc-composers-for-state jabber-chatstates--muc-composers nick state))) (jabber-chatstates--update-muc-ewoc)))))) (add-hook 'jabber-chat-send-hooks #'jabber-chatstates-when-sending) (defun jabber-chatstates-when-sending (_text _id) "Chat-send hook: cancel state timers and attach an `active' element." (jabber-chatstates--clear-send-typing) (jabber-chatstates-stop-timer) (when (and jabber-chatstates-confirm jabber-chatstates-requested) (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--conversation () "Return the current chat target and message type, or nil." (cond ((bound-and-true-p jabber-group) (list jabber-group "groupchat")) ((bound-and-true-p jabber-chatting-with) (list jabber-chatting-with "chat")))) (defun jabber-chatstates--stanza (state) "Return a standalone chat STATE stanza for the current buffer." (when-let* ((conversation (jabber-chatstates--conversation))) `(message ((to . ,(car conversation)) (type . ,(cadr conversation))) ,@(jabber-message-thread--elements (bound-and-true-p jabber-message-thread-id) (bound-and-true-p jabber-message-thread-parent-id)) (,state ((xmlns . ,jabber-chatstates-xmlns)))))) (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--call-in-buffer (buffer function) "Call FUNCTION in BUFFER when BUFFER is still live." (when (buffer-live-p buffer) (with-current-buffer buffer (funcall function)))) (defun jabber-chatstates--run-with-buffer-timer (seconds function) "Call FUNCTION after SECONDS in the current live buffer." (run-with-timer seconds nil #'jabber-chatstates--call-in-buffer (current-buffer) function)) (defun jabber-chatstates-kick-timer () "Start (or restart) the `paused' timer as approriate." (jabber-chatstates-stop-timer) (setq jabber-chatstates-paused-timer (jabber-chatstates--run-with-buffer-timer 5 #'jabber-chatstates-send-paused))) (defun jabber-chatstates-send-paused () "Send a `paused' state notification, then start the inactive timer." (when-let* (((and jabber-chatstates-confirm jabber-chatstates-requested)) (stanza (jabber-chatstates--stanza 'paused))) (setq jabber-chatstates-composing-sent nil) (jabber-send-sexp-if-connected jabber-buffer-connection stanza) (setq jabber-chatstates-inactive-timer (jabber-chatstates--run-with-buffer-timer 30 #'jabber-chatstates-send-inactive)))) (defun jabber-chatstates-send-inactive () "Send an `inactive' state notification." (when-let* (((and jabber-chatstates-confirm jabber-chatstates-requested)) (stanza (jabber-chatstates--stanza 'inactive))) (jabber-send-sexp-if-connected jabber-buffer-connection stanza))) (defun jabber-chatstates-send-gone () "Send a `gone' state notification and cancel timers. Added to `kill-buffer-hook' in chat buffers." (when-let* (((and jabber-chatstates-confirm jabber-chatstates-requested (not (bound-and-true-p jabber-group)))) (stanza (jabber-chatstates--stanza 'gone))) (jabber-chatstates-stop-timer) (jabber-send-sexp-if-connected jabber-buffer-connection stanza))) (defun jabber-chatstates-after-change () "Post-command-hook: emit `composing'/`active' when typing state flips." (let* ((composing-now (not (= (point-max) jabber-point-insert))) (state (if composing-now 'composing 'active))) (when-let* (((and jabber-chatstates-confirm jabber-chatstates-requested (not (eq composing-now jabber-chatstates-composing-sent)))) (stanza (jabber-chatstates--stanza state))) (jabber-send-sexp-if-connected jabber-buffer-connection stanza) (when (setq jabber-chatstates-composing-sent composing-now) (jabber-chatstates-kick-timer))))) ;;; COMMON (defun jabber-chatstates--real-body-message-p (xml-data) "Return non-nil when XML-DATA has a body that should clear chatstates." (and (jabber-xml-get-children xml-data 'body) (not (jabber-reactions--reaction-only-p xml-data)))) (defun jabber-chatstates--handle-direct-state (buffer jc xml-data) "Update direct chat BUFFER from XML-DATA received on 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) (remove-hook 'kill-buffer-hook #'jabber-chatstates-send-gone t) (setq jabber-chatstates-requested nil)) (t (let ((state (jabber-chatstates--message-state xml-data)) (body-message-p (jabber-chatstates--real-body-message-p xml-data))) (when (eq state 'gone) (jabber-chatstates-stop-timer) (setq jabber-chatstates-composing-sent nil) (if (bound-and-true-p jabber-message-thread-id) (jabber-message-thread--renew-id) (jabber-chat--retire-session-thread jc))) ;; Set up hooks for composition notification (when (and jabber-chatstates-confirm state) (jabber-chatstates--enable-send-hooks nil)) (when (and body-message-p (not state)) (remove-hook 'post-command-hook #'jabber-chatstates-after-change t) (remove-hook 'kill-buffer-hook #'jabber-chatstates-send-gone t) (setq jabber-chatstates-requested nil)) (when (or state body-message-p) (setq jabber-chatstates-last-state state) (jabber-chatstates--update-ewoc state))))))) (defun jabber-chatstates--parent-buffer (jc from type) "Return FROM's ordinary chat buffer on JC for message TYPE." (if (equal type "groupchat") (jabber-muc-find-buffer (jabber-jid-user from) jc) (get-buffer (jabber-chat-get-buffer from jc)))) (defun jabber-chatstates--thread-buffer (jc from type thread-id) "Return THREAD-ID's open buffer for FROM and TYPE on JC." (let ((account (jabber-connection-bare-jid jc)) (peer (jabber-jid-user from))) (if (equal type "error") (let ((chat (jabber-message-thread-find-buffer account peer "chat" thread-id)) (groupchat (jabber-message-thread-find-buffer account peer "groupchat" thread-id))) (cond ((and chat groupchat) nil) (chat chat) (groupchat groupchat))) (jabber-message-thread-find-buffer account peer type thread-id)))) (defun jabber-chatstates--thread-state-buffer (jc from type thread-id) "Return THREAD-ID's chat-state buffer for FROM and TYPE on JC." (let* ((parent (jabber-chatstates--parent-buffer jc from type)) (target (jabber-message-thread-chat-state-target jc (jabber-jid-user from) type thread-id parent))) (cond ((eq target 'parent) parent) ((buffer-live-p target) target)))) (defun jabber-chatstates--thread-content-buffer (jc xml-data from type) "Return threaded content XML-DATA's display buffer on JC." (let ((target (jabber-message-thread-display-target jc (jabber-jid-user from) type (jabber-chat--msg-plist-from-stanza xml-data)))) (cond ((eq target 'parent) (jabber-chatstates--parent-buffer jc from type)) ((buffer-live-p target) target)))) (defun jabber-chatstates--target-buffer (jc xml-data from type) "Return XML-DATA's chat-state buffer for FROM and TYPE on JC." (let ((fields (jabber-message-thread--fields xml-data)) (body-message-p (jabber-chatstates--real-body-message-p xml-data))) (cond ((or (not jabber-message-thread-use-buffers) (and (equal type "chat") (jabber-muc-sender-p from))) (jabber-chatstates--parent-buffer jc from type)) ((not (jabber-message-thread-protocol-has-core-p xml-data)) (jabber-chatstates--parent-buffer jc from type)) ((not fields) (and body-message-p (jabber-chatstates--parent-buffer jc from type))) ((equal type "error") (jabber-chatstates--thread-buffer jc from type (plist-get fields :thread-id))) (body-message-p (jabber-chatstates--thread-content-buffer jc xml-data from type)) (t (jabber-chatstates--thread-state-buffer jc from type (plist-get fields :thread-id)))))) (defun jabber-handle-incoming-message-chatstates (jc xml-data) "Update the chat buffer's typing indicator from XML-DATA on JC." (when-let* ((from (jabber-xml-get-attribute xml-data 'from)) (type (or (jabber-xml-get-attribute xml-data 'type) "chat")) (buffer (jabber-chatstates--target-buffer jc xml-data from type))) (if (string= type "groupchat") (let ((state (jabber-chatstates--message-state xml-data))) (when (and (not (string= (jabber-xml-get-attribute xml-data 'type) "error")) (or state (jabber-chatstates--real-body-message-p xml-data))) (jabber-chatstates--handle-muc-state buffer jc from state))) (jabber-chatstates--handle-direct-state buffer jc xml-data)))) (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 here emacs-jabber-0.13.1/lisp/jabber-compose.el000066400000000000000000000105731523531702000202740ustar00rootroot00000000000000;;; 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: comm ;; 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-chat) ;; Global reference declarations (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar-local jabber-compose-recipients nil "Recipients for the message in the current compose buffer.") (defvar-local jabber-compose-subject "" "Subject for the message in the current compose buffer.") (defun jabber-compose--read-recipients (&optional initial) "Read message recipients, using INITIAL as default values." (jabber-completing-read-multiple "Recipients: " (mapcar #'symbol-name (jabber-concat-rosters)) initial)) (defun jabber-compose-edit-recipients () "Edit recipients for the current composed message." (interactive) (setq-local jabber-compose-recipients (jabber-compose--read-recipients jabber-compose-recipients)) (force-mode-line-update)) (defun jabber-compose-edit-subject () "Edit subject for the current composed message." (interactive) (setq-local jabber-compose-subject (read-string "Subject: " jabber-compose-subject)) (force-mode-line-update)) (defvar-keymap jabber-compose-mode-map :doc "Keymap for composing Jabber messages." :parent text-mode-map "C-c C-c" #'jabber-compose-send "C-c C-r" #'jabber-compose-edit-recipients "C-c C-s" #'jabber-compose-edit-subject) (define-derived-mode jabber-compose-mode text-mode "Jabber-Compose" "Major mode for composing a multiline Jabber message." (setq-local header-line-format '(:eval (format "To: %s Subject: %s" (string-join jabber-compose-recipients ", ") jabber-compose-subject)))) ;; ;;;###autoload (defun jabber-compose (jc &optional recipient) "Create a buffer for composing a Jabber message to RECIPIENT. JC is the Jabber connection. RECIPIENT, when non-nil, prefills the recipient list." (interactive (list (jabber-read-account) (jabber-read-jid-completing "To whom? "))) (let* ((interactive-p (called-interactively-p 'interactive)) (recipients (if interactive-p (jabber-compose--read-recipients (and recipient (list recipient))) (and recipient (list recipient)))) (subject (if interactive-p (read-string "Subject: ") "")) (buffer (generate-new-buffer (concat "*Jabber Compose" (when recipient (format ": %s" (jabber-jid-displayname recipient))) "*")))) (with-current-buffer buffer (jabber-compose-mode) (setq-local jabber-buffer-connection jc jabber-compose-recipients recipients jabber-compose-subject subject)) (pop-to-buffer buffer) (message "Send with C-c C-c; edit recipients with C-c C-r"))) (defun jabber-compose-send (&rest _ignore) "Send the message composed in the current `jabber-compose' buffer." (interactive) (let ((text (buffer-substring-no-properties (point-min) (point-max)))) (when (null jabber-compose-recipients) (user-error "No recipients specified")) (dolist (to jabber-compose-recipients) (jabber-send-message jabber-buffer-connection to jabber-compose-subject text nil)) (bury-buffer) (message "Message sent"))) (provide 'jabber-compose) ;;; jabber-compose.el ends here emacs-jabber-0.13.1/lisp/jabber-conn.el000066400000000000000000000443231523531702000175640ustar00rootroot00000000000000;;; 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 'fsm) (require 'jabber-util) (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-conn--normalize-proxy (proxy) "Return validated PROXY settings, or nil when PROXY is nil." (when proxy (let ((type (plist-get proxy :type)) (host (plist-get proxy :host)) (port (plist-get proxy :port))) (unless (eq type 'socks5) (error "Unsupported Jabber proxy type: %S" type)) (unless (and (stringp host) (> (length host) 0)) (error "Jabber SOCKS5 proxy host must be a non-empty string")) (unless (and (integerp port) (<= 1 port) (<= port 65535)) (error "Jabber SOCKS5 proxy port must be between 1 and 65535")) proxy))) (defun jabber-conn--socks5-request (host port) "Return a SOCKS5 CONNECT request for HOST and PORT." (let* ((name (encode-coding-string host 'utf-8 t)) (length (length name))) (unless (<= length 255) (error "SOCKS5 target hostname is longer than 255 bytes")) (unless (and (integerp port) (<= 1 port) (<= port 65535)) (error "SOCKS5 target port must be between 1 and 65535")) (concat (unibyte-string 5 1 0 3 length) name (unibyte-string (ash port -8) (logand port 255))))) (defun jabber-conn--socks5-parse-method (bytes) "Parse a SOCKS5 method response from BYTES." (if (< (length bytes) 2) '(:status incomplete) (let ((version (aref bytes 0)) (method (aref bytes 1))) (cond ((/= version 5) '(:status error :message "Invalid SOCKS5 method response version")) ((= method 0) (list :status 'ok :rest (substring bytes 2))) ((= method 255) '(:status error :message "SOCKS5 proxy has no acceptable authentication method")) (t '(:status error :message "SOCKS5 proxy requires unsupported authentication")))))) (defconst jabber-conn--socks5-reply-errors '((1 . "general server failure") (2 . "connection not allowed") (3 . "network unreachable") (4 . "host unreachable") (5 . "connection refused") (6 . "TTL expired") (7 . "command not supported") (8 . "address type not supported")) "SOCKS5 CONNECT reply error messages.") (defun jabber-conn--socks5-reply-length (bytes) "Return the complete SOCKS5 reply length for BYTES. Return nil when more bytes are needed, or signal on an invalid address type." (pcase (aref bytes 3) (1 10) (3 (when (>= (length bytes) 5) (+ 7 (aref bytes 4)))) (4 22) (_ (error "Invalid SOCKS5 reply address type")))) (defun jabber-conn--socks5-parse-reply (bytes) "Parse a SOCKS5 CONNECT response from BYTES." (if (< (length bytes) 4) '(:status incomplete) (cond ((/= (aref bytes 0) 5) '(:status error :message "Invalid SOCKS5 CONNECT response version")) ((/= (aref bytes 2) 0) '(:status error :message "Invalid SOCKS5 CONNECT response reserved byte")) (t (condition-case err (let ((length (jabber-conn--socks5-reply-length bytes))) (if (or (null length) (< (length bytes) length)) '(:status incomplete) (let ((reply (aref bytes 1))) (if (= reply 0) (list :status 'ok :rest (substring bytes length)) (list :status 'error :message (or (alist-get reply jabber-conn--socks5-reply-errors) (format "unknown SOCKS5 failure %d" reply))))))) (error (list :status 'error :message (error-message-string err)))))))) (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 &optional proxy) "Find connection targets for SERVER. If NETWORK-SERVER and/or PORT are specified, use them (always STARTTLS). When PROXY is non-nil, bypass SRV lookup and use the explicit target or SERVER on port 5222. 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 proxy 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. NETWORK-SERVER is the explicit host overriding SRV resolution, or nil. PORT is the explicit port or nil for SRV/defaults. 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 (plist-get (fsm-get-state-data fsm) :proxy))) (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 &optional proxy) "Create a network process connecting to HOST:PORT in BUFFER. When DIRECTTLS-P is non-nil, use TLS-on-connect with SNI for SERVER. When PROXY is non-nil, connect to its endpoint using binary coding." (let ((args (list :name "jabber" :buffer buffer :host (or (plist-get proxy :host) host) :service (or (plist-get proxy :port) port) :coding (if proxy 'binary '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-conn--socks5-step (state bytes host port) "Advance SOCKS5 STATE with BYTES for HOST and PORT. Return a plist describing the next state, bytes to send, success, or an error." (let* ((stage (plist-get state :stage)) (pending (concat (plist-get state :pending) bytes)) (result (if (eq stage 'method) (jabber-conn--socks5-parse-method pending) (jabber-conn--socks5-parse-reply pending)))) (pcase (plist-get result :status) ('incomplete (list :state (list :stage stage :pending pending))) ('error (list :error (plist-get result :message))) ('ok (if (eq stage 'method) (list :state (list :stage 'reply :pending (plist-get result :rest)) :send (jabber-conn--socks5-request host port)) (list :connected t :rest (plist-get result :rest))))))) (defun jabber-conn--socks5-filter (expected host port success failure) "Return a SOCKS5 filter for EXPECTED connecting to HOST and PORT. Call SUCCESS after negotiation, or FAILURE with an error message." (let ((state (list :stage 'method :pending (unibyte-string))) settled) (lambda (process bytes) (when (and (eq process expected) (not settled)) (condition-case err (let ((result (jabber-conn--socks5-step state bytes host port))) (cond ((plist-get result :error) (setq settled t) (funcall failure process (plist-get result :error))) ((plist-get result :connected) (setq settled t) (set-process-filter process nil) (set-process-coding-system process 'utf-8 'utf-8) (funcall success process)) (t (setq state (plist-get result :state)) (when-let* ((send (plist-get result :send))) (process-send-string process send))))) (error (setq settled t) (funcall failure process (error-message-string err)))))))) (defun jabber-conn--start-socks5 (process host port success failure) "Start SOCKS5 negotiation on PROCESS for HOST and PORT. Call SUCCESS or FAILURE when negotiation reaches a terminal state." (condition-case err (progn (set-process-coding-system process 'binary 'binary) (set-process-filter process (jabber-conn--socks5-filter process host port success failure)) (process-send-string process (unibyte-string 5 1 0))) (error (funcall failure process (error-message-string err))))) (defun jabber-conn--delete-failed-process (connection buffer) "Delete failed CONNECTION and BUFFER unless debug retention is enabled." (when (processp connection) (delete-process connection)) (when (and (buffer-live-p buffer) (not jabber-debug-keep-process-buffers)) (kill-buffer buffer))) (defun jabber-network-connect-async (fsm server network-server port &optional proxy) "Asynchronously connect FSM to SERVER, trying each SRV target in turn. NETWORK-SERVER and PORT are explicit overrides, or nil to use SRV/defaults. When PROXY is non-nil, establish SOCKS5 before reporting success." ;; Get all potential targets... (let* ((proxy (jabber-conn--normalize-proxy proxy)) (targets (jabber-srv-targets server network-server port proxy)) 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)) (proc nil) (process-buffer nil) (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) ;; Direct success runs inside the old sentinel, so it ;; must remain asynchronous. SOCKS success runs in ;; the filter and changes sentinel ownership before ;; a close can be delivered. (if proxy (fsm-send-sync fsm (list :connected c directtls-p)) (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)) (jabber-conn--delete-failed-process c process-buffer) (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 ((buffer (generate-new-buffer jabber-process-buffer))) (setq process-buffer buffer) (setq proc (jabber-conn--make-process host svc buffer directtls-p server proxy)) (set-process-sentinel proc (lambda (connection status) (cond ((string-match "^open" status) (if proxy (jabber-conn--start-socks5 connection host svc #'connection-successful #'connection-failed) (connection-successful connection))) ((string-match "^failed" status) (connection-failed connection status)) ((string-match "^deleted" status) nil) (t (if proxy (connection-failed connection status) (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 (jabber-conn--delete-failed-process proc process-buffer) (connection-failed nil (car (cddr e)))) (error (jabber-conn--delete-failed-process proc process-buffer) (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 STRING via the plain TCP/IP CONNECTION to the Jabber server." (process-send-string connection string)) (defun jabber-starttls-initiate (fsm) "Initiate a STARTTLS connection on FSM." (jabber-send-sexp fsm `(starttls ((xmlns . ,jabber-tls-xmlns))))) (defun jabber-starttls-process-input (fsm xml-data) "Process result of starttls request on FSM. On failure, signal an 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")))) (define-obsolete-variable-alias '*jabber-virtual-server-function* 'jabber-virtual-server-function "0.11.0") (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) "Send STRING through CONNECTION via the virtual-server function." (funcall jabber-virtual-server-function connection string)) (provide 'jabber-conn) ;;; jabber-conn.el ends here emacs-jabber-0.13.1/lisp/jabber-console.el000066400000000000000000000123071523531702000202660ustar00rootroot00000000000000;;; 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-keymap) (require 'jabber-input) (require 'jabber-stanza) (require 'jabber-util) (require 'jabber-truncate) (require 'xml) (require 'ewoc) (require 'sgml-mode) ;we base on this mode to hightlight XML (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-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) (defun jabber-console-create-buffer (jc) "Get or create the XMPP console buffer for connection 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) "Echo DATA into the console buffer for JC and send it raw to the server." ;; 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 STR as a timestamped comment into the 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-print DATA, an XML-sexp or raw bytes, into the console buffer." (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 for JC as XML in \"*-jabber-console-JID-*\" buffer. DIRECTION is a marker string (typically \"send\", \"recv\", or \"raw\")." (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))))))) (setq jabber-stanza-log-function #'jabber-process-console) (provide 'jabber-console) ;;; jabber-console.el ends here emacs-jabber-0.13.1/lisp/jabber-core.el000066400000000000000000001162271523531702000175620ustar00rootroot00000000000000;;; 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 'fsm) (require 'jabber-util) (require 'jabber-xml) (require 'jabber-conn) (require 'jabber-iq) (require 'jabber-lifecycle) (require 'jabber-presence-events) (require 'jabber-sasl) (require 'jabber-console) (require 'jabber-sm) (require 'jabber-sm-runtime) (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-mam-maybe-catchup 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-mam-maybe-catchup 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-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) (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. (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 ;; ;;;###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 ARG), 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))) (proxy (cdr (assq :proxy 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 proxy) (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 proxy) "Connect USERNAME@SERVER/RESOURCE to the Jabber server. When REGISTERP is non-nil, register a new account. Optional PASSWORD, NETWORK-SERVER, PORT, CONNECTION-TYPE and PROXY override the defaults from `jabber-account-list'." (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 proxy 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))) (setq proxy (cdr (assq :proxy 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 proxy))) (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) (let ((proxy (jabber-conn--normalize-proxy proxy))) (push (start-jabber-connection username server resource registerp password network-server port connection-type proxy) jabber-connections)))) (define-state-machine jabber-connection :start ((username server resource registerp password network-server port connection-type &optional proxy) "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 :proxy proxy)))))) (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-lifecycle-dispatch-session-reset fsm) (setq state-data (jabber-sm--discard-pending state-data "connection closed before transport handoff")) (setq state-data (jabber-sm--reset state-data))) (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)) (jabber-lifecycle-dispatch-connection-list-changed) ;; 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 state-data (plist-put state-data :disconnection-expected t)) (jabber-lifecycle-dispatch-session-reset fsm) (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)) (defun jabber-core--connected-state-data (state-data connection directtls-p) "Update STATE-DATA for a new CONNECTION using DIRECTTLS-P." (plist-put (plist-put state-data :connection connection) :encrypted (and directtls-p t))) (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 (jabber-core--connected-state-data state-data connection directtls-p)) (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, updating STATE-DATA." ;; 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-lifecycle-dispatch-registration fsm) (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))))) (defun jabber--send-bind-request (jc state-data) "Request resource binding for JC using STATE-DATA." (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 jc nil "set" `(bind ((xmlns . ,jabber-bind-xmlns)) ,@(when resource `((resource () ,resource)))) handle-bind t handle-bind nil))) (define-enter-state jabber-connection :bind (fsm state-data) (if (plist-get state-data :bind-after-sm-failure) (progn (setq state-data (plist-put state-data :bind-after-sm-failure nil)) (jabber--send-bind-request 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-lifecycle-dispatch-session-reset fsm) (setq state-data (jabber-sm--discard-pending state-data "stream resumption unavailable")) (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) (progn (jabber--send-bind-request fsm state-data) (list :bind state-data)) (message "Server doesn't permit resource binding") (list nil state-data))) ;; Normal bind flow. ((jabber-xml-get-children stanza 'bind) (jabber--send-bind-request fsm state-data) (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)) (list :session-established new-state-data))) ((jabber-sm--failed-p stanza) (message "Stream Management resume failed, binding a new session") (jabber-lifecycle-dispatch-session-reset fsm) (setq state-data (jabber-sm--handle-failed-resume state-data stanza)) (if (jabber-xml-get-children (plist-get state-data :stream-features) 'bind) (list :bind (plist-put state-data :bind-after-sm-failure t)) (message "Server doesn't permit resource binding") (list nil 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: feature modules fetch initial session data. (jabber-lifecycle-dispatch-session-bootstrap fsm) (setq state-data (jabber-sm--drain-pending fsm state-data))) (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) (condition-case err (progn (setq state-data (jabber-sm--process-ack state-data stanza)) (setq state-data (jabber-sm--drain-pending fsm state-data)) (list :session-established state-data :keep)) (jabber-sm-handled-count-too-high (let ((h (cadr err)) (sent (caddr err))) (jabber-sm--send-count-too-high-error fsm h sent) (list nil (plist-put state-data :disconnection-reason (format "Server acknowledged %d stanzas after %d sent" h sent))))))) (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-presence-events-dispatch-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. INTERACTIVEP is non-nil when called interactively." (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))) (ignore dont-redisplay)) (defun jabber-disconnected () "Re-initialise jabber package variables. Call this function after disconnection." (jabber-clear-roster) (run-hooks 'jabber-post-disconnect-hook)) (defvar jabber-core--filtering nil "Re-entrance guard for `jabber-pre-filter'.") (defun jabber-pre-filter (process string fsm) "Append STRING from PROCESS to FSM's parse buffer." (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) "Parse complete XML stanzas from PROCESS buffer and dispatch to FSM." (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-stream-error (xml-data state-data) "Process an incoming stream error in XML-DATA with STATE-DATA. 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)))) (provide 'jabber-core) ;;; jabber-core.el ends here emacs-jabber-0.13.1/lisp/jabber-csi.el000066400000000000000000000120321523531702000173750ustar00rootroot00000000000000;;; 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) (require 'jabber-xml) (defvar jabber-pre-disconnect-hook) (defvar jabber-lost-connection-hooks) (defvar jabber-post-resume-hooks) (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 :group 'jabber-csi) (defvar jabber-csi--last-state (make-hash-table :test #'eq) "Last CSI state sent per connection. Each value is `active', `inactive', or nil.") (defvar jabber-csi--timer nil "Pending debounce timer for focus changes, or nil.") (defconst jabber-csi--debounce-delay 0.5 "Seconds to wait before sending a CSI state change. Coalesces rapid focus oscillations into one stanza.") (defun jabber-csi--stop-timer () "Cancel any pending CSI debounce timer." (when (timerp jabber-csi--timer) (cancel-timer jabber-csi--timer) (setq jabber-csi--timer 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--supported-p (jc) "Return non-nil if JC advertised CSI stream support." (let ((features (plist-get (fsm-get-state-data jc) :stream-features))) (and features (jabber-xml-child-with-xmlns features jabber-csi-xmlns)))) (defun jabber-csi--last-state-get (jc) "Return last CSI state sent for JC." (and (hash-table-p jabber-csi--last-state) (gethash jc jabber-csi--last-state))) (defun jabber-csi--last-state-put (jc state) "Record STATE as the last CSI state sent for JC." (unless (hash-table-p jabber-csi--last-state) (setq jabber-csi--last-state (make-hash-table :test #'eq))) (puthash jc state jabber-csi--last-state)) (defun jabber-csi--last-state-remove (&optional jc) "Forget the last CSI state for JC, or all state when JC is nil." (unless (hash-table-p jabber-csi--last-state) (setq jabber-csi--last-state (make-hash-table :test #'eq))) (if jc (remhash jc jabber-csi--last-state) (clrhash jabber-csi--last-state))) (defun jabber-csi--send-state-to-connection (jc state) "Send CSI STATE to JC when supported and not already current." (when (and (jabber-csi--supported-p jc) (not (eq state (jabber-csi--last-state-get jc)))) (jabber-csi--last-state-put jc state) (jabber-send-sexp-if-connected jc `(,state ((xmlns . ,jabber-csi-xmlns)))))) (defun jabber-csi--send-state () "Send CSI active or inactive to all supporting connections." (setq jabber-csi--timer nil) (when jabber-csi-enable (let ((state (if (jabber-csi--focused-p) 'active 'inactive))) (dolist (jc jabber-connections) (jabber-csi--send-state-to-connection jc state))))) (defun jabber-csi--focus-changed () "Hook for `after-focus-change-function'. Debounces rapid focus changes into a single CSI stanza." (jabber-csi--stop-timer) (setq jabber-csi--timer (run-with-timer jabber-csi--debounce-delay nil #'jabber-csi--send-state))) (defun jabber-csi--on-connect (jc) "Send current CSI state to JC after connection. Added to `jabber-post-connect-hooks'." (jabber-csi--stop-timer) (jabber-csi--last-state-remove jc) (when jabber-csi-enable (jabber-csi--send-state-to-connection jc (if (jabber-csi--focused-p) 'active 'inactive)))) (defun jabber-csi--on-disconnect (&optional jc) "Cancel pending CSI timer and reset state for JC on disconnect." (jabber-csi--stop-timer) (jabber-csi--last-state-remove jc)) (add-hook 'jabber-post-connect-hooks #'jabber-csi--on-connect) (add-hook 'jabber-post-resume-hooks #'jabber-csi--on-connect) (add-hook 'jabber-pre-disconnect-hook #'jabber-csi--on-disconnect) (add-hook 'jabber-lost-connection-hooks #'jabber-csi--on-disconnect) (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-0.13.1/lisp/jabber-db.el000066400000000000000000002636351523531702000172250ustar00rootroot00000000000000;;; 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 'subr-x) (require 'jabber-util) (require 'jabber-xml) (require 'jabber-message-thread-protocol) (require 'jabber-muc-protocol) (require 'jabber-muc-state) (eval-when-compile (require 'cl-lib) (require 'seq)) (defvar jabber-chatting-with) ; jabber-chat.el (defvar jabber-chat-send-hooks) ; jabber-chat.el (defvar jabber-chat-encryption) ; jabber-chatbuffer.el (defvar jabber-chat--sending-correction) ; jabber-chat.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.") (defvar jabber-db-message-thread-stored-functions nil "Functions run after a threaded message is stored. Each function receives ACCOUNT, PEER, TYPE, THREAD-ID, and TIMESTAMP.") ;;; 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, reply_to_id TEXT, reply_to_jid TEXT, fallback_start INTEGER, fallback_end INTEGER, thread_id TEXT, thread_parent_id TEXT)" "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 INDEX IF NOT EXISTS idx_msg_thread ON message(account, peer, type, thread_id, timestamp) WHERE thread_id IS NOT NULL" "CREATE TABLE IF NOT EXISTS message_thread ( account TEXT NOT NULL, peer TEXT NOT NULL, type TEXT NOT NULL, thread_id TEXT NOT NULL, parent_thread_id TEXT, root_message_id INTEGER, root_stanza_id TEXT, root_server_id TEXT, created_at INTEGER NOT NULL, read_message_id INTEGER, dedicated INTEGER NOT NULL DEFAULT 0, title TEXT, PRIMARY KEY (account, peer, type, thread_id))" "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, spk_rotated_at INTEGER)" "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', thread_id TEXT, 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 message_reaction ( message_id INTEGER NOT NULL REFERENCES message(id) ON DELETE CASCADE, sender TEXT NOT NULL, reaction TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender, reaction))" "CREATE INDEX IF NOT EXISTS idx_reaction_message_id ON message_reaction(message_id)" "CREATE TABLE IF NOT EXISTS message_reaction_actor ( message_id INTEGER NOT NULL REFERENCES message(id) ON DELETE CASCADE, sender TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender))" "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))) (defun jabber-db--table-exists-p (db table) "Return non-nil when TABLE exists in DB." (not (null (sqlite-select db "\ SELECT name FROM sqlite_master WHERE type = 'table' AND name = ?" (list table))))) (defun jabber-db--ensure-reaction-actor-table (db) "Create the reaction actor metadata table in DB when missing." (sqlite-execute db "\ CREATE TABLE IF NOT EXISTS message_reaction_actor ( message_id INTEGER NOT NULL REFERENCES message(id) ON DELETE CASCADE, sender TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender))")) (defun jabber-db--reaction-actors-current-p (db) "Return non-nil when reaction actor metadata in DB is current." (and (jabber-db--table-exists-p db "message_reaction_actor") (zerop (caar (sqlite-select db "\ SELECT count(*) FROM ( SELECT message_id, sender, MAX(updated_at) AS updated_at FROM message_reaction GROUP BY message_id, sender) AS reaction_actor LEFT JOIN message_reaction_actor ON message_reaction_actor.message_id = reaction_actor.message_id AND message_reaction_actor.sender = reaction_actor.sender WHERE message_reaction_actor.message_id IS NULL OR message_reaction_actor.updated_at < reaction_actor.updated_at"))))) (defun jabber-db--backfill-reaction-actors (db) "Backfill reaction actor metadata in DB from reaction rows." (sqlite-execute db "\ INSERT OR IGNORE INTO message_reaction_actor (message_id, sender, updated_at) SELECT message_id, sender, MAX(updated_at) FROM message_reaction GROUP BY message_id, sender") (sqlite-execute db "\ UPDATE message_reaction_actor SET updated_at = ( SELECT MAX(updated_at) FROM message_reaction WHERE message_reaction.message_id = message_reaction_actor.message_id AND message_reaction.sender = message_reaction_actor.sender) WHERE updated_at < ( SELECT MAX(updated_at) FROM message_reaction WHERE message_reaction.message_id = message_reaction_actor.message_id AND message_reaction.sender = message_reaction_actor.sender)")) (defun jabber-db--repair-reaction-actors (db) "Repair reaction actor metadata in DB when missing or stale." (unless (jabber-db--reaction-actors-current-p db) (jabber-db--ensure-reaction-actor-table db) (jabber-db--backfill-reaction-actors db))) (defconst jabber-db--schema-version 10 "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' in DB and offer reset. Return 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-v1-to-v2 (db) "Migrate DB from schema version 1 to version 2." (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")) (defun jabber-db--migrate-v2-to-v3 (db) "Migrate DB from schema version 2 to version 3." (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")) (defun jabber-db--migrate-v3-to-v4 (db) "Migrate DB from schema version 3 to version 4." (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")) (defun jabber-db--migrate-v4-to-v5 (db) "Migrate DB from schema version 4 to version 5." (sqlite-execute db "\ CREATE TABLE IF NOT EXISTS message_reaction ( message_id INTEGER NOT NULL REFERENCES message(id) ON DELETE CASCADE, sender TEXT NOT NULL, reaction TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender, reaction))") (sqlite-execute db "\ CREATE INDEX IF NOT EXISTS idx_reaction_message_id ON message_reaction(message_id)") (jabber-db--ensure-reaction-actor-table db) (jabber-db--backfill-reaction-actors db) (sqlite-execute db "PRAGMA user_version=5")) (defun jabber-db--migrate-v5-to-v6 (db) "Migrate DB from schema version 5 to version 6." (sqlite-execute db "ALTER TABLE omemo_store ADD COLUMN spk_rotated_at INTEGER") (sqlite-execute db "PRAGMA user_version=6")) (defun jabber-db--migrate-v6-to-v7 (db) "Migrate DB from schema version 6 to version 7." (dolist (column '("reply_to_id TEXT" "reply_to_jid TEXT" "fallback_start INTEGER" "fallback_end INTEGER")) (sqlite-execute db (concat "ALTER TABLE message ADD COLUMN " column))) (sqlite-execute db "PRAGMA user_version=7")) (defun jabber-db--migrate-v7-to-v8-steps (db) "Apply the schema changes from version 7 to version 8 in DB." (dolist (column '("thread_id TEXT" "thread_parent_id TEXT")) (sqlite-execute db (concat "ALTER TABLE message ADD COLUMN " column))) (when (cl-every (lambda (column) (member column (mapcar #'car (sqlite-select db "SELECT name FROM pragma_table_info('message')")))) '("account" "peer" "type" "timestamp")) (sqlite-execute db "\ CREATE INDEX IF NOT EXISTS idx_msg_thread ON message(account, peer, type, thread_id, timestamp) WHERE thread_id IS NOT NULL")) (sqlite-execute db "\ CREATE TABLE IF NOT EXISTS message_thread ( account TEXT NOT NULL, peer TEXT NOT NULL, type TEXT NOT NULL, thread_id TEXT NOT NULL, parent_thread_id TEXT, root_message_id INTEGER, root_stanza_id TEXT, root_server_id TEXT, created_at INTEGER NOT NULL, read_message_id INTEGER, PRIMARY KEY (account, peer, type, thread_id))") (sqlite-execute db "PRAGMA user_version=8")) (defun jabber-db--migrate-v7-to-v8 (db) "Migrate DB atomically from schema version 7 to version 8." (sqlite-execute db "SAVEPOINT jabber_schema_v8") (condition-case err (prog1 (jabber-db--migrate-v7-to-v8-steps db) (sqlite-execute db "RELEASE jabber_schema_v8")) (error (ignore-errors (sqlite-execute db "ROLLBACK TO jabber_schema_v8")) (ignore-errors (sqlite-execute db "RELEASE jabber_schema_v8")) (signal (car err) (cdr err))))) (defun jabber-db--migrate-v8-to-v9-steps (db) "Apply the schema changes from version 8 to version 9 in DB." (sqlite-execute db "\ ALTER TABLE message_thread ADD COLUMN dedicated INTEGER NOT NULL DEFAULT 0") (sqlite-execute db "\ UPDATE message_thread AS mt SET dedicated = 1 WHERE mt.type = 'groupchat' OR mt.parent_thread_id IS NOT NULL OR mt.read_message_id IS NOT NULL OR EXISTS ( SELECT 1 FROM message AS root WHERE root.id = mt.root_message_id AND (root.thread_id IS NULL OR root.thread_id != mt.thread_id))") (when (cl-every (lambda (column) (member column (mapcar #'car (sqlite-select db "SELECT name FROM pragma_table_info('message')")))) '("account" "peer" "type" "thread_id" "direction" "reply_to_id")) (sqlite-execute db "\ UPDATE message_thread AS mt SET dedicated = 1 WHERE EXISTS ( SELECT 1 FROM message AS m WHERE m.account = mt.account AND m.peer = mt.peer AND m.type = mt.type AND m.thread_id = mt.thread_id AND m.direction = 'out' AND m.reply_to_id IS NULL)")) (sqlite-execute db "PRAGMA user_version=9")) (defun jabber-db--migrate-v8-to-v9 (db) "Migrate DB atomically from schema version 8 to version 9." (sqlite-execute db "SAVEPOINT jabber_schema_v9") (condition-case err (prog1 (jabber-db--migrate-v8-to-v9-steps db) (sqlite-execute db "RELEASE jabber_schema_v9")) (error (ignore-errors (sqlite-execute db "ROLLBACK TO jabber_schema_v9")) (ignore-errors (sqlite-execute db "RELEASE jabber_schema_v9")) (signal (car err) (cdr err))))) (defun jabber-db--migrate-v9-to-v10 (db) "Add local thread state atomically to schema version 9 in DB." (sqlite-execute db "SAVEPOINT jabber_schema_v10") (condition-case err (progn (sqlite-execute db "ALTER TABLE message_thread ADD COLUMN title TEXT") (sqlite-execute db "\ CREATE TABLE IF NOT EXISTS chat_settings ( account TEXT NOT NULL, peer TEXT NOT NULL, encryption TEXT DEFAULT 'default', thread_id TEXT, PRIMARY KEY (account, peer))") (unless (member "thread_id" (mapcar #'car (sqlite-select db "SELECT name FROM pragma_table_info('chat_settings')"))) (sqlite-execute db "ALTER TABLE chat_settings ADD COLUMN thread_id TEXT")) (sqlite-execute db "PRAGMA user_version=10") (sqlite-execute db "RELEASE jabber_schema_v10")) (error (ignore-errors (sqlite-execute db "ROLLBACK TO jabber_schema_v10")) (ignore-errors (sqlite-execute db "RELEASE jabber_schema_v10")) (signal (car err) (cdr err))))) (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) (jabber-db--migrate-v1-to-v2 db) (setq version 2)) (when (= version 2) (jabber-db--migrate-v2-to-v3 db) (setq version 3)) (when (= version 3) (jabber-db--migrate-v3-to-v4 db) (setq version 4)) (when (= version 4) (jabber-db--migrate-v4-to-v5 db) (setq version 5)) (when (= version 5) (jabber-db--migrate-v5-to-v6 db) (setq version 6)) (when (= version 6) (jabber-db--migrate-v6-to-v7 db) (setq version 7)) (when (= version 7) (jabber-db--migrate-v7-to-v8 db) (setq version 8)) (when (= version 8) (jabber-db--migrate-v8-to-v9 db) (setq version 9)) (when (= version 9) (jabber-db--migrate-v9-to-v10 db) (setq version 10)) (when (= version 10) (jabber-db--repair-reaction-actors db)))) (defun jabber-db-ensure-open () "Open the SQLite database, creating it if needed. Idempotent. Migrate an existing connection when the package schema has advanced. Return the database connection, or nil if storage is disabled." (when jabber-db-path (let ((connection-live-p (and jabber-db--connection (sqlitep jabber-db--connection)))) (unless connection-live-p (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)) (when (and connection-live-p (< (caar (sqlite-select jabber-db--connection "PRAGMA user_version")) jabber-db--schema-version)) (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 INTO chat_settings (account, peer, encryption) VALUES (?, ?, ?) ON CONFLICT(account, peer) DO UPDATE SET encryption = excluded.encryption" (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))))) (defun jabber-db-set-chat-thread (account peer thread-id) "Store the current parent chat THREAD-ID for ACCOUNT and PEER." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "\ INSERT INTO chat_settings (account, peer, thread_id) VALUES (?, ?, ?) ON CONFLICT(account, peer) DO UPDATE SET thread_id = excluded.thread_id" (list account peer thread-id)))) (defun jabber-db-get-chat-thread (account peer) "Return the current parent chat thread ID for ACCOUNT and PEER." (when-let* ((db (jabber-db-ensure-open))) (caar (sqlite-select db "\ SELECT thread_id FROM chat_settings WHERE account = ? AND peer = ?" (list account peer))))) ;;; 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--extract-reply-fields (xml-data) "Return XEP-0461 reply metadata in XML-DATA as a plist, or nil. Keys are :reply-to-id, :reply-to-jid and :fallback-range. Mirrors `jabber-chat--reply-fields' in jabber-chat.el; duplicated here for the same layering reason as `jabber-db--stanza-id-element'." (and-let* ((reply-el (seq-find (lambda (child) (and (eq (jabber-xml-node-name child) 'reply) (equal (jabber-xml-get-xmlns child) "urn:xmpp:reply:0"))) (jabber-xml-node-children xml-data)))) (list :reply-to-id (jabber-xml-get-attribute reply-el 'id) :reply-to-jid (jabber-xml-get-attribute reply-el 'to) :fallback-range (jabber-db--reply-fallback-range xml-data)))) (defun jabber-db--extract-thread-fields (xml-data) "Return valid XEP-0201 thread metadata from XML-DATA, or nil." (jabber-message-thread-protocol-fields xml-data)) (defun jabber-db--reply-fallback-range (xml-data) "Return the XEP-0428 fallback range for replies in XML-DATA. Same return values as `jabber-chat--reply-fallback-range': a \(START END) list, `all', or nil." (when-let* ((fallback (seq-find (lambda (child) (and (eq (jabber-xml-node-name child) 'fallback) (equal (jabber-xml-get-xmlns child) "urn:xmpp:fallback:0") (equal (jabber-xml-get-attribute child 'for) "urn:xmpp:reply:0"))) (jabber-xml-node-children xml-data)))) (if-let* ((body (car (jabber-xml-get-children fallback 'body)))) (let ((start (jabber-xml-get-attribute body 'start)) (end (jabber-xml-get-attribute body 'end))) (if (or start end) (and start end (string-match-p "\\`[0-9]+\\'" start) (string-match-p "\\`[0-9]+\\'" end) (list (string-to-number start) (string-to-number end))) 'all)) 'all))) (defun jabber-db--fallback-range-cols (range) "Encode RANGE for storage as a (START . END) cons of column values. RANGE is nil, `all', or a (START END) list; `all' is stored as -1/-1, nil as NULL/NULL." (pcase range ('all '(-1 . -1)) (`(,start ,end) (cons start end)) (_ '(nil . nil)))) (defun jabber-db--decode-fallback-range (start end) "Decode fallback columns START and END back into a range value. Inverse of `jabber-db--fallback-range-cols'." (cond ((and (eql start -1) (eql end -1)) 'all) ((and start end) (list start end)))) (defun jabber-db--detect-duplicate (db account peer timestamp body stanza-id server-id &optional type) "Check whether a message for ACCOUNT already exists in DB. PEER, TIMESTAMP, BODY, STANZA-ID and SERVER-ID identify the candidate. 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 are unique only within the assigning entity. ;; PEER is that entity for the stored conversation. ((and server-id (caar (sqlite-select db "SELECT 1 FROM message \ WHERE server_id = ? AND account = ? AND peer = ? LIMIT 1" (list server-id account peer)))) '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 reply thread) "Insert a new message row into DB for ACCOUNT and attach OOB-ENTRIES. PEER, RESOURCE, OCCUPANT-ID, DIRECTION, TYPE, BODY, TIMESTAMP, STANZA-ID, SERVER-ID and ENCRYPTED fill the corresponding columns. REPLY and THREAD contain parsed reply and thread metadata." (pcase-let ((`(,fb-start . ,fb-end) (jabber-db--fallback-range-cols (plist-get reply :fallback-range)))) (sqlite-execute db "INSERT INTO message \ (account, peer, resource, occupant_id, direction, type, body, timestamp, \ stanza_id, server_id, encrypted, reply_to_id, reply_to_jid, \ fallback_start, fallback_end, thread_id, thread_parent_id) \ VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" (list account peer resource occupant-id direction type body timestamp stanza-id server-id (if encrypted 1 0) (plist-get reply :reply-to-id) (plist-get reply :reply-to-jid) fb-start fb-end (plist-get thread :thread-id) (plist-get thread :thread-parent-id)))) (let ((msg-id (caar (sqlite-select db "SELECT last_insert_rowid()")))) (when oob-entries (dolist (entry oob-entries) (sqlite-execute db "INSERT INTO message_oob (message_id, url, desc) VALUES (?, ?, ?)" (list msg-id (car entry) (cdr entry))))) msg-id)) (defun jabber-db--update-duplicate-ids (db account peer timestamp body stanza-id server-id oob-entries dup-id-col) "Update an existing duplicate in DB matched by DUP-ID-COL. Normalize TIMESTAMP when non-nil and replace failed placeholders with BODY. Skip retracted messages to prevent MAM replays from undoing retractions. ACCOUNT and PEER scope the row; STANZA-ID and SERVER-ID identify it; OOB-ENTRIES replaces the row's OOB metadata when BODY is upgraded." (let* ((id-val (if (eq dup-id-col 'stanza_id) stanza-id server-id)) (where-clause (format "%s = ? AND account = ? AND peer = ?" dup-id-col)) (where-params (list id-val account peer)) (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 (when timestamp (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 (jabber--decrypt-failure-body-p 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 in DB with server-assigned IDs. ACCOUNT, PEER, TIMESTAMP and BODY locate the row; STANZA-ID and SERVER-ID are the new IDs to fill in if missing." (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--backfill-reply-fields (db account peer stanza-id reply) "Fill NULL reply columns in DB for ACCOUNT/PEER using STANZA-ID and REPLY. Completes rows stored before the reply elements were attached to the outgoing stanza (e.g. the OMEMO pending echo)." (pcase-let ((`(,fb-start . ,fb-end) (jabber-db--fallback-range-cols (plist-get reply :fallback-range)))) (sqlite-execute db "UPDATE message SET reply_to_id = ?, reply_to_jid = ?, \ fallback_start = ?, fallback_end = ? \ WHERE stanza_id = ? AND account = ? AND peer = ? AND reply_to_id IS NULL" (list (plist-get reply :reply-to-id) (plist-get reply :reply-to-jid) fb-start fb-end stanza-id account peer)))) (defun jabber-db--duplicate-row-id (db account peer timestamp body stanza-id server-id duplicate-kind) "Return the exact duplicate row in DB described by DUPLICATE-KIND. ACCOUNT and PEER scope all identifiers. TIMESTAMP and BODY identify a content match; STANZA-ID and SERVER-ID identify protocol matches." (pcase duplicate-kind ('server_id (caar (sqlite-select db "SELECT id FROM message \ WHERE account = ? AND peer = ? AND server_id = ? ORDER BY id DESC LIMIT 1" (list account peer server-id)))) ('stanza_id (caar (sqlite-select db "SELECT id FROM message \ WHERE account = ? AND peer = ? AND stanza_id = ? ORDER BY id DESC LIMIT 1" (list account peer stanza-id)))) ('content (caar (sqlite-select db "SELECT id FROM message \ WHERE account = ? AND peer = ? AND timestamp = ? AND body = ? \ ORDER BY id DESC LIMIT 1" (list account peer timestamp body)))))) (defun jabber-db--backfill-thread-fields (db message-id thread) "Fill missing THREAD columns for MESSAGE-ID in DB." (when (and thread message-id) (sqlite-execute db "UPDATE message SET thread_id = ?, thread_parent_id = ? \ WHERE id = ? AND thread_id IS NULL" (list (plist-get thread :thread-id) (plist-get thread :thread-parent-id) message-id)))) (defun jabber-db--register-message-thread (account peer type thread-id parent-thread-id root-stanza-id root-server-id created-at root-message-id dedicated-p) "Store THREAD-ID metadata and DEDICATED-P for ACCOUNT, PEER, and TYPE." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "INSERT INTO message_thread \ (account, peer, type, thread_id, parent_thread_id, root_message_id, \ root_stanza_id, root_server_id, created_at, dedicated) \ VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?) \ ON CONFLICT(account, peer, type, thread_id) DO UPDATE SET \ parent_thread_id = COALESCE(message_thread.parent_thread_id, excluded.parent_thread_id), \ root_message_id = COALESCE(message_thread.root_message_id, excluded.root_message_id), \ root_stanza_id = COALESCE(message_thread.root_stanza_id, excluded.root_stanza_id), \ root_server_id = COALESCE(message_thread.root_server_id, excluded.root_server_id), \ dedicated = MAX(message_thread.dedicated, excluded.dedicated)" (list account peer type thread-id parent-thread-id root-message-id root-stanza-id root-server-id created-at (if dedicated-p 1 0))))) (defun jabber-db-register-message-thread (account peer type thread-id parent-thread-id root-stanza-id root-server-id created-at &optional root-message-id) "Register THREAD-ID as a dedicated thread for ACCOUNT and PEER. TYPE, PARENT-THREAD-ID, ROOT-STANZA-ID, ROOT-SERVER-ID, CREATED-AT, and ROOT-MESSAGE-ID describe its identity and root message." (jabber-db--register-message-thread account peer type thread-id parent-thread-id root-stanza-id root-server-id created-at root-message-id t)) (defun jabber-db--normalize-message-thread-title (title) "Return TITLE trimmed onto one line, or nil when it is empty." (when title (let ((trimmed (string-trim (replace-regexp-in-string "[[:space:][:cntrl:]]+" " " title)))) (unless (string-empty-p trimmed) trimmed)))) (defun jabber-db-set-message-thread-title (account peer type thread-id title) "Set dedicated THREAD-ID's local TITLE for ACCOUNT, PEER, and TYPE. Whitespace around TITLE is removed; an empty title clears it." (let ((title (jabber-db--normalize-message-thread-title title))) (when-let* ((db (jabber-db-ensure-open))) (unless (equal 1 (caar (sqlite-select db "SELECT dedicated FROM message_thread WHERE account = ? AND peer = ? AND type = ? AND thread_id = ?" (list account peer type thread-id)))) (user-error "Unknown dedicated message thread")) (sqlite-execute db "UPDATE message_thread SET title = ? WHERE account = ? AND peer = ? AND type = ? AND thread_id = ? AND dedicated = 1" (list title account peer type thread-id)) title))) (defun jabber-db--message-thread-stored-p (db account peer type thread-id) "Return non-nil when DB stores THREAD-ID for ACCOUNT, PEER, and TYPE." (caar (sqlite-select db "SELECT 1 FROM message_thread WHERE account = ? AND peer = ? AND type = ? AND thread_id = ?" (list account peer type thread-id)))) (defun jabber-db--ensure-message-thread (account peer type timestamp stanza-id server-id thread) "Register THREAD after storing a message for ACCOUNT, PEER, and TYPE. TIMESTAMP, STANZA-ID, and SERVER-ID identify its first observed root." (when-let* ((thread-id (plist-get thread :thread-id)) (db (jabber-db-ensure-open))) (let* ((new-p (not (jabber-db--message-thread-stored-p db account peer type thread-id))) (parent-id (plist-get thread :thread-parent-id)) (root-message-id (and new-p (caar (sqlite-select db "SELECT id FROM message \ WHERE account = ? AND peer = ? AND type = ? AND thread_id = ? \ ORDER BY id DESC LIMIT 1" (list account peer type thread-id)))))) (jabber-db--register-message-thread account peer type thread-id parent-id stanza-id server-id timestamp root-message-id (or (equal type "groupchat") parent-id))))) (defun jabber-db-store-message (account peer direction type body timestamp &optional resource stanza-id server-id occupant-id oob-entries encrypted reply thread) "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, or nil when the source has no authoritative timestamp. 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. Optional REPLY is a reply metadata plist from `jabber-db--extract-reply-fields'. Optional THREAD is a thread metadata plist from `jabber-db--extract-thread-fields'." (when-let* ((db (jabber-db-ensure-open))) (let* ((stored-timestamp (or timestamp (floor (float-time)))) (dup-id-col (jabber-db--detect-duplicate db account peer stored-timestamp body stanza-id server-id type)) message-id) (pcase dup-id-col ('nil (setq message-id (jabber-db--insert-message db account peer resource occupant-id direction type body stored-timestamp stanza-id server-id encrypted oob-entries reply thread))) ((or 'stanza_id 'server_id) (jabber-db--update-duplicate-ids db account peer timestamp body stanza-id server-id oob-entries dup-id-col) (setq message-id (jabber-db--duplicate-row-id db account peer stored-timestamp body stanza-id server-id dup-id-col)) (when (and reply stanza-id) (jabber-db--backfill-reply-fields db account peer stanza-id reply))) ('content (jabber-db--upgrade-content-match db account peer stored-timestamp body stanza-id server-id) (setq message-id (jabber-db--duplicate-row-id db account peer stored-timestamp body stanza-id server-id dup-id-col)))) (jabber-db--backfill-thread-fields db message-id thread) (jabber-db--ensure-message-thread account peer type stored-timestamp stanza-id server-id thread) (when-let* ((thread-id (plist-get thread :thread-id))) (run-hook-with-args 'jabber-db-message-thread-stored-functions account peer type thread-id stored-timestamp))))) (defun jabber-db-prune-empty-message-threads (account peer) "Delete thread metadata without a surviving message for ACCOUNT and PEER." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "DELETE FROM message_thread AS mt \ WHERE mt.account = ? AND mt.peer = ? AND NOT EXISTS ( \ SELECT 1 FROM message AS m WHERE m.account = mt.account AND m.peer = mt.peer \ AND m.type = mt.type AND (m.thread_id = mt.thread_id \ OR (mt.root_message_id IS NOT NULL AND m.id = mt.root_message_id) \ OR (mt.type = 'groupchat' AND mt.root_server_id IS NOT NULL \ AND m.server_id = mt.root_server_id) \ OR (mt.type != 'groupchat' AND mt.root_stanza_id IS NOT NULL \ AND m.stanza_id = mt.root_stanza_id)))" (list account peer)))) ;;; 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) "Retract globally unambiguous SERVER-ID by RETRACTED-BY. Optional REASON is the human-readable retraction reason string. Conversation-aware callers should use `jabber-db-retract-message-in-peer'." (when (and jabber-db--connection server-id) (sqlite-execute jabber-db--connection "UPDATE message SET retracted_by = ?, retraction_reason = ? \ WHERE server_id = ? AND \ (SELECT COUNT(*) FROM message WHERE server_id = ?) = 1" (list retracted-by reason server-id server-id)))) (defun jabber-db-retract-message-in-peer (account peer server-id retracted-by &optional reason) "Mark SERVER-ID as retracted in PEER on ACCOUNT. RETRACTED-BY is the moderator or sender JID. Optional REASON is the human-readable retraction reason string." (when (and jabber-db--connection account peer server-id) (sqlite-execute jabber-db--connection "UPDATE message SET retracted_by = ?, retraction_reason = ? \ WHERE account = ? AND peer = ? AND server_id = ?" (list retracted-by reason account peer server-id)))) (defun jabber-db-occupant-id-by-server-id (server-id) "Return occupant-id for globally unambiguous 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 = ? GROUP BY server_id HAVING COUNT(*) = 1" (list server-id))))) (defun jabber-db-occupant-id-by-server-id-in-peer (account peer server-id) "Return occupant-id for SERVER-ID in PEER on ACCOUNT, or nil." (when (and jabber-db--connection account peer server-id) (caar (sqlite-select jabber-db--connection "SELECT occupant_id FROM message \ WHERE account = ? AND peer = ? AND server_id = ? LIMIT 1" (list account peer server-id))))) (defun jabber-db-occupant-id-by-stanza-id (stanza-id) "Return the occupant ID for globally unique STANZA-ID, or nil." (when (and jabber-db--connection stanza-id) (caar (sqlite-select jabber-db--connection "SELECT occupant_id FROM message \ WHERE stanza_id = ? GROUP BY stanza_id HAVING COUNT(*) = 1" (list stanza-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) "Correct globally unique STANZA-ID with NEW-BODY. Protocol handlers should use `jabber-db-correct-message-row' after a conversation-scoped lookup." (when (and jabber-db--connection stanza-id) (sqlite-execute jabber-db--connection "UPDATE message SET body = ?, edited = 1 WHERE id = (\ SELECT MIN(id) FROM message WHERE stanza_id = ? \ GROUP BY stanza_id HAVING COUNT(*) = 1)" (list new-body stanza-id)))) (defun jabber-db-message-correction-candidates (account peer stanza-id) "Return correction candidates for STANZA-ID in ACCOUNT's PEER chat." (when-let* ((db (jabber-db-ensure-open))) (mapcar (lambda (row) (seq-let (row-id direction row-peer resource row-account occupant-id timestamp type) row (list :row-id row-id :from (if (or (string= direction "in") (string= type "groupchat")) (if resource (concat row-peer "/" resource) row-peer) row-account) :occupant-id occupant-id :timestamp timestamp))) (sqlite-select db "SELECT id, direction, peer, resource, account, occupant_id, timestamp, type \ FROM message WHERE account = ? AND peer = ? AND stanza_id = ?" (list account peer stanza-id))))) (defun jabber-db-correct-message-row (row-id new-body) "Replace the body of primary message ROW-ID with NEW-BODY." (when (and jabber-db--connection row-id) (sqlite-execute jabber-db--connection "UPDATE message SET body = ?, edited = 1 WHERE id = ?" (list new-body row-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)) (sqlite-execute db "DELETE FROM message_thread WHERE account = ? AND peer = ?" (list account peer)))) (defun jabber-db-message-sender-by-stanza-id (stanza-id) "Return the sender of globally unique 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 = ? \ GROUP BY stanza_id HAVING COUNT(*) = 1" (list stanza-id))))) (seq-let (direction peer resource account) row (if (string= direction "in") (if resource (concat peer "/" resource) peer) account))))) (defun jabber-db-reply-target-body (account peer reply-id muc-p) "Return the body of the message REPLY-ID references, or nil. In a MUC (MUC-P non-nil) REPLY-ID is the room-assigned stanza-id \(XEP-0461), so match on server_id; in 1:1 chat it is the sender's origin id, so match on stanza_id. ACCOUNT and PEER scope the lookup." (when-let* ((db (jabber-db-ensure-open))) (caar (sqlite-select db (format "SELECT body FROM message \ WHERE account = ? AND peer = ? AND %s = ? AND retracted_by IS NULL \ LIMIT 1" (if muc-p "server_id" "stanza_id")) (list account peer reply-id))))) ;;; Reactions (defun jabber-db--reaction-id-column (type) "Return the message ID column used for reaction targets of TYPE." (if (string= type "groupchat") "server_id" "stanza_id")) (defun jabber-db--message-id-for-reaction-target (db account peer type target-id) "Return DB message id for reaction target TARGET-ID, or nil. DB is the SQLite connection. ACCOUNT, PEER and TYPE scope the lookup." (when (and account peer type target-id) (caar (sqlite-select db (format "SELECT id FROM message \ WHERE account = ? AND peer = ? AND type = ? AND %s = ? LIMIT 1" (jabber-db--reaction-id-column type)) (list account peer type target-id))))) (defun jabber-db--reaction-current-updated-at (db message-id sender) "Return actor reaction timestamp in DB for MESSAGE-ID and SENDER." (caar (sqlite-select db "SELECT updated_at FROM message_reaction_actor \ WHERE message_id = ? AND sender = ?" (list message-id sender)))) (defun jabber-db--source-reaction-stale-p (db message-id sender updated-at) "Return non-nil when UPDATED-AT is stale for MESSAGE-ID and SENDER in DB." (when-let* ((current-updated-at (jabber-db--reaction-current-updated-at db message-id sender))) (<= updated-at current-updated-at))) (defun jabber-db-reaction-stale-p (account peer type target-id sender updated-at) "Return non-nil when UPDATED-AT is stale for SENDER's target reactions. ACCOUNT, PEER, TYPE and TARGET-ID identify the target message. Return nil when storage is disabled or the target is not stored." (when-let* ((db (jabber-db-ensure-open)) (updated-at) (message-id (jabber-db--message-id-for-reaction-target db account peer type target-id))) (jabber-db--source-reaction-stale-p db message-id sender updated-at))) (defun jabber-db-replace-reactions (account peer type target-id sender reactions &optional updated-at) "Replace SENDER's REACTIONS for TARGET-ID in ACCOUNT/PEER conversation. TYPE is the target message type. Return non-nil when the target message exists and the replacement was applied. Empty REACTIONS deletes SENDER's stored reactions for the target. Non-nil UPDATED-AT is source ordered and older or equal values are ignored. Nil UPDATED-AT is a local replacement and is always accepted with the current timestamp." (when-let* ((db (jabber-db-ensure-open)) (message-id (jabber-db--message-id-for-reaction-target db account peer type target-id))) (unless (and updated-at (jabber-db--source-reaction-stale-p db message-id sender updated-at)) (let ((deduplicated (delete-dups (cl-remove-if-not #'stringp reactions))) (replacement-updated-at (or updated-at (floor (float-time))))) (sqlite-execute db "INSERT INTO message_reaction_actor \ (message_id, sender, updated_at) VALUES (?, ?, ?) \ ON CONFLICT(message_id, sender) DO UPDATE SET updated_at = excluded.updated_at" (list message-id sender replacement-updated-at)) (sqlite-execute db "DELETE FROM message_reaction \ WHERE message_id = ? AND sender = ?" (list message-id sender)) (dolist (reaction deduplicated) (unless (string-empty-p reaction) (sqlite-execute db "INSERT INTO message_reaction \ (message_id, sender, reaction, updated_at) VALUES (?, ?, ?, ?)" (list message-id sender reaction replacement-updated-at)))) t)))) (defun jabber-db-reactions-for-message-ids (message-ids) "Return reaction state for MESSAGE-IDS keyed by message DB id. The returned hash table maps message ids to alists of (SENDER . REACTIONS)." (let ((grouped (make-hash-table :test #'eql))) (when-let* ((db (jabber-db-ensure-open)) ((cl-some #'identity message-ids))) (dolist (row (sqlite-select db (format "SELECT message_id, sender, reaction \ FROM message_reaction WHERE message_id IN (%s) \ ORDER BY message_id, updated_at, rowid" (mapconcat #'number-to-string message-ids ",")))) (seq-let (message-id sender reaction) row (push reaction (alist-get sender (gethash message-id grouped) nil nil #'equal)))) (maphash (lambda (message-id sender-state) (puthash message-id (mapcar (lambda (entry) (cons (car entry) (nreverse (cdr entry)))) (nreverse sender-state)) grouped)) grouped)) grouped)) (defun jabber-db--attach-reactions (plists) "Batch-query reactions and attach them to PLISTS by :db-id." (let* ((ids (cl-loop for p in plists for id = (plist-get p :db-id) when id collect id)) (reactions (jabber-db-reactions-for-message-ids ids))) (dolist (p plists) (when-let* ((db-id (plist-get p :db-id))) (plist-put p :reactions (gethash db-id reactions)))) plists)) ;;; Retrieval (defconst jabber-db--backlog-columns "SELECT id, account, peer, direction, body, timestamp, \ resource, type, encrypted, stanza_id, delivered_at, displayed_at, \ server_id, retracted_by, retraction_reason, edited, \ reply_to_id, reply_to_jid, fallback_start, fallback_end, \ thread_id, thread_parent_id FROM message" "Columns shared by parent and thread backlog queries.") (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 reply-to-id reply-to-jid fallback-start fallback-end thread-id thread-parent-id) 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))) :reply-to-id reply-to-id :reply-to-jid reply-to-jid :fallback-range (jabber-db--decode-fallback-range fallback-start fallback-end) :thread-id thread-id :thread-parent-id thread-parent-id :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--thread-summary (db account peer type thread-row) "Return THREAD-ROW's summary from DB for ACCOUNT, PEER, and TYPE." (seq-let (thread-id parent-id root-message-id root-stanza-id root-server-id read-message-id title) thread-row (seq-let (reply-count latest-in-id local-reply-count) (car (sqlite-select db "SELECT count(*), MAX(CASE WHEN direction = 'in' THEN id END), \ COALESCE(SUM(CASE WHEN direction = 'out' THEN 1 ELSE 0 END), 0) \ FROM message WHERE account = ? AND peer = ? AND type = ? AND thread_id = ? \ AND NOT (CASE WHEN ? IS NOT NULL THEN id = ? \ WHEN ? = 'groupchat' AND ? IS NOT NULL THEN server_id = ? \ WHEN ? IS NOT NULL THEN stanza_id = ? ELSE 0 END)" (list account peer type thread-id root-message-id root-message-id type root-server-id root-server-id root-stanza-id root-stanza-id))) (list :thread-id thread-id :thread-type type :thread-parent-id parent-id :root-message-id root-message-id :root-stanza-id root-stanza-id :root-server-id root-server-id :title title :reply-count reply-count :local-reply-count local-reply-count :unread (and latest-in-id (or (null read-message-id) (> latest-in-id read-message-id))))))) (defun jabber-db-message-thread-summary (account peer type thread-id) "Return THREAD-ID's summary for ACCOUNT, PEER, and TYPE, or nil." (when-let* ((db (jabber-db-ensure-open)) (row (car (sqlite-select db "SELECT thread_id, parent_thread_id, root_message_id, \ root_stanza_id, root_server_id, read_message_id, title, type \ FROM message_thread \ WHERE account = ? AND peer = ? AND type = ? AND thread_id = ? \ AND dedicated = 1" (list account peer type thread-id))))) (jabber-db--thread-summary db account peer type row))) (defconst jabber-db--message-threads-sql "SELECT mt.thread_id, mt.parent_thread_id, mt.created_at, COALESCE(MAX(m.timestamp), mt.created_at) AS latest_at, root.id, root.stanza_id, root.server_id, root.resource, root.direction, root.body, root.timestamp, root.retracted_by, root.retraction_reason, COALESCE(SUM(CASE WHEN m.id IS NULL THEN 0 WHEN (CASE WHEN mt.root_message_id IS NOT NULL THEN m.id = mt.root_message_id WHEN mt.type = 'groupchat' AND mt.root_server_id IS NOT NULL THEN m.server_id = mt.root_server_id WHEN mt.root_stanza_id IS NOT NULL THEN m.stanza_id = mt.root_stanza_id ELSE 0 END) THEN 0 ELSE 1 END), 0), COALESCE(SUM(CASE WHEN m.id IS NULL OR m.direction != 'out' THEN 0 WHEN (CASE WHEN mt.root_message_id IS NOT NULL THEN m.id = mt.root_message_id WHEN mt.type = 'groupchat' AND mt.root_server_id IS NOT NULL THEN m.server_id = mt.root_server_id WHEN mt.root_stanza_id IS NOT NULL THEN m.stanza_id = mt.root_stanza_id ELSE 0 END) THEN 0 ELSE 1 END), 0), MAX(CASE WHEN m.direction = 'in' AND NOT (CASE WHEN mt.root_message_id IS NOT NULL THEN m.id = mt.root_message_id WHEN mt.type = 'groupchat' AND mt.root_server_id IS NOT NULL THEN m.server_id = mt.root_server_id WHEN mt.root_stanza_id IS NOT NULL THEN m.stanza_id = mt.root_stanza_id ELSE 0 END) THEN m.id END), mt.read_message_id, mt.title FROM message_thread mt LEFT JOIN message root ON (mt.root_message_id IS NOT NULL AND root.id = mt.root_message_id AND root.account = mt.account AND root.peer = mt.peer AND root.type = mt.type) OR (mt.root_message_id IS NULL AND mt.type = 'groupchat' AND mt.root_server_id IS NOT NULL AND root.server_id = mt.root_server_id AND root.account = mt.account AND root.peer = mt.peer AND root.type = mt.type) OR (mt.root_message_id IS NULL AND NOT (mt.type = 'groupchat' AND mt.root_server_id IS NOT NULL) AND mt.root_stanza_id IS NOT NULL AND root.stanza_id = mt.root_stanza_id AND root.account = mt.account AND root.peer = mt.peer AND root.type = mt.type) LEFT JOIN message m ON m.account = mt.account AND m.peer = mt.peer AND m.type = mt.type AND m.thread_id = mt.thread_id WHERE mt.account = ? AND mt.peer = ? AND mt.type = ? AND mt.dedicated = 1 GROUP BY mt.account, mt.peer, mt.type, mt.thread_id ORDER BY latest_at DESC, mt.created_at DESC, mt.thread_id LIMIT 50" "Query dedicated threads in one conversation by latest activity.") (defun jabber-db--thread-root-from (account peer type resource direction) "Return a root sender from ACCOUNT, PEER, TYPE, RESOURCE, and DIRECTION." (cond ((equal direction "in") (if resource (concat peer "/" resource) peer)) ((and (equal type "groupchat") resource) (concat peer "/" resource)) (t account))) (defun jabber-db--thread-list-row-to-plist (account peer type row) "Convert a thread listing ROW for ACCOUNT, PEER, and TYPE to a plist." (seq-let (thread-id parent-id created-at latest-at root-id root-stanza-id root-server-id root-resource root-direction root-body root-timestamp root-retracted-by root-retraction-reason reply-count local-reply-count latest-in-id read-message-id title) row (list :thread-id thread-id :thread-type type :thread-parent-id parent-id :title title :created-at (seconds-to-time created-at) :latest-at (seconds-to-time latest-at) :reply-count reply-count :local-reply-count local-reply-count :unread (and latest-in-id (or (null read-message-id) (> latest-in-id read-message-id))) :root-message (and root-id (list :db-id root-id :id root-stanza-id :server-id root-server-id :from (jabber-db--thread-root-from account peer type root-resource root-direction) :resource root-resource :body (or root-body "") :timestamp (seconds-to-time root-timestamp) :retracted (and root-retracted-by t) :retracted-by root-retracted-by :retraction-reason root-retraction-reason :thread-id thread-id :thread-parent-id parent-id :direction root-direction :msg-type type))))) (defun jabber-db-message-threads (account peer type) "Return ACCOUNT and PEER's TYPE threads by latest activity." (when-let* ((db (jabber-db-ensure-open))) (mapcar (lambda (row) (jabber-db--thread-list-row-to-plist account peer type row)) (sqlite-select db jabber-db--message-threads-sql (list account peer type))))) (defun jabber-db-message-thread-known-p (account peer type thread-id) "Return non-nil when THREAD-ID is dedicated for ACCOUNT, PEER, and TYPE." (and thread-id (jabber-db-message-thread-summary account peer type thread-id) t)) (defun jabber-db-message-thread-root-p (account peer type thread-id stanza-id server-id &optional message-id) "Return non-nil when MESSAGE-ID identifies THREAD-ID's root. ACCOUNT, PEER, and TYPE scope the lookup. SERVER-ID and STANZA-ID are fallback wire identifiers when the thread has no database row ID." (when-let* ((summary (jabber-db-message-thread-summary account peer type thread-id))) (cond ((plist-get summary :root-message-id) (and message-id (equal message-id (plist-get summary :root-message-id)))) ((and (equal type "groupchat") (plist-get summary :root-server-id)) (and server-id (equal server-id (plist-get summary :root-server-id)))) ((plist-get summary :root-stanza-id) (and stanza-id (equal stanza-id (plist-get summary :root-stanza-id))))))) (defun jabber-db--message-thread-location (db account peer type column value) "Return VALUE's thread location from DB. ACCOUNT, PEER, and TYPE scope the trusted internal COLUMN." (when-let* ((row (car (sqlite-select db (format "SELECT mt.thread_id, \ CASE WHEN mt.root_message_id IS NOT NULL THEN mt.root_message_id = m.id \ WHEN m.type = 'groupchat' AND mt.root_server_id IS NOT NULL \ THEN mt.root_server_id = m.server_id \ WHEN mt.root_stanza_id IS NOT NULL THEN mt.root_stanza_id = m.stanza_id \ ELSE 0 END \ FROM message m LEFT JOIN message_thread mt \ ON mt.account = m.account AND mt.peer = m.peer AND mt.type = m.type \ AND mt.dedicated = 1 \ AND (mt.thread_id = m.thread_id OR (m.thread_id IS NULL AND \ CASE WHEN mt.root_message_id IS NOT NULL THEN mt.root_message_id = m.id \ WHEN m.type = 'groupchat' AND mt.root_server_id IS NOT NULL \ THEN mt.root_server_id = m.server_id \ WHEN mt.root_stanza_id IS NOT NULL THEN mt.root_stanza_id = m.stanza_id \ ELSE 0 END)) \ WHERE m.account = ? AND m.peer = ? AND m.type = ? AND %s = ? \ AND mt.thread_id IS NOT NULL LIMIT 1" column) (list account peer type value))))) (list :thread-id (car row) :root (= (cadr row) 1)))) (defun jabber-db-message-thread-location (account peer type message-id server-id-p) "Return MESSAGE-ID's thread location for ACCOUNT, PEER, and TYPE. The result contains `:thread-id' and non-nil `:root' when the message is the thread root. SERVER-ID-P selects server IDs." (when-let* ((db (jabber-db-ensure-open))) (jabber-db--message-thread-location db account peer type (if server-id-p "m.server_id" "m.stanza_id") message-id))) (defun jabber-db-message-thread-location-by-row (account peer type row-id) "Return ROW-ID's thread location for ACCOUNT, PEER, and TYPE." (when-let* ((db (jabber-db-ensure-open))) (jabber-db--message-thread-location db account peer type "m.id" row-id))) (defun jabber-db-message-thread-for-message (account peer type message-id server-id-p) "Return MESSAGE-ID's reply thread for ACCOUNT, PEER, and TYPE. Thread roots return nil so their canonical owner remains the parent buffer. SERVER-ID-P selects server IDs." (when-let* ((location (jabber-db-message-thread-location account peer type message-id server-id-p)) ((not (plist-get location :root)))) (plist-get location :thread-id))) (defun jabber-db--attach-thread-summaries (db account peer plists) "Attach DB thread summaries for ACCOUNT and PEER to root PLISTS." (dolist (row (sqlite-select db "SELECT thread_id, parent_thread_id, root_message_id, \ root_stanza_id, root_server_id, read_message_id, title, type \ FROM message_thread \ WHERE account = ? AND peer = ? AND dedicated = 1" (list account peer))) (let* ((type (nth 7 row)) (root (seq-find (lambda (msg) (and (equal (plist-get msg :msg-type) type) (jabber-db--message-thread-root-p msg type (nth 2 row) (nth 3 row) (nth 4 row)))) plists))) (when root (plist-put root :thread-summary (jabber-db--thread-summary db account peer type row))))) plists) (defun jabber-db-backlog (account peer &optional count start-time resource msg-type include-thread-replies) "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). INCLUDE-THREAD-REPLIES non-nil keeps replies in the result." (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))) (parent-clause (if include-thread-replies "" " AND (thread_id IS NULL OR NOT EXISTS (\ SELECT 1 FROM message_thread mt WHERE mt.account = message.account \ AND mt.peer = message.peer AND mt.type = message.type \ AND mt.thread_id = message.thread_id AND mt.dedicated = 1) OR EXISTS (\ SELECT 1 FROM message_thread mt WHERE mt.account = message.account \ AND mt.peer = message.peer AND mt.type = message.type \ AND mt.thread_id = message.thread_id AND mt.dedicated = 1 \ AND (CASE WHEN mt.root_message_id IS NOT NULL \ THEN mt.root_message_id = message.id \ WHEN message.type = 'groupchat' AND mt.root_server_id IS NOT NULL \ THEN mt.root_server_id = message.server_id \ WHEN mt.root_stanza_id IS NOT NULL \ THEN mt.root_stanza_id = message.stanza_id ELSE 0 END)))")) (sql (cond (resource (concat jabber-db--backlog-columns " WHERE account = ? AND peer = ? \ AND type = 'chat' AND (resource = ? OR direction = 'out') \ AND timestamp >= ?" parent-clause " ORDER BY timestamp DESC LIMIT ?")) (msg-type (concat jabber-db--backlog-columns " WHERE account = ? AND peer = ? \ AND type = ? AND timestamp >= ?" parent-clause " \ ORDER BY timestamp DESC LIMIT ?")) (t (concat jabber-db--backlog-columns " WHERE account = ? AND peer = ? \ AND timestamp >= ?" parent-clause " 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-thread-summaries db account peer (jabber-db--attach-reactions (jabber-db--attach-oob-entries db plists)))))) (defun jabber-db--message-thread-root-p (msg type root-message-id root-stanza-id root-server-id) "Return non-nil when MSG matches a supplied thread root ID. TYPE selects groupchat server IDs. ROOT-MESSAGE-ID is the database row ID. ROOT-STANZA-ID and ROOT-SERVER-ID are wire identifiers." (cond (root-message-id (equal root-message-id (plist-get msg :db-id))) ((and (equal type "groupchat") root-server-id) (equal root-server-id (plist-get msg :server-id))) (root-stanza-id (equal root-stanza-id (plist-get msg :id))))) (defun jabber-db-thread-backlog (account peer type thread-id &optional count start-time) "Return THREAD-ID's root and replies for ACCOUNT, PEER, and TYPE. Results are reverse chronological, limited by COUNT after START-TIME." (when-let* ((db (jabber-db-ensure-open)) (thread-row (car (sqlite-select db "SELECT root_message_id, root_stanza_id, root_server_id \ FROM message_thread WHERE account = ? AND peer = ? AND type = ? \ AND thread_id = ?" (list account peer type thread-id))))) (let* ((root-message-id (nth 0 thread-row)) (root-stanza-id (nth 1 thread-row)) (root-server-id (nth 2 thread-row)) (cutoff (floor (or start-time 0))) (rows (sqlite-select db (concat jabber-db--backlog-columns "\ WHERE account = ? AND peer = ? AND type = ? AND timestamp >= ? \ AND (thread_id = ? OR CASE WHEN ? IS NOT NULL THEN id = ? \ WHEN ? = 'groupchat' AND ? IS NOT NULL THEN server_id = ? \ WHEN ? IS NOT NULL THEN stanza_id = ? ELSE 0 END) \ ORDER BY timestamp DESC") (list account peer type cutoff thread-id root-message-id root-message-id type root-server-id root-server-id root-stanza-id root-stanza-id))) (plists (mapcar #'jabber-db--row-to-plist rows)) (root (seq-find (lambda (msg) (jabber-db--message-thread-root-p msg type root-message-id root-stanza-id root-server-id)) plists)) (limit (or count jabber-backlog-number)) (replies (seq-remove (lambda (msg) (eq msg root)) plists)) (selected (if (eq limit t) replies (seq-take replies (max 0 (1- limit))))) (result (append selected (and root (list root))))) (jabber-db--attach-reactions (jabber-db--attach-oob-entries db result))))) (defun jabber-db-mark-message-thread-read (account peer type thread-id) "Mark stored THREAD-ID replies read for ACCOUNT, PEER, and TYPE." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "UPDATE message_thread SET read_message_id = COALESCE((\ SELECT MAX(id) FROM message WHERE account = ? AND peer = ? AND type = ? \ AND thread_id = ?), read_message_id) \ WHERE account = ? AND peer = ? AND type = ? AND thread_id = ?" (list account peer type thread-id account peer type thread-id)))) (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--stanza-id-element (xml-data expected-by) "Return the child of XML-DATA whose `by' is EXPECTED-BY. Matching on the node name matters: shares the urn:xmpp:sid:0 namespace, and occupants can inject stanza-id elements with arbitrary `by' values." (seq-find (lambda (child) (and (eq (jabber-xml-node-name child) 'stanza-id) (string= (jabber-xml-get-xmlns child) "urn:xmpp:sid:0") (jabber-xml-get-attribute child 'id) (equal (jabber-xml-get-attribute child 'by) expected-by))) (jabber-xml-node-children xml-data))) (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)) (peer (jabber-jid-user from)) (resource (jabber-jid-resource from)) (direction (if (and (equal type "groupchat") resource (equal resource (jabber-muc-nickname peer jc))) "out" "in")) (stanza-id (jabber-xml-get-attribute xml-data 'id)) (server-id ;; Trust only the stanza-id assigned by our own server ;; (1:1) or by a joined room itself (MUC). (when-let* ((expected-by (if (string= type "groupchat") (and (jabber-muc-joined-p (jabber-jid-user from)) (jabber-jid-user from)) (jabber-connection-bare-jid jc))) (sid-el (jabber-db--stanza-id-element xml-data expected-by))) (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) peer direction (or type "chat") body (floor (float-time (or timestamp (current-time)))) resource stanza-id server-id (jabber-db--extract-occupant-id xml-data) oob-entries encrypted (jabber-db--extract-reply-fields xml-data) (jabber-db--extract-thread-fields xml-data)))))) (defun jabber-db--outgoing-handler (body id &optional reply thread) "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'. Reply metadata is read from `jabber-chat--send-hook-stanza' when the hooks that emit the reply elements have already run. Optional REPLY and THREAD supply metadata for messages stored before those hooks run." (when (and jabber-chatting-with jabber-buffer-connection (not (bound-and-true-p jabber-chat--sending-correction))) (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)) (or reply (and (bound-and-true-p jabber-chat--send-hook-stanza) (jabber-db--extract-reply-fields jabber-chat--send-hook-stanza))) (or thread (and (bound-and-true-p jabber-chat--send-hook-stanza) (jabber-db--extract-thread-fields jabber-chat--send-hook-stanza))))) 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 (jabber-chain-add 'jabber-message-chain #'jabber-db--message-handler 90) ;; Depth 90: run after the hooks that attach reply/receipt elements, ;; so the stored row sees the complete stanza. (add-hook 'jabber-chat-send-hooks #'jabber-db--outgoing-handler 90) (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-0.13.1/lisp/jabber-disco-menu.el000066400000000000000000000036561523531702000206760ustar00rootroot00000000000000;;; jabber-disco-menu.el --- Service discovery command menus -*- 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. ;;; Commentary: ;; Collect discovery-related commands after their feature modules load. ;;; Code: (require 'keymap-popup) (require 'jabber-ahc) (require 'jabber-browse) (require 'jabber-carbons) (require 'jabber-disco) (require 'jabber-info) (require 'jabber-ping) (require 'jabber-register) (require 'jabber-search) (require 'jabber-time) (require 'jabber-vcard) (require 'jabber-version) (defvar jabber-info-menu-map) (defvar jabber-service-menu-map) (keymap-popup-define jabber-info-menu-map "Jabber info/discovery commands." :group "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)) (defun jabber-info-menu () "Jabber info/discovery commands." (interactive) (keymap-popup jabber-info-menu-map)) (keymap-popup-define jabber-service-menu-map "Jabber service commands." :group "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)) (defun jabber-service-menu () "Jabber service commands." (interactive) (keymap-popup jabber-service-menu-map)) (provide 'jabber-disco-menu) ;;; jabber-disco-menu.el ends here emacs-jabber-0.13.1/lisp/jabber-disco.el000066400000000000000000000701671523531702000177350ustar00rootroot00000000000000;;; 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 'cl-lib) (require 'jabber-db) (require 'jabber-iq) (require 'jabber-xml) (require 'jabber-xdata) (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 (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.") (defvar jabber-presence-element-functions nil) ; jabber-presence.el (defvar jabber-disco-features-changed-hook nil "Hook run after connected clients advertise a new feature.") ;; (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-xdata-form-type a) (jabber-xdata-form-type 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-xdata-form-type 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-xdata-form-type 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) (run-hooks 'jabber-disco-features-changed-hook)))) (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))))) (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. JC is the Jabber connection. XML-DATA is the IQ result stanza. 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)) (cl-remove-if-not (lambda (x) (string= (jabber-xml-get-xmlns x) jabber-xdata-xmlns)) (jabber-xml-get-children (jabber-iq-query xml-data) 'x)))) (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)))) (provide 'jabber-disco) ;;; jabber-disco.el ends here. emacs-jabber-0.13.1/lisp/jabber-eme.el000066400000000000000000000031131523531702000173650ustar00rootroot00000000000000;;; 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-0.13.1/lisp/jabber-hints.el000066400000000000000000000033751523531702000177560ustar00rootroot00000000000000;;; 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-0.13.1/lisp/jabber-httpupload.el000066400000000000000000000574171523531702000210230ustar00rootroot00000000000000;;; 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 'cl-lib) (require 'fsm) (require 'mailcap) (require 'subr-x) (require 'jabber-chat) (require 'jabber-conn) (require 'jabber-core) (require 'jabber-disco) (require 'jabber-iq) (require 'jabber-muc-state) (require 'jabber-util) (require 'jabber-xml) (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).") (defvar jabber-httpupload-max-file-size nil "Alist of Jabber connections and advertised HTTP Upload size limits. Each element is (jabber-connection . max-file-size), where max-file-size is in bytes.") (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)) (jabber-httpupload--record-support jc iri result))) 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)) (defun jabber-httpupload--xdata-field-value (form var) "Return the first value for xdata FORM field VAR." (when-let* ((field (cl-find-if (lambda (field) (string= (jabber-xml-get-attribute field 'var) var)) (jabber-xml-get-children form 'field))) (value (car (jabber-xml-get-children field 'value))) (text (car (jabber-xml-node-children value))) ((stringp text))) text)) (defun jabber-httpupload--parse-max-file-size (value) "Return positive integer VALUE, or nil when VALUE is invalid." (when (and (stringp value) (string-match-p "\\`[0-9]+\\'" value)) (let ((size (string-to-number value))) (and (> size 0) size)))) (defun jabber-httpupload--max-file-size (result) "Return HTTP Upload max-file-size from disco info RESULT, or nil." (cl-some (lambda (form) (when (string= (jabber-httpupload--xdata-field-value form "FORM_TYPE") jabber-httpupload-xmlns) (jabber-httpupload--parse-max-file-size (jabber-httpupload--xdata-field-value form "max-file-size")))) (nth 2 result))) (defun jabber-httpupload--record-support (jc iri result) "Record HTTP Upload support for JC through IRI using disco RESULT." (unless (assq jc jabber-httpupload-support) (push (cons jc iri) jabber-httpupload-support)) (if-let* ((max-file-size (jabber-httpupload--max-file-size result))) (setf (alist-get jc jabber-httpupload-max-file-size) max-file-size) (setq jabber-httpupload-max-file-size (assq-delete-all jc jabber-httpupload-max-file-size)))) (defun jabber-httpupload--validate-file-size (jc filepath size) "Signal a user error if FILEPATH is larger than JC's advertised SIZE limit." (when-let* ((max-file-size (cdr (assq jc jabber-httpupload-max-file-size)))) (when (> size max-file-size) (user-error "File %s is too large for HTTP Upload (maximum %s bytes)" (file-name-nondirectory filepath) max-file-size)))) (defun jabber-httpupload--error-child (error child-name) "Return ERROR's XEP-0363 child named CHILD-NAME." (cl-find-if (lambda (child) (and (eq (jabber-xml-node-name child) child-name) (string= (jabber-xml-get-attribute child 'xmlns) jabber-httpupload-xmlns))) (jabber-xml-node-children error))) (defun jabber-httpupload--child-text (node child-name) "Return NODE's first CHILD-NAME text." (when-let* ((child (car (jabber-xml-get-children node child-name))) (text (car (jabber-xml-node-children child))) ((stringp text))) text)) (defun jabber-httpupload--slot-error-message (filename xml-data) "Return a user-facing slot error message for FILENAME and XML-DATA." (let* ((error (jabber-iq-error xml-data)) (file-too-large (and error (jabber-httpupload--error-child error 'file-too-large))) (retry (and error (jabber-httpupload--error-child error 'retry)))) (cond (file-too-large (if-let* ((max-file-size (jabber-httpupload--parse-max-file-size (jabber-httpupload--child-text file-too-large 'max-file-size)))) (format "File %s is too large for HTTP Upload (maximum %s bytes)" filename max-file-size) (format "File %s is too large for HTTP Upload" filename))) (retry (if-let* ((stamp (jabber-xml-get-attribute retry 'stamp))) (format "HTTP Upload temporarily unavailable for %s; retry after %s" filename stamp) (format "HTTP Upload temporarily unavailable for %s" filename))) (error (format "HTTP Upload slot rejected for %s: %s" filename (jabber-parse-error error))) (t (format "HTTP Upload slot rejected for %s" filename))))) ;; 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--child (node child-name &optional inherited-namespace) "Return NODE's XEP-0363 child named CHILD-NAME. When INHERITED-NAMESPACE is non-nil, children without an explicit xmlns inherit it from NODE." (cl-find-if (lambda (child) (and (eq (jabber-xml-node-name child) child-name) (let ((xmlns (jabber-xml-get-attribute child 'xmlns))) (string= (or xmlns inherited-namespace) jabber-httpupload-xmlns)))) (jabber-xml-get-children node child-name))) (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* ((slot (jabber-httpupload--child xml-data 'slot)) (put (and slot (jabber-httpupload--child slot 'put jabber-httpupload-xmlns))) (get (and slot (jabber-httpupload--child slot 'get jabber-httpupload-xmlns))) (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--curl-header-args (headers &optional redact) "Return curl -H arguments for HEADERS. When REDACT is non-nil, omit header values from the returned arguments." (cl-loop for (name . value) in headers append (list "-H" (format "%s: %s" name (if redact "" value))))) (defun jabber-httpupload--curl-command (curl-path filepath headers put-url ignore-cert-problems &optional redact) "Return a CURL-PATH command for FILEPATH, HEADERS, and PUT-URL. IGNORE-CERT-PROBLEMS adds curl's insecure certificate option. REDACT omits header values from the command." `(,curl-path ,@(and ignore-cert-problems '("--insecure")) "--fail" "--upload-file" ,filepath ,@(jabber-httpupload--curl-header-args headers redact) ,put-url)) (defun jabber-httpupload--curl-buffer-tail (process) "Return a short sanitized tail from PROCESS buffer, or nil." (when-let* ((buffer (process-buffer process)) ((buffer-live-p buffer))) (with-current-buffer buffer (let* ((end (point-max)) (start (max (point-min) (- end 500))) (tail (string-trim (buffer-substring-no-properties start end)))) (unless (string-empty-p tail) (let ((case-fold-search t)) (replace-regexp-in-string "\\(Authorization\\|Cookie\\)[[:space:]]*:[[:space:]]*.*" "\\1: " tail))))))) (defun jabber-httpupload--curl-status-message (process-status exit-status) "Return a curl failure status message for PROCESS-STATUS and EXIT-STATUS." (pcase process-status ('exit (format "exit status %s" exit-status)) ('signal (format "signal status %s" exit-status)) (_ (format "%s status %s" process-status exit-status)))) (defun jabber-httpupload--curl-failure-message (filename process-status exit-status event tail) "Return a curl failure message. FILENAME, PROCESS-STATUS, EXIT-STATUS, EVENT, and TAIL describe the failure." (string-join (delq nil (list (format "HTTP Upload failed for %s: %s" filename (jabber-httpupload--curl-status-message process-status exit-status)) (format "event: %s" (string-trim event)) (and tail (format "curl output: %s" tail)))) "; ")) (defun jabber-httpupload--curl-log-sentinel (process event) "Append curl PROCESS sentinel EVENT to its buffer." (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)))))) (defun jabber-httpupload--curl-sentinel (process event callback callback-arg) "Handle curl upload PROCESS EVENT. Call CALLBACK with CALLBACK-ARG only when curl exits with status zero." (let ((tail (jabber-httpupload--curl-buffer-tail process))) (jabber-httpupload--curl-log-sentinel process event) (when (memq (process-status process) '(exit signal)) (let ((process-status (process-status process)) (exit-status (process-exit-status process))) (if (and (eq process-status 'exit) (zerop exit-status)) (funcall callback callback-arg) (message "%s" (jabber-httpupload--curl-failure-message (or (process-get process :jabber-httpupload-filename) "unknown file") process-status exit-status event tail))))))) (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 (jabber-httpupload--curl-command curl-path filepath headers put-url ignore-cert-problems)) (logged-command (jabber-httpupload--curl-command curl-path filepath headers put-url ignore-cert-problems t))) (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) logged-command)))) (let ((process (make-process :name "jabber-httpupload-curl" :buffer buffer :command command :sentinel (lambda (process event) (jabber-httpupload--curl-sentinel process event callback callback-arg))))) (process-put process :jabber-httpupload-filename (file-name-nondirectory filepath)) process)))) ;; Core upload pipeline (defun jabber-httpupload--disco-error-p (result) "Return non-nil when RESULT is a disco error node." (eq (car-safe result) 'error)) (defun jabber-httpupload--unsupported-error () "Report that the current server has no HTTP Upload service." (user-error "HTTP Upload is not supported by this server")) (defun jabber-httpupload--maybe-upload (jc filepath callback iri result) "Upload FILEPATH on JC through IRI when RESULT advertises HTTP Upload. On success, pass the uploaded URL to CALLBACK." (when (and (not (jabber-httpupload--disco-error-p result)) (member jabber-httpupload-xmlns (nth 1 result))) (jabber-httpupload--record-support jc iri result) (jabber-httpupload--upload jc filepath callback) t)) (defun jabber-httpupload--discover-from-items (jc filepath callback items) "Inspect ITEMS for JC and upload FILEPATH when one supports HTTP Upload. On success, pass the uploaded URL to CALLBACK." (if (or (null items) (jabber-httpupload--disco-error-p items)) (jabber-httpupload--unsupported-error) (let ((remaining (length items)) (done nil)) (dolist (item items) (let ((iri (elt item 1))) (jabber-disco-get-info jc iri nil (lambda (jc _data result) (unless done (if (jabber-httpupload--maybe-upload jc filepath callback iri result) (setq done t) (setq remaining (1- remaining)) (when (zerop remaining) (jabber-httpupload--unsupported-error))))) nil)))))) (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 ((node (plist-get (fsm-get-state-data jc) :server))) (jabber-disco-get-items jc node nil (lambda (jc _data result) (jabber-httpupload--discover-from-items jc filepath callback result)) 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-httpupload--validate-file-size jc filepath size) (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) (user-error "%s" (jabber-httpupload--slot-error-message 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 when BODY carries a pending upload URL. Return the OOB element list for `jabber-chat-send-hooks', and clear the pending state. If the URL is no longer in BODY (user deleted it), clear the pending state 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 over connection JC 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 connection 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 via connection JC 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-0.13.1/lisp/jabber-image.el000066400000000000000000000152511523531702000177070ustar00rootroot00000000000000;;; 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 'url-queue) ;; For the `image-property' setf-expander (not preloaded on emacs-nox). (require 'image) (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) (defcustom jabber-image-max-bytes (* 25 1024 1024) "Maximum size in bytes for downloaded inline images. Larger downloads are never decoded, not even when loaded manually. nil means no limit." :type '(choice (const :tag "No limit" nil) (natnum :tag "Bytes"))) (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--size-ok-p (data) "Return non-nil when DATA fits within `jabber-image-max-bytes'." (or (null jabber-image-max-bytes) (<= (string-bytes data) jabber-image-max-bytes))) (defun jabber-image--type-ok-p (data allowed-types) "Return non-nil when DATA's detected image type is permitted. ALLOWED-TYPES is a list of image type symbols; nil permits any." (or (null allowed-types) (memq (image-type-from-data data) allowed-types))) (defun jabber-image--result-from-data (data allowed-types) "Return an image decoding result for DATA and ALLOWED-TYPES. The result contains either :image, or an :error symbol. Decode failures also retain DATA under :data so an explicit user action can offer to save the payload without fetching it again." (cond ((null data) (list :error 'response)) ((not (jabber-image--size-ok-p data)) (list :error 'size)) ((not (jabber-image--type-ok-p data allowed-types)) (list :error 'type)) (t (condition-case err (list :image (jabber-image-create data)) (error (list :error 'decode :message (error-message-string err) :data data)))))) (defun jabber-image-from-data (data &optional allowed-types) "Create a dynamically-sized image from raw DATA string. Return nil when DATA exceeds `jabber-image-max-bytes', its detected type is not in ALLOWED-TYPES (nil permits any), or it cannot be decoded." (let ((result (jabber-image--result-from-data data allowed-types))) (when (eq (plist-get result :error) 'decode) (message "jabber-image: failed to decode image: %s" (plist-get result :message))) (plist-get result :image))) (defun jabber-image--response-body () "Return the HTTP response body of the current buffer, or nil. The buffer is made unibyte; nil is returned when no header separator is found." (set-buffer-multibyte nil) (goto-char (point-min)) (when (re-search-forward "\r?\n\r?\n" nil t) (buffer-substring-no-properties (point) (point-max)))) (defun jabber-image--fetch-result (url allowed-types callback &rest cbargs) "Fetch URL and call CALLBACK with an image result and CBARGS. ALLOWED-TYPES restricts decoded image types; nil permits any. The result follows `jabber-image--result-from-data'. Transport failures use the error symbol `fetch'." (url-queue-retrieve url (lambda (status types cb args) (let ((url-buffer (current-buffer)) (result (if (plist-get status :error) (list :error 'fetch) (jabber-image--result-from-data (jabber-image--response-body) types)))) (kill-buffer url-buffer) (apply cb result args))) (list allowed-types callback cbargs) 'silent 'inhibit-cookies)) (defun jabber-image-fetch (url allowed-types callback &rest cbargs) "Fetch image at URL asynchronously. When complete, call CALLBACK with the image object (or nil on error) followed by CBARGS. The image must satisfy `jabber-image-max-bytes' and ALLOWED-TYPES per `jabber-image-from-data'; it is sized per `jabber-image-max-width' and `jabber-image-max-height'." (apply #'jabber-image--fetch-result url allowed-types (lambda (result cb args) (apply cb (plist-get result :image) args)) callback cbargs)) (provide 'jabber-image) ;;; jabber-image.el ends here emacs-jabber-0.13.1/lisp/jabber-info.el000066400000000000000000000165221523531702000175620ustar00rootroot00000000000000;;; 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-disco) (require 'jabber-iq) (require 'jabber-muc) (require 'jabber-ping) (require 'jabber-time) (require 'jabber-util) (require 'jabber-version) ;; Global reference declarations (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 insert 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 BARE-JID over connection JC. 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 over connection JC. 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-0.13.1/lisp/jabber-input.el000066400000000000000000000032571523531702000177670ustar00rootroot00000000000000;;; jabber-input.el --- Shared Jabber input buffer support -*- 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, or (at your option) ;; any later version. ;;; Commentary: ;; State and sending behavior shared by chat and XML console input buffers. ;;; Code: (require 'cl-lib) (require 'jabber-util) (defvar jabber-point-insert nil "Position where the message being composed starts.") (defvar jabber-send-function nil "Function for sending a message from a Jabber input buffer.") (defvar-local jabber-buffer-connection nil "Jabber connection associated with the current buffer.") (defun jabber-chat-buffer-send (&optional extra-elements) "Send the input composed below the prompt in the current buffer. EXTRA-ELEMENTS are optional XML elements for the outgoing stanza." (interactive) (when (cl-plusp (- (point-max) jabber-point-insert)) (unless (memq jabber-buffer-connection jabber-connections) (setq jabber-buffer-connection (or (jabber-find-active-connection jabber-buffer-connection) (jabber-read-account t)))) (let ((body (delete-and-extract-region jabber-point-insert (point-max)))) (if extra-elements (funcall jabber-send-function jabber-buffer-connection body extra-elements) (funcall jabber-send-function jabber-buffer-connection body))))) (provide 'jabber-input) ;;; jabber-input.el ends here emacs-jabber-0.13.1/lisp/jabber-iq.el000066400000000000000000000224531523531702000172400ustar00rootroot00000000000000;;; 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-keymap) (define-obsolete-variable-alias '*jabber-open-info-queries* 'jabber-open-info-queries "0.11.0") (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 (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)) (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'. CLOSURE-DATA is passed through to the browse buffer." (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'. CLOSURE-DATA may be a function or string used to build the alert text." (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-0.13.1/lisp/jabber-keepalive.el000066400000000000000000000165171523531702000206000ustar00rootroot00000000000000;;; 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 'fsm) (require 'jabber-core) (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 ;;;###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) (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)) (when (timerp jabber-keepalive-timeout-timer) (cancel-timer jabber-keepalive-timeout-timer)) (setq jabber-keepalive-timer nil jabber-keepalive-timeout-timer nil jabber-keepalive-pending nil)) (defun jabber-keepalive-do () "Send a ping to every connection and arm the timeout timer." (when jabber-keepalive-debug (message "%s: sending keepalive packet(s)" (current-time-string))) (when (timerp jabber-keepalive-timeout-timer) (cancel-timer jabber-keepalive-timeout-timer)) (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) "Mark connection JC as having answered the last keepalive ping." (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 () "Treat any connection that did not answer as lost and disconnect it." (let ((pending jabber-keepalive-pending)) (setq jabber-keepalive-timeout-timer nil jabber-keepalive-pending nil) (dolist (c 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)) (unless jabber-connections (jabber-keepalive-stop)))) ;;;; 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 () "Send a single space to every live connection as a whitespace ping." (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 here emacs-jabber-0.13.1/lisp/jabber-keymap.el000066400000000000000000000047521523531702000201170ustar00rootroot00000000000000;;; jabber-keymap.el --- Shared Jabber keymaps -*- 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. ;;; Commentary: ;; Shared keymaps are assembled from command symbols without loading their ;; owning feature modules. The main Jabber entry point establishes the full ;; feature load order. ;;; Code: (require 'keymap-popup) (defconst jabber-keymap--common-bindings '(("C-c C-i" "Info/Discovery" jabber-info-menu) ("C-c C-m" "MUC" jabber-muc-menu) ("C-c C-s" "Services" jabber-service-menu)) "Bindings shared by Jabber `special-mode' maps.") (defconst jabber-keymap--global-bindings '(("C-c" "Connect" jabber-connect-all) ("C-d" "Disconnect" jabber-disconnect) ("C-r" "Roster" jabber-roster-popup) ("C-j" "Chat with" jabber-chat-with) ("C-l" "Next unread" jabber-activity-switch-to) ("C-a" "Away" jabber-send-away-presence) ("C-o" "Online" jabber-send-default-presence) ("C-x" "Extended away" jabber-send-xa-presence) ("C-p" "Set presence" jabber-send-presence) ("C-b" "Switch buffer" jabber-chat-buffer-switch) ("C-m" "Join MUC" jabber-muc-join)) "Bindings exposed through `jabber-global-keymap'.") (defun jabber-keymap--add-bindings (keymap bindings) "Install BINDINGS and their popup descriptions in KEYMAP." (dolist (binding bindings) (pcase-let ((`(,key ,description ,command) binding)) (keymap-popup-add-entry keymap key description command)))) (keymap-popup-define jabber-common-keymap "Common Jabber commands." :parent special-mode-map "TAB" ("Next button" forward-button) "" ("Previous button" backward-button)) (jabber-keymap--add-bindings jabber-common-keymap jabber-keymap--common-bindings) (keymap-popup-define jabber-global-keymap "Global Jabber commands." "C-g" ("Quit" keyboard-quit)) ;; keymap-popup 0.3 cannot add entries before a map has popup metadata. (jabber-keymap--add-bindings jabber-global-keymap jabber-keymap--global-bindings) (keymap-popup-remove-entry jabber-global-keymap "C-g") (define-key ctl-x-map "\C-j" jabber-global-keymap) (provide 'jabber-keymap) ;;; jabber-keymap.el ends here emacs-jabber-0.13.1/lisp/jabber-lifecycle.el000066400000000000000000000044261523531702000205660ustar00rootroot00000000000000;;; jabber-lifecycle.el --- Connection lifecycle effect dispatch -*- 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: ;; Keeps the connection FSM independent from feature lifecycle effects. ;;; Code: (defvar jabber-lifecycle-session-reset-functions nil "Functions called with a connection when its logical session is lost.") (defvar jabber-lifecycle-session-bootstrap-functions nil "Functions called with a connection after a new session is established.") (defvar jabber-lifecycle-registration-functions nil "Functions called with a connection entering account registration.") (defvar jabber-lifecycle-connection-list-changed-functions nil "Functions called after the live connection list changes.") (defun jabber-lifecycle-dispatch-session-reset (jc) "Dispatch logical session reset effects for JC." (run-hook-with-args 'jabber-lifecycle-session-reset-functions jc)) (defun jabber-lifecycle-dispatch-session-bootstrap (jc) "Dispatch new session bootstrap effects for JC." (run-hook-with-args 'jabber-lifecycle-session-bootstrap-functions jc)) (defun jabber-lifecycle-dispatch-registration (jc) "Dispatch account registration startup for JC." (run-hook-with-args 'jabber-lifecycle-registration-functions jc)) (defun jabber-lifecycle-dispatch-connection-list-changed () "Dispatch effects of a change to the live connection list." (run-hooks 'jabber-lifecycle-connection-list-changed-functions)) (provide 'jabber-lifecycle) ;;; jabber-lifecycle.el ends here emacs-jabber-0.13.1/lisp/jabber-mam.el000066400000000000000000001122131523531702000173730ustar00rootroot00000000000000;;; 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) (require 'jabber-db) (require 'jabber-chat) (require 'jabber-disco) (require 'jabber-iq) (require 'jabber-message-correct) (require 'jabber-muc-state) (eval-when-compile (require 'cl-lib)) (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.") ;;; 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 (ACCOUNT PEER TYPE) entries.") ;;; 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. Each entry is (ACCOUNT PEER TYPE), where ACCOUNT is the local bare JID. 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--peer-syncing nil "Alist of active automatic peer catch-ups. Each entry has the shape ((JC PEER) . TOKEN).") (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--begin-peer-sync (jc peer) "Record an automatic MAM catch-up for JC and PEER. Return its unique token, or nil when one was already active." (let ((key (list jc peer))) (unless (assoc key jabber-mam--peer-syncing #'equal) (let ((token (make-symbol "jabber-mam-peer-sync-"))) (push (cons key token) jabber-mam--peer-syncing) token)))) (defun jabber-mam--peer-sync-active-p (jc peer token) "Return non-nil when TOKEN owns JC and PEER's catch-up." (eq token (cdr (assoc (list jc peer) jabber-mam--peer-syncing #'equal)))) (defun jabber-mam--end-peer-sync (jc peer token) "Forget TOKEN's automatic MAM catch-up for JC and PEER." (when-let* ((entry (assoc (list jc peer) jabber-mam--peer-syncing #'equal)) ((eq token (cdr entry)))) (setq jabber-mam--peer-syncing (delq entry jabber-mam--peer-syncing)) t)) (defun jabber-mam--finish-peer-sync (jc peer token) "Finish TOKEN's peer catch-up for JC and PEER." (when (jabber-mam--end-peer-sync jc peer token) (run-hook-with-args 'jabber-mam-peer-syncing-functions peer "chat" nil))) (defun jabber-mam--complete-query (queryid) "Remove and run the completion callback for QUERYID." (when-let* ((cb (assoc queryid 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: completion callback error: %s" (error-message-string err)))) t)) (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 the stanza XML-DATA. Return (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 XML-DATA. Return 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 &optional archive-id) "Replace OUTER stanza's attributes and children with INNER's. Marks the stanza as MAM-origin so downstream handlers can suppress outgoing receipts. ARCHIVE-ID is preserved for bodyless archive stanzas whose downstream handlers need the MAM result id. Mutates OUTER in place." (setcar (cdr outer) (append (jabber-xml-node-attributes inner) `((jabber-mam--origin . "t") ,@(and archive-id `((jabber-mam--archive-id . ,archive-id)))))) (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--query-target (queryid) "Return the archive target for QUERYID, excluding control markers." (cdr (cl-find-if (lambda (entry) (and (string= queryid (car entry)) (not (eq (cdr entry) 'one-shot)))) jabber-mam--query-targets))) (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 the entity recorded for QUERYID: our own bare JID for user archives, or the queried room JID for room archives. A nil FROM is accepted only for own-archive queries because some servers omit the attribute when the message originates from the user's own archive. QUERYID identifies the active query for target lookup." (let ((target (jabber-mam--query-target queryid))) (if (null from) (null target) (let ((bare (jabber-jid-user from)) (our-jid (jabber-connection-bare-jid jc))) (if target (string= bare target) (string= bare our-jid)))))) (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 non-nil." (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 ts (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--store-new-message-p (jc inner-msg) "Return non-nil when INNER-MSG should be stored as a new message for JC." (not (run-hook-with-args-until-success 'jabber-history-inhibit-received-message-functions jc inner-msg))) (defun jabber-mam--message-action (jc inner-msg fields) "Return how MAM should handle INNER-MSG with FIELDS for JC." (cond ((or (not (plist-get fields :peer)) (not (plist-get fields :body))) :unwrap) ((jabber-message-correct--replace-id inner-msg) :correct) ((jabber-mam--store-new-message-p jc inner-msg) :store) (t :unwrap))) (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 (let ((inhibit-message t) (message-log-max nil)) (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)) (timestamp (and-let* ((time (plist-get fields :timestamp))) (floor (float-time time)))) (action (jabber-mam--message-action jc inner-msg fields))) (pcase action ((or :correct :store) (pcase action (:correct (unless (jabber--decrypt-failure-body-p body) (jabber-message-correct--apply (jabber-message-correct--replace-id inner-msg) body (plist-get fields :from) (string= (plist-get fields :type) "groupchat") nil (jabber-db--extract-occupant-id inner-msg) (plist-get fields :our-jid) peer nil))) (:store (let ((jabber-db-message-thread-stored-functions nil)) (jabber-db-store-message (plist-get fields :our-jid) peer (plist-get fields :direction) (plist-get fields :type) body timestamp (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-db--extract-reply-fields inner-msg) (jabber-db--extract-thread-fields inner-msg))))) (jabber-mam--track-sync-ids qid archive-id (plist-get fields :stanza-id) timestamp) (jabber-mam--mark-dirty jc peer (plist-get fields :type)) (setcdr (cdr xml-data) nil)) (:unwrap (jabber-mam--unwrap-into xml-data inner-msg archive-id)))))) (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)))) (defun jabber-mam--mark-dirty (jc peer type) "Record that PEER's buffer needs redisplay after sync. JC identifies the local account. TYPE is the message type." (let ((entry (list (jabber-connection-bare-jid jc) peer type))) (cl-pushnew entry jabber-mam--dirty-peers :test #'equal))) (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=)) (setq jabber-mam--query-targets (cl-remove queryid jabber-mam--query-targets :key #'car :test #'string=)) (jabber-mam--complete-query queryid) (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) "")))) (jabber-mam--complete-query queryid) ;; 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. (jabber-mam--complete-query queryid) (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 on JC: 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 token) "Sync missed messages for PEER via MAM. JC is the Jabber connection. PEER is the bare JID. TOKEN identifies the automatic peer sync attempt. 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 () (jabber-mam--finish-peer-sync jc peer token))) 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--handle-chat-disco (jc closure-data result) "Start a peer catch-up after disco completes. JC is the connection. CLOSURE-DATA is (PEER TOKEN). RESULT is the disco response." (pcase-let ((`(,peer ,token) closure-data)) (when (jabber-mam--peer-sync-active-p jc peer token) (if (and (listp result) (not (eq (car result) 'error)) (member jabber-mam-xmlns (cadr result))) (condition-case err (jabber-mam--chat-catch-up jc peer token) (error (jabber-mam--finish-peer-sync jc peer token) (message "MAM: peer catch-up failed to start: %s" (error-message-string err)))) (jabber-mam--finish-peer-sync jc peer token))))) (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-with'. Sets the syncing indicator immediately; clears it when the catch-up query completes (or when disco reveals MAM is not supported)." (when-let* ((token (and jabber-mam-enable (jabber-mam--begin-peer-sync jc peer)))) (run-hook-with-args 'jabber-mam-peer-syncing-functions peer "chat" t) (condition-case err (jabber-disco-get-info jc (jabber-connection-bare-jid jc) nil #'jabber-mam--handle-chat-disco (list peer token)) (error (jabber-mam--finish-peer-sync jc peer token) (signal (car err) (cdr err)))))) ;;; 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) (jabber-db-prune-empty-message-threads account peer) (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=)))) (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 jc 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)))) ;;; Disconnect cleanup (defun jabber-mam--cleanup-connection (jc) "Clean up MAM state for connection JC. Called from `jabber-lost-connection-hooks' on involuntary disconnect." (dolist (entry (copy-sequence jabber-mam--peer-syncing)) (when (eq (caar entry) jc) (jabber-mam--finish-peer-sync jc (cadar entry) (cdr entry)))) (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))) (jabber-mam--complete-query qid) (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 (copy-sequence jabber-mam--completion-callbacks)) (jabber-mam--complete-query (car cb))) (dolist (entry (copy-sequence jabber-mam--peer-syncing)) (jabber-mam--finish-peer-sync (caar entry) (cadar entry) (cdr entry))) (setq jabber-mam--syncing nil jabber-mam--tx-depth 0 jabber-mam--completion-callbacks nil jabber-mam--peer-syncing 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)) (jabber-mam--complete-query qid) (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) (jabber-chain-add 'jabber-message-chain #'jabber-mam--process-message -10) (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-0.13.1/lisp/jabber-message-correct.el000066400000000000000000000424711523531702000217140ustar00rootroot00000000000000;;; 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-util) (require 'jabber-chatbuffer) (require 'jabber-chat) (require 'jabber-muc) (require 'jabber-db) (require 'jabber-disco) (require 'jabber-message-reply) (defconst jabber-message-correct-xmlns "urn:xmpp:message-correct:0" "XML namespace for XEP-0308 Last Message Correction.") (defvar jabber-message-correct--muc-presence-sessions (make-hash-table :test #'equal) "Active legacy MUC participant lifetimes keyed by connection and sender.") (defvar jabber-message-correct--muc-last-message-ids (make-hash-table :test #'equal) "Latest accepted legacy MUC message IDs by connection and sender.") (defvar-local jabber-message-correct--pending-outgoing nil "Token for an OMEMO correction awaiting transport handoff.") ;;; 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)) (replace-id (jabber-xml-get-attribute el 'id)) ((not (string= replace-id (or (jabber-xml-get-attribute xml-data 'id) ""))))) replace-id)) ;;; Sender validation (defun jabber-message-correct--valid-sender-p (original-from new-from muc-p &optional original-occupant-id new-occupant-id) "Return non-nil if NEW-FROM may correct a message from ORIGINAL-FROM. MUC-P non-nil means full-JID comparison unless ORIGINAL-OCCUPANT-ID and NEW-OCCUPANT-ID are both available." (if muc-p (if (and original-occupant-id new-occupant-id) (string= original-occupant-id new-occupant-id) (string= original-from new-from)) (string= (jabber-jid-user original-from) (jabber-jid-user new-from)))) (defun jabber-message-correct--muc-key (jc from) "Return the legacy MUC continuity key for JC and full JID FROM." (list jc from)) (defun jabber-message-correct--muc-presence-enter (jc from) "Start a participant lifetime for FROM observed on JC." (let ((key (jabber-message-correct--muc-key jc from))) (unless (gethash key jabber-message-correct--muc-presence-sessions) (remhash key jabber-message-correct--muc-last-message-ids) (puthash key t jabber-message-correct--muc-presence-sessions)))) (defun jabber-message-correct--muc-presence-leave (jc from) "End the participant lifetime for FROM observed on JC." (let ((key (jabber-message-correct--muc-key jc from))) (remhash key jabber-message-correct--muc-presence-sessions) (remhash key jabber-message-correct--muc-last-message-ids))) (defun jabber-message-correct--record-muc-original (jc from stanza-id) "Record accepted STANZA-ID from legacy MUC sender FROM on JC." (let ((key (jabber-message-correct--muc-key jc from))) (when (gethash key jabber-message-correct--muc-presence-sessions) (puthash key stanza-id jabber-message-correct--muc-last-message-ids)))) (defun jabber-message-correct--muc-current-target-p (jc from stanza-id) "Return non-nil when STANZA-ID is FROM's latest live message on JC." (let ((key (jabber-message-correct--muc-key jc from))) (and (gethash key jabber-message-correct--muc-presence-sessions) (equal stanza-id (gethash key jabber-message-correct--muc-last-message-ids))))) (defun jabber-message-correct--muc-session-reset (jc) "Forget legacy MUC correction continuity belonging to JC." (dolist (table (list jabber-message-correct--muc-presence-sessions jabber-message-correct--muc-last-message-ids)) (maphash (lambda (key _value) (when (eq (car key) jc) (remhash key table))) table))) (defun jabber-message-correct--muc-room-leave (jc group) "Forget legacy MUC correction continuity for GROUP on JC." (dolist (table (list jabber-message-correct--muc-presence-sessions jabber-message-correct--muc-last-message-ids)) (maphash (lambda (key _value) (when (and (eq (car key) jc) (equal group (jabber-jid-user (cadr key)))) (remhash key table))) table))) (add-hook 'jabber-lifecycle-session-reset-functions #'jabber-message-correct--muc-session-reset) ;;; Apply correction (defun jabber-message-correct--matching-candidates (candidates new-from muc-p new-occupant-id legacy-authorized-p) "Return CANDIDATES that NEW-FROM may correct. MUC-P, NEW-OCCUPANT-ID, and LEGACY-AUTHORIZED-P describe the incoming correction." (seq-filter (lambda (candidate) (let ((original-from (plist-get candidate :from)) (original-occupant-id (plist-get candidate :occupant-id))) (and (jabber-message-correct--valid-sender-p original-from new-from muc-p original-occupant-id new-occupant-id) (or (not muc-p) (and original-occupant-id new-occupant-id) (and (null original-occupant-id) (null new-occupant-id) legacy-authorized-p))))) candidates)) (defun jabber-message-correct--update-buffer (buffer muc-p replace-id original-from new-body) "Apply NEW-BODY to the matching message in BUFFER. MUC-P selects lookup by REPLACE-ID and ORIGINAL-FROM." (when buffer (with-current-buffer buffer (when-let* ((node (if muc-p (jabber-chat-ewoc-find-by-id-and-sender replace-id original-from) (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))))) (defun jabber-message-correct--apply (replace-id new-body new-from muc-p buffers &optional new-occupant-id account peer legacy-authorized-p) "Apply correction REPLACE-ID with NEW-BODY sent by NEW-FROM. MUC-P non-nil for groupchat. BUFFERS is a chat buffer, a list of buffers, nil, or a function resolving buffers from the accepted original message plist. NEW-OCCUPANT-ID is the correction stanza's XEP-0421 occupant-id. ACCOUNT and PEER scope persistence. LEGACY-AUTHORIZED-P permits the current-presence MUC fallback when occupant-id is unavailable. 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* ((scoped-p (and account peer)) (candidates (and scoped-p (jabber-db-message-correction-candidates account peer replace-id))) (matches (and scoped-p (jabber-message-correct--matching-candidates candidates new-from muc-p new-occupant-id legacy-authorized-p))) (original (and (= (length matches) 1) (car matches))) (original-from (if scoped-p (plist-get original :from) (jabber-db-message-sender-by-stanza-id replace-id))) (original-occupant-id (if scoped-p (plist-get original :occupant-id) (and muc-p (jabber-db-occupant-id-by-stanza-id replace-id))))) (cond ;; A correction that failed to decrypt must never overwrite the ;; original body with the placeholder (issue #134). ((jabber--decrypt-failure-body-p new-body) (message "XEP-0308: dropped correction %s with undecryptable body" replace-id) nil) ((and scoped-p (/= (length matches) 1)) (message "XEP-0308: correction target %s is missing or ambiguous" replace-id) nil) ((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 original-occupant-id new-occupant-id)) (message "XEP-0308: rejected correction from %s for message by %s" new-from original-from) nil) (t (if scoped-p (jabber-db-correct-message-row (plist-get original :row-id) new-body) (jabber-db-correct-message replace-id new-body)) (let ((targets (if (functionp buffers) (funcall buffers original) buffers))) (dolist (buffer (if (listp targets) targets (list targets))) (jabber-message-correct--update-buffer buffer muc-p replace-id original-from new-body))) 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 MSG) 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) "") msg)))) (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)))) (defun jabber-message-correct--outgoing-candidates (account peer id stored-from) "Return stored correction candidates matching STORED-FROM. ACCOUNT, PEER, and ID scope the database lookup." (seq-filter (lambda (candidate) (equal stored-from (plist-get candidate :from))) (jabber-db-message-correction-candidates account peer id))) (defun jabber-message-correct--update-outgoing-buffer (buffer group id from new-body fallback-length) "Update outgoing message ID in BUFFER with NEW-BODY. GROUP and FROM select the MUC lookup. FALLBACK-LENGTH updates the stored fallback range." (when (buffer-live-p buffer) (with-current-buffer buffer (when-let* ((node (if group (jabber-chat-ewoc-find-by-id-and-sender id from) (jabber-chat-ewoc-find-by-id id)))) (plist-put (cadr (ewoc-data node)) :fallback-range (and fallback-length (list 0 fallback-length))) (jabber-message-correct--update-ewoc jabber-chat-ewoc node new-body)) (setq jabber-message-correct--pending-outgoing nil)))) (defun jabber-message-correct--send (jc group body extra &optional success failure) "Send correction BODY and EXTRA on JC. Use the MUC transport when GROUP is non-nil. SUCCESS and FAILURE are optional transport callbacks." (if group (if success (jabber-muc-send jc body extra success failure) (jabber-muc-send jc body extra)) (if success (jabber-chat-send jc body extra success failure) (jabber-chat-send jc body extra)))) ;;; Interactive command (defun jabber-correct-last-message () "Correct the last sent message in this chat buffer. Prompts with the existing body pre-filled. When the corrected message is a reply, re-attach its element: per XEP-0308 the correction replaces the whole message, XEP-0461 linkage included." (interactive) (when jabber-message-correct--pending-outgoing (user-error "A correction is still waiting to be sent")) (pcase (jabber-message-correct--find-last-sent jabber-chat-ewoc) ('nil (user-error "No sent message found to correct")) (`(,_node ,id ,body ,msg) (let ((new-body (read-string "Correction: " body))) (when (string= new-body body) (user-error "No change")) (let* ((fb-len (jabber-message-reply--correction-fallback-length msg new-body)) (reply-els (and-let* ((reply-id (plist-get msg :reply-to-id))) (jabber-message-reply--elements reply-id (plist-get msg :reply-to-jid) fb-len))) (thread (jabber-message-reply--thread-fields msg)) (thread-els (jabber-message-thread-protocol-elements (plist-get thread :thread-id) (plist-get thread :thread-parent-id)))) (let* ((buffer (current-buffer)) (group (bound-and-true-p jabber-group)) (account (jabber-connection-bare-jid jabber-buffer-connection)) (peer (jabber-jid-user (or group jabber-chatting-with))) (stored-from (if group (plist-get msg :from) account)) (db-matches (jabber-message-correct--outgoing-candidates account peer id stored-from)) (row-id (and (= (length db-matches) 1) (plist-get (car db-matches) :row-id))) (extra (append (list (jabber-message-correct--replace-element id)) reply-els thread-els)) (omemo-p (eq jabber-chat-encryption 'omemo)) (token (list t id)) (commit (lambda () (when (and (car token) (or (not omemo-p) (and (buffer-live-p buffer) (with-current-buffer buffer (eq token jabber-message-correct--pending-outgoing))))) (setcar token nil) (when row-id (jabber-db-correct-message-row row-id new-body)) (jabber-message-correct--update-outgoing-buffer buffer group id (plist-get msg :from) new-body fb-len)))) (failure (lambda (_reason) (when (car token) (setcar token nil) (when (buffer-live-p buffer) (with-current-buffer buffer (when (eq token jabber-message-correct--pending-outgoing) (setq jabber-message-correct--pending-outgoing nil)))))))) (when (and jabber-db-path (/= (length db-matches) 1)) (user-error "Stored correction target is missing or ambiguous")) (if omemo-p (progn (setq jabber-message-correct--pending-outgoing token) (condition-case err (jabber-message-correct--send jabber-buffer-connection group new-body extra commit failure) (error (funcall failure (error-message-string err)) (signal (car err) (cdr err))))) (funcall commit) (jabber-message-correct--send jabber-buffer-connection group new-body extra)))))))) (provide 'jabber-message-correct) ;;; jabber-message-correct.el ends here emacs-jabber-0.13.1/lisp/jabber-message-reply.el000066400000000000000000000267231523531702000214100ustar00rootroot00000000000000;;; 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-util) (require 'jabber-disco) (require 'jabber-message-thread-protocol) (require 'jabber-muc-protocol) (require 'jabber-xml) (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 (defvar jabber-chatting-with) ; jabber-chatbuffer.el (defvar jabber-buffer-connection) ; jabber-chatbuffer.el (defvar jabber-chat--send-hook-stanza) ; jabber-chat.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-text nil "Fallback quote string inserted into the composition area.") (defvar-local jabber-message-reply--thread nil "Thread metadata for the message being replied to.") ;;; 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--strip-fallback (body range) "Return BODY with the reply fallback RANGE removed. RANGE is nil, `all', or a (START END) list of code point offsets as stored in :fallback-range. Invalid ranges leave BODY unchanged. Quoting a reply must not re-quote its own quote." (pcase range ('nil body) ('all "") (`(,start ,end) (if (and (integerp start) (integerp end) (<= 0 start end (length body))) (concat (substring body 0 start) (substring body end)) body)) (_ body))) (defun jabber-message-reply--elements (reply-id reply-jid fb-len) "Return (and ) elements for an outgoing message. REPLY-ID is the referenced message id. REPLY-JID is the author JID; nil or empty omits the `to' attribute (a SHOULD, not a MUST, and strict parsers reject to=\"\" and drop the whole reply element). FB-LEN, when non-nil, is the code point length of the leading fallback quote in the outgoing body." (let ((elements (list `(reply ((xmlns . ,jabber-message-reply-xmlns) ,@(and reply-jid (not (string-empty-p reply-jid)) (list (cons 'to reply-jid))) (id . ,reply-id)))))) (when fb-len (push `(fallback ((xmlns . ,jabber-message-reply-fallback-xmlns) (for . ,jabber-message-reply-xmlns)) (body ((start . "0") (end . ,(number-to-string fb-len))))) elements)) elements)) (defun jabber-message-reply--fallback-string (msg) "Return MSG's own leading fallback quote text, or nil. Only ranges starting at offset 0 (as produced by `jabber-chat-reply') are useful for re-attaching on a correction." (let ((body (plist-get msg :body))) (and (stringp body) (pcase (plist-get msg :fallback-range) ('all body) (`(0 ,end) (and (integerp end) (<= end (length body)) (substring body 0 end))))))) (defun jabber-message-reply--correction-fallback-length (msg new-body) "Return the length of MSG's quote when NEW-BODY still starts with it. Nil when the quote was edited away, so a correction must not advertise a stale range." (and-let* ((old-fb (jabber-message-reply--fallback-string msg)) ((not (string-empty-p old-fb))) ((string-prefix-p old-fb new-body))) (length old-fb))) (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), use :server-id only. In 1:1 chat, prefer the XEP-0359 origin-id over the stanza id, as XEP-0461 asks. Returns nil if unavailable." (if muc-p (plist-get msg :server-id) (or (plist-get msg :origin-id) (plist-get msg :id)))) (defun jabber-message-reply--thread-fields (msg) "Return MSG's direct or registered thread metadata, or nil." (let* ((summary (plist-get msg :thread-summary)) (thread-id (or (plist-get msg :thread-id) (plist-get summary :thread-id)))) (when thread-id (list :thread-id thread-id :thread-parent-id (or (plist-get msg :thread-parent-id) (plist-get summary :thread-parent-id)))))) ;;; Send hook (defun jabber-message-reply--thread-elements () "Return pending thread metadata unless the stanza already has it." (unless (and (bound-and-true-p jabber-chat--send-hook-stanza) (jabber-message-thread-protocol-has-core-p jabber-chat--send-hook-stanza)) (jabber-message-thread-protocol-elements (plist-get jabber-message-reply--thread :thread-id) (plist-get jabber-message-reply--thread :thread-parent-id)))) (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. The range is emitted only when BODY still starts with the inserted quote: after an edit the advertised range would cover the user's own text, which receivers strip from display. Stays inert during corrections: the pending reply belongs to the message being composed, not to a re-sent old one." (when (and jabber-message-reply--id (not (bound-and-true-p jabber-chat--sending-correction))) (let ((reply-id jabber-message-reply--id) (reply-jid jabber-message-reply--jid) (fb-text jabber-message-reply--fallback-text) (thread-elements (jabber-message-reply--thread-elements))) (setq jabber-message-reply--id nil jabber-message-reply--jid nil jabber-message-reply--fallback-text nil jabber-message-reply--thread nil) (append thread-elements (jabber-message-reply--elements reply-id reply-jid (and fb-text (not (string-empty-p fb-text)) (string-prefix-p fb-text body) (length fb-text))))))) (add-hook 'jabber-chat-send-hooks #'jabber-message-reply--send-hook) ;;; Helpers (defun jabber-message-reply--self-jid () "Return our own bare JID for a self-reply, or nil when unknown. In MUC private chats our address is the room occupant JID, not the account JID, so there is no useful value and the reply `to' attribute is omitted (it is a SHOULD, not a MUST)." (and (bound-and-true-p jabber-buffer-connection) (not (and (bound-and-true-p jabber-chatting-with) (jabber-muc-sender-p jabber-chatting-with))) (jabber-connection-bare-jid jabber-buffer-connection))) (defun jabber-message-reply--author-name (jid) "Return a short display name for JID. In MUC buffers and MUC private chats the resource is the nickname. In 1:1 chat, use the username part of the JID." (cond ((bound-and-true-p jabber-group) (or (jabber-jid-resource jid) (jabber-jid-displayname jid))) ((jabber-muc-sender-p jid) (jabber-jid-resource jid)) (t (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 the start of the input area, so it lines up with the range (offset 0) even when a draft is already present." (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 (jabber-message-reply--strip-fallback (or (plist-get msg :body) "") (plist-get msg :fallback-range))) (jid (or from (jabber-message-reply--self-jid) "")) (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-text fallback jabber-message-reply--thread (jabber-message-reply--thread-fields msg)) (goto-char jabber-point-insert) (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 the inserted quote. The quote is deleted only while still intact at the start of the input area; edited input is left alone." (interactive) (when jabber-message-reply--id (let ((fb-text jabber-message-reply--fallback-text)) (setq jabber-message-reply--id nil jabber-message-reply--jid nil jabber-message-reply--fallback-text nil jabber-message-reply--thread nil) (when (and fb-text (not (string-empty-p fb-text))) (let ((end (+ jabber-point-insert (length fb-text)))) (when (and (<= end (point-max)) (string= fb-text (buffer-substring-no-properties jabber-point-insert end))) (delete-region jabber-point-insert end))))) (message "Reply cancelled"))) ;;; Disco (jabber-disco-advertise-feature jabber-message-reply-xmlns) (provide 'jabber-message-reply) ;;; jabber-message-reply.el ends here emacs-jabber-0.13.1/lisp/jabber-message-thread-protocol.el000066400000000000000000000060231523531702000233520ustar00rootroot00000000000000;;; jabber-message-thread-protocol.el --- XEP-0201 protocol data -*- 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: ;; Pure parsing and construction of XEP-0201 thread elements. ;;; Code: (require 'seq) (require 'subr-x) (require 'jabber-xml) (defun jabber-message-thread-protocol--core-element-p (element) "Return non-nil when ELEMENT is a core XMPP thread element." (and (consp element) (eq (jabber-xml-node-name element) 'thread) (member (jabber-xml-get-xmlns element) '(nil "jabber:client")))) (defun jabber-message-thread-protocol-fields (xml-data) "Return valid XEP-0201 thread metadata from XML-DATA, or nil." (let ((threads (seq-filter #'jabber-message-thread-protocol--core-element-p (jabber-xml-node-children xml-data)))) (when (= (length threads) 1) (let* ((thread (car threads)) (content (jabber-xml-node-children thread)) (id (and content (seq-every-p #'stringp content) (apply #'concat content))) (parent (jabber-xml-get-attribute thread 'parent))) (when (and id (not (string-empty-p id)) (or (null parent) (and (not (string-empty-p parent)) (not (equal parent id))))) (list :thread-id id :thread-parent-id parent)))))) (defun jabber-message-thread-protocol-has-core-p (xml-data) "Return non-nil when XML-DATA contains a core thread element." (seq-some #'jabber-message-thread-protocol--core-element-p (jabber-xml-node-children xml-data))) (defun jabber-message-thread-protocol-elements (thread-id parent-id) "Return a thread element for THREAD-ID and optional PARENT-ID." (when (and (stringp thread-id) (not (string-empty-p thread-id)) (or (null parent-id) (and (stringp parent-id) (not (string-empty-p parent-id)) (not (equal thread-id parent-id))))) (list `(thread (,@(when parent-id (list (cons 'parent parent-id)))) ,thread-id)))) (provide 'jabber-message-thread-protocol) ;;; jabber-message-thread-protocol.el ends here emacs-jabber-0.13.1/lisp/jabber-message-thread.el000066400000000000000000001002131523531702000215070ustar00rootroot00000000000000;;; jabber-message-thread.el --- XEP-0201 Message Threads -*- 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-0201 message thread parsing, routing, and thread chat buffers. ;;; Code: (require 'subr-x) (require 'ewoc) (require 'seq) (require 'jabber-buffer-registry) (require 'jabber-chatbuffer) (require 'jabber-db) (require 'jabber-input) (require 'jabber-message-thread-protocol) (require 'jabber-util) (require 'jabber-xml) (defvar jabber-chat-earliest-backlog) (defvar jabber-chat-ewoc) (defvar jabber-chat-encryption) (defvar jabber-chat-header-line-format-override) (defvar jabber-chat-send-hooks) (defvar jabber-chat--send-hook-stanza) (defvar jabber-chatting-with) (defvar jabber-group) (defvar jabber-muc-private-p) (defvar jabber-send-function) (defvar jabber-message-thread-buffer-created-functions nil "Functions run after initializing a new thread buffer. Each function receives the thread's parent buffer.") (defcustom jabber-message-thread-use-buffers t "Non-nil means display XEP-0201 threads in dedicated buffers. When nil, hide thread controls and display threaded messages through the original parent chat buffer paths. Thread metadata remains stored." :type 'boolean :group 'jabber-chat) (defconst jabber-message-thread--preview-width 48 "Maximum display width of an automatic thread preview.") ;; Chat loads thread support; these reverse calls therefore remain lazy. (declare-function jabber-chat-pp "jabber-chat" (data)) (declare-function jabber-chat-send "jabber-chat" (jc body &optional extra-elements success-callback failure-callback)) (declare-function jabber-muc-send "jabber-muc" (jc body &optional extra-elements success-callback failure-callback)) (declare-function jabber-chat--insert-backlog-chunked "jabber-chat" (buffer entries callback &optional generation)) (declare-function jabber-chat-display-buffer-images "jabber-chat" ()) (autoload 'jabber-chat-pp "jabber-chat") (autoload 'jabber-chat-send "jabber-chat") (autoload 'jabber-muc-send "jabber-muc") (autoload 'jabber-chat--insert-backlog-chunked "jabber-chat") (autoload 'jabber-chat-display-buffer-images "jabber-chat") (defvar-local jabber-message-thread-id nil "Opaque XEP-0201 thread identifier for the current buffer.") (defvar-local jabber-message-thread-parent-id nil "Parent thread identifier for the current buffer, or nil.") (defvar-local jabber-message-thread-type nil "Message type for the current thread buffer.") (defvar-local jabber-message-thread-peer nil "Bare contact or room JID for the current thread buffer.") (defvar-local jabber-message-thread-title nil "Local display title for the current thread buffer, or nil.") (defvar-local jabber-message-thread-root-preview nil "Display preview of the current thread's root message, or nil.") (defvar-local jabber-message-thread-parent-name nil "Buffer-name prefix inherited from the parent conversation.") (defvar-local jabber-message-thread-session-id nil "Current XEP-0201 session ID for an ordinary parent chat buffer.") (defvar-local jabber-message-thread--root-reply-id nil "Root message ID to link from the first locally sent reply.") (defvar-local jabber-message-thread--root-reply-jid nil "Root author JID for the first locally sent reply.") (defun jabber-message-thread--fields (xml-data) "Return XEP-0201 thread fields parsed from XML-DATA. Return nil when XML-DATA has no valid, unambiguous thread element." (jabber-message-thread-protocol-fields xml-data)) (defun jabber-message-thread--elements (thread-id parent-id) "Return a thread element for THREAD-ID and optional PARENT-ID. Return nil when THREAD-ID is empty or equals PARENT-ID." (jabber-message-thread-protocol-elements thread-id parent-id)) (defun jabber-message-thread--generate-id () "Return a new opaque message thread identifier." (secure-hash 'sha256 (format "%S:%S:%S:%S" (current-time) (random most-positive-fixnum) (random most-positive-fixnum) (make-temp-name "")))) (defun jabber-message-thread-available-p () "Return non-nil when dedicated threads are available here." (and jabber-message-thread-use-buffers (not (bound-and-true-p jabber-muc-private-p)))) (defun jabber-message-thread--ensure-buffers () "Signal a user error when dedicated threads are unavailable." (cond ((not jabber-message-thread-use-buffers) (user-error "Message thread buffers are disabled")) ((bound-and-true-p jabber-muc-private-p) (user-error "Dedicated threads are not supported in MUC private chats")))) (defun jabber-message-thread--renew-id () "Replace the current thread ID while preserving its lineage." (when-let* ((old-id jabber-message-thread-id) (account (jabber-connection-bare-jid jabber-buffer-connection)) (new-id (jabber-message-thread--generate-id))) (jabber-db-register-message-thread account jabber-message-thread-peer jabber-message-thread-type new-id old-id nil nil (floor (float-time))) (when jabber-message-thread-title (jabber-db-set-message-thread-title account jabber-message-thread-peer jabber-message-thread-type new-id jabber-message-thread-title)) (jabber-buffer-registry--remove-current) (setq jabber-message-thread-id new-id jabber-message-thread-parent-id old-id jabber-message-thread--root-reply-id nil jabber-message-thread--root-reply-jid nil) (jabber-buffer-registry-register 'thread (jabber-message-thread--key account jabber-message-thread-peer jabber-message-thread-type new-id)) new-id)) (defun jabber-message-thread--send-hook (_body _id) "Return thread metadata and the pending root reply link." (jabber-message-thread--ensure-buffers) (let ((elements (unless (and (bound-and-true-p jabber-chat--send-hook-stanza) (jabber-message-thread-protocol-has-core-p jabber-chat--send-hook-stanza)) (jabber-message-thread--elements jabber-message-thread-id jabber-message-thread-parent-id)))) (unless (bound-and-true-p jabber-chat--sending-correction) (when jabber-message-thread--root-reply-id (setq elements (append elements (list `(reply ((xmlns . "urn:xmpp:reply:0") ,@(and jabber-message-thread--root-reply-jid (list (cons 'to jabber-message-thread--root-reply-jid))) (id . ,jabber-message-thread--root-reply-id)))))) (setq jabber-message-thread--root-reply-id nil jabber-message-thread--root-reply-jid nil))) elements)) (defun jabber-message-thread--key (account peer type thread-id) "Return the registry key for ACCOUNT, PEER, TYPE, and THREAD-ID." (list account peer type thread-id)) (defun jabber-message-thread-find-buffer (account peer type thread-id) "Return THREAD-ID's live buffer for ACCOUNT, PEER, and TYPE, or nil." (jabber-buffer-registry-find 'thread (jabber-message-thread--key account peer type thread-id))) (defun jabber-message-thread-chat-state-target (jc peer type thread-id parent-buffer) "Return THREAD-ID's chat-state target on JC for PEER and TYPE. PARENT-BUFFER is the ordinary conversation view. The result is `parent', a dedicated thread buffer, or nil." (let ((thread-buffer (jabber-message-thread-find-buffer (jabber-connection-bare-jid jc) peer type thread-id))) (cond ((buffer-live-p thread-buffer) thread-buffer) ((and (buffer-live-p parent-buffer) (equal thread-id (buffer-local-value 'jabber-message-thread-session-id parent-buffer))) 'parent)))) (defun jabber-message-thread--root-preview (root-msg) "Return ROOT-MSG's normalized display preview, or nil." (when root-msg (if (plist-get root-msg :retracted) "[Message retracted]" (let ((body (string-trim (replace-regexp-in-string "[[:space:][:cntrl:]]+" " " (substring-no-properties (or (plist-get root-msg :body) "")))))) (truncate-string-to-width (if (string-empty-p body) "(no text)" body) jabber-message-thread--preview-width nil nil "…"))))) (defun jabber-message-thread--buffer-name (parent-name label) "Return a thread buffer name from PARENT-NAME and display LABEL." (format "%s [%s]*" parent-name (or label "Thread"))) (defun jabber-message-thread--rename-buffer () "Rename the current thread buffer for its current display title." (when jabber-message-thread-parent-name (rename-buffer (jabber-message-thread--buffer-name jabber-message-thread-parent-name (or jabber-message-thread-title jabber-message-thread-root-preview)) t))) (defun jabber-message-thread--header () "Return the header text for the current thread buffer." (let ((label (or jabber-message-thread-title jabber-message-thread-root-preview))) (format " %sThread in %s" (if label (concat (string-replace "%" "%%" label) " · ") "") (jabber-jid-displayname jabber-message-thread-peer)))) (defun jabber-message-thread--setup-kind (peer type) "Set conversation variables and send function for PEER and TYPE." (if (equal type "groupchat") (progn (setq-local jabber-group peer) (setq-local jabber-send-function #'jabber-muc-send)) (setq-local jabber-chatting-with peer) (setq-local jabber-send-function #'jabber-chat-send))) (defun jabber-message-thread--load-backlog (account peer type thread-id) "Load THREAD-ID backlog for ACCOUNT, PEER, and TYPE." (let ((entries (jabber-db-thread-backlog account peer type thread-id))) (if entries (progn (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)) (setq jabber-chat-earliest-backlog (float-time))))) (defun jabber-message-thread-create-buffer (jc peer type thread-id parent-id parent-buffer &optional root-msg display-msg) "Create or return THREAD-ID's buffer on JC for PEER and TYPE. PARENT-ID records lineage, PARENT-BUFFER names the sibling view, and ROOT-MSG supplies the first outgoing reply's XEP-0461 link. DISPLAY-MSG supplies the preview when it differs from ROOT-MSG." (jabber-message-thread--ensure-buffers) (let* ((account (jabber-connection-bare-jid jc)) (existing (jabber-message-thread-find-buffer account peer type thread-id))) (or existing (let* ((parent-name (string-remove-suffix "*" (buffer-name parent-buffer))) (summary (jabber-db-message-thread-summary account peer type thread-id)) (title (plist-get summary :title)) (root-preview (jabber-message-thread--root-preview (or display-msg root-msg)))) (with-current-buffer (get-buffer-create (generate-new-buffer-name (jabber-message-thread--buffer-name parent-name (or title root-preview)))) (jabber-chat-mode) (setq-local jabber-message-thread-id thread-id) (setq-local jabber-message-thread-parent-id parent-id) (setq-local jabber-message-thread-type type) (setq-local jabber-message-thread-peer peer) (setq-local jabber-message-thread-title title) (setq-local jabber-message-thread-root-preview root-preview) (setq-local jabber-message-thread-parent-name parent-name) (jabber-message-thread--setup-kind peer type) (jabber-chat-mode-setup jc #'jabber-chat-pp) (setq-local jabber-send-function (if (equal type "groupchat") #'jabber-muc-send #'jabber-chat-send)) (setq-local jabber-chat-header-line-format-override '((:eval (jabber-message-thread--header)) (:eval jabber-chat-receipt-message))) (setq-local header-line-format jabber-chat-header-line-format-override) (add-hook 'jabber-chat-send-hooks #'jabber-message-thread--send-hook nil t) (setq-local jabber-message-thread--root-reply-id (and root-msg (if (equal type "groupchat") (plist-get root-msg :server-id) (or (plist-get root-msg :origin-id) (plist-get root-msg :id)))) jabber-message-thread--root-reply-jid (and root-msg (plist-get root-msg :from))) (jabber-buffer-registry-register 'thread (jabber-message-thread--key account peer type thread-id)) (jabber-message-thread--load-backlog account peer type thread-id) (run-hook-with-args 'jabber-message-thread-buffer-created-functions parent-buffer) (current-buffer)))))) (defun jabber-message-thread--mark-root-retracted (server-id) "Replace the cached root preview when SERVER-ID identifies the root." (when-let* ((thread-id (bound-and-true-p jabber-message-thread-id)) (connection (bound-and-true-p jabber-buffer-connection)) (account (jabber-connection-bare-jid connection)) (summary (jabber-db-message-thread-summary account jabber-message-thread-peer jabber-message-thread-type thread-id)) ((equal server-id (plist-get summary :root-server-id)))) (setq jabber-message-thread-root-preview "[Message retracted]") (jabber-message-thread--rename-buffer) (force-mode-line-update t))) (defun jabber-message-thread-display-target (jc peer type msg) "Return MSG's target on JC for PEER and TYPE. The result is `parent', a thread buffer, or nil." (let ((thread-id (plist-get msg :thread-id))) (when thread-id (if (not jabber-message-thread-use-buffers) 'parent (let ((account (jabber-connection-bare-jid jc))) (if (or (not (jabber-db-message-thread-known-p account peer type thread-id)) (jabber-db-message-thread-root-p account peer type thread-id (plist-get msg :id) (plist-get msg :server-id) (plist-get msg :db-id))) 'parent (jabber-message-thread-find-buffer account peer type thread-id))))))) (defun jabber-message-thread--update-targets (account peer type location) "Return live buffers for LOCATION in ACCOUNT, PEER, and TYPE. Return `closed' when the threaded message has no live view." (when location (if jabber-message-thread-use-buffers (let* ((thread-id (plist-get location :thread-id)) (thread-buffer (jabber-message-thread-find-buffer account peer type thread-id))) (if (plist-get location :root) (or (delete-dups (delq nil (list (jabber-message-thread--parent-buffer account peer type) thread-buffer))) 'closed) (or (and thread-buffer (list thread-buffer)) 'closed)))))) (defun jabber-message-thread-update-targets (jc peer type message-id &optional server-id-p) "Return live buffers containing MESSAGE-ID on JC. PEER and TYPE scope the lookup. SERVER-ID-P selects server IDs. Return `closed' when the threaded message has no live view, and nil when MESSAGE-ID has no thread association." (let ((account (jabber-connection-bare-jid jc))) (jabber-message-thread--update-targets account peer type (jabber-db-message-thread-location account peer type message-id server-id-p)))) (defun jabber-message-thread-update-targets-for-row (jc peer type row-id) "Return live buffers containing database ROW-ID on JC. PEER and TYPE scope the exact stored message lookup." (let ((account (jabber-connection-bare-jid jc))) (jabber-message-thread--update-targets account peer type (jabber-db-message-thread-location-by-row account peer type row-id)))) (defun jabber-message-thread--root-node-p (msg summary) "Return non-nil when MSG is the root described by SUMMARY." (let ((db-id (plist-get msg :db-id)) (root-id (plist-get summary :root-message-id)) (root-stanza-id (plist-get summary :root-stanza-id)) (root-server-id (plist-get summary :root-server-id)) (groupchat-p (equal (plist-get summary :thread-type) "groupchat"))) (cond (db-id (and root-id (equal db-id root-id))) (groupchat-p (and root-server-id (equal (plist-get msg :server-id) root-server-id))) (root-stanza-id (equal (plist-get msg :id) root-stanza-id))))) (defun jabber-message-thread--node-for-root (ewoc summary) "Return the EWOC node matching the root IDs in SUMMARY." (let ((node (ewoc-nth ewoc 0)) found) (while (and node (not found)) (let* ((data (ewoc-data node)) (msg (and (listp (cadr data)) (cadr data)))) (when (and msg (jabber-message-thread--root-node-p msg summary)) (setq found node))) (setq node (and (not found) (ewoc-next ewoc node)))) found)) (defun jabber-message-thread--new-row-only-root-p (summary) "Return non-nil when SUMMARY's new root needs row reconciliation." (and (plist-get summary :root-message-id) (zerop (or (plist-get summary :reply-count) 0)) (if (equal (plist-get summary :thread-type) "groupchat") (null (plist-get summary :root-server-id)) (null (plist-get summary :root-stanza-id))))) (defun jabber-message-thread--parent-buffer (account peer type) "Return the live parent buffer matching ACCOUNT, PEER, and TYPE." (seq-find (lambda (buffer) (with-current-buffer buffer (and (eq major-mode 'jabber-chat-mode) (not (bound-and-true-p jabber-message-thread-id)) (bound-and-true-p jabber-buffer-connection) (equal account (jabber-connection-bare-jid jabber-buffer-connection)) (if (equal type "groupchat") (equal peer (bound-and-true-p jabber-group)) (and (not (bound-and-true-p jabber-group)) (equal peer (and (bound-and-true-p jabber-chatting-with) (jabber-jid-user jabber-chatting-with)))))))) (buffer-list))) (defun jabber-message-thread--refresh-root (account peer type thread-id) "Refresh THREAD-ID's root marker for ACCOUNT, PEER, and TYPE." (when-let* ((buffer (jabber-message-thread--parent-buffer account peer type)) (summary (jabber-db-message-thread-summary account peer type thread-id))) (with-current-buffer buffer (if-let* ((node (jabber-message-thread--node-for-root jabber-chat-ewoc summary))) (progn (plist-put (cadr (ewoc-data node)) :thread-summary summary) (ewoc-invalidate jabber-chat-ewoc node)) (when (jabber-message-thread--new-row-only-root-p summary) (jabber-chat-buffer-refresh)))))) (defun jabber-message-thread--stored (account peer type thread-id _timestamp) "Update THREAD-ID views after storage for ACCOUNT, PEER, and TYPE." (when (and jabber-message-thread-use-buffers thread-id) (when-let* ((buffer (jabber-message-thread-find-buffer account peer type thread-id)) ((get-buffer-window buffer t))) (jabber-db-mark-message-thread-read account peer type thread-id)) (jabber-message-thread--refresh-thread-root account peer type thread-id) (jabber-message-thread--refresh-root account peer type thread-id))) (add-hook 'jabber-db-message-thread-stored-functions #'jabber-message-thread--stored) (defun jabber-message-thread--message-at-point () "Return the message plist at point, or nil." (when-let* (((number-or-marker-p jabber-point-insert)) ((< (point) jabber-point-insert)) (node (and (bound-and-true-p jabber-chat-ewoc) (ewoc-locate jabber-chat-ewoc (point)))) (data (ewoc-data node)) ((listp (cadr data)))) (cadr data))) (defun jabber-message-thread--parent-context () "Return the current parent conversation as (PEER TYPE)." (cond ((bound-and-true-p jabber-group) (list (jabber-jid-user jabber-group) "groupchat")) ((bound-and-true-p jabber-chatting-with) (list (jabber-jid-user jabber-chatting-with) "chat")) (t (user-error "Not in a chat buffer")))) (defun jabber-message-thread--browse-context () "Return (ACCOUNT PEER TYPE PARENT-BUFFER) for the current chat." (pcase-let* ((`(,peer ,type) (jabber-message-thread--parent-context)) (account (jabber-connection-bare-jid jabber-buffer-connection)) (parent (if jabber-message-thread-id (or (jabber-message-thread--parent-buffer account peer type) (user-error "Parent chat buffer is not open")) (current-buffer)))) (list account peer type parent))) (defun jabber-message-thread--completion-label (thread) "Return THREAD's compact completion label." (let* ((title (plist-get thread :title)) (root (plist-get thread :root-message)) (from (plist-get root :from)) (body (string-trim (replace-regexp-in-string "[[:space:]]+" " " (or (plist-get root :body) "")))) (preview (if (plist-get root :retracted) "[Message retracted]" (truncate-string-to-width (if (string-empty-p body) "(no text)" body) 72 nil nil "…"))) (nick (and (equal (plist-get thread :thread-type) "groupchat") (stringp from) (jabber-jid-resource from)))) (cond ((and (stringp title) (not (string-empty-p title))) (truncate-string-to-width title 72 nil nil "…")) (nick (format "%s: %s" nick preview)) (t preview)))) (defun jabber-message-thread--unique-label (label used) "Return a unique completion LABEL and record it in USED." (let ((candidate label) (number 1)) (while (gethash candidate used) (setq number (1+ number) candidate (format "%s (%d)" label number))) (puthash candidate t used) candidate)) (defun jabber-message-thread--completion-items (threads) "Return unique completion items for ordered THREADS." (let ((used (make-hash-table :test #'equal))) (mapcar (lambda (thread) (cons (jabber-message-thread--unique-label (jabber-message-thread--completion-label thread) used) thread)) threads))) (defun jabber-message-thread--completion-annotation (thread) "Return a completion annotation for THREAD." (let* ((count (or (plist-get thread :reply-count) 0)) (latest (plist-get thread :latest-at)) (parts (list (format "%d %s" count (if (= count 1) "reply" "replies")) (and latest (format "active %s" (format-time-string "%Y-%m-%d %H:%M" latest))) (and (plist-get thread :unread) "unread")))) (concat " " (string-join (delq nil parts) " · ")))) (defun jabber-message-thread--read-thread (threads) "Read and return one entry from ordered THREADS." (unless threads (user-error "No threads in this chat")) (let* ((items (jabber-message-thread--completion-items threads)) (table (lambda (string pred action) (if (eq action 'metadata) '(metadata (display-sort-function . identity) (cycle-sort-function . identity)) (complete-with-action action items string pred)))) (completion-extra-properties (list :annotation-function (lambda (candidate) (jabber-message-thread--completion-annotation (cdr (assoc-string candidate items)))))) (choice (completing-read "Open thread: " table nil t))) (cdr (assoc-string choice items)))) (defun jabber-message-thread--open-stored (connection account peer type parent summary) "Open SUMMARY for CONNECTION, ACCOUNT, PEER, TYPE, and PARENT." (let ((buffer (jabber-message-thread-create-buffer connection peer type (plist-get summary :thread-id) (plist-get summary :thread-parent-id) parent (and (zerop (plist-get summary :local-reply-count)) (plist-get summary :root-message)) (plist-get summary :root-message)))) (jabber-db-mark-message-thread-read account peer type (plist-get summary :thread-id)) (jabber-message-thread--refresh-root account peer type (plist-get summary :thread-id)) (pop-to-buffer buffer))) ;;;###autoload (defun jabber-message-thread-browse () "Choose and open a thread from the current chat." (interactive) (jabber-message-thread--ensure-buffers) (unless (jabber-db-ensure-open) (user-error "Message threads require persistent message storage")) (pcase-let* ((`(,account ,peer ,type ,parent) (jabber-message-thread--browse-context)) (summary (jabber-message-thread--read-thread (jabber-db-message-threads account peer type)))) (jabber-message-thread--open-stored jabber-buffer-connection account peer type parent summary))) ;;;###autoload (defun jabber-message-thread-set-title (title) "Set the current thread's local TITLE, or clear it when empty." (interactive (list (read-string "Thread title (empty clears): " jabber-message-thread-title))) (unless jabber-message-thread-id (user-error "Not in a thread buffer")) (unless (jabber-db-ensure-open) (user-error "Message threads require persistent message storage")) (let ((account (jabber-connection-bare-jid jabber-buffer-connection))) (setq jabber-message-thread-title (jabber-db-set-message-thread-title account jabber-message-thread-peer jabber-message-thread-type jabber-message-thread-id title)) (jabber-message-thread--rename-buffer) (force-mode-line-update t))) (defun jabber-message-thread--refresh-thread-root (account peer type thread-id) "Reload THREAD-ID's buffer when its stored root is missing. ACCOUNT, PEER, and TYPE scope the thread." (when-let* ((buffer (jabber-message-thread-find-buffer account peer type thread-id)) (summary (jabber-db-message-thread-summary account peer type thread-id))) (with-current-buffer buffer (unless (jabber-message-thread--node-for-root jabber-chat-ewoc summary) (jabber-chat-buffer-refresh))))) ;;;###autoload (defun jabber-message-thread-start () "Send the current draft as a new thread and open its buffer." (interactive) (jabber-message-thread--ensure-buffers) (when jabber-message-thread-id (user-error "Already in a thread buffer")) (unless (and (number-or-marker-p jabber-point-insert) (< jabber-point-insert (point-max))) (user-error "No draft to send")) (unless (jabber-db-ensure-open) (user-error "Message threads require persistent message storage")) (pcase-let* ((`(,peer ,type) (jabber-message-thread--parent-context)) (thread-id (jabber-message-thread--generate-id)) (account (jabber-connection-bare-jid jabber-buffer-connection)) (created-at (floor (float-time))) (parent-buffer (current-buffer)) (root-msg (list :body (buffer-substring-no-properties jabber-point-insert (point-max))))) (jabber-chat-buffer-send (jabber-message-thread--elements thread-id nil)) (jabber-db-register-message-thread account peer type thread-id nil nil nil created-at) (pop-to-buffer (jabber-message-thread-create-buffer jabber-buffer-connection peer type thread-id nil parent-buffer nil root-msg)))) ;;;###autoload (defun jabber-message-thread-open (&optional msg) "Open the thread rooted at MSG or the message at point." (interactive) (jabber-message-thread--ensure-buffers) (when jabber-message-thread-id (user-error "Already in a thread buffer")) (unless (jabber-db-ensure-open) (user-error "Message threads require persistent message storage")) (let* ((msg (or msg (jabber-message-thread--message-at-point))) (type (if (bound-and-true-p jabber-group) "groupchat" "chat")) (peer (jabber-jid-user (or (bound-and-true-p jabber-group) (bound-and-true-p jabber-chatting-with)))) (account (jabber-connection-bare-jid jabber-buffer-connection)) (received-thread-id (and msg (plist-get msg :thread-id))) (summary (or (and msg (plist-get msg :thread-summary)) (and received-thread-id (jabber-db-message-thread-summary account peer type received-thread-id)))) (root-stanza-id (and msg (plist-get msg :id))) (root-server-id (and msg (plist-get msg :server-id))) (thread-id (or (plist-get summary :thread-id) received-thread-id (jabber-message-thread--generate-id)))) (unless msg (user-error "No message at point")) (unless (or summary (plist-get msg :db-id) (if (equal type "groupchat") root-server-id root-stanza-id)) (user-error "Message is not stored and has no stable ID")) (unless summary (jabber-db-register-message-thread account peer type thread-id (plist-get msg :thread-parent-id) root-stanza-id root-server-id (floor (float-time (plist-get msg :timestamp))) (plist-get msg :db-id)) (setq summary (jabber-db-message-thread-summary account peer type thread-id)) (jabber-message-thread--refresh-root account peer type thread-id)) (let ((buffer (jabber-message-thread-create-buffer jabber-buffer-connection peer type thread-id (plist-get summary :thread-parent-id) (current-buffer) (and (zerop (plist-get summary :local-reply-count)) msg) msg))) (jabber-db-mark-message-thread-read account peer type thread-id) (jabber-message-thread--refresh-root account peer type thread-id) (pop-to-buffer buffer)))) (provide 'jabber-message-thread) ;;; jabber-message-thread.el ends here emacs-jabber-0.13.1/lisp/jabber-modeline.el000066400000000000000000000202361523531702000204200ustar00rootroot00000000000000;;; 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-presence-display) (require 'jabber-alert) (require 'jabber-activity) (require 'jabber-lifecycle) (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-modeline-mode) ;; Activity variables (defined in jabber-activity.el) (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"))) (defun jabber-modeline--connection-list-changed () "Refresh presence display after a live connection list update." (when jabber-modeline-mode (jabber-mode-line-presence-update))) (add-hook 'jabber-lifecycle-connection-list-changed-functions #'jabber-modeline--connection-list-changed) (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-presence-sent-hooks #'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-presence-sent-hooks #'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-0.13.1/lisp/jabber-moderation.el000066400000000000000000000247401523531702000207710ustar00rootroot00000000000000;;; 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-util) (require 'jabber-xml) (require 'jabber-disco) (require 'jabber-iq) (require 'jabber-muc) (require 'jabber-db) (require 'jabber-message-thread) (require 'cl-lib) (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--child-with-name-and-xmlns (xml-data name xmlns) "Return the first child of XML-DATA with NAME and XMLNS." (cl-find-if (lambda (child) (and (listp child) (eq (jabber-xml-node-name child) name) (string= (jabber-xml-get-xmlns child) xmlns))) (jabber-xml-node-children xml-data))) (defun jabber-moderation--retraction-element (xml-data) "Return (ELEMENT . TOMBSTONE-P) for a moderated retraction in XML-DATA." (or (when-let* ((retract (jabber-moderation--child-with-name-and-xmlns xml-data 'retract jabber-moderation-retract-xmlns))) (cons retract nil)) (when-let* (((jabber-xml-get-attribute xml-data 'jabber-mam--origin)) (retracted (jabber-moderation--child-with-name-and-xmlns xml-data 'retracted jabber-moderation-retract-xmlns))) (cons retracted t)))) (defun jabber-moderation--moderator (xml-data moderated) "Return the moderator JID from MODERATED in XML-DATA, or nil." (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)))) (defun jabber-moderation--target-id (xml-data retraction tombstone-p) "Return the server id targeted by RETRACTION in XML-DATA. TOMBSTONE-P non-nil means RETRACTION is an archived element." (if tombstone-p (jabber-xml-get-attribute xml-data 'jabber-mam--archive-id) (jabber-xml-get-attribute retraction 'id))) (defun jabber-moderation--valid-source-p (from tombstone-p) "Return non-nil if FROM may send this moderation stanza. TOMBSTONE-P allows archived tombstones from the original occupant. Live moderation action stanzas must come from the bare MUC service." (or tombstone-p (not (jabber-jid-resource from)))) (defun jabber-moderation--target-buffers (jc room server-id) "Return live buffers containing SERVER-ID in ROOM on JC." (let ((thread-targets (jabber-message-thread-update-targets jc room "groupchat" server-id t))) (cond ((eq thread-targets 'closed) nil) (thread-targets thread-targets) (t (delq nil (list (jabber-muc-find-buffer room jc))))))) (defun jabber-moderation--handle-message (jc xml-data) "Handle moderated message retraction in XML-DATA. Live action stanzas update an existing message. Archived tombstones use the preserved MAM archive id as the original server id. JC is the connection the stanza arrived on." (when-let* ((type (jabber-xml-get-attribute xml-data 'type)) ((string= type "groupchat")) (entry (jabber-moderation--retraction-element xml-data)) (retraction (car entry)) (moderated (car (jabber-xml-get-children retraction 'moderated))) (stanza-id (jabber-moderation--target-id xml-data retraction (cdr entry))) (from (jabber-xml-get-attribute xml-data 'from)) ((jabber-moderation--valid-source-p from (cdr entry))) (room (jabber-jid-user from))) (let* ((moderator (jabber-moderation--moderator xml-data moderated)) (reason-el (car (jabber-xml-get-children retraction 'reason))) (reason (car (jabber-xml-node-children reason-el))) (buffers (jabber-moderation--target-buffers jc room stanza-id))) (when moderator (jabber-db-retract-message-in-peer (jabber-connection-bare-jid jc) room stanza-id moderator reason)) (dolist (buffer buffers) (with-current-buffer buffer (jabber-moderation--mark-ewoc-retracted stanza-id moderator reason))) t))) (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." (jabber-message-thread--mark-root-retracted server-id) (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--mark-local-retracted (jc _xml-data data) "Mark the moderated message in DATA as retracted locally on JC." (pcase-let ((`(,room ,server-id ,moderator ,reason) data)) (jabber-db-retract-message-in-peer (jabber-connection-bare-jid jc) room server-id moderator reason) (dolist (buffer (jabber-moderation--target-buffers jc room server-id)) (with-current-buffer buffer (jabber-moderation--mark-ewoc-retracted server-id moderator reason))))) (defun jabber-moderation--send-retract (jc room server-id &optional reason) "Send a moderation IQ to retract SERVER-ID in ROOM on JC. Marks the message as retracted locally after the MUC accepts the IQ. Optional REASON is a human-readable string." (let ((moderator (concat room "/" (jabber-muc-nickname room jc)))) (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-moderation--mark-local-retracted (list room server-id moderator reason) #'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* ((account (jabber-connection-bare-jid jabber-buffer-connection)) (occupant-id (jabber-db-occupant-id-by-server-id-in-peer account jabber-group server-id))) (unless occupant-id (user-error "No occupant-id for this message")) (let* ((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-0.13.1/lisp/jabber-muc-menu.el000066400000000000000000000033661523531702000203570ustar00rootroot00000000000000;;; jabber-muc-menu.el --- Multi-user chat command menu -*- 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, or (at your option) ;; any later version. ;;; Commentary: ;; Assemble the MUC popup after its protocol and information providers load. ;;; Code: (require 'keymap-popup) (require 'jabber-info) (require 'jabber-muc) (defvar jabber-muc-menu-map) (keymap-popup-define jabber-muc-menu-map "Jabber MUC commands." :description (lambda () (if (bound-and-true-p jabber-group) (format "MUC actions for %s" (propertize jabber-group 'face 'font-lock-constant-face)) "MUC actions")) :group "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) :group "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) :group "Admin" "r" ("Set role" jabber-muc-set-role) "a" ("Set affiliation" jabber-muc-set-affiliation)) (defun jabber-muc-menu () "Show the Jabber MUC command menu." (interactive) (keymap-popup jabber-muc-menu-map)) (provide 'jabber-muc-menu) ;;; jabber-muc-menu.el ends here emacs-jabber-0.13.1/lisp/jabber-muc-nick-completion.el000066400000000000000000000166001523531702000225010ustar00rootroot00000000000000;;; 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) (require 'jabber-muc-state) (defvar jabber-alert-muc-personal-p-function) ;;; 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) (define-obsolete-variable-alias '*jabber-muc-participant-last-speaking* 'jabber-muc-participant-last-speaking "0.11.0") (defvar jabber-muc-participant-last-speaking nil "Global alist in form (group . ((member . time-of-last-speaking) ...) ...).") ;; Global reference declarations (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." (when (stringp message) (let ((nickname (jabber-my-nick group))) (when (stringp nickname) (string-match (concat "^" (regexp-quote nickname) (regexp-opt jabber-muc-looks-personaling-symbols)) message))))) (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) "Track time of NICK's last speaking in GROUP. TEXT is the message body used to detect personal-mention bonus." (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) (length jabber-muc-completion-delimiter))) 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-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) (setq jabber-alert-muc-personal-p-function #'jabber-muc-looks-like-personal-p) (provide 'jabber-muc-nick-completion) ;;; jabber-muc-nick-completion.el ends here emacs-jabber-0.13.1/lisp/jabber-muc-protocol.el000066400000000000000000000062561523531702000212550ustar00rootroot00000000000000;;; jabber-muc-protocol.el --- Multi-user chat stanza classification -*- 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. ;;; Commentary: ;; Classify MUC stanzas without loading room buffers or interactive commands. ;;; Code: (require 'cl-lib) (require 'jabber-muc-state) (require 'jabber-util) (require 'jabber-xml) (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-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.") ;;;###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." (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)) (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-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)))) (or muc-marker (and (string= type "error") (gethash (jabber-jid-symbol from) jabber-pending-groupchats))))) (provide 'jabber-muc-protocol) ;;; jabber-muc-protocol.el ends here emacs-jabber-0.13.1/lisp/jabber-muc-state.el000066400000000000000000000053751523531702000205350ustar00rootroot00000000000000;;; jabber-muc-state.el --- Multi-user chat state -*- 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. ;;; Commentary: ;; Track joined rooms independently from MUC protocol handling and buffers. ;;; Code: (require 'cl-lib) (require 'subr-x) (defvar jabber-muc--rooms (make-hash-table :test #'equal) "Map room JIDs to lists of connection and nickname pairs.") (defvar jabber-muc--generation 0 "Generation counter incremented after every room-state change.") (defun jabber-muc-nickname (group &optional jc) "Return our nickname in GROUP, optionally restricted to JC." (let ((entries (gethash group jabber-muc--rooms))) (if jc (alist-get jc entries) (cdar entries)))) (defun jabber-muc-connection (group) "Return the first connection joined to GROUP, or nil." (caar (gethash group jabber-muc--rooms))) (defun jabber-muc-joined-p (group &optional jc) "Return non-nil when GROUP is joined, optionally through JC." (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 when NICK belongs to us in GROUP." (cl-some (lambda (entry) (string= nick (cdr entry))) (gethash group jabber-muc--rooms))) (defun jabber-muc-room-entries (group) "Return connection and nickname pairs for GROUP." (gethash group jabber-muc--rooms)) (defun jabber-muc-active-rooms () "Return the JIDs of all joined rooms." (hash-table-keys jabber-muc--rooms)) (defun jabber-muc-join-set (group jc nickname) "Record that JC joined GROUP as 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 state, or only the entry associated with JC." (if jc (let ((entries (assq-delete-all jc (gethash group jabber-muc--rooms)))) (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 the room-state generation counter." jabber-muc--generation) (provide 'jabber-muc-state) ;;; jabber-muc-state.el ends here emacs-jabber-0.13.1/lisp/jabber-muc.el000066400000000000000000003047421523531702000174170ustar00rootroot00000000000000;;; 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 'color) (require 'ewoc) (require 'seq) (require 'jabber-buffer-registry) (require 'jabber-disco) (require 'jabber-lifecycle) (require 'jabber-muc-protocol) (require 'jabber-muc-state) (require 'jabber-ping) (require 'jabber-presence-events) (require 'jabber-bookmarks) (require 'jabber-chatbuffer) (require 'jabber-chat) (require 'jabber-db) (require 'jabber-presence) (require 'jabber-reactions) (require 'jabber-version) (require 'jabber-xdata-form) (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-muc--room-jids (make-hash-table :test #'equal) "Per-room known bare JIDs from affiliation queries. Keys are group JID strings. Values are hash tables mapping bare JID strings to affiliation strings.") (defvar jabber-muc--nonanonymous-rooms (make-hash-table :test #'equal) "Set of rooms known to be non-anonymous. Keys are group JID strings, values are t.") (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-local jabber-muc--config-connection nil "Connection associated with the current room configuration form.") (defvar-local jabber-muc--config-group nil "Room JID associated with the current configuration form.") (defvar-local jabber-muc-private-p nil "Non-nil in a private chat buffer addressed to a MUC occupant.") (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 (make-hash-table :test #'equal) "Map account bare JIDs to (ROOM NICK PASSWORD) reconnect snapshots.") (defvar jabber-muc--session-passwords (make-hash-table :test #'equal) "In-memory room passwords keyed by (JC GROUP). A nil value marks a password rejected for the current session.") (defun jabber-muc--session-password (jc group) "Return in-memory or bookmarked password for GROUP on JC." (let ((password (gethash (list jc group) jabber-muc--session-passwords jabber-muc--session-passwords))) (if (eq password jabber-muc--session-passwords) (jabber-get-conference-data jc group nil :password) password))) (defun jabber-muc--remember-password (jc group password) "Remember PASSWORD for GROUP on JC when non-nil." (when password (puthash (list jc group) password jabber-muc--session-passwords))) (defun jabber-muc--forget-password (jc group) "Forget in-memory password for GROUP on JC." (remhash (list jc group) jabber-muc--session-passwords)) (defun jabber-muc--reject-password (jc group) "Mark the in-memory password for GROUP on JC as rejected." (puthash (list jc group) nil jabber-muc--session-passwords)) (defun jabber-muc--password-rejected-p (jc group) "Return non-nil when GROUP's password was rejected on JC." (null (gethash (list jc group) jabber-muc--session-passwords jabber-muc--session-passwords))) (defun jabber-muc--clear-passwords (jc) "Forget all in-memory room passwords belonging to JC." (let (keys) (maphash (lambda (key _password) (when (eq (car key) jc) (push key keys))) jabber-muc--session-passwords) (dolist (key keys) (remhash key jabber-muc--session-passwords)))) (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-nonanonymous "100") (defconst jabber-muc-status-self-presence "110") (defconst jabber-muc-status-logging-enabled "170") (defconst jabber-muc-status-logging-disabled "171") (defconst jabber-muc-status-now-nonanonymous "172") (defconst jabber-muc-status-now-semianonymous "173") (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")))) (defface jabber-muc-nick-local-face '((t :inherit jabber-chat-nick-plaintext :weight semi-bold)) "Face for the local nickname in MUC transcripts." :group 'jabber-faces) (defun jabber-muc--linear-rgb-component (component) "Return linear-light value for sRGB COMPONENT." (if (<= component 0.04045) (/ component 12.92) (expt (/ (+ component 0.055) 1.055) 2.4))) (defun jabber-muc--color-rgb (color) "Return normalized RGB components for COLOR." (let ((values (color-values-from-color-spec color))) (if values (mapcar (lambda (component) (/ component 65535.0)) values) (color-name-to-rgb color)))) (defun jabber-muc--relative-luminance (rgb) "Return relative luminance for normalized RGB." (pcase-let ((`(,red ,green ,blue) (mapcar #'jabber-muc--linear-rgb-component rgb))) (+ (* 0.2126 red) (* 0.7152 green) (* 0.0722 blue)))) (defun jabber-muc--contrast-ratio (first second) "Return the contrast ratio between normalized RGB colors FIRST and SECOND." (let ((a (jabber-muc--relative-luminance first)) (b (jabber-muc--relative-luminance second))) (/ (+ (max a b) 0.05) (+ (min a b) 0.05)))) (defconst jabber-muc--hsluv-matrix '((3.240969941904521 -1.537383177570093 -0.498610760293) (-0.96924363628087 1.87596750150772 0.041555057407175) (0.055630079696993 -0.20397695888897 1.056971514242878)) "HSLuv matrix for converting XYZ to linear sRGB.") (defun jabber-muc--hsluv-bounds (lightness) "Return the RGB gamut bounds at HSLuv LIGHTNESS." (let* ((sub1 (/ (expt (+ lightness 16) 3) 1560896.0)) (sub2 (if (> sub1 0.0088564516) sub1 (/ lightness 903.2962962)))) (cl-loop for (m1 m2 m3) in jabber-muc--hsluv-matrix append (cl-loop for channel in '(0 1) for top1 = (* (- (* 284517 m1) (* 94839 m3)) sub2) for top2 = (- (* (+ (* 838422 m3) (* 769860 m2) (* 731718 m1)) lightness sub2) (* 769860 channel lightness)) for bottom = (+ (* (- (* 632260 m3) (* 126452 m2)) sub2) (* 126452 channel)) collect (cons (/ top1 bottom) (/ top2 bottom)))))) (defun jabber-muc--hsluv-max-chroma (lightness hue) "Return maximum HSLuv chroma for LIGHTNESS and HUE." (let ((angle (* float-pi (/ hue 180.0)))) (cl-loop for (slope . intercept) in (jabber-muc--hsluv-bounds lightness) for divisor = (- (sin angle) (* slope (cos angle))) for length = (unless (zerop divisor) (/ intercept divisor)) when (and length (>= length 0)) minimize length))) (defun jabber-muc--hsluv-rgb (hue saturation lightness) "Convert HSLuv HUE, SATURATION, and LIGHTNESS to sRGB." (cond ((< lightness 0.00000001) '(0.0 0.0 0.0)) ((> lightness 99.9999999) '(1.0 1.0 1.0)) (t (let* ((angle (* float-pi (/ hue 180.0))) (chroma (* (jabber-muc--hsluv-max-chroma lightness hue) (/ saturation 100.0))) (u (* (cos angle) chroma)) (v (* (sin angle) chroma)) (y (if (<= lightness 8) (/ lightness 903.2962962) (expt (/ (+ lightness 16) 116.0) 3))) (var-u (+ (/ u (* 13 lightness)) 0.19783000664283)) (var-v (+ (/ v (* 13 lightness)) 0.46831999493879)) (x (/ (* 9 y var-u) (* 4 var-v))) (z (/ (- (* 9 y) (* 15 var-v y) (* var-v x)) (* 3 var-v)))) (mapcar #'color-clamp (color-xyz-to-srgb x y z)))))) (defun jabber-muc--nick-color (hue saturation variation background) "Return a readable nickname color for HUE, SATURATION, and VARIATION. Adapt the result to BACKGROUND." (let* ((background-rgb (jabber-muc--color-rgb background)) (lighter-p (> (jabber-muc--contrast-ratio '(1.0 1.0 1.0) background-rgb) (jabber-muc--contrast-ratio '(0.0 0.0 0.0) background-rgb))) (preferred-lightness (if lighter-p (+ 64 (* 18 variation)) (- 46 (* 18 variation)))) (lightnesses (cons preferred-lightness (if lighter-p (number-sequence (* 5 (ceiling preferred-lightness 5)) 95 5) (number-sequence (* 5 (floor preferred-lightness 5)) 5 -5)))) (colors (mapcar (lambda (lightness) (apply #'color-rgb-to-hex (append (jabber-muc--hsluv-rgb hue saturation lightness) '(2)))) lightnesses)) (color (cl-find-if (lambda (candidate) (>= (jabber-muc--contrast-ratio (jabber-muc--color-rgb candidate) background-rgb) 4.5)) colors))) (or color (if lighter-p "#ffffff" "#000000")))) (defun jabber-muc--nick-color-components (nickname) "Return base hue, display hue, saturation, and variation for NICKNAME." (let* ((hash (secure-hash 'sha1 (encode-coding-string nickname 'utf-8) nil nil t)) (value (+ (aref hash 0) (ash (aref hash 1) 8))) (hue (* 360.0 (/ value 65536.0))) (offset-value (+ (aref hash 4) (ash (aref hash 5) 8) (ash (aref hash 6) 16) (ash (aref hash 7) 24))) (offset (- (* 36 (/ offset-value 4294967296.0)) 18)) (display-hue (mod (+ hue offset) 360.0)) (saturation (+ 60 (* 40 (/ (aref hash 2) 255.0)))) (variation (/ (aref hash 3) 255.0))) (list hue display-hue saturation variation))) (defun jabber-muc--nick-hue (nickname) "Return the XEP-0392 hue angle for NICKNAME." (car (jabber-muc--nick-color-components nickname))) (defun jabber-muc--default-background () "Return the current default face background." (let ((background (face-background 'default nil t))) (if (and background (not (equal background "unspecified-bg"))) background (if (eq (frame-parameter nil 'background-mode) 'dark) "#000000" "#ffffff")))) (define-obsolete-variable-alias 'jabber-muc-nick-color-faces 'jabber-muc-colorize-nicks "0.13.0") (defcustom jabber-muc-colorize-nicks t "Non-nil means color foreign MUC nicknames consistently." :type 'boolean :group 'jabber-chat) (defun jabber-muc--refresh-nick-faces (&optional _theme) "Refresh nickname faces in live MUC buffers." (dolist (buffer (buffer-list)) (with-current-buffer buffer (when (and (eq major-mode 'jabber-chat-mode) (bound-and-true-p jabber-group) (bound-and-true-p jabber-chat-ewoc)) (let ((anchors (jabber-chat-buffer--capture-view)) (buffer-undo-list t)) (ewoc-refresh jabber-chat-ewoc) (jabber-chat-buffer--restore-view anchors)))))) (add-hook 'enable-theme-functions #'jabber-muc--refresh-nick-faces) (add-hook 'disable-theme-functions #'jabber-muc--refresh-nick-faces) (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-private-header-line-format '(" " (:eval (jabber-jid-resource jabber-chatting-with)) " in " (:eval (jabber-jid-displayname (jabber-jid-user jabber-chatting-with))) " " (: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) ;; Optional providers load at their action boundary. MAM and the correction ;; parser require MUC, so their unguarded reverse calls remain lazy. (declare-function jabber-omemo--send-muc "jabber-omemo" (jc body &optional extra-elements success-callback failure-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-openpgp--send-muc "jabber-openpgp" (jc body &optional extra-elements success-callback failure-callback)) (declare-function jabber-openpgp-legacy--send-muc "jabber-openpgp-legacy" (jc body &optional extra-elements)) (declare-function jabber-mam-muc-joined "jabber-mam" (jc group)) (declare-function jabber-mam--cancel-muc-query "jabber-mam" (group)) (autoload 'jabber-mam-muc-joined "jabber-mam") (autoload 'jabber-mam--cancel-muc-query "jabber-mam") (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 buffers &optional new-occupant-id account peer legacy-authorized-p)) (declare-function jabber-message-correct--muc-current-target-p "jabber-message-correct" (jc peer replace-id)) (declare-function jabber-message-correct--muc-presence-enter "jabber-message-correct" (jc occupant)) (declare-function jabber-message-correct--muc-presence-leave "jabber-message-correct" (jc occupant)) (declare-function jabber-message-correct--record-muc-original "jabber-message-correct" (jc peer msg-id)) (declare-function jabber-message-correct--muc-room-leave "jabber-message-correct" (jc group)) (autoload 'jabber-message-correct--replace-id "jabber-message-correct") (autoload 'jabber-message-correct--apply "jabber-message-correct") (declare-function jabber-vcard-get "jabber-vcard" (jc jid)) (declare-function jabber-chatstates--delete-typing-node "jabber-chatstates" ()) (declare-function jabber-chatstates--muc-reinsert-typing "jabber-chatstates" ()) (declare-function jabber-chatstates--muc-remove-nick "jabber-chatstates" (nickname)) (defvar jabber-silent-mode) ; jabber.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-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--buffer-key (jc group) "Return the account-scoped buffer registry key for JC and GROUP." (list (jabber-connection-bare-jid jc) group)) (defun jabber-muc-find-buffer (group &optional jc) "Find an existing MUC buffer for GROUP on JC, or nil. Without JC, return a buffer only when GROUP has one unambiguous live buffer." (if jc (jabber-buffer-registry-find 'muc (jabber-muc--buffer-key jc group)) (let (found ambiguous) (dolist (buffer (buffer-list)) (when (and (buffer-live-p buffer) (equal group (buffer-local-value 'jabber-group buffer))) (if found (setq ambiguous t) (setq found buffer)))) (unless ambiguous found)))) (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" (not jabber-message-thread-use-buffers)))) (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)))) (jabber-chat-buffer-recenter-input)) ;; Make sure the connection variable is up to date. (setq jabber-buffer-connection jc) (jabber-buffer-registry-register 'muc (jabber-muc--buffer-key jc 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-buffer-registry-find '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)) (setq-local jabber-muc-private-p t) (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)) (setq-local jabber-muc-private-p t) (jabber-buffer-registry-register '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 nil t))) (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 success-callback failure-callback) "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 success-callback failure-callback)) ('openpgp (require 'jabber-openpgp) (jabber-openpgp--send-muc jc body extra-elements success-callback failure-callback)) ('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) (when success-callback (funcall success-callback)))))) (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." (when (and jc (fboundp 'jabber-message-correct--muc-room-leave)) (jabber-message-correct--muc-room-leave jc group)) (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))) (remhash group jabber-muc--room-jids) (remhash group jabber-muc--nonanonymous-rooms))) (cl-defun jabber-muc-connection-closed (bare-jid &optional (preserve-for-reconnect-p t)) "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' when PRESERVE-FOR-RECONNECT-P is non-nil so non-bookmarked rooms can be rejoined. It defaults to non-nil for compatibility with old one-argument callers. 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 (list room (cdr match) (gethash (list (car match) room) jabber-muc--session-passwords)) snapshot) ;; Clear autojoin queue for this connection. (jabber-muc--autojoin-clear (car match)) (jabber-muc-leave-remove room (car match)) (jabber-muc--forget-password (car match) room) ;; 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))) (remhash room jabber-muc--room-jids) (remhash room jabber-muc--nonanonymous-rooms))))) (if (and preserve-for-reconnect-p snapshot) (puthash bare-jid snapshot jabber-muc--rooms-before-disconnect) (remhash bare-jid jabber-muc--rooms-before-disconnect)))) (defun jabber-muc--session-reset (jc) "Clear room state belonging to the lost logical session on JC." (let* ((state-data (fsm-get-state-data jc)) (preserve-for-reconnect-p (and jabber-auto-reconnect (not (plist-get state-data :disconnection-expected)) (plist-get state-data :ever-session-established)))) (jabber-muc-connection-closed (jabber-connection-bare-jid jc) preserve-for-reconnect-p) (jabber-muc--clear-passwords jc))) (add-hook 'jabber-lifecycle-session-reset-functions #'jabber-muc--session-reset) (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-muc--session-password jc room))) (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 with PROMPT the name of a joined chatroom (or current buffer's room). 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 with PROMPT 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: ")))) (require 'jabber-vcard) (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 the MUC configuration form for GROUP. JC is the Jabber connection." (interactive (jabber-muc-argument-list)) (jabber-send-iq jc group "get" `(query ((xmlns . ,jabber-muc-xmlns-owner))) #'jabber-muc--receive-config (list (current-buffer) group) #'jabber-muc--config-error group)) (defun jabber-muc--config-xdata (xml-data) "Return the XEP-0004 configuration form from XML-DATA." (seq-find (lambda (x) (string= (jabber-xml-get-attribute x 'xmlns) jabber-xdata-xmlns)) (jabber-xml-get-children (jabber-iq-query xml-data) 'x))) (defun jabber-muc--config-form (xdata group) "Return parsed XDATA titled for room GROUP." (plist-put (jabber-xdata-parse xdata) :title (format "Configuration: %s" group))) (defun jabber-muc--receive-config (jc xml-data context) "Open XML-DATA's MUC configuration form using JC and CONTEXT. CONTEXT contains the originating buffer and room JID." (let ((buffer (car context)) (group (cadr context)) (xdata (jabber-muc--config-xdata xml-data))) (cond ((not (buffer-live-p buffer)) (message "MUC configuration arrived after its buffer was closed")) ((null xdata) (message "No configuration possible for %s" group)) (t (with-current-buffer buffer (pop-to-buffer buffer) (jabber-xdata-form-open (jabber-muc--config-form xdata group) (list (list :key "RET" :label "Submit" :command (lambda () (interactive) (jabber-muc-submit-config jc group)) :submits-form t) (list :key "q" :label "Cancel" :command (lambda () (interactive) (jabber-muc-cancel-config jc group)))))))))) (defun jabber-muc--config-error (_jc xml-data group) "Report a failed configuration request for GROUP from XML-DATA." (message "MUC configuration request failed for %s: %s" group (jabber-parse-error (jabber-iq-error xml-data)))) (defun jabber-muc--config-active-connection (&optional connection) "Return an active connection corresponding to CONNECTION." (let ((connection (or connection jabber-muc--config-connection))) (or (and (jabber-connection-active-p connection) connection) (when-let* ((replacement (and connection (ignore-errors (jabber-find-active-connection connection)))) ((jabber-connection-active-p replacement))) replacement) (user-error "The MUC configuration connection is no longer active")))) (defun jabber-muc-submit-config (&optional connection group) "Submit the current form to GROUP using CONNECTION." (interactive) (jabber-send-iq (jabber-muc--config-active-connection connection) (or group jabber-muc--config-group) "set" `(query ((xmlns . ,jabber-muc-xmlns-owner)) ,(jabber-xdata-form-submit-form)) #'jabber-report-success "MUC configuration" #'jabber-report-success "MUC configuration")) (defun jabber-muc-cancel-config (&optional connection group) "Cancel the current form for GROUP using CONNECTION." (interactive) (jabber-send-iq (jabber-muc--config-active-connection connection) (or group jabber-muc--config-group) "set" `(query ((xmlns . ,jabber-muc-xmlns-owner)) (x ((xmlns . ,jabber-xdata-xmlns) (type . "cancel")))) nil nil nil nil)) (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 GROUP as NICKNAME, 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 (let ((password (jabber-muc--session-password jc group))) (when (and popup (not password)) (setq password (read-passwd (format "Password for %s: " group))) (when (string-empty-p password) (setq password nil))) (jabber-muc--send-join-presence jc group nickname password 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 the active groupchat buffer for GROUP. 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* ((features (plist-get v :features)) (password (jabber-muc--session-password jc group)) (rejected-p (jabber-muc--password-rejected-p jc group))) (when (and (not password) (or (member "muc_passwordprotected" features) (and popup rejected-p))) (setq password (read-passwd (format "Password for %s: " (jabber-jid-displayname group))))) (when (member "muc_nonanonymous" features) (puthash group t jabber-muc--nonanonymous-rooms)) (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." (jabber-muc--remember-password jc group password) ;; 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 groupchat GROUP. 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-muc--autojoin-dequeue jc group) (let* ((bare-jid (jabber-connection-bare-jid jc)) (snapshot (cl-delete group (gethash bare-jid jabber-muc--rooms-before-disconnect) :key #'car :test #'string=))) (if snapshot (puthash bare-jid snapshot jabber-muc--rooms-before-disconnect) (remhash bare-jid jabber-muc--rooms-before-disconnect))) (jabber-muc--forget-password jc group) (when jabber-bookmarks-auto-add (jabber-bookmarks--retract-one jc group))) (defvar-local jabber-muc-names--group nil "Room JID for the current participants buffer.") (defun jabber-muc-names--entries (group) "Return tabulated-list entries for participants in GROUP." (mapcar (lambda (participant) (let ((nick (car participant)) (props (cdr participant))) (list nick (vector nick (or (plist-get props 'role) "") (or (plist-get props 'affiliation) "") (or (plist-get props 'jid) ""))))) (cdr (assoc group jabber-muc-participants)))) (defun jabber-muc-names--refresh () "Refresh the participant list from `jabber-muc-participants'." (setq tabulated-list-entries (jabber-muc-names--entries jabber-muc-names--group))) (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)]) (add-hook 'tabulated-list-revert-hook #'jabber-muc-names--refresh nil 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) (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) (jabber-muc-names--refresh) (tabulated-list-print t)) (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. Sets JID as a member (needed for members-only rooms) and sends a XEP-0249 direct invitation. 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: "))) ;; Grant membership so the invite works in members-only rooms. (jabber-send-iq jc group "set" `(query ((xmlns . ,jabber-muc-xmlns-admin)) (item ((jid . ,jid) (affiliation . "member")))) nil nil nil nil) (jabber-send-sexp jc `(message ((to . ,jid)) (x ((xmlns . ,jabber-muc-xmlns-direct-invite) (jid . ,group) ,@(when-let* ((password (jabber-muc--session-password jc group))) `((password . ,password))) ,@(unless (zerop (length reason)) `((reason . ,reason)))))))) (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 PASSWORD) 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)) (password (jabber-xml-get-attribute x 'password))) (when (and group (not (jabber-muc-joined-p group))) (cl-return (list group inviter reason password))))))) (defun jabber-muc--insert-invite (group inviter reason &optional mediated-p password) "Insert MUC invitation UI for GROUP from INVITER with REASON. When MEDIATED-P is non-nil, include a Decline button. PASSWORD is the optional direct-invite room 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--remember-password jabber-buffer-connection group password) (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 in display MODE. 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) nil (nth 3 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 for JC: advance to 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-muc--session-password jc group))) (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) "On JC, rejoin pre-disconnect rooms not already joined. Called after bookmark autojoin to recover non-bookmarked rooms. Rooms are added to the pending disco list for batched querying." (let ((bare-jid (jabber-connection-bare-jid jc))) (dolist (room-nick-password (gethash bare-jid jabber-muc--rooms-before-disconnect)) (pcase-let ((`(,room ,nick ,password) room-nick-password)) (jabber-muc--remember-password jc room password) (unless (or (jabber-muc-joined-p room jc) (jabber-muc--autojoin-queued-p jc room)) (jabber-muc--autojoin-enqueue-pending jc room nick)))) (remhash bare-jid jabber-muc--rooms-before-disconnect))) (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)))) (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-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--nick-face (nickname) "Return the face for foreign MUC NICKNAME." (if (null jabber-muc-colorize-nicks) '((:weight semi-bold) jabber-chat-nick-foreign-plaintext) (pcase-let ((`(,_base-hue ,display-hue ,saturation ,variation) (jabber-muc--nick-color-components nickname))) (list :weight 'semi-bold :foreground (jabber-muc--nick-color display-hue saturation variation (jabber-muc--default-background)))))) (defun jabber-muc-print-prompt (msg &optional local dont-print-nick-p) "Print MUC prompt for message plist MSG. LOCAL is non-nil when MSG was sent by us (uses local-nick face). When DONT-PRINT-NICK-P is non-nil, omit the nickname." (let ((nick (jabber-jid-resource (plist-get msg :from))) (timestamp (plist-get msg :timestamp)) (delayed (plist-get msg :delayed))) (if (stringp nick) (let ((face (if local 'jabber-muc-nick-local-face (jabber-muc--nick-face nick)))) (jabber-chat--insert-prompt (jabber-chat--format-time timestamp delayed) (if dont-print-nick-p "" nick) face)) (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) '((:weight semi-bold) 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 &optional target-buffer) "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 (unless (eq target-buffer 'closed) (or target-buffer (jabber-muc-find-buffer group jc)))) (alert-buffer (or buffer (and (eq target-buffer 'closed) (jabber-muc-find-buffer group jc))))) ;; 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-chat-buffer-with-scrolltobottom (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 alert-buffer body-text (funcall jabber-alert-muc-function nick group alert-buffer body-text))))))) (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))) (unless (jabber-reactions--reaction-only-p xml-data) (let* ((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)) (thread-target (if replace-id 'correction (if (plist-get msg-plist :thread-id) (jabber-message-thread-display-target jc group "groupchat" msg-plist) 'parent))) (target-buffer (cond ((eq thread-target 'correction) 'closed) ((eq thread-target 'parent) (jabber-muc-find-buffer group jc)) ((null thread-target) 'closed) ((bufferp thread-target) thread-target) (t 'closed)))) (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 (lambda (original) (let ((targets (jabber-message-thread-update-targets-for-row jc group "groupchat" (plist-get original :row-id)))) (cond ((eq targets 'closed) nil) (targets targets) (t (delq nil (list (jabber-muc-find-buffer group jc))))))) (jabber-db--extract-occupant-id xml-data) (jabber-connection-bare-jid jc) group (jabber-message-correct--muc-current-target-p jc from replace-id)) (jabber-muc--display-message jc xml-data group nick type msg-plist target-buffer) (when (and (fboundp 'jabber-message-correct--record-muc-original) (plist-get msg-plist :body) (not (jabber--decrypt-failure-body-p (plist-get msg-plist :body))) (not (jabber-muc--history-message-p xml-data)) (jabber-xml-get-attribute xml-data 'id)) (jabber-message-correct--record-muc-original jc from (jabber-xml-get-attribute xml-data 'id))))))))) (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) "On JC, 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 (and (string= type "error") error-node (eq (jabber-error-condition error-node) 'not-authorized)) (jabber-muc--reject-password jc group)) (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-chat-buffer-with-scrolltobottom (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. JC is the connection. 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) ">"))))) (when (fboundp 'jabber-message-correct--muc-presence-leave) (jabber-message-correct--muc-presence-leave jc (concat group "/" nickname))) (jabber-muc-remove-participant group nickname) (when-let* ((buffer (jabber-muc-find-buffer group jc))) (with-current-buffer buffer (jabber-chat-buffer-with-scrolltobottom (when (and (fboundp 'jabber-chatstates--muc-remove-nick) (fboundp 'jabber-chatstates--delete-typing-node)) (jabber-chatstates--muc-remove-nick nickname) (jabber-chatstates--delete-typing-node)) (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)))) (when (fboundp 'jabber-chatstates--muc-reinsert-typing) (jabber-chatstates--muc-reinsert-typing))))))) (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--status-notices (status-codes) "Return user-visible notices for MUC STATUS-CODES." (delq nil (mapcar (lambda (code) (cond ((string= code jabber-muc-status-nonanonymous) "This room exposes your real JID to other occupants") ((string= code jabber-muc-status-logging-enabled) "This room is publicly logged") ((string= code jabber-muc-status-logging-disabled) "This room is no longer publicly logged") ((string= code jabber-muc-status-now-nonanonymous) "This room is now non-anonymous") ((string= code jabber-muc-status-now-semianonymous) "This room is now semi-anonymous"))) status-codes))) (defun jabber-muc--insert-notice (notice) "Insert NOTICE into the current MUC buffer." (jabber-chat-buffer-with-scrolltobottom (jabber-chat-ewoc-enter (list :muc-notice notice :time (current-time))))) (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." (mapc #'jabber-muc--insert-notice (jabber-muc--status-notices status-codes)) (when (member jabber-muc-status-nick-modified status-codes) (jabber-muc--insert-notice (concat "Your nick was changed to " nickname " by the server"))) (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-muc--insert-notice (jabber-muc--room-created-message))))) (defun jabber-muc--query-affiliations (jc group) "On JC, query member, admin, and owner affiliation lists for GROUP. Sends three IQ-get requests. Results are merged into `jabber-muc--room-jids' and `jabber-muc-participants'." (dolist (affiliation '("member" "admin" "owner")) (jabber-send-iq jc group "get" `(query ((xmlns . ,jabber-muc-xmlns-admin)) (item ((affiliation . ,affiliation)))) #'jabber-muc--affiliation-result group #'jabber-muc--affiliation-error group))) (defun jabber-muc--affiliation-result (_jc xml-data group) "Handle affiliation list result for GROUP. XML-DATA is the IQ result. GROUP is the room JID." (let* ((query (jabber-iq-query xml-data)) (items (jabber-xml-get-children query 'item)) (room-jids (or (gethash group jabber-muc--room-jids) (let ((ht (make-hash-table :test #'equal))) (puthash group ht jabber-muc--room-jids) ht)))) (dolist (item items) (let ((jid (jabber-xml-get-attribute item 'jid)) (affiliation (jabber-xml-get-attribute item 'affiliation)) (nick (jabber-xml-get-attribute item 'nick))) (when jid (puthash (jabber-jid-user jid) (or affiliation "member") room-jids) (when nick (jabber-muc-modify-participant group nick (list 'jid jid 'affiliation affiliation)))))))) (defun jabber-muc--affiliation-error (_jc _xml-data _group) "Handle affiliation list query error. Silently ignore; the user may lack permissions." nil) (defun jabber-muc--process-enter (jc group nickname symbol status-codes x-muc actor reason our-nickname) "On JC, 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." (when (fboundp 'jabber-message-correct--muc-presence-enter) (jabber-message-correct--muc-presence-enter jc (concat group "/" nickname))) ;; 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 jc))) (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 jc))) (let ((report (jabber-muc-report-delta nickname old-plist new-plist reason actor))) (when report (with-current-buffer buffer (jabber-chat-buffer-with-scrolltobottom (jabber-maybe-print-rare-time (jabber-chat-ewoc-enter (list :muc-notice report :time (current-time)))))))) ;; Status-code notices 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)) (when (or (member jabber-muc-status-nonanonymous status-codes) (gethash group jabber-muc--nonanonymous-rooms)) (jabber-muc--query-affiliations 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) "On JC, dispatch the 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) (add-hook 'jabber-presence-muc-functions #'jabber-muc-process-presence) (provide 'jabber-muc) ;;; jabber-muc.el ends here. emacs-jabber-0.13.1/lisp/jabber-notifications.el000066400000000000000000000120201523531702000214650ustar00rootroot00000000000000;;; 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) (require 'jabber-avatar) (require 'jabber-muc-nick-completion) (require 'jabber-xml) (require 'jabber-util) (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 "Timeout of the pop up window in milliseconds." :type 'integer :group 'jabber-alerts) (defcustom jabber-notifications-app "Emacs Jabber" "Defines the app of the pop up." :type 'string :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) (defun jabber-notifications--remove-action-callback (callback) "Remove CALLBACK from the pending notification actions." (setq notifications-on-action-map (cl-delete callback notifications-on-action-map :key #'cadr :test #'eq)) (when (and (null notifications-on-action-map) notifications-on-action-object) (dbus-unregister-object notifications-on-action-object) (setq notifications-on-action-object nil))) (defun jabber-message-notifications (from buffer text title) "Show a message from FROM through the notifications.el interface. BUFFER is the associated chat buffer, TEXT is the message body, and TITLE is the notification title." (letrec ((body (or (jabber-escape-xml text) " ")) (avatar-hash (get (jabber-jid-symbol from) 'avatar-hash)) (action-callback (lambda (&rest _) (when (buffer-live-p buffer) (pop-to-buffer buffer)))) (close-callback (lambda (&rest _) (jabber-notifications--remove-action-callback action-callback)))) (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" :actions '("default" "Switch to buffer") :on-action action-callback :on-close close-callback :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 from NICK in GROUP through the notifications.el interface. BUFFER, TEXT and TITLE are passed through to the underlying notification call. 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-jabber-personal-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-0.13.1/lisp/jabber-omemo-store.el000066400000000000000000000321541523531702000210740ustar00rootroot00000000000000;;; 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. Preserves the spk_rotated_at column; INSERT OR REPLACE would delete and re-insert the row, wiping it." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "INSERT INTO omemo_store (account, store_blob) VALUES (?, ?) ON CONFLICT(account) DO UPDATE SET store_blob = excluded.store_blob" (list account blob)))) (defun jabber-omemo-store-spk-rotated-at (account) "Return ACCOUNT's signed pre-key rotation time as epoch seconds, or nil." (when-let* ((db (jabber-db-ensure-open))) (caar (sqlite-select db "SELECT spk_rotated_at FROM omemo_store WHERE account = ?" (list account))))) (defun jabber-omemo-store-set-spk-rotated-at (account time) "Record TIME (epoch seconds) as ACCOUNT's signed pre-key rotation time. The account's store row must already exist." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "UPDATE omemo_store SET spk_rotated_at = ? WHERE account = ?" (list time account)))) (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 of ACCOUNT+JID 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-save-session-and-clear-legacy-keys (account jid device-id blob) "Save session BLOB for ACCOUNT, JID, DEVICE-ID and remove legacy keys." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "SAVEPOINT omemo_session_migration") (condition-case err (prog1 (progn (jabber-omemo-store-save-session account jid device-id blob) (jabber-omemo-store-delete-skipped-keys account jid device-id)) (sqlite-execute db "RELEASE omemo_session_migration")) (error (condition-case cleanup-err (sqlite-execute db "ROLLBACK TO omemo_session_migration") (error (message "OMEMO session rollback failed: %s" (error-message-string cleanup-err)))) (condition-case cleanup-err (sqlite-execute db "RELEASE omemo_session_migration") (error (message "OMEMO session savepoint release failed: %s" (error-message-string cleanup-err)))) (signal (car err) (cdr err)))))) (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))))) ;;; Legacy skipped-key migration (defun jabber-omemo-store-all-skipped-keys (account jid device-id) "Return all skipped message keys for ACCOUNT+JID+DEVICE-ID. Each element is (MSG-NUMBER DH-KEY MSG-KEY), the entry format of `jabber-omemo--session-set-skipped-keys'." (when-let* ((db (jabber-db-ensure-open))) (mapcar (lambda (row) (list (car row) (jabber-omemo-store--as-unibyte (cadr row)) (jabber-omemo-store--as-unibyte (caddr row)))) (sqlite-select db "\ SELECT message_number, dh_key, message_key FROM omemo_skipped_keys WHERE account = ? AND jid = ? AND device_id = ? ORDER BY created_at ASC, rowid ASC" (list account jid device-id))))) (defun jabber-omemo-store-delete-skipped-keys (account jid device-id) "Delete all skipped message keys for ACCOUNT+JID+DEVICE-ID. Used when a session is replaced; keys from the old ratchet can never match again." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "\ DELETE FROM omemo_skipped_keys WHERE account = ? AND jid = ? AND device_id = ?" (list account jid device-id)))) (provide 'jabber-omemo-store) ;;; jabber-omemo-store.el ends here emacs-jabber-0.13.1/lisp/jabber-omemo-trust.el000066400000000000000000000402251523531702000211170ustar00rootroot00000000000000;;; 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-util) (require 'jabber-omemo) (require 'jabber-omemo-store) (require 'keymap-popup) (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 (eval-when-compile (defvar jabber-omemo-trust-mode-map)) (keymap-popup-define jabber-omemo-trust-mode-map "OMEMO trust commands." :description #'jabber-omemo-trust--menu-description :group "Trust" "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)) (keymap-set jabber-omemo-trust-mode-map "h" #'jabber-omemo-trust-menu) (keymap-set jabber-omemo-trust-mode-map "?" #'jabber-omemo-trust-menu) (defun jabber-omemo--list-format () "Return the column format vector for the OMEMO trust list buffer." (let ((width (window-width))) (vector (list "Device ID" (max 9 (/ width 10))) (list "Trust" (max 8 (/ width 10))) (list "Fingerprint" (max 32 (/ width 3))) (list "First Seen" (max 16 (/ width 10)))))) (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 (defun jabber-omemo-fingerprints () "Display OMEMO trust management for the current chat peer." (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) ;;;###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 (eq (bound-and-true-p jabber-omemo--available) t) (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 (eq (bound-and-true-p jabber-omemo--available) t) (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))) ;;; Popup menu (defun jabber-omemo-trust--menu-description () "Return description string for the popup menu." (format "Peer: %s Account: %s" (propertize (or jabber-omemo-trust--peer "?") 'face 'jabber-chat-nick-foreign-encrypted) (propertize (or jabber-omemo-trust--account "?") 'face 'jabber-chat-nick-encrypted))) (defun jabber-omemo-trust-menu () "Show OMEMO trust commands." (interactive) (unless (derived-mode-p 'jabber-omemo-trust-mode) (user-error "Not in an OMEMO trust buffer; use `jabber-omemo-show-trust' first")) (keymap-popup jabber-omemo-trust-mode-map)) ;;; 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)))) (add-hook 'jabber-post-disconnect-hook #'jabber-omemo-trust--kill-buffers) (provide 'jabber-omemo-trust) ;;; jabber-omemo-trust.el ends here emacs-jabber-0.13.1/lisp/jabber-omemo.el000066400000000000000000002475151523531702000177530ustar00rootroot00000000000000;;; 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 and re-exports the core ;; functions under the public jabber-omemo- namespace. ;;; Code: (require 'cl-lib) (require 'hex-util) (require 'jabber-util) (require 'jabber-omemo-store) (require 'jabber-pubsub) (require 'jabber-xml) (require 'jabber-hints) (require 'jabber-eme) (require 'jabber-chat) (require 'jabber-db) (require 'jabber-disco) (require 'jabber-httpupload) (require 'jabber-iq) (require 'jabber-message-thread-protocol) (require 'jabber-muc-state) ;; Groupchat paths run only after MUC has established room state. (declare-function jabber-muc-modify-participant "jabber-muc" (group nickname new-plist)) (declare-function jabber-muc-participant-plist "jabber-muc" (group nickname)) (declare-function jabber-muc-create-buffer "jabber-muc" (jc group)) (defvar jabber-muc--room-jids) (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-signed-pre-key-rotation-period (* 7 86400) "Seconds between OMEMO signed pre-key rotations. Checked on connect. XEP-0384 recommends rotating once a week to once a month. The previous signed pre-key is retained for one rotation, so in-flight pre-key messages still decrypt." :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-chat--decrypt-consumed-p) (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-message-reply--fallback-text) ; jabber-message-reply.el (defvar jabber-message-reply--thread) ; jabber-message-reply.el (defvar jabber-message-thread-id) ; jabber-message-thread.el (defvar jabber-message-thread-parent-id) ; jabber-message-thread.el (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. (unless (or jabber-omemo--available (not jabber-omemo-enable)) (if (require 'jabber-omemo-core nil t) (setq jabber-omemo--available t) (setq jabber-omemo--available 'unavailable) (message "OMEMO: native module not found, encryption disabled"))) (defun jabber-omemo--require-module () "Return non-nil if the native OMEMO module is available. Signal a `user-error' otherwise." (if (eq jabber-omemo--available t) t (user-error "OMEMO module not compiled"))) ;; 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--remove-pre-key "ext:jabber-omemo-core") (declare-function jabber-omemo--used-pre-key-id "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--legacy-session-blob-p "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--session-skipped-keys "ext:jabber-omemo-core") (declare-function jabber-omemo--session-set-skipped-keys "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--require-module) (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--require-module) (jabber-omemo--deserialize-store blob)) (defun jabber-omemo-serialize-store (store-ptr) "Serialize STORE-PTR back to a unibyte string." (jabber-omemo--require-module) (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--require-module) (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--require-module) (jabber-omemo--rotate-signed-pre-key store-ptr)) (defun jabber-omemo-remove-pre-key (store-ptr id) "Remove one-time pre-key ID from STORE-PTR. Zeroes the matching slot per XEP-0384 one-time use; `jabber-omemo-refill-pre-keys' regenerates zeroed slots. The store must be re-serialized afterwards. Returns non-nil when a slot was removed." (jabber-omemo--remove-pre-key store-ptr id)) (defun jabber-omemo-used-pre-key-id (session-ptr) "Return the one-time pre-key id consumed by SESSION-PTR. Zero when the session never consumed a pre-key. Only meaningful right after a fresh session decrypted a pre-key message; the value persists in the serialized session." (jabber-omemo--used-pre-key-id session-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--require-module) (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--require-module) (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--require-module) (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--require-module) (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--require-module) (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--require-module) (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--require-module) (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--require-module) (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--require-module) (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--require-module) (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--require-module) (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--require-module) (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))) (when (jabber-omemo--legacy-session-blob-p blob) (jabber-omemo--session-set-skipped-keys session-ptr (jabber-omemo-store-all-skipped-keys account jid device-id))) (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-and-clear-legacy-keys 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 JC's 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))))))) ;;; One-time pre-key removal (XEP-0384 section 4.3) (defvar jabber-omemo--pending-prekey-removals (make-hash-table :test #'equal) "Account to list of consumed one-time pre-key ids awaiting removal. Filled after a fresh-session pre-key decrypt. Removal is deferred until MAM catchup completes so a repeated or corrected pre-key message from the same catchup still decrypts; the established session and the decrypt dedup cache cover the live window in the meantime.") (defvar jabber-omemo--prekey-flush-timer nil "Debounce timer for `jabber-omemo--flush-prekey-removals'.") (defconst jabber-omemo--prekey-flush-delay 30 "Seconds to wait before removing consumed pre-keys. Covers accounts without MAM: long enough for an offline-push duplicate of the pre-key message to arrive first.") (defvar jabber-omemo--prekey-exports-warned nil "Non-nil after warning once about a stale native module.") (defun jabber-omemo--prekey-exports-p () "Return non-nil when the native module has the pre-key exports. Warn once when it does not (stale jabber-omemo-core.so)." (or (and (fboundp 'jabber-omemo--used-pre-key-id) (fboundp 'jabber-omemo--remove-pre-key)) (prog1 nil (unless jabber-omemo--prekey-exports-warned (setq jabber-omemo--prekey-exports-warned t) (message "OMEMO: jabber-omemo-core.so predates pre-key removal; \ run `make module' to rebuild"))))) (defun jabber-omemo--mam-syncing-p () "Return non-nil when a MAM catchup is in progress." (and (fboundp 'jabber-mam-syncing-p) (jabber-mam-syncing-p))) (defun jabber-omemo--note-consumed-prekey (jc session-ptr) "Record SESSION-PTR's consumed one-time pre-key for later removal. Called after a fresh-session pre-key decrypt on JC; the reuse path must not call this, since `usedpk_id' persists in serialized sessions. Schedules a debounced flush." (when (jabber-omemo--prekey-exports-p) (let ((id (jabber-omemo-used-pre-key-id session-ptr)) (account (jabber-connection-bare-jid jc))) (when (> id 0) (cl-pushnew id (gethash account jabber-omemo--pending-prekey-removals)) (jabber-omemo--schedule-prekey-flush jc))))) (defun jabber-omemo--schedule-prekey-flush (jc) "Restart the debounced pre-key removal flush for JC." (when (timerp jabber-omemo--prekey-flush-timer) (cancel-timer jabber-omemo--prekey-flush-timer)) (setq jabber-omemo--prekey-flush-timer (run-with-timer jabber-omemo--prekey-flush-delay nil #'jabber-omemo--flush-prekey-removals jc))) (defun jabber-omemo--flush-prekey-removals (jc) "Remove consumed one-time pre-keys for JC's account and republish. No-op while a MAM sync is running (the sync-complete hook retries) or when nothing is pending. Removes each pending pre-key from the store, refills, persists, and republishes the bundle; the drift check in `jabber-omemo--bundle-needs-republish-p' cannot see an id-level replacement, so the publish is unconditional." (let* ((account (jabber-connection-bare-jid jc)) (ids (gethash account jabber-omemo--pending-prekey-removals))) (when (and ids (not (jabber-omemo--mam-syncing-p)) (jabber-omemo--prekey-exports-p)) (remhash account jabber-omemo--pending-prekey-removals) (let ((store-ptr (jabber-omemo--get-store jc))) (dolist (id ids) (jabber-omemo-remove-pre-key store-ptr id)) (jabber-omemo-refill-pre-keys store-ptr) (jabber-omemo--persist-store jc) (message "OMEMO: removed %d consumed pre-key(s)" (length ids)) (jabber-omemo--publish-bundle jc))))) (defun jabber-omemo--on-mam-sync-complete (_peers) "Flush pending pre-key removals once MAM catchup has finished." (unless (jabber-omemo--mam-syncing-p) (dolist (jc jabber-connections) (jabber-omemo--flush-prekey-removals jc)))) ;;; Session establishment (defun jabber-omemo--establish-session (jc jid device-id bundle) "Establish an OMEMO session on JC 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--match-jid-by-affiliation (group nick) "Try to match NICK in GROUP to a bare JID from affiliation data. Finds JIDs in `jabber-muc--room-jids' not yet assigned to any participant. If exactly one unassigned JID exists, return it and store the mapping for future lookups." (when-let* ((room-jids (gethash group jabber-muc--room-jids))) (let* ((participants (cdr (assoc group jabber-muc-participants))) (assigned (make-hash-table :test #'equal))) (dolist (entry participants) (when-let* ((jid (plist-get (cdr entry) 'jid))) (puthash (jabber-jid-user jid) t assigned))) (let (candidates) (maphash (lambda (bare-jid _aff) (unless (gethash bare-jid assigned) (push bare-jid candidates))) room-jids) (when (= (length candidates) 1) (let ((jid (car candidates))) (jabber-muc-modify-participant group nick (list 'jid jid)) jid)))))) (defun jabber-omemo--resolve-sender-jid (xml-data) "Return the real bare JID of the sender of XML-DATA. For 1:1 messages, this is `jabber-jid-user' of the from attribute. For MUC messages (type=groupchat), try in order: 1. Nickname lookup in `jabber-muc-participants' 2. Match by affiliation between participants and `jabber-muc--room-jids'" (let* ((from (jabber-xml-get-attribute xml-data 'from)) (msg-type (jabber-xml-get-attribute xml-data 'type))) (if (not (equal msg-type "groupchat")) (and from (jabber-jid-user from)) (let* ((group (jabber-jid-user from)) (nick (jabber-jid-resource from)) (plist (jabber-muc-participant-plist group nick)) (real-jid (plist-get plist 'jid))) (or (and real-jid (jabber-jid-user real-jid)) (jabber-omemo--match-jid-by-affiliation group nick)))))) (defun jabber-omemo--decrypt-key-with-session (jc sender-jid sender-did store-ptr pre-key-p key-data) "Decrypt KEY-DATA from SENDER-JID's device SENDER-DID via JC. STORE-PTR is the local OMEMO store. For a pre-key message \(PRE-KEY-P non-nil) an existing session is tried first: an established ratchet must not re-run the pre-key handshake, or a repeated pre-key message (offline edit, replay) would consume the pre-key twice. When that attempt fails, fall back to a fresh session; picomemo restores session state on a failed decrypt, so the retry is safe. This also resolves a peer that reset their session and simultaneous initiations. A regular message requires an existing session. Skipped ratchet keys are owned by the native session and persisted inside its serialized blob, so out-of-order messages survive restarts. Returns (SESSION-PTR DECRYPTED-KEY FRESH-P), FRESH-P non-nil when the fresh-session pre-key path was used. Signals `jabber-omemo-no-session' or `jabber-omemo-prekey-failed'." (let ((existing (jabber-omemo--get-session jc sender-jid sender-did))) (cl-flet ((decrypt-existing (prekey) (let ((key (jabber-omemo-decrypt-key existing store-ptr prekey key-data))) (list existing key nil)))) (cond ((not pre-key-p) (unless existing (signal 'jabber-omemo-no-session (list sender-jid sender-did))) (decrypt-existing nil)) (t (or (and existing (condition-case nil (decrypt-existing t) (jabber-omemo-error nil))) (let ((fresh (jabber-omemo-make-session))) (condition-case err (let ((key (jabber-omemo-decrypt-key fresh store-ptr t key-data))) (list fresh key t)) (jabber-omemo-error (signal 'jabber-omemo-prekey-failed (list sender-jid sender-did (error-message-string err)))))))))))) (defun jabber-omemo--decrypt-stanza (jc xml-data parsed) "Decrypt OMEMO message on JC 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 on both the existing-session and fresh-session paths (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)) (sender-jid (jabber-omemo--resolve-sender-jid xml-data))) (if (not sender-jid) (error "Sender JID unknown (anonymous room?)") (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))) (pcase-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 ,decrypted-key ,fresh-p) (jabber-omemo--decrypt-key-with-session jc sender-jid sender-did store-ptr pre-key-p key-data))) (setq jabber-chat--decrypt-consumed-p t) (jabber-omemo--save-session jc sender-jid sender-did session-ptr) (jabber-omemo--persist-store jc) (when fresh-p (jabber-omemo--note-consumed-prekey jc session-ptr)) (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. Keys contain the connection, room, expected local occupant JID, and message ID. Entries are consumed when the matching MUC server echo is received, so the cache is normally near-empty.") (defun jabber-omemo--muc-echo-key (jc group from id) "Return the sent-plaintext cache key for JC, GROUP, FROM, and ID." (list jc group from id)) (defun jabber-omemo--detect-encrypted (xml-data) "Detect OMEMO encryption in XML-DATA. Returns a detection plist or nil." (when-let* ((parsed (jabber-omemo--parse-encrypted xml-data))) (list :type 'omemo :parsed parsed))) (defun jabber-omemo--recover-prekey-failure (jc sender-jid sender-did) "Drop the stale session for SENDER-JID's device SENDER-DID and rebuild. Called when a pre-key message failed to decrypt on both the existing-session and fresh-session paths: the local session state is unusable, so delete it (database and cache) and re-fetch the peer's sessions so the next exchange re-establishes cleanly. JC is the connection." (let ((account (jabber-connection-bare-jid jc))) (jabber-omemo-store-delete-session account sender-jid sender-did) (remhash (jabber-omemo--session-key account sender-jid sender-did) jabber-omemo--sessions) (message "OMEMO: rebuilding session for %s device %s" sender-jid sender-did) (jabber-omemo--ensure-sessions jc sender-jid #'ignore))) (defun jabber-omemo--empty-error-result (xml-data payload err) "Return XML-DATA for an empty OMEMO stanza, or re-signal ERR. PAYLOAD is non-nil when the stanza carries user content." (if payload (signal (car err) (cdr err)) (setq jabber-chat--decrypt-retryable-failure-p (not jabber-chat--decrypt-consumed-p)) xml-data)) (defun jabber-omemo--decrypt-handler (jc xml-data detected) "Decrypt OMEMO message on JC in XML-DATA. DETECTED is the plist from `jabber-omemo--detect-encrypted'. 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). - Other failures on empty OMEMO messages also return XML-DATA unchanged because those stanzas carry no user content. - `jabber-omemo-prekey-failed': drop the stale session and schedule a rebuild via `jabber-omemo--recover-prekey-failure', then re-signal payload failures so the dispatcher reports them to the user. Empty failures remain bodyless. Bundle repair happens via the lifecycle-driven `--publish-bundle-if-needed' trigger, not from the decrypt path. Other payload failures propagate unchanged so the dispatcher can replace the body with a generic decrypt-failed placeholder. Other empty failures remain bodyless." (let* ((from (jabber-xml-get-attribute xml-data 'from)) (id (jabber-xml-get-attribute xml-data 'id)) (group (and from (jabber-jid-user from))) (echo-key (and id group (jabber-omemo--muc-echo-key jc group from id))) (cached (and echo-key (gethash echo-key jabber-omemo--sent-muc-plaintexts))) (payload (plist-get (plist-get detected :parsed) :payload))) (if cached (progn (remhash echo-key jabber-omemo--sent-muc-plaintexts) (jabber-chat--set-body xml-data cached)) (pcase (plist-get detected :type) ('omemo (condition-case err (jabber-omemo--decrypt-stanza jc xml-data (plist-get detected :parsed)) (jabber-omemo-not-for-us (jabber-omemo--empty-error-result xml-data payload err)) (jabber-omemo-prekey-failed (message "OMEMO: pre-key decrypt failed: %s" (error-message-string err)) (pcase-let ((`(,sender-jid ,sender-did ,_reason) (cdr err))) (let ((recovery-error (condition-case recovery-err (progn (jabber-omemo--recover-prekey-failure jc sender-jid sender-did) nil) (error recovery-err)))) (jabber-omemo--empty-error-result xml-data payload (or recovery-error err))))) (error (jabber-omemo--empty-error-result xml-data payload 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 GROUP. Collects JIDs from PARTICIPANTS (the alist from `jabber-muc-participants') and from affiliation query results in `jabber-muc--room-jids'." (let ((jid-set (make-hash-table :test #'equal))) (dolist (entry participants) (when-let* ((full-jid (plist-get (cdr entry) 'jid)) (bare (jabber-jid-user full-jid))) (puthash bare t jid-set))) (when-let* ((room-jids (gethash group jabber-muc--room-jids))) (maphash (lambda (bare _aff) (puthash bare t jid-set)) room-jids)) (hash-table-keys jid-set))) (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 (defvar jabber-omemo--pending-send-operations (make-hash-table :test #'eq) "Active OMEMO sends grouped by connection.") (defun jabber-omemo--send-operation-register (jc success failure) "Register an OMEMO send on JC with SUCCESS and FAILURE callbacks." (let ((operation (list :active t :connection jc :success success :failure failure))) (puthash jc (cons operation (gethash jc jabber-omemo--pending-send-operations)) jabber-omemo--pending-send-operations) operation)) (defun jabber-omemo--send-operation-active-p (operation) "Return non-nil when OPERATION may still complete." (or (null operation) (plist-get operation :active))) (defun jabber-omemo--send-operation-finish (operation result &optional reason) "Finish OPERATION once with RESULT and optional failure REASON." (when (and operation (plist-get operation :active)) (plist-put operation :active nil) (let* ((jc (plist-get operation :connection)) (remaining (delq operation (gethash jc jabber-omemo--pending-send-operations)))) (if remaining (puthash jc remaining jabber-omemo--pending-send-operations) (remhash jc jabber-omemo--pending-send-operations))) (condition-case err (if (eq result 'success) (when-let* ((callback (plist-get operation :success))) (funcall callback)) (when-let* ((callback (plist-get operation :failure))) (funcall callback reason))) (error (message "OMEMO send callback failed: %s" (error-message-string err)))))) (defun jabber-omemo--fail-send-operations (jc reason) "Fail every active OMEMO send on JC with REASON." (dolist (operation (copy-sequence (gethash jc jabber-omemo--pending-send-operations))) (jabber-omemo--send-operation-finish operation 'failure reason))) (defun jabber-omemo--fail-all-send-operations (reason) "Fail every active OMEMO send with REASON." (dolist (jc (hash-table-keys jabber-omemo--pending-send-operations)) (jabber-omemo--fail-send-operations jc reason))) (defun jabber-omemo--pending-thread (extra-elements) "Return pending thread metadata from EXTRA-ELEMENTS or buffer state." (or (and extra-elements (jabber-message-thread-protocol-fields `(message () ,@extra-elements))) (bound-and-true-p jabber-message-reply--thread) (when (bound-and-true-p jabber-message-thread-id) (list :thread-id jabber-message-thread-id :thread-parent-id (bound-and-true-p jabber-message-thread-parent-id))))) (defun jabber-omemo--pending-message (body id extra-elements) "Return the pending message plist for BODY, ID, and EXTRA-ELEMENTS." (let* ((stanza `(message () (body () ,body) ,@extra-elements)) (reply (jabber-db--extract-reply-fields stanza)) (thread (jabber-omemo--pending-thread extra-elements)) (msg (list :id id :body body :timestamp (current-time) :status :sending :encrypted t))) (append msg reply thread))) (defun jabber-omemo--enter-pending (msg) "Enter MSG as pending, or reuse its freshly loaded database node." (when (run-hook-with-args-until-success 'jabber-chat-printers msg :local :printp) (let* ((entered (jabber-chat-ewoc-enter (list :local msg))) (node (or entered (jabber-chat-ewoc-find-by-id (plist-get msg :id))))) (when node (let ((stored (cadr (ewoc-data node)))) (plist-put stored :status :sending) (when-let* ((thread-id (plist-get msg :thread-id))) (plist-put stored :thread-id thread-id) (plist-put stored :thread-parent-id (plist-get msg :thread-parent-id))) (unless entered (jabber-chat-ewoc-invalidate node))) (when entered (jabber-maybe-print-rare-time node)) node)))) (defun jabber-omemo--display-pending (buffer body id &optional jc extra-elements) "Display BODY in BUFFER as a message with :sending status. ID is the stanza id. JC and EXTRA-ELEMENTS provide send context. Persists to DB immediately. Return the owning buffer and ewoc node." (when (buffer-live-p buffer) (with-current-buffer buffer (let* ((msg (jabber-omemo--pending-message body id extra-elements)) (thread (and (plist-get msg :thread-id) msg)) (reply (and (plist-get msg :reply-to-id) msg))) (jabber-db--outgoing-handler body id reply thread) (when-let* ((target (if jc (jabber-chat--local-message-buffer jc msg) (and (or (null thread) (bound-and-true-p jabber-message-thread-id)) buffer)))) (with-current-buffer target (when-let* ((node (jabber-omemo--enter-pending msg))) (run-hook-with-args 'jabber-chat-local-message-functions (cadr (ewoc-data node))) (list :buffer target :node node)))))))) (defun jabber-omemo--send-failed (buffer node body reason &optional node-buffer) "Mark NODE as :undelivered and restore BODY to input area. BUFFER is the composition buffer. REASON is shown via `message'. NODE-BUFFER owns NODE when it differs from BUFFER." (when (and node (buffer-live-p (or node-buffer buffer))) (with-current-buffer (or node-buffer buffer) (plist-put (cadr (ewoc-data node)) :status :undelivered) (jabber-chat-ewoc-invalidate node))) (when (buffer-live-p buffer) (with-current-buffer buffer (goto-char (point-max)) (insert body))) (message "%s" reason)) (defun jabber-omemo--send-chat (jc body &optional extra-elements success-callback failure-callback) "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 (current-buffer)) (id (format "emacs-msg-%.6f" (float-time))) (send-context (jabber-chat--capture-send-context body extra-elements)) (extra-elements (plist-get send-context :extra-elements)) (pending (unless is-correction (jabber-omemo--display-pending buffer body id jc extra-elements))) (node (plist-get pending :node)) (node-buffer (plist-get pending :buffer)) (raw-failed (lambda (reason) (when (buffer-live-p buffer) (with-current-buffer buffer (jabber-chat--restore-send-context send-context))) (jabber-omemo--send-failed buffer node body reason node-buffer) (when failure-callback (funcall failure-callback reason)))) (operation (jabber-omemo--send-operation-register jc success-callback raw-failed)) (succeeded (and operation (lambda () (jabber-omemo--send-operation-finish operation 'success)))) (failed (if operation (lambda (reason) (jabber-omemo--send-operation-finish operation 'failure reason)) raw-failed))) (condition-case err (jabber-omemo--ensure-sessions jc recipient (lambda (recipient-sessions) (when (jabber-omemo--send-operation-active-p operation) (if (null recipient-sessions) (funcall failed (format "OMEMO: no sessions for %s, cannot send" recipient)) (condition-case own-error (jabber-omemo--ensure-sessions jc (jabber-connection-bare-jid jc) (lambda (own-sessions) (when (jabber-omemo--send-operation-active-p operation) (condition-case send-error (jabber-omemo--send-encrypted jc body chat-with (append recipient-sessions own-sessions) buffer node id extra-elements succeeded failed node-buffer) (error (funcall failed (error-message-string send-error))))))) (error (funcall failed (error-message-string own-error)))))))) (error (funcall failed (error-message-string err)))))) (defun jabber-omemo--send-encrypted (jc body chat-with all-sessions &optional buffer node id extra-elements success-callback failure-callback node-buffer) "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. SUCCESS-CALLBACK and FAILURE-CALLBACK report transport completion. NODE-BUFFER owns NODE." (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))) (if (and buffer (not (buffer-live-p buffer))) (when failure-callback (funcall failure-callback "OMEMO: chat buffer closed before send")) (when (buffer-live-p buffer) (with-current-buffer buffer ;; This runs from an async IQ callback where current buffer ;; is not the chat buffer; the send hooks read buffer-local ;; state, so restore the chat buffer first. (jabber-chat--run-send-hooks stanza body id) (cond (node (when (buffer-live-p (or node-buffer buffer)) (with-current-buffer (or node-buffer buffer) (plist-put (cadr (ewoc-data node)) :status :sent) (jabber-chat-ewoc-invalidate node)))) ((not is-correction) (let ((msg-plist (jabber-chat--msg-plist-from-stanza stanza))) (plist-put msg-plist :body body) (plist-put msg-plist :status :sent) (jabber-chat--display-local-message jc msg-plist)))))) (if (or success-callback failure-callback) (jabber-send-sexp jc stanza success-callback failure-callback) (jabber-send-sexp jc stanza))))) (defun jabber-omemo--send-muc (jc body &optional extra-elements success-callback failure-callback) "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)) (id (format "emacs-msg-%.6f" (float-time))) (send-context (jabber-chat--capture-send-context body extra-elements)) (extra-elements (plist-get send-context :extra-elements)) (participants (cdr (assoc group jabber-muc-participants))) (bare-jids (jabber-omemo--muc-participant-jids group participants)) (raw-failed (lambda (reason) (when (buffer-live-p buffer) (with-current-buffer buffer (jabber-chat--restore-send-context send-context))) (jabber-omemo--send-failed buffer nil body reason) (when failure-callback (funcall failure-callback reason)))) (operation (jabber-omemo--send-operation-register jc success-callback raw-failed)) (succeeded (and operation (lambda () (jabber-omemo--send-operation-finish operation 'success)))) (failed (if operation (lambda (reason) (jabber-omemo--send-operation-finish operation 'failure reason)) raw-failed))) (if (null bare-jids) (progn (funcall failed "OMEMO: no participant JIDs available") (user-error "OMEMO: no participant JIDs available (room may be anonymous)")) (condition-case err (jabber-omemo--ensure-sessions-multi jc bare-jids (lambda (all-sessions) (when (jabber-omemo--send-operation-active-p operation) (if (null all-sessions) (let ((reason "OMEMO: no sessions for MUC participants, cannot send")) (funcall failed reason)) (condition-case own-error (jabber-omemo--ensure-sessions jc (jabber-connection-bare-jid jc) (lambda (own-sessions) (when (jabber-omemo--send-operation-active-p operation) (condition-case send-error (jabber-omemo--send-encrypted-muc jc body group (append all-sessions own-sessions) buffer id extra-elements succeeded failed) (error (funcall failed (error-message-string send-error))))))) (error (funcall failed (error-message-string own-error)))))))) (error (funcall failed (error-message-string err))))))) (defun jabber-omemo--send-encrypted-muc (jc body group all-sessions &optional buffer id extra-elements success-callback failure-callback) "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. BUFFER is the MUC buffer whose buffer-local state the send hooks must see. ID is the captured stanza ID. EXTRA-ELEMENTS are spliced into the stanza outside the encryption envelope. SUCCESS-CALLBACK and FAILURE-CALLBACK report transport completion. 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 (or id (format "emacs-msg-%.6f" (float-time)))) (nick (jabber-muc-nickname group jc)) (echo-key (and nick (jabber-omemo--muc-echo-key jc group (concat group "/" nick) id))) (_ (when echo-key (puthash echo-key body jabber-omemo--sent-muc-plaintexts))) (failed (lambda (reason) (when echo-key (remhash echo-key jabber-omemo--sent-muc-plaintexts)) (when failure-callback (funcall failure-callback reason)))) (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))) (condition-case err (progn (when (buffer-live-p buffer) (with-current-buffer buffer (jabber-chat--run-send-hooks stanza body id))) (if (or success-callback failure-callback) (jabber-send-sexp jc stanza success-callback failed) (jabber-send-sexp jc stanza))) (error (funcall failed (error-message-string err)))))) (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)))) ;;; Connect/disconnect hooks (defun jabber-omemo--maybe-rotate-signed-pre-key (jc) "Rotate JC's signed pre-key when the rotation period has passed. On the first check for an account, record the current time as a baseline without rotating. After a rotation, the bundle republish check on connect picks up the new signed pre-key id." (let* ((account (jabber-connection-bare-jid jc)) (rotated-at (jabber-omemo-store-spk-rotated-at account)) (now (time-convert nil 'integer))) (cond ((null rotated-at) (jabber-omemo-store-set-spk-rotated-at account now)) ((>= (- now rotated-at) jabber-omemo-signed-pre-key-rotation-period) (jabber-omemo-rotate-signed-pre-key (jabber-omemo--get-store jc)) (jabber-omemo--persist-store jc) (jabber-omemo-store-set-spk-rotated-at account now) (message "OMEMO: rotated signed pre-key for %s" account))))) ;;;###autoload (defun jabber-omemo-on-connect (jc) "Post-connect hook on JC for OMEMO initialization. Loads or creates the store, rotates the signed pre-key when due, 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--maybe-rotate-signed-pre-key jc) (jabber-omemo--ensure-device-listed jc) (jabber-omemo--publish-bundle-if-needed jc) (jabber-omemo--prefetch-open-chats jc)) (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)))))) (defun jabber-omemo--on-disconnect () "Pre-disconnect hook. Clear OMEMO in-memory caches." (jabber-omemo--fail-all-send-operations "OMEMO: connection closed before the message was sent") (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) (clrhash jabber-omemo--sent-muc-plaintexts)) (defun jabber-omemo--session-reset (jc) "Discard pending OMEMO work belonging to logical session JC." (jabber-omemo--fail-send-operations jc "OMEMO: connection reset before the message was sent") (maphash (lambda (key _value) (when (eq jc (car key)) (remhash key jabber-omemo--sent-muc-plaintexts))) jabber-omemo--sent-muc-plaintexts)) ;;; XEP-0454: aesgcm file upload (defun jabber-omemo--httpupload-transform (filepath callback) "Encrypt FILEPATH for aesgcm upload when OMEMO is active. CALLBACK receives the URL of the uploaded ciphertext. 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 GET-URL (aesgcm://) as an OMEMO-encrypted message from JC to JID. Returns non-nil if handled, nil to fall through to plaintext." (when (string-prefix-p "aesgcm://" get-url) ;; This runs from the upload process sentinel, where the current ;; buffer is arbitrary; derive the chat buffer from JID rather ;; than trusting buffer-local state. (if (jabber-muc-joined-p jid) (with-current-buffer (jabber-muc-create-buffer jc jid) (jabber-omemo--send-muc jc get-url)) (with-current-buffer (jabber-chat-create-buffer jc jid) (jabber-omemo--send-chat jc get-url))) t)) ;;; Disco and PubSub registration (when (eq jabber-omemo--available t) (jabber-disco-advertise-feature jabber-omemo-xmlns) (jabber-disco-advertise-feature (concat jabber-omemo-devicelist-node "+notify")) (setf (alist-get jabber-omemo-devicelist-node jabber-pubsub-node-handlers nil nil #'equal) #'jabber-omemo--handle-device-list) (add-hook 'jabber-post-connect-hooks #'jabber-omemo-on-connect) (add-hook 'jabber-pre-disconnect-hook #'jabber-omemo--on-disconnect) (add-hook 'jabber-lifecycle-session-reset-functions #'jabber-omemo--session-reset) (add-hook 'jabber-mam-sync-complete-functions #'jabber-omemo--on-mam-sync-complete) (setq jabber-httpupload-pre-upload-transform #'jabber-omemo--httpupload-transform) (setq jabber-httpupload-send-url-function #'jabber-omemo--httpupload-send-url)) (when (eq jabber-omemo--available t) (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-0.13.1/lisp/jabber-openpgp-legacy.el000066400000000000000000000355611523531702000215450ustar00rootroot00000000000000;;; 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-util) (require 'jabber-xml) (require 'jabber-hints) (require 'jabber-chat) (require 'jabber-disco) (require 'jabber-openpgp) (eval-when-compile (require 'cl-lib)) (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-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) (jabber-chat--display-local-message jc 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)) (id (format "emacs-msg-%d" (floor (* 1000 (float-time))))) (stanza `(message ((to . ,group) (type . "groupchat") (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) (jabber-send-sexp jc stanza)))) ;;; Message decryption (receive) (defun jabber-openpgp-legacy--detect-encrypted (xml-data) "Return stripped armor text from \"jabber:x:encrypted\" child of XML-DATA, 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 XML-DATA. 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) (jabber-chain-add 'jabber-presence-chain #'jabber-openpgp-legacy--process-presence 30) (provide 'jabber-openpgp-legacy) ;;; jabber-openpgp-legacy.el ends here emacs-jabber-0.13.1/lisp/jabber-openpgp.el000066400000000000000000000554661523531702000203110ustar00rootroot00000000000000;;; 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 'jabber-util) (require 'epg) (require 'jabber-pubsub) (require 'jabber-xml) (require 'jabber-hints) (require 'jabber-eme) (require 'jabber-chat) (require 'jabber-disco) (eval-when-compile (require 'pcase)) (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. Keyring search for \"xmpp:BARE-JID\" User ID 3. Keyring search for BARE-JID as-is (email-style UID)" (let* ((bare-jid (jabber-connection-bare-jid jc)) (ctx (epg-make-context 'OpenPGP)) (fingerprint (cdr (assoc bare-jid jabber-openpgp-key-alist)))) (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'" 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 &optional failure) "Ensure public keys for all JIDS are available, then call CALLBACK. For any JID whose key is missing locally, fetch it via PubSub over JC. CALLBACK is called with no arguments once all keys are resolved. FAILURE receives an error string 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 (let ((reason (format "OpenPGP: could not fetch keys for: %s" (string-join failed ", ")))) (if failure (funcall failure reason) (message "%s" reason))) (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 on JC: advertise and publish key if configured. Added to `jabber-post-connect-hooks'." (when (jabber-openpgp--our-key-safe jc) (jabber-disco-advertise-feature (concat jabber-openpgp-pubkeys-node "+notify")) (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 success-callback failure-callback) "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)) (chat-with jabber-chatting-with) (buffer (current-buffer)) (id (format "emacs-msg-%.6f" (float-time))) (send-context (jabber-chat--capture-send-context body extra-elements)) (extra-elements (plist-get send-context :extra-elements)) (failed (lambda (reason) (when (buffer-live-p buffer) (with-current-buffer buffer (jabber-chat--restore-send-context send-context))) (if failure-callback (funcall failure-callback reason) (message "%s" reason))))) (jabber-openpgp--ensure-recipient-keys jc (list recipient) (lambda () (if (not (buffer-live-p buffer)) (funcall failed "OpenPGP: chat buffer closed before send") (with-current-buffer buffer (condition-case err (jabber-openpgp--send-chat-1 jc body recipient chat-with id extra-elements success-callback failed) (error (funcall failed (error-message-string err))))))) failed))) (defun jabber-openpgp--send-chat-1 (jc body recipient chat-with id &optional extra-elements success failure) "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)) (stanza `(message ((to . ,chat-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) (jabber-chat--display-local-message jc msg-plist))) (if (or success failure) (jabber-send-sexp jc stanza success failure) (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--muc-recipient-jids (jc group) "Return GROUP recipients, including JC's account JID. Signal a user error before any pending send state is consumed when the room does not expose participant JIDs." (let* ((recipients (jabber-openpgp--muc-participant-jids group)) (our-jid (jabber-jid-user (jabber-connection-bare-jid jc)))) (unless recipients (user-error "OpenPGP: no participant JIDs available (room may be anonymous)")) (if (member our-jid recipients) recipients (cons our-jid recipients)))) (defun jabber-openpgp--send-muc (jc body &optional extra-elements success-callback failure-callback) "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) (all-jids (jabber-openpgp--muc-recipient-jids jc group)) (buffer (current-buffer)) (id (format "emacs-msg-%.6f" (float-time))) (send-context (jabber-chat--capture-send-context body extra-elements)) (extra-elements (plist-get send-context :extra-elements)) (failed (lambda (reason) (when (buffer-live-p buffer) (with-current-buffer buffer (jabber-chat--restore-send-context send-context))) (if failure-callback (funcall failure-callback reason) (message "%s" reason))))) (jabber-openpgp--ensure-recipient-keys jc all-jids (lambda () (if (not (buffer-live-p buffer)) (funcall failed "OpenPGP: MUC buffer closed before send") (condition-case err (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") (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))) (when (buffer-live-p buffer) (with-current-buffer buffer ;; This runs from the async key-fetch callback where the ;; current buffer is not the MUC buffer; the send hooks ;; read buffer-local state, so restore the buffer first. (jabber-chat--run-send-hooks stanza body id))) (if (or success-callback failure-callback) (jabber-send-sexp jc stanza success-callback failure-callback) (jabber-send-sexp jc stanza))) (error (funcall failed (error-message-string err)))))) failed))) ;;; 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) (defun jabber-openpgp--handle-keys-event (jc from _node items) "Handle PubSub event for an OpenPGP public key update. JC is the connection, FROM is the sender JID, ITEMS is the list of child elements from the event. Fetch the updated key into the local GPG keyring. Bail early if no local key is configured." (when (jabber-openpgp--our-key-safe jc) (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))))))))) (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") (add-hook 'jabber-post-connect-hooks #'jabber-openpgp-on-connect) (provide 'jabber-openpgp) ;;; jabber-openpgp.el ends here emacs-jabber-0.13.1/lisp/jabber-ping.el000066400000000000000000000055231523531702000175630ustar00rootroot00000000000000;;; 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-disco) ;; Global reference declarations (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-0.13.1/lisp/jabber-presence-display.el000066400000000000000000000030721523531702000220720ustar00rootroot00000000000000;;; jabber-presence-display.el --- Shared presence display data -*- 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, or (at your option) ;; any later version. ;;; Commentary: ;; Immutable mappings shared by presence renderers and completion UI. ;;; Code: ;;;###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.") (provide 'jabber-presence-display) ;;; jabber-presence-display.el ends here emacs-jabber-0.13.1/lisp/jabber-presence-events.el000066400000000000000000000050731523531702000217340ustar00rootroot00000000000000;;; jabber-presence-events.el --- Presence effect dispatch -*- 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: ;; Keeps presence parsing independent from roster, chat, and MUC effects. ;;; Code: (defvar jabber-presence-roster-update-functions nil "Functions called with a parsed roster update. Arguments are connection, new items, changed items, and deleted items.") (defvar jabber-presence-muc-functions nil "Functions called with a connection and an incoming MUC presence stanza.") (defvar jabber-presence-contact-functions nil "Functions called with a connection and ordinary presence sender.") (defvar jabber-presence-subscription-request-functions nil "Functions called with a connection, sender, and subscription status.") (defun jabber-presence-events-dispatch-roster-update (jc new-items changed-items deleted-items) "Dispatch a roster update for JC. NEW-ITEMS, CHANGED-ITEMS, and DELETED-ITEMS are JID symbol lists." (run-hook-with-args 'jabber-presence-roster-update-functions jc new-items changed-items deleted-items)) (defun jabber-presence-events-dispatch-muc (jc presence) "Dispatch an incoming MUC PRESENCE stanza on JC." (run-hook-with-args 'jabber-presence-muc-functions jc presence)) (defun jabber-presence-events-dispatch-contact (jc from) "Dispatch ordinary presence from FROM on JC." (run-hook-with-args 'jabber-presence-contact-functions jc from)) (defun jabber-presence-events-dispatch-subscription-request (jc from presence-status) "Dispatch a subscription request from FROM on JC with PRESENCE-STATUS." (run-hook-with-args 'jabber-presence-subscription-request-functions jc from presence-status)) (provide 'jabber-presence-events) ;;; jabber-presence-events.el ends here emacs-jabber-0.13.1/lisp/jabber-presence.el000066400000000000000000000564131523531702000204360ustar00rootroot00000000000000;;; 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-disco) (require 'jabber-iq) (require 'jabber-lifecycle) (require 'jabber-alert) (require 'jabber-util) (require 'jabber-muc-protocol) (require 'jabber-muc-state) (require 'jabber-presence-events) (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.") (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 for STATE-DATA. 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-presence-events-dispatch-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--request-initial-roster (jc) "Request the initial roster for JC." (jabber-send-iq jc nil "get" `(query ((xmlns . ,jabber-roster-xmlns))) #'jabber-process-roster 'initial #'jabber-initial-roster-failure nil)) (add-hook 'jabber-lifecycle-session-bootstrap-functions #'jabber-presence--request-initial-roster) (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--resource-plist (resource &rest properties) "Return a copy of RESOURCE updated with PROPERTIES." (let ((result (copy-sequence resource))) (while properties (setq result (plist-put result (pop properties) (pop properties)))) result)) (defun jabber-presence--resource-transition (type resource current metadata) "Return the presence transition for RESOURCE given TYPE and METADATA. CURRENT is the existing resource plist. The result contains `:newstatus' and `:resource', plus `:clear-all' and `:status' when a bare unavailable or error presence resets the buddy." (let ((show (plist-get metadata :show)) (status (plist-get metadata :status)) (error-xml (plist-get metadata :error)) (priority (plist-get metadata :priority))) (cond ((and (string= resource "") (member type '("unavailable" "error"))) (list :newstatus (and (string= type "error") "error") :resource nil :clear-all t :status (if error-xml (jabber-parse-error error-xml) status))) ((string= type "unavailable") (list :newstatus nil :resource (jabber-presence--resource-plist current 'connected nil 'show nil 'status status))) ((string= type "error") (list :newstatus "error" :resource (jabber-presence--resource-plist current 'connected nil 'show "error" 'status (if error-xml (jabber-parse-error error-xml) status)))) ((member type '("unsubscribe" "subscribed" "unsubscribed")) (list :newstatus type :resource current)) (t (list :newstatus (or show "") :resource (jabber-presence--resource-plist current 'connected t 'show (or show "") 'status status 'priority priority)))))) (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* ((current (cdr (assoc resource (get buddy 'resources)))) (transition (jabber-presence--resource-transition type resource current metadata)) (newstatus (plist-get transition :newstatus)) (resource-plist (plist-get transition :resource))) (when (plist-get transition :clear-all) ;; A bare unavailable or error presence takes every resource offline. (put buddy 'resources nil) (put buddy 'connected nil) (put buddy 'show newstatus) (put buddy 'status (plist-get transition :status))) (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'." (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-presence-events-dispatch-subscription-request jc from (plist-get metadata :status))) ((jabber-muc-presence-p xml-data) (jabber-presence-events-dispatch-muc jc xml-data)) (t (jabber-presence-events-dispatch-contact 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-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))) ;;;###autoload (defun jabber-send-presence (show status priority &optional jc) "Set presence to SHOW with STATUS message and PRIORITY. SHOW is one of \"\", \"away\", \"chat\", \"dnd\", \"xa\". 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))))))) (run-hooks 'jabber-presence-sent-hooks)) (defun jabber-presence-children (jc) "Return the children for a stanza. JC is the Jabber connection." (append (delq nil (list (when (and jabber-current-status (> (length jabber-current-status) 0)) `(status () ,jabber-current-status)) (when (and jabber-current-show (> (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 presence to away with the given STATUS message. 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 the given STATUS message. 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-presence--refresh-advertised-features () "Resend presence with the current advertised feature set." (mapc #'jabber-send-current-presence jabber-connections)) (add-hook 'jabber-disco-features-changed-hook #'jabber-presence--refresh-advertised-features) (defun jabber-send-subscription-request (jc to &optional request) "Send a subscription request to TO. REQUEST, if non-empty, is included as the status text. 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 roster item JID with NAME and GROUPS. 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) "Remove JID from the roster on connection JC." (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")) (provide 'jabber-presence) ;;; jabber-presence.el ends here emacs-jabber-0.13.1/lisp/jabber-private.el000066400000000000000000000051451523531702000203000ustar00rootroot00000000000000;;; 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) "Pass the inner private XML node from XML-DATA to SUCCESS-CALLBACK. JC is the Jabber connection." (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-0.13.1/lisp/jabber-pubsub.el000066400000000000000000000152411523531702000201240ustar00rootroot00000000000000;;; 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 ;;; 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)))))))) (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-0.13.1/lisp/jabber-reactions.el000066400000000000000000000517761523531702000206300ustar00rootroot00000000000000;;; jabber-reactions.el --- XEP-0444 Message Reactions -*- 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-0444 Message Reactions data helpers and outgoing stanza support. ;;; Code: (require 'cl-lib) (require 'ewoc) (require 'subr-x) (require 'jabber-buffer-registry) (require 'jabber-chatbuffer) (require 'jabber-db) (require 'jabber-disco) (require 'jabber-util) (require 'jabber-muc-state) (require 'jabber-message-thread) (defconst jabber-reactions-xmlns "urn:xmpp:reactions:0" "XEP-0444 Message Reactions namespace.") (defconst jabber-reactions-hints-xmlns "urn:xmpp:hints" "XEP-0334 Message Processing Hints namespace.") (defconst jabber-reactions-fallback-xmlns "urn:xmpp:fallback:0" "XEP-0428 Fallback Indication namespace.") (defcustom jabber-reactions-default-choices '("👍" "❤️" "😂" "🎉" "😮" "😢" "🙏") "Reaction strings offered by the outgoing reaction picker. This list is only a default set of picker choices. Incoming reactions are not filtered against it." :type '(repeat string) :group 'jabber) (defface jabber-reaction '((t :inherit shadow)) "Face for message reaction summaries." :group 'jabber) (defface jabber-reaction-chosen '((t :inherit success)) "Face for message reactions selected by the local user." :group 'jabber) (defvar jabber-buffer-connection) (defvar jabber-chat-ewoc) (defvar jabber-chatting-with) (defvar jabber-group) (defvar jabber-point-insert) ;; Chat and MUC are loaded before their reaction-specific paths run. (declare-function jabber-chat--unwrap-carbon "jabber-chat" (jc xml-data)) (declare-function jabber-muc-find-buffer "jabber-muc" (group &optional jc)) ;;; Pure helpers (defun jabber-reactions--deduplicate (reactions) "Return REACTIONS without duplicates, nils, or empty strings. The first occurrence of each non-empty string is kept." (let ((seen nil) (result nil)) (dolist (reaction reactions (nreverse result)) (when (and (stringp reaction) (not (string-empty-p reaction)) (not (member reaction seen))) (push reaction seen) (push reaction result))))) (defun jabber-reactions--target-id (msg muc-p) "Return the XEP-0444 target message ID from MSG. Use :server-id for MUC messages when MUC-P is non-nil. For 1:1 chat messages prefer :origin-id and fall back to :id." (if muc-p (plist-get msg :server-id) (or (plist-get msg :origin-id) (plist-get msg :id)))) (defun jabber-reactions--message-attributes (to type outgoing-id) "Return message attributes for reaction stanza TO TYPE OUTGOING-ID." (append `((to . ,to) (type . ,type)) (and outgoing-id `((id . ,outgoing-id))))) (defun jabber-reactions--build-stanza (to type target-id reactions outgoing-id) "Build an outgoing XEP-0444 reaction stanza. TO is the destination JID. TYPE is the message type string. TARGET-ID is the stanza ID of the message being reacted to. REACTIONS is a list of selected reaction strings. OUTGOING-ID is the ID for the outgoing message stanza, or nil to omit it." `(message ,(jabber-reactions--message-attributes to type outgoing-id) (reactions ((xmlns . ,jabber-reactions-xmlns) (id . ,target-id)) ,@(mapcar (lambda (reaction) `(reaction () ,reaction)) (jabber-reactions--deduplicate reactions))) (store ((xmlns . ,jabber-reactions-hints-xmlns))))) (defun jabber-reactions--display-entry (reaction senders chosen-sender) "Build a display entry for REACTION by SENDERS. Non-nil CHOSEN-SENDER marks entries selected by that sender." (list :reaction reaction :count (length senders) :chosen (and chosen-sender (member chosen-sender senders) t) :senders senders)) (defun jabber-reactions--display-entries (sender-state &optional chosen-sender) "Aggregate SENDER-STATE into reaction display entries. SENDER-STATE is an alist of (SENDER . REACTIONS), where REACTIONS is a list of reaction strings currently selected by SENDER. CHOSEN-SENDER is used to mark locally selected reactions. Return a list of plists with :reaction, :count, :chosen, and :senders keys, preserving the first-seen reaction order." (let ((order nil) (senders-by-reaction nil)) (dolist (entry sender-state) (let ((sender (car entry))) (dolist (reaction (jabber-reactions--deduplicate (cdr entry))) (unless (assoc reaction senders-by-reaction) (push reaction order)) (cl-pushnew sender (alist-get reaction senders-by-reaction nil nil #'equal) :test #'equal)))) (mapcar (lambda (reaction) (jabber-reactions--display-entry reaction (nreverse (alist-get reaction senders-by-reaction nil nil #'equal)) chosen-sender)) (nreverse order)))) (defun jabber-reactions--sender-name (sender) "Return a human-readable name for reaction SENDER key. SENDER is a MUC occupant JID (\"room@host/nick\") or a 1:1 bare JID. Prefer the MUC nick, then the roster display name, then SENDER itself." (or (jabber-jid-resource sender) (jabber-jid-displayname sender) sender)) (defun jabber-reactions--entry-help-echo (entry) "Return help-echo text naming who sent reaction ENTRY, or nil. ENTRY is a display plist from `jabber-reactions--display-entries'. The text reads \"REACTION: name1, name2\" so it stays self-explanatory in a tooltip or in the echo area via `display-local-help'." (when-let* ((senders (plist-get entry :senders))) (format "%s: %s" (plist-get entry :reaction) (string-join (mapcar #'jabber-reactions--sender-name senders) ", ")))) (defun jabber-reactions--sender-reactions (sender msg) "Return SENDER's current reactions from MSG." (copy-sequence (alist-get sender (plist-get msg :reactions) nil nil #'equal))) (defun jabber-reactions--toggle-reaction (reaction reactions) "Return REACTIONS with REACTION toggled. Existing REACTION is removed. Missing REACTION is appended after the current deduplicated reaction list." (let ((deduplicated (jabber-reactions--deduplicate reactions))) (if (member reaction deduplicated) (remove reaction deduplicated) (append deduplicated (list reaction))))) (defun jabber-reactions--replace-sender-reactions (sender sender-reactions reactions) "Return REACTIONS with SENDER replaced by SENDER-REACTIONS. When SENDER-REACTIONS is nil, remove SENDER from REACTIONS." (let ((without-sender (cl-remove sender reactions :key #'car :test #'equal)) (deduplicated (jabber-reactions--deduplicate sender-reactions))) (if deduplicated (cons (cons sender deduplicated) without-sender) without-sender))) (defun jabber-reactions--parse-element (reactions) "Return (TARGET-ID REACTIONS) parsed from REACTIONS element. REACTIONS is a XEP-0444 `' XML node. Empty strings and repeated reaction strings are ignored. The reaction list may be nil for an empty update." (when-let* ((target-id (jabber-xml-get-attribute reactions 'id))) (list target-id (jabber-reactions--deduplicate (mapcar (lambda (reaction) (car (jabber-xml-node-children reaction))) (jabber-xml-get-children reactions 'reaction)))))) (defun jabber-reactions--single-element (message) "Return MESSAGE's sole XEP-0444 reactions element, or nil." (let ((reactions (cl-remove-if-not (lambda (child) (string= (jabber-xml-get-attribute child 'xmlns) jabber-reactions-xmlns)) (jabber-xml-get-children message 'reactions)))) (and (null (cdr reactions)) (car reactions)))) (defun jabber-reactions--fallback-for-reactions-p (fallback) "Return non-nil when FALLBACK is XEP-0444 reaction fallback text. Mark fallback text as reaction-only when the fallback element covers the body." (and (string= (or (jabber-xml-get-attribute fallback 'xmlns) "") jabber-reactions-fallback-xmlns) (string= (or (jabber-xml-get-attribute fallback 'for) "") jabber-reactions-xmlns))) (defun jabber-reactions--body-text (xml-data) "Return the plain `' text from XML-DATA, or nil." (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'body))))) (defun jabber-reactions--integer-attribute (xml-data attribute) "Return XML-DATA's integer ATTRIBUTE, or nil when malformed." (when-let* ((value (jabber-xml-get-attribute xml-data attribute)) ((string-match-p "\\`[0-9]+\\'" value))) (string-to-number value))) (defun jabber-reactions--element-children (xml-data) "Return XML-DATA's child elements." (cl-remove-if-not #'listp (jabber-xml-node-children xml-data))) (defun jabber-reactions--fallback-body-range (fallback) "Return FALLBACK body coverage as `whole', (START END), or nil." (let ((children (jabber-reactions--element-children fallback))) (if (null children) 'whole (when-let* ((body (car (jabber-xml-get-children fallback 'body)))) (let ((start-attr (jabber-xml-get-attribute body 'start)) (end-attr (jabber-xml-get-attribute body 'end))) (cond ((and (null start-attr) (null end-attr)) 'whole) ((and start-attr end-attr) (when-let* ((start (jabber-reactions--integer-attribute body 'start)) (end (jabber-reactions--integer-attribute body 'end))) (list start end))))))))) (defun jabber-reactions--range-covers-body-p (range body) "Return non-nil when RANGE covers all of BODY." (or (eq range 'whole) (pcase range (`(,start ,end) (and (zerop start) (>= end (length body))))))) (defun jabber-reactions--fallback-body-p (xml-data) "Return non-nil when XML-DATA's body is only XEP-0444 fallback text." (when-let* ((body (jabber-reactions--body-text xml-data))) (cl-some (lambda (fallback) (and (jabber-reactions--fallback-for-reactions-p fallback) (jabber-reactions--range-covers-body-p (jabber-reactions--fallback-body-range fallback) body))) (jabber-xml-get-children xml-data 'fallback)))) (defun jabber-reactions--reaction-only-p (xml-data) "Return non-nil when XML-DATA is only a reaction update stanza. A reaction-only stanza has a XEP-0444 `' payload and no real `', `', or `' child. A `' fully marked as XEP-0428 fallback for reactions does not count as a real body." (and (jabber-xml-child-with-xmlns xml-data jabber-reactions-xmlns) (or (not (jabber-xml-get-children xml-data 'body)) (jabber-reactions--fallback-body-p xml-data)) (not (jabber-xml-get-children xml-data 'subject)) (not (jabber-xml-get-children xml-data 'error)))) (defun jabber-reactions--history-inhibit-p (_jc xml-data) "Return non-nil when XML-DATA should not be stored as a message body." (jabber-reactions--reaction-only-p xml-data)) (defun jabber-reactions--incoming-sender (from type) "Return the reaction sender key for incoming FROM and message TYPE." (when from (if (string= type "groupchat") from (jabber-jid-user from)))) (defun jabber-reactions--buffer-for-stanza (jc from type) "Return the displayed chat buffer for incoming FROM and message TYPE on JC." (when from (if (string= type "groupchat") (jabber-muc-find-buffer (jabber-jid-user from) jc) (jabber-buffer-registry-find 'chat (jabber-jid-user from))))) (defun jabber-reactions--storage-peer (jc message type) "Return the DB peer for reaction-bearing MESSAGE on JC with TYPE." (let ((from (jabber-xml-get-attribute message 'from)) (to (jabber-xml-get-attribute message 'to))) (if (string= type "groupchat") (and from (jabber-jid-user from)) (let ((account (jabber-connection-bare-jid jc))) (cond ((and from (string= (jabber-jid-user from) account)) (and to (jabber-jid-user to))) (from (jabber-jid-user from)) (to (jabber-jid-user to))))))) (defun jabber-reactions--message-updated-at (message) "Return the source timestamp for reaction MESSAGE, or nil. Nil means MESSAGE has no delayed/source timestamp and should be applied in arrival order." (when-let* ((timestamp (jabber-message-timestamp message))) (floor (float-time timestamp)))) (defun jabber-reactions--persist-update (jc message target-id sender reactions) "Persist SENDER's REACTIONS for TARGET-ID from MESSAGE on JC. Return :stale when persistent storage confirms MESSAGE is stale." (let ((type (or (jabber-xml-get-attribute message 'type) "chat")) (updated-at (jabber-reactions--message-updated-at message))) (when-let* ((account (jabber-connection-bare-jid jc)) (peer (jabber-reactions--storage-peer jc message type))) (unless (jabber-db-replace-reactions account peer type target-id sender reactions updated-at) (when (jabber-db-reaction-stale-p account peer type target-id sender updated-at) :stale))))) (defun jabber-reactions--unwrap-stanza (jc xml-data) "Return (MESSAGE . BUFFER) for reaction-bearing XML-DATA on JC." (if (or (string= (or (jabber-xml-get-attribute xml-data 'type) "") "groupchat") (not (fboundp 'jabber-chat--unwrap-carbon))) (cons xml-data nil) (jabber-chat--unwrap-carbon jc xml-data))) (defun jabber-reactions--update-message (msg sender sender-reactions) "Return MSG with SENDER's reactions replaced by SENDER-REACTIONS." (plist-put (copy-sequence msg) :reactions (jabber-reactions--replace-sender-reactions sender sender-reactions (plist-get msg :reactions)))) (defun jabber-reactions--local-sender () "Return the local sender key for reaction state in the current buffer." (when jabber-buffer-connection (if (bound-and-true-p jabber-group) (when-let* ((nick (jabber-muc-nickname jabber-group jabber-buffer-connection))) (concat jabber-group "/" nick)) (jabber-connection-bare-jid jabber-buffer-connection)))) ;;; Command support (defun jabber-reactions--composition-point-p () "Return non-nil when point is in the chat composition area." (and (boundp 'jabber-point-insert) (markerp jabber-point-insert) (>= (point) jabber-point-insert))) (defun jabber-reactions--message-id () "Return a generated message ID for outgoing reaction stanzas." (format "emacs-reaction-%.6f" (float-time))) (defun jabber-reactions--reactable-node-at-point () "Return reaction context for the EWOC node at point, or nil. The returned list has the form (NODE MSG TARGET-ID)." (unless (jabber-reactions--composition-point-p) (when-let* ((node (and (bound-and-true-p jabber-chat-ewoc) (ewoc-locate jabber-chat-ewoc (point)))) (data (ewoc-data node)) ((listp data)) (msg (cadr data)) ((listp msg)) (target-id (jabber-reactions--target-id msg (bound-and-true-p jabber-group)))) (list node msg target-id)))) (defun jabber-reactions--insert-literal-bang () "Insert a literal exclamation mark in the composition area." (when (and (boundp 'jabber-point-insert) (markerp jabber-point-insert) (< (point) jabber-point-insert)) (goto-char jabber-point-insert)) (insert "!")) (defun jabber-reactions--chat-target () "Return reaction stanza target information for the current buffer. The returned list has the form (TO TYPE), or nil outside chat and MUC buffers with a known destination." (cond ((bound-and-true-p jabber-group) (list jabber-group "groupchat")) ((bound-and-true-p jabber-chatting-with) (list jabber-chatting-with "chat")))) (defun jabber-reactions--optimistic-update (node msg sender sender-reactions) "Update NODE's MSG reaction state for SENDER to SENDER-REACTIONS." (let* ((reactions (plist-get msg :reactions)) (updated-msg (plist-put (copy-sequence msg) :reactions (jabber-reactions--replace-sender-reactions sender sender-reactions reactions)))) (setcar (cdr (ewoc-data node)) updated-msg) (jabber-chat-ewoc-invalidate node))) ;;;###autoload (defun jabber-reactions-react-at-point-or-insert () "React to the message at point, or insert a literal exclamation mark." (interactive) (pcase-let ((`(,node ,msg ,target-id) (jabber-reactions--reactable-node-at-point)) (`(,to ,type) (jabber-reactions--chat-target)) (sender (jabber-reactions--local-sender))) (if (and node msg target-id to type sender) (let ((reaction (completing-read "Reaction: " jabber-reactions-default-choices nil nil))) (when (string-empty-p reaction) (user-error "Reaction cannot be empty")) (let ((sender-reactions (jabber-reactions--toggle-reaction reaction (jabber-reactions--sender-reactions sender msg)))) (jabber-send-sexp jabber-buffer-connection (jabber-reactions--build-stanza to type target-id sender-reactions (jabber-reactions--message-id))) (jabber-db-replace-reactions (jabber-connection-bare-jid jabber-buffer-connection) (jabber-jid-user to) type target-id sender sender-reactions) (unless (bound-and-true-p jabber-group) (jabber-reactions--optimistic-update node msg sender sender-reactions)))) (jabber-reactions--insert-literal-bang)))) ;;; Incoming updates (defun jabber-reactions--apply-incoming-update (node sender sender-reactions) "Apply SENDER's SENDER-REACTIONS to the message stored in NODE." (when-let* ((data (ewoc-data node)) ((listp data)) (msg (cadr data)) ((listp msg))) (setcar (cdr data) (jabber-reactions--update-message msg sender sender-reactions)) (jabber-chat-ewoc-invalidate node))) (defun jabber-reactions--handle-message (jc xml-data) "Handle incoming XEP-0444 reaction stanzas in XML-DATA on JC. Update stored and visible reaction state for the sending entity." (pcase-let* ((`(,message . ,carbon-buffer) (jabber-reactions--unwrap-stanza jc xml-data))) (when-let* ((reactions (jabber-reactions--single-element message)) (parsed (jabber-reactions--parse-element reactions)) (from (jabber-xml-get-attribute message 'from)) (type (or (jabber-xml-get-attribute message 'type) "chat")) (sender (jabber-reactions--incoming-sender from type))) (unless (eq (jabber-reactions--persist-update jc message (car parsed) sender (cadr parsed)) :stale) (when-let* ((peer (jabber-reactions--storage-peer jc message type))) (let* ((thread-targets (jabber-message-thread-update-targets jc peer type (car parsed) (string= type "groupchat"))) (buffers (cond ((eq thread-targets 'closed) nil) (thread-targets thread-targets) (t (delq nil (list (or carbon-buffer (jabber-reactions--buffer-for-stanza jc from type)))))))) (dolist (buffer buffers) (with-current-buffer buffer (when-let* ((node (jabber-chat-ewoc-find-by-id (car parsed)))) (jabber-reactions--apply-incoming-update node sender (cadr parsed))))))))))) (jabber-chain-add 'jabber-message-chain #'jabber-reactions--handle-message -5) (add-to-list 'jabber-history-inhibit-received-message-functions #'jabber-reactions--history-inhibit-p) ;;; Disco (jabber-disco-advertise-feature jabber-reactions-xmlns) (provide 'jabber-reactions) ;;; jabber-reactions.el ends here emacs-jabber-0.13.1/lisp/jabber-receipts.el000066400000000000000000000425151523531702000204460ustar00rootroot00000000000000;;; 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-util) (require 'jabber-core) (require 'jabber-chat) (require 'jabber-muc) (require 'jabber-db) (require 'jabber-disco) (require 'jabber-message-thread) (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.") (defun jabber-receipts--sender-authorized-p (jc from) "Return non-nil when FROM may observe presence for JC." (let ((bare-jid (jabber-jid-user from))) (or (and (jabber-jid-resource from) (jabber-muc-joined-p bare-jid jc)) (when-let* ((contact (jabber-jid-symbol bare-jid)) ((memq contact (plist-get (fsm-get-state-data jc) :roster)))) (member (get contact 'subscription) '("from" "both")))))) ;;; 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. MUC chat markers need per-occupant tracking, so do not request them from groupchat messages until that state exists." (if (bound-and-true-p jabber-group) nil `((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--display-buffer (jc effective from) "Return the buffer that can mark EFFECTIVE from FROM displayed on JC. Return nil when a dedicated thread owns the message but is closed." (let* ((peer (jabber-jid-user from)) (parent (jabber-receipts--find-buffer from jc)) (private-p (and (jabber-jid-resource from) (jabber-muc-joined-p peer jc))) (msg (jabber-chat--msg-plist-from-stanza effective))) (if (or private-p (not (plist-get msg :thread-id))) parent (pcase (jabber-message-thread-display-target jc peer "chat" msg) ('parent parent) ((and target (pred buffer-live-p)) target))))) (defun jabber-receipts--effective-stanza (jc xml-data) "Return (EFFECTIVE-XML . CARBON-TYPE) for XML-DATA on JC. CARBON-TYPE is nil (not a carbon), `received', or `sent'. For carbons, EFFECTIVE-XML is the inner forwarded message; for non-carbons it is XML-DATA unchanged. Returns (nil . invalid) for forged carbons whose outer from does not match our bare JID (CVE-2017-5589)." (let ((carbon (jabber-chat--extract-carbon xml-data))) (if (not carbon) (cons xml-data nil) (let ((outer-from-bare (jabber-jid-user (jabber-xml-get-attribute xml-data 'from))) (our-bare (jabber-connection-bare-jid jc))) (if (string= outer-from-bare our-bare) (cons (cdr carbon) (car carbon)) (warn "Jabber: dropping forged carbon receipts from %s" outer-from-bare) (cons nil 'invalid)))))) (defun jabber-receipts--process-incoming-markers (jc effective from) "Dispatch incoming markers in EFFECTIVE stanza from FROM. Handles XEP-0184 , XEP-0333 and . JC is the connection." ;; XEP-0184: (when-let* ((received (jabber-xml-child-with-xmlns effective 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 effective 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 effective 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"))) (defun jabber-receipts--maybe-send-receipt (jc effective from carbon-type) "Send XEP-0184 reply if EFFECTIVE requests it. Suppressed for carbons (primary resource owns the receipt) and MAM-replayed messages. JC is the connection, FROM is the sender, CARBON-TYPE is nil, `received', or `sent'." (let ((id (jabber-xml-get-attribute effective 'id))) (when (and jabber-chat-send-receipts id (null carbon-type) (jabber-receipts--sender-authorized-p jc from) (not (jabber-xml-get-attribute effective 'jabber-mam--origin)) (jabber-xml-get-children effective 'body) (let ((req (jabber-xml-child-with-xmlns effective 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)))))))) (defun jabber-receipts--track-displayed (jc effective from carbon-type) "Queue or send for the markable message in EFFECTIVE. If the chat buffer is visible, send immediately; otherwise queue the id for `jabber-receipts--on-window-change' to flush later. Skipped for `sent' carbons (we are the sender) and MAM replays. JC is the connection, FROM is the sender, CARBON-TYPE is nil, `received', or `sent'." (when-let* ((id (jabber-xml-get-attribute effective 'id)) ((not (eq carbon-type 'sent))) ((jabber-receipts--sender-authorized-p jc from)) ((not (jabber-xml-get-attribute effective 'jabber-mam--origin))) ((jabber-xml-get-children effective 'body)) (marker (jabber-xml-child-with-xmlns effective jabber-chat-markers-xmlns)) ((eq (jabber-xml-node-name marker) 'markable))) (when-let* ((buffer (jabber-receipts--display-buffer jc effective from))) (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))))))) (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'. Unwraps XEP-0280 Message Carbons before dispatching to sub-handlers." (let* ((eff (jabber-receipts--effective-stanza jc xml-data)) (effective (car eff)) (carbon-type (cdr eff))) (when (and effective (not (eq carbon-type 'invalid))) (let* ((from (jabber-xml-get-attribute effective 'from)) (type (jabber-xml-get-attribute effective 'type)) (groupchat-p (equal type "groupchat"))) (unless (or (null from) groupchat-p) ;; Incoming markers: skip for `sent' carbons (those carry our ;; own-device outgoing markers, not peer-to-us markers). ;; TODO: cross-device read-sync could use sent-carbon markers ;; to locally mark peer messages as read. (unless (eq carbon-type 'sent) (jabber-receipts--process-incoming-markers jc effective from)) (jabber-receipts--maybe-send-receipt jc effective from carbon-type) (jabber-receipts--track-displayed jc effective from carbon-type)))))) (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--status-upgrades-p (current new) "Return non-nil if NEW is a higher status than CURRENT. Status progression: :sent < :delivered < :displayed. A late-arriving `' from a second resource must not overwrite an earlier `' from another resource." (let ((order '(:sent 0 :delivered 1 :displayed 2))) (< (or (plist-get order current) -1) (or (plist-get order new) -1)))) (defun jabber-receipts--latest-local-node () "Return the most recent outgoing message node in the current buffer." (let ((node (and jabber-chat-ewoc (ewoc-nth jabber-chat-ewoc -1)))) (while (and node (not (eq (car (ewoc-data node)) :local))) (setq node (ewoc-prev jabber-chat-ewoc node))) node)) (defun jabber-receipts--update-buffer-status (buffer ref-id column timestamp status) "Update REF-ID's visible status in BUFFER. COLUMN, TIMESTAMP, and STATUS describe the receipt. Return the pair (ACCEPTED . CASCADE-EPOCH)." (with-current-buffer buffer (when-let* ((node (jabber-chat-ewoc-find-by-id ref-id))) (let* ((msg (cadr (ewoc-data node))) (current-status (plist-get msg :status)) (msg-ts (plist-get msg :timestamp)) (msg-epoch (and msg-ts (floor (float-time msg-ts)))) (displayed-p (string= column "displayed_at")) (forward-p (or (not displayed-p) (not msg-epoch) (> msg-epoch jabber-receipts--latest-displayed-ts))) (inhibit-read-only t)) (when (and forward-p (or (null current-status) (jabber-receipts--status-upgrades-p current-status status))) (plist-put msg :status status) (jabber-chat-ewoc-invalidate node) (when (eq node (jabber-receipts--latest-local-node)) (jabber-receipts--update-header-line column timestamp)) (when displayed-p (when msg-epoch (setq jabber-receipts--latest-displayed-ts msg-epoch)) (jabber-receipts--cascade-displayed node)) (cons t (and displayed-p msg-epoch))))))) (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\". Never downgrade a visible message from `:displayed' to `:delivered'." (let* ((timestamp (floor (float-time))) (account (jabber-connection-bare-jid jc)) (peer (jabber-jid-user from)) (status (if (string= column "displayed_at") :displayed :delivered)) (thread-targets (jabber-message-thread-update-targets jc peer "chat" ref-id)) (buffers (cond ((eq thread-targets 'closed) nil) (thread-targets thread-targets) (t (delq nil (list (jabber-receipts--find-buffer from jc)))))) accepted cascade-epoch) (dolist (buffer buffers) (when-let* ((result (jabber-receipts--update-buffer-status buffer ref-id column timestamp status))) (setq accepted t cascade-epoch (or (cdr result) cascade-epoch)))) (when (or accepted (null buffers)) (jabber-db-update-receipt account peer ref-id column timestamp)) (when cascade-epoch (jabber-db-cascade-displayed account peer timestamp cascade-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)))) (defun jabber-receipts--clear-header-line () "Clear receipt status when sending a new outgoing message." (setq jabber-chat-receipt-message "") (force-mode-line-update)) (defun jabber-receipts--local-message-inserted (_msg) "Clear the old receipt status when a new outgoing message is inserted." (jabber-receipts--clear-header-line)) (add-hook 'jabber-chat-local-message-functions #'jabber-receipts--local-message-inserted) (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 (jabber-receipts--sender-authorized-p jabber-buffer-connection 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-0.13.1/lisp/jabber-register.el000066400000000000000000000277231523531702000204600ustar00rootroot00000000000000;;; 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 'cl-lib) (require 'seq) (require 'subr-x) (require 'jabber-core) (require 'jabber-iq) (require 'jabber-lifecycle) (require 'jabber-xdata) (require 'jabber-xdata-form) ;; Global reference declarations (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 (defvar-local jabber-register--submit-to nil "JID receiving the current registration or search form.") (defvar-local jabber-register--legacy-p nil "Non-nil when the current form uses legacy XEP-0077 or XEP-0055 fields.") (defvar-local jabber-register--registered-p nil "Non-nil when the current legacy XEP-0077 form edits an existing account.") (defvar jabber-register-search-result-function nil "Callback used to render a submitted XEP-0055 search result.") ;; 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 to TO 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-register--start-account-registration (jc) "Start in-band account registration on JC." (jabber-get-register jc nil)) (add-hook 'jabber-lifecycle-registration-functions #'jabber-register--start-account-registration) (defconst jabber-register--legacy-fields '((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")) "Legacy XEP-0077 form fields and labels.") (defun jabber-register--legacy-form (query default-username) "Return plain-data form for legacy QUERY using DEFAULT-USERNAME." (list :title "Legacy registration or search form" :instructions (when-let* ((node (car (jabber-xml-get-children query 'instructions))) (text (car (jabber-xml-node-children node)))) (list text)) :fields (cl-loop for node in (jabber-xml-node-children query) for name = (jabber-xml-node-name node) for label = (cdr (assq name jabber-register--legacy-fields)) when label collect (list :var (symbol-name name) :type (if (eq name 'password) "text-private" "text-single") :label label :values (list (or (car (jabber-xml-node-children node)) (and (eq name 'username) default-username) "")))))) (defun jabber-register--submission (type) "Return current form encoded for its original protocol and request TYPE." (if jabber-register--legacy-p (let ((fields (plist-get (jabber-xdata-form-form) :fields))) (when (and (eq type 'register) (not jabber-register--registered-p)) (when-let* ((missing (seq-find (lambda (field) (string-empty-p (or (car (plist-get field :values)) ""))) fields))) (user-error "%s is required" (or (plist-get missing :label) (plist-get missing :var))))) (cl-loop for field in fields for value = (or (car (plist-get field :values)) "") unless (and (eq type 'search) (string-empty-p value)) collect (list (intern (plist-get field :var)) nil value))) (list (jabber-xdata-form-submit-form)))) (defun jabber-register--close-form () "Close the current registration or search form without submitting." (interactive)) (defun jabber-register--actions (type) "Return form actions for registration or search TYPE." (append (list (list :key "RET" :label "Submit" :command (if (eq type 'register) #'jabber-submit-register #'jabber-submit-search) :submits-form t :stay-open t) (list :key "q" :label "Cancel" :command #'jabber-register--close-form)) (when (eq type 'register) (list (list :key "d" :label "Cancel registration" :command #'jabber-remove-register))))) (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)) (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)) (submit-to (or (jabber-xml-get-attribute xml-data 'from) server)) (xdata (seq-find (lambda (x) (string= (jabber-xml-get-attribute x 'xmlns) jabber-xdata-xmlns)) (jabber-xml-get-children query 'x))) (legacy-p (null xdata)) (form (if xdata (let ((parsed (jabber-xdata-parse xdata))) (if (and register-account (string= (jabber-xdata-form-type xdata) jabber-register-xmlns) (jabber-xdata-field parsed "username")) (jabber-xdata-set-values parsed "username" (list username)) parsed)) (jabber-register--legacy-form query (and register-account username)))) (buffer (jabber-xdata-form-open form (jabber-register--actions type)))) (with-current-buffer buffer (setq-local jabber-buffer-connection jc jabber-register--submit-to submit-to jabber-register--legacy-p legacy-p jabber-register--registered-p (and legacy-p (jabber-xml-get-children query 'registered)))))) (defun jabber-register--submission-callback (jc xml-data closure-data) "Run the callback in CLOSURE-DATA for JC and XML-DATA. Close its form buffer after a successful submission callback." (funcall (plist-get closure-data :callback) jc xml-data (plist-get closure-data :callback-data)) (when-let* (((plist-get closure-data :close-form)) (buffer (plist-get closure-data :buffer)) ((buffer-live-p buffer))) (with-current-buffer buffer (set-buffer-modified-p nil)) (kill-buffer buffer))) (defun jabber-register--submission-callback-data (callback callback-data close-form) "Return form callback data for CALLBACK with CALLBACK-DATA. CLOSE-FORM non-nil closes the current form after CALLBACK returns." (list :callback callback :callback-data callback-data :buffer (current-buffer) :close-form close-form)) (defun jabber-submit-register (&rest _ignore) "Submit registration input. See `jabber-process-register-or-search'." (interactive) (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-register--submit-to)) (error-handler (if registerp #'jabber-report-success handler)) (error-text (if registerp "Account registration" text))) (jabber-send-iq jabber-buffer-connection jabber-register--submit-to "set" `(query ((xmlns . ,jabber-register-xmlns)) ,@(jabber-register--submission 'register)) #'jabber-register--submission-callback (jabber-register--submission-callback-data handler (if registerp 'success text) t) #'jabber-register--submission-callback (jabber-register--submission-callback-data error-handler error-text nil))) (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-submit-search (&rest _ignore) "Submit the current XEP-0055 search form." (interactive) (unless jabber-register-search-result-function (user-error "Jabber search support is not loaded")) (let ((text (concat "Search at " jabber-register--submit-to))) (jabber-send-iq jabber-buffer-connection jabber-register--submit-to "set" `(query ((xmlns . ,jabber-search-xmlns)) ,@(jabber-register--submission 'search)) #'jabber-register--submission-callback (jabber-register--submission-callback-data #'jabber-process-data jabber-register-search-result-function t) #'jabber-register--submission-callback (jabber-register--submission-callback-data #'jabber-report-success text nil)) (message "Search sent"))) (defun jabber-remove-register (&rest _ignore) "Cancel registration. See `jabber-process-register-or-search'." (interactive) (if (or jabber-silent-mode (yes-or-no-p (concat "Are you sure that you want to cancel your registration to " jabber-register--submit-to "? "))) (jabber-send-iq jabber-buffer-connection jabber-register--submit-to "set" `(query ((xmlns . ,jabber-register-xmlns)) (remove)) #'jabber-report-success "Unregistration" #'jabber-report-success "Unregistration"))) (provide 'jabber-register) ;;; jabber-register.el ends here emacs-jabber-0.13.1/lisp/jabber-roster-menu.el000066400000000000000000000465731523531702000211200ustar00rootroot00000000000000;;; jabber-roster-menu.el --- Roster commands and popup menus -*- 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, or (at your option) ;; any later version. ;;; Commentary: ;; Interactive roster commands and their cross-feature popup menus. ;;; Code: (require 'cl-lib) (require 'keymap-popup) (require 'jabber-activity) (require 'jabber-blocking) (require 'jabber-bookmarks) (require 'jabber-browse) (require 'jabber-chat) (require 'jabber-core) (require 'jabber-disco) (require 'jabber-info) (require 'jabber-muc) (require 'jabber-presence) (require 'jabber-presence-display) (require 'jabber-roster) (require 'jabber-version) (declare-function jabber-omemo-show-fingerprints "jabber-omemo-trust" (jc)) (defvar jabber-current-show) ; jabber.el (defvar jabber-activity-jids) ; jabber-activity.el (defvar jabber-muc--rooms) ; jabber-muc.el (defvar jabber-roster-account-action-map) (defvar jabber-roster-contact-action-map) (defvar jabber-roster-discovery-map) (defvar jabber-roster-popup-map) (defvar jabber-roster-presence-map) (defvar jabber-roster--scoped-connection nil "When non-nil, a connection object to scope roster views to. Only contacts and rooms belonging to this connection are shown.") ;;; Roster commands (defun jabber-roster--contacts () "Return roster contacts, filtered by scope if active." (if jabber-roster--scoped-connection (plist-get (fsm-get-state-data jabber-roster--scoped-connection) :roster) (jabber-concat-rosters))) (defun jabber-roster--online-count () "Return count of contacts with at least one connected resource." (cl-count-if (lambda (buddy) (get buddy 'connected)) (jabber-roster--contacts))) (defun jabber-roster--total-count () "Return total number of contacts across all accounts." (length (jabber-roster--contacts))) (defun jabber-roster--unread-count () "Return number of JIDs with unread activity." (length (bound-and-true-p jabber-activity-jids))) (defun jabber-roster--muc-count () "Return number of currently joined MUC rooms." (if jabber-roster--scoped-connection (let ((count 0)) (maphash (lambda (_room entries) (when (assq jabber-roster--scoped-connection entries) (cl-incf count))) jabber-muc--rooms) count) (hash-table-count jabber-muc--rooms))) (keymap-popup-define jabber-roster-presence-map "Set presence." :description (lambda () (format "Presence (current: %s)" (propertize (or (cdr (assoc jabber-current-show jabber-presence-strings)) "Offline") 'face 'keymap-popup-value))) "o" ("Online" jabber-send-default-presence) "a" ("Away" jabber-send-away-presence) "x" ("Extended away" jabber-send-xa-presence) "p" ("Custom" jabber-send-presence)) (keymap-popup-define jabber-roster-discovery-map "Discovery commands." "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)) (defun jabber-roster--presence-menu () "Show roster presence menu." (interactive) (keymap-popup jabber-roster-presence-map)) (defun jabber-roster--discovery-menu () "Show roster discovery menu." (interactive) (keymap-popup jabber-roster-discovery-map)) (defun jabber-roster--show-omemo-fingerprints () "Show OMEMO fingerprints after loading trust support." (interactive) (require 'jabber-omemo-trust) (call-interactively #'jabber-omemo-show-fingerprints)) (defvar jabber-roster--selected-jid nil "JID selected by `completing-read', used by action submenu.") (keymap-popup-define jabber-roster-contact-action-map "Action for selected contact." :description (lambda () (format "Contact: %s" (propertize (or jabber-roster--selected-jid "?") 'face 'font-lock-constant-face))) "c" ("Chat" jabber-roster--action-chat) "i" ("Info" jabber-roster--action-info) "e" ("Edit" jabber-roster--action-edit) "d" ("Delete" jabber-roster--action-delete) "b" ("Block" jabber-roster--action-block)) (keymap-popup-define jabber-roster-popup-map "Jabber roster." :description (lambda () (if jabber-connections (format "Jabber: %s" (propertize (if jabber-roster--scoped-connection (jabber-connection-bare-jid jabber-roster--scoped-connection) (string-join (mapcar #'jabber-connection-bare-jid jabber-connections) ", ")) 'face 'font-lock-constant-face)) "Jabber (not connected)")) :group "Contacts" "o" ((lambda () (format "Online %s" (propertize (number-to-string (jabber-roster--online-count)) 'face 'success))) jabber-roster-chat-online :if (lambda () jabber-connections)) "c" ((lambda () (format "All contacts %s" (propertize (number-to-string (jabber-roster--total-count)) 'face 'keymap-popup-value))) jabber-roster-chat-any :if (lambda () jabber-connections)) "u" ((lambda () (format "Unread %s" (propertize (number-to-string (jabber-roster--unread-count)) 'face 'warning))) jabber-roster-chat-unread :if (lambda () (bound-and-true-p jabber-activity-jids))) :group "MUC" "m" ((lambda () (format "Joined rooms %s" (propertize (number-to-string (jabber-roster--muc-count)) 'face 'keymap-popup-value))) jabber-roster-switch-muc :if (lambda () (> (jabber-roster--muc-count) 0)) :c-u "match by room name") "j" ("Join room" jabber-muc-join :if (lambda () jabber-connections)) "B" ("Bookmarks" jabber-edit-bookmarks :if (lambda () jabber-connections)) :group "Roster" "a" ("Add contact" jabber-roster-change :if (lambda () jabber-connections)) "s" ("Subscribe" jabber-send-subscription-request :if (lambda () jabber-connections)) :row :group "Presence" "p" ("Presence" jabber-roster--presence-menu :if (lambda () jabber-connections)) :group "Discovery" "d" ("Discovery" jabber-roster--discovery-menu :if (lambda () jabber-connections)) :group "Connection" "C" ("Connect" jabber-connect-all :if (lambda () (null jabber-connections))) "D" ("Disconnect all" jabber-disconnect :if (lambda () jabber-connections)) "A" ((lambda () (format "Accounts %s" (propertize (format "[%s]" (if jabber-roster--scoped-connection (jabber-connection-bare-jid jabber-roster--scoped-connection) "all")) 'face 'font-lock-constant-face))) jabber-roster-accounts :if (lambda () (cdr jabber-connections))) :group "OMEMO" "f" ("Fingerprints" jabber-roster--show-omemo-fingerprints :if (lambda () jabber-connections))) ;;;###autoload (defun jabber-roster-popup () "Show the Jabber roster popup menu." (interactive) (keymap-popup jabber-roster-popup-map)) ;;;###autoload (defalias 'jabber-roster #'jabber-roster-popup) (defun jabber-roster-chat-online () "Select an online contact and open chat." (interactive) (let* ((online (cl-remove-if-not (lambda (buddy) (get buddy 'connected)) (jabber-roster--contacts))) (jid (jabber-read-jid-completing "Chat with (online): " online t))) (when jid (let ((jc (jabber-roster--jc-for-jid jid))) (jabber-chat-with jc jid))))) (defun jabber-roster-chat-any () "Select any contact and show action submenu." (interactive) (let ((jid (jabber-read-jid-completing "Contact: " nil t))) (when jid (setq jabber-roster--selected-jid jid) (keymap-popup jabber-roster-contact-action-map)))) (defun jabber-roster-chat-unread () "Select a JID with unread activity and switch to its buffer." (interactive) (if (null jabber-activity-jids) (message "No unread messages") (let ((jid (completing-read "Unread: " jabber-activity-jids nil t))) (when (and jid (not (string-empty-p jid))) (jabber-activity-switch-to jid))))) (defun jabber-roster--muc-room-name (room) "Return cached bookmark name for ROOM, or nil if absent." (when-let* ((jc (jabber-muc-connection room)) (name (jabber-get-conference-data jc room nil :name))) (unless (or (string-empty-p name) (string= name room)) name))) (defun jabber-roster--muc-completion-entries () "Return active MUC completion entries as (ROOM . NAME)." (mapcar (lambda (room) (cons room (jabber-roster--muc-room-name room))) (jabber-muc-active-rooms))) (defun jabber-roster--muc-name-counts (entries) "Return hash table of cached-name counts from MUC ENTRIES." (let ((counts (make-hash-table :test 'equal))) (dolist (entry entries counts) (when-let* ((name (cdr entry))) (puthash name (1+ (gethash name counts 0)) counts))))) (defun jabber-roster--muc-room-jids (entries) "Return hash table of active room JIDs from MUC ENTRIES." (let ((rooms (make-hash-table :test 'equal))) (dolist (entry entries rooms) (puthash (car entry) t rooms)))) (defun jabber-roster--muc-safe-name-candidate-p (name name-counts room-jids) "Return non-nil when NAME is safe as a completion candidate. NAME-COUNTS records cached-name frequency. ROOM-JIDS records active room JIDs in the same completion set." (and name (= (gethash name name-counts 0) 1) (not (gethash name room-jids)))) (defun jabber-roster--muc-completion-candidate (entry name-counts room-jids use-names) "Return completion candidate for ENTRY using NAME-COUNTS and ROOM-JIDS. When USE-NAMES is non-nil, use a cached name only if it is safe." (let ((room (car entry)) (name (cdr entry))) (if (and use-names (jabber-roster--muc-safe-name-candidate-p name name-counts room-jids)) name room))) (defun jabber-roster--muc-completion-item (entry name-counts room-jids use-names) "Return a completion item plist for MUC ENTRY. NAME-COUNTS records cached-name frequency. ROOM-JIDS records active room JIDs. When USE-NAMES is non-nil, safe cached names become candidates." (let* ((room (car entry)) (name (cdr entry)) (candidate (jabber-roster--muc-completion-candidate entry name-counts room-jids use-names)) (annotation (if (string= candidate room) name room))) (list :room room :candidate candidate :annotation annotation))) (defun jabber-roster--muc-completion-items (entries use-names) "Return completion item plists for MUC ENTRIES. When USE-NAMES is non-nil, safe cached names become candidates and room JIDs become annotations." (let ((name-counts (jabber-roster--muc-name-counts entries)) (room-jids (jabber-roster--muc-room-jids entries))) (mapcar (lambda (entry) (jabber-roster--muc-completion-item entry name-counts room-jids use-names)) entries))) (defun jabber-roster--muc-completion-table (items) "Return completion table for MUC ITEMS." (let ((candidates (mapcar (lambda (item) (cons (plist-get item :candidate) (plist-get item :room))) items)) (annotations (make-hash-table :test 'equal))) (dolist (item items) (when-let* ((annotation (plist-get item :annotation))) (puthash (plist-get item :candidate) annotation annotations))) (lambda (string pred action) (if (eq action 'metadata) `(metadata (annotation-function . ,(lambda (candidate) (when-let* ((annotation (gethash candidate annotations))) (concat " " annotation))))) (complete-with-action action candidates string pred))))) (defun jabber-roster--muc-completion-normalize (candidate items) "Return CANDIDATE normalized to a room JID from MUC ITEMS." (or (cdr (assoc-string candidate (mapcar (lambda (item) (cons (plist-get item :candidate) (plist-get item :room))) items))) (and (cl-find candidate items :key (lambda (item) (plist-get item :room)) :test #'string=) candidate))) (defun jabber-roster-switch-muc (use-names) "Select a joined MUC room and switch to it. With prefix argument USE-NAMES, complete on unique cached room names and annotate them with room JIDs." (interactive "P") (let* ((entries (jabber-roster--muc-completion-entries)) (items (jabber-roster--muc-completion-items entries use-names)) (candidate (completing-read "Room: " (jabber-roster--muc-completion-table items) nil t))) (when-let* ((room (and (not (string-empty-p candidate)) (jabber-roster--muc-completion-normalize candidate items)))) (jabber-muc-switch-to room)))) ;;; Account management (defvar jabber-roster--selected-account nil "Connection selected in the accounts menu.") (keymap-popup-define jabber-roster-account-action-map "Account actions." :description (lambda () (if jabber-roster--selected-account (jabber-connection-bare-jid jabber-roster--selected-account) "Account")) "i" ((lambda () (if (eq jabber-roster--scoped-connection jabber-roster--selected-account) "Show all accounts" "Isolate")) jabber-roster--account-toggle-scope) "d" ("Disconnect" jabber-roster--account-disconnect)) (defconst jabber-roster--all-accounts-label "All accounts" "Synthetic entry in the account picker that clears scope.") (defun jabber-roster-accounts () "Select a connected account and show actions. When the roster is scoped to a single account, an \"All accounts\" entry is offered to clear the scope." (interactive) (let* ((accounts (mapcar (lambda (jc) (cons (jabber-connection-bare-jid jc) jc)) jabber-connections)) (candidates (if jabber-roster--scoped-connection (cons jabber-roster--all-accounts-label (mapcar #'car accounts)) (mapcar #'car accounts))) (choice (completing-read "Account: " candidates nil t))) (cond ((or (null choice) (string-empty-p choice))) ((string= choice jabber-roster--all-accounts-label) (setq jabber-roster--scoped-connection nil) (keymap-popup jabber-roster-popup-map)) (t (setq jabber-roster--selected-account (cdr (assoc choice accounts))) (keymap-popup jabber-roster-account-action-map))))) (defun jabber-roster--account-disconnect () "Disconnect the selected account." (interactive) (when jabber-roster--selected-account (when (eq jabber-roster--scoped-connection jabber-roster--selected-account) (setq jabber-roster--scoped-connection nil)) (jabber-disconnect-one jabber-roster--selected-account) (setq jabber-roster--selected-account nil))) (defun jabber-roster--account-toggle-scope () "Toggle roster scope to/from the selected account." (interactive) (setq jabber-roster--scoped-connection (if (eq jabber-roster--scoped-connection jabber-roster--selected-account) nil jabber-roster--selected-account)) (setq jabber-roster--selected-account nil) (keymap-popup jabber-roster-popup-map)) (defun jabber-roster--clear-scope () "Clear scope if the scoped connection is no longer active." (when (and jabber-roster--scoped-connection (not (memq jabber-roster--scoped-connection jabber-connections))) (setq jabber-roster--scoped-connection nil))) (add-hook 'jabber-post-disconnect-hook #'jabber-roster--clear-scope) (defun jabber-roster--jc-for-jid (jid) "Return the connection that has JID in its roster." (or (cl-find-if (lambda (jc) (jabber-roster-contact-p jc jid)) jabber-connections) (car jabber-connections))) (defun jabber-roster--action-chat () "Open chat with the selected contact." (interactive) (when jabber-roster--selected-jid (let ((jc (jabber-roster--jc-for-jid jabber-roster--selected-jid))) (jabber-chat-with jc jabber-roster--selected-jid)))) (defun jabber-roster--action-info () "Get info for the selected contact." (interactive) (when jabber-roster--selected-jid (let ((jc (jabber-roster--jc-for-jid jabber-roster--selected-jid))) (jabber-get-info jc jabber-roster--selected-jid)))) (defun jabber-roster--action-edit () "Edit name and groups of the selected contact." (interactive) (when jabber-roster--selected-jid (let* ((jc (jabber-roster--jc-for-jid jabber-roster--selected-jid)) (sym (jabber-jid-symbol jabber-roster--selected-jid)) (name (get sym 'name)) (groups (get sym 'groups)) (all-groups (apply #'append (mapcar (lambda (j) (get j 'groups)) (plist-get (fsm-get-state-data jc) :roster)))) (new-name (jabber-read-with-input-method (format "Name: (default `%s') " name) nil nil name)) (new-groups (delete "" (completing-read-multiple (format "Groups, comma-separated: (default %s) " (if groups (string-join groups ",") "none")) all-groups nil nil nil 'jabber-roster-group-history (string-join groups ",") t)))) (jabber-roster-change jc sym new-name new-groups)))) (defun jabber-roster--action-delete () "Delete the selected contact from roster." (interactive) (when jabber-roster--selected-jid (when (yes-or-no-p (format "Delete %s from roster? " jabber-roster--selected-jid)) (let ((jc (jabber-roster--jc-for-jid jabber-roster--selected-jid))) (jabber-roster-delete jc jabber-roster--selected-jid))))) (defun jabber-roster--action-block () "Block the selected contact." (interactive) (when jabber-roster--selected-jid (let ((jc (jabber-roster--jc-for-jid jabber-roster--selected-jid))) (jabber-blocking-block-jid jc jabber-roster--selected-jid)))) (provide 'jabber-roster-menu) ;;; jabber-roster-menu.el ends here emacs-jabber-0.13.1/lisp/jabber-roster.el000066400000000000000000000174351523531702000201510ustar00rootroot00000000000000;;; jabber-roster.el --- roster management -*- 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-presence-events) (require 'jabber-util) (require 'jabber-private) (defgroup jabber-roster nil "Roster options." :group 'jabber) (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-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))) ;;; Faces (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.") (defvar jabber-roster-debug nil "Debug roster operations.") ;;; Roster data management (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)))) (maphash (lambda (key val) (puthash key (nreverse val) hash)) hash) (setq all-groups (sort (cl-remove-duplicates all-groups :test #'string=) #'string<)) (plist-put state-data :roster-groups (mapcar #'list all-groups)) (plist-put state-data :roster-hash hash))) (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)) ;;;###autoload (defun jabber-roster-update (jc new-items changed-items deleted-items) "Update roster in memory. 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))) (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) (if (not hash) (jabber-roster-prepare-roster jc) (when jabber-roster-debug (message "update hash-based roster")) (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)) (puthash group (delq delete-this (gethash group hash)) hash))) (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))) (puthash group (cons insert-this (gethash group hash)) hash) (push (list group) all-groups))) (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)))) ;;; Private storage (group rolling state) (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) (let* ((state-data (fsm-get-state-data jc)) (roll-groups (plist-get state-data :roster-roll-groups))) (unless (cl-find group roll-groups :test #'string=) (plist-put state-data :roster-roll-groups (cons group roll-groups)))))))) (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")))) (add-hook 'jabber-presence-roster-update-functions #'jabber-roster-update) (provide 'jabber-roster) ;;; jabber-roster.el ends here emacs-jabber-0.13.1/lisp/jabber-rtt.el000066400000000000000000000305231523531702000174350ustar00rootroot00000000000000;;; 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 'jabber-chat) (require 'jabber-muc) (require 'subr-x) (require 'ewoc) (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 (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-out-of-sync-p nil) (defvar-local jabber-rtt-message nil) (defvar-local jabber-rtt-pending-events nil) (defvar-local jabber-rtt-timer nil) (jabber-chain-add 'jabber-message-chain #'jabber-rtt-handle-message 50) ;;;###autoload (defun jabber-rtt-handle-message (jc xml-data) "Process an inbound message XML-DATA on JC for XEP-0301 RTT events." ;; 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 (not jabber-rtt-out-of-sync-p) 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 (setq jabber-rtt-out-of-sync-p t) ;; TODO: show warning when not in sync (message "out of sync! %s vs %s" seq jabber-rtt-last-seq)))) ;; event="init" only negotiates activation. This client does not ;; implement activation negotiation; doap.xml advertises partial support. ))))) (defun jabber-rtt--reset () "Clear RTT state and tear down the typing ewoc node and timer." (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-out-of-sync-p nil jabber-rtt-message nil jabber-rtt-pending-events nil jabber-rtt-timer nil)) (defun jabber-rtt--enqueue-actions (new-actions) "Append NEW-ACTIONS to the pending RTT queue and start replay if idle." (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) "Replay pending RTT actions inside BUFFER, scheduling waits with a timer." (when (buffer-live-p 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))) (text (car (jabber-xml-node-children action)))) (setq position (max position 0)) (setq position (min position (length jabber-rtt-message))) (unless (string-blank-p (or text "")) (setf (substring jabber-rtt-message position position) text) (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--wait-duration (action) "Return the non-negative duration of wait ACTION, or nil." (when (eq (jabber-xml-node-name action) 'w) (max (string-to-number (jabber-xml-get-attribute action 'n)) 0))) (defun jabber-rtt--scale-wait (action scale) "Return wait ACTION normalized and multiplied by SCALE." (if-let* ((duration (jabber-rtt--wait-duration action))) `(w ((n . ,(number-to-string (truncate (* scale duration))))) nil) action)) (defun jabber-rtt--fix-waits (actions) "Scale wait events inside ACTIONS so their total never exceeds 700 ms." (let* ((durations (delq nil (mapcar #'jabber-rtt--wait-duration actions))) (sum (apply #'+ durations)) (scale (if (> sum 700) (/ 700.0 sum) 1))) (mapcar (lambda (action) (jabber-rtt--scale-wait action scale)) 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 () "Send a `cancel' RTT event and clear local send state." (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) "Snapshot the unsent buffer text as an RTT `new' (or `reset' if RESETP) event." (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) "After-change hook: queue an RTT edit for the BEG..END change. PRE-CHANGE-LENGTH is how many characters were replaced." (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) "Flush the pending RTT edit events for BUFFER as a single stanza." (when (buffer-live-p 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) "Chat-send hook: clear RTT state once the final is going out." ;; 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-0.13.1/lisp/jabber-sasl.el000066400000000000000000000156601523531702000175730ustar00rootroot00000000000000;;; 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 (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 "%s: no SASL mechanisms offered, server requires STARTTLS which was not negotiated" (jabber-connection-bare-jid jc)) (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'. SASL-DATA is the (CLIENT STEP PASSPHRASE) state list." (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-0.13.1/lisp/jabber-search.el000066400000000000000000000076201523531702000200730ustar00rootroot00000000000000;;; 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) (require 'jabber-xdata) ;; 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 to TO 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'. (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-xdata-render-result 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")))))) (setq jabber-register-search-result-function #'jabber-process-search-result) (provide 'jabber-search) ;;; jabber-search.el ends hereemacs-jabber-0.13.1/lisp/jabber-sm-runtime.el000066400000000000000000000142471523531702000207310ustar00rootroot00000000000000;;; jabber-sm-runtime.el --- Stream Management effects -*- 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. ;;; Commentary: ;; This module contains the network and timer effects for XEP-0198. State ;; transitions and XML transformations remain in `jabber-sm'. ;;; Code: (require 'fsm) (require 'jabber-sm) (require 'jabber-stanza) (defun jabber-sm--discard-pending (state-data reason) "Fail pending entries in STATE-DATA with REASON, then clear them." (dolist (entry (plist-get state-data :sm-pending-queue)) (when (keywordp (car-safe entry)) (jabber-sm--run-pending-callback (plist-get entry :failure) reason))) (plist-put state-data :sm-pending-queue nil)) (defun jabber-sm--count-inbound (jc state-data stanza) "Record inbound STANZA and send a periodic acknowledgement when due. 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) (defun jabber-sm--drain-pending (jc state-data) "Send queued stanzas on JC up to the in-flight limit. STATE-DATA is the FSM plist. Return updated state data." (let ((queue (sort (plist-get state-data :sm-pending-queue) (lambda (a b) (< (jabber-sm--pending-priority a) (jabber-sm--pending-priority b))))) failed) (while (and queue (not failed) (or (null jabber-sm-max-in-flight) (< (jabber-sm--in-flight-count state-data) jabber-sm-max-in-flight))) (let* ((entry (pop queue)) (sexp (jabber-sm--pending-stanza entry))) (condition-case err (progn (jabber-send-sexp--raw jc sexp) (setq state-data (jabber-sm--count-outbound state-data sexp)) (when (keywordp (car-safe entry)) (jabber-sm--run-pending-callback (plist-get entry :success)))) (error (setq failed t) (when (keywordp (car-safe entry)) (jabber-sm--run-pending-callback (plist-get entry :failure) (error-message-string err))))))) (plist-put state-data :sm-pending-queue queue))) (defun jabber-sm--check-stall (jc) "Check JC for an acknowledgement stall and recover when timed out." (let ((state-data (fsm-get-state-data jc))) (if (and jabber-sm-max-in-flight (plist-get state-data :sm-pending-queue) (>= (jabber-sm--in-flight-count state-data) jabber-sm-max-in-flight)) (let ((stall-since (plist-get state-data :sm-stall-since))) (if stall-since (when (>= (- (float-time) stall-since) jabber-sm-stall-timeout) (jabber-sm--recover-stall jc state-data)) (plist-put state-data :sm-stall-since (float-time)))) (plist-put state-data :sm-stall-since nil)))) (defun jabber-sm--recover-stall (jc state-data) "Reconnect JC after an acknowledgement stall in STATE-DATA." (let ((pending-count (length (plist-get state-data :sm-pending-queue)))) (message "SM: ack stall detected, reconnecting (%d stanzas pending)" pending-count) (plist-put state-data :disconnection-reason "Stream Management acknowledgement timeout") (if-let* ((connection (plist-get state-data :connection)) ((processp connection))) (delete-process connection) (fsm-send jc '(:connection-dead))))) (defun jabber-sm--send-count-too-high-error (jc h sent) "Reject on JC an acknowledgement H beyond SENT." (jabber-send-string jc (format (concat "" "" "" "") jabber-sm-xmlns h sent))) (defun jabber-sm--send-ack (jc state-data) "Send an acknowledgement to JC using STATE-DATA." (jabber-send-string jc (jabber-sm--make-ack-xml (plist-get state-data :sm-inbound-count)))) (defun jabber-sm--request-ack (jc) "Request an acknowledgement from JC." (jabber-send-string jc (jabber-sm--make-request-xml))) (defun jabber-sm--r-timer-function (jc) "Request an acknowledgement from JC and check for a stall." (when (memq jc jabber-connections) (condition-case err (progn (jabber-sm--request-ack jc) (jabber-sm--check-stall jc)) (error (message "SM: ack timer failed: %s" (error-message-string err)))))) (defun jabber-sm--start-r-timer (jc state-data) "Start the acknowledgement request timer for JC in STATE-DATA." (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 acknowledgement request timer in 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)) (defun jabber-sm-maybe-start (jc) "Start the Stream Management acknowledgement timer for JC when enabled." (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-runtime) ;;; jabber-sm-runtime.el ends here emacs-jabber-0.13.1/lisp/jabber-sm.el000066400000000000000000000325711523531702000172500ustar00rootroot00000000000000;;; 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. This module contains the ;; state and XML transformations; `jabber-sm-runtime' owns network and timer ;; effects. ;;; Code: (require 'cl-lib) (require 'jabber-xml) (require 'fsm) (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))) (defcustom jabber-sm-stall-timeout 90 "Seconds before reconnecting after an SM acknowledgement stall. When the server has not acknowledged outbound stanzas for this many seconds while the pending queue is non-empty, reconnect so Stream Management can resume without discarding unacknowledged data." :type 'integer :group 'jabber-sm) (define-error 'jabber-sm-handled-count-too-high "Server acknowledged more stanzas than were sent") ;;; 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 :sm-stall-since 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) ;;; 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 in STATE-DATA. True when SM is enabled, SEXP is a countable stanza, back-pressure is enabled, and the in-flight count has reached the cap. IQ stanzas always bypass the gate since they have their own timeout handling and are useless when stale." (and jabber-sm-max-in-flight (plist-get state-data :sm-enabled) (jabber-sm--stanza-p sexp) (not (eq (jabber-xml-node-name sexp) 'iq)) (>= (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 &optional success-callback failure-callback) "Append SEXP to the pending queue in STATE-DATA. Callbacks run after transport handoff or queue disposal. Return updated STATE-DATA." (plist-put state-data :sm-pending-queue (nconc (plist-get state-data :sm-pending-queue) (list (if (or success-callback failure-callback) (list :priority (jabber-sm--stanza-priority sexp) :stanza sexp :success success-callback :failure failure-callback) (cons (jabber-sm--stanza-priority sexp) sexp)))))) (defun jabber-sm--pending-priority (entry) "Return the priority stored in pending ENTRY." (if (keywordp (car-safe entry)) (plist-get entry :priority) (car entry))) (defun jabber-sm--pending-stanza (entry) "Return the stanza stored in pending ENTRY." (if (keywordp (car-safe entry)) (plist-get entry :stanza) (cdr entry))) ;;; 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--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. Only advance `:sm-last-acked' forward -- ignore stale acks whose h is at or behind the current value. Signal `jabber-sm-handled-count-too-high' for an impossible ack. 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)) (last-acked (plist-get state-data :sm-last-acked)) (queue (plist-get state-data :sm-outbound-queue)) (pruned (jabber-sm--prune-queue queue h))) (cond ((jabber-sm--counter-<= h last-acked) state-data) ((not (jabber-sm--counter-<= h sent)) (signal 'jabber-sm-handled-count-too-high (list h sent))) (t (setq state-data (plist-put state-data :sm-last-acked h)) (setq state-data (plist-put state-data :sm-outbound-queue pruned)) (plist-put state-data :sm-stall-since nil))))) ;;; 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))) (defun jabber-sm--handle-failed-resume (state-data stanza) "Prepare STATE-DATA for a new session after failed resume STANZA. Preserve stanzas the server did not acknowledge and existing pending entries." (let ((h (jabber-xml-get-attribute stanza 'h))) (when h (setq state-data (jabber-sm--process-ack state-data stanza)))) (let ((outbound (mapcar (lambda (entry) (cons (jabber-sm--stanza-priority (cdr entry)) (cdr entry))) (plist-get state-data :sm-outbound-queue))) (pending (plist-get state-data :sm-pending-queue))) (setq state-data (jabber-sm--reset state-data)) (plist-put state-data :sm-pending-queue (append outbound pending)))) ;;; 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))) (provide 'jabber-sm) ;;; jabber-sm.el ends here emacs-jabber-0.13.1/lisp/jabber-srv.el000066400000000000000000000163621523531702000174430ustar00rootroot00000000000000;;; 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 ((remaining (copy-sequence entries)) result) (while remaining (let* ((total (cl-loop for a in remaining sum (cadr (assq 'weight a)))) (r (random (1+ total))) (running 0) (chosen (cl-dolist (a remaining) (cl-incf running (cadr (assq 'weight a))) (when (>= running r) (cl-return a))))) (push chosen result) (setq remaining (delq chosen remaining)))) (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-0.13.1/lisp/jabber-stanza.el000066400000000000000000000143571523531702000201330ustar00rootroot00000000000000;;; jabber-stanza.el --- Jabber stanza transport -*- 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. ;;; Commentary: ;; Serialize, transmit, and dispatch XMPP stanzas. Stream Management state ;; transformations remain in `jabber-sm'; this module applies them at the ;; network boundary. ;;; Code: (require 'fsm) (require 'jabber-sm) (require 'jabber-state) (require 'jabber-xml) (defconst jabber-bind-xmlns "urn:ietf:params:xml:ns:xmpp-bind" "RFC 6120 resource binding namespace.") (defconst jabber-session-xmlns "urn:ietf:params:xml:ns:xmpp-session" "RFC 6120 session establishment namespace.") (defconst jabber-streams-xmlns "http://etherx.jabber.org/streams" "RFC 6120 XMPP streams namespace.") (defcustom jabber-debug-log-xml nil "Set to non-nil to log XML input and output in a console buffer. Set to a string to also append XML input and output to that file." :type '(choice (const :tag "Do not dump XML input or output" nil) (const :tag "Dump XML in console" t) (string :tag "Dump XML in console and this file")) :group 'jabber-debug) (defvar jabber-stanza-log-function nil "Function called with connection, direction, and stanza log data.") (defun jabber-log-xml (jc direction data) "Log DATA for JC in DIRECTION when XML debugging is enabled." (when (and jabber-debug-log-xml (functionp jabber-stanza-log-function)) (funcall jabber-stanza-log-function jc direction data))) (defun jabber-stanza--connection-jid (state-data) "Return the full JID represented by STATE-DATA." (concat (plist-get state-data :username) "@" (plist-get state-data :server) "/" (plist-get state-data :resource))) (defun jabber-send-string (jc string) "Send STRING through connection JC." (let* ((state-data (fsm-get-state-data jc)) (connection (plist-get state-data :connection)) (send-function (plist-get state-data :send-function))) (unless connection (error "%s has no connection" (jabber-stanza--connection-jid state-data))) (funcall send-function connection string))) (defun jabber-send-sexp--raw (jc sexp) "Send SEXP to JC without updating Stream Management state." (condition-case err (jabber-log-xml jc "sending" sexp) (error (ding) (message "Couldn't write XML log: %s" (error-message-string err)) (sit-for 2))) (let* ((xml (jabber-sexp2xml sexp)) (state-data (fsm-get-state-data jc)) (sm-countable (and (plist-get state-data :sm-enabled) (jabber-sm--stanza-p sexp)))) (jabber-send-string jc (if sm-countable (concat xml (jabber-sm--make-request-xml)) xml)))) (defun jabber-sm--run-pending-callback (callback &optional argument) "Run CALLBACK with optional ARGUMENT without disrupting send state." (when callback (condition-case err (if argument (funcall callback argument) (funcall callback)) (error (message "SM callback failed: %s" (error-message-string err)))))) (defun jabber-send-sexp--immediate (jc sexp &optional success-callback failure-callback) "Send SEXP on JC, update SM state, and run transport callbacks." (condition-case err (prog1 (progn (jabber-send-sexp--raw jc sexp) (jabber-sm--count-outbound (fsm-get-state-data jc) sexp)) (jabber-sm--run-pending-callback success-callback)) (error (if failure-callback (jabber-sm--run-pending-callback failure-callback (error-message-string err)) (signal (car err) (cdr err)))))) (defun jabber-send-sexp (jc sexp &optional success-callback failure-callback) "Send SEXP on JC with SM back-pressure and transport callbacks." (let ((state-data (fsm-get-state-data jc))) (if (jabber-sm--should-queue-p state-data sexp) (progn (jabber-sm--enqueue-pending state-data sexp success-callback failure-callback) (when (eq (jabber-xml-node-name sexp) 'message) (message "SM: message queued (waiting for server ack, %d pending)" (length (plist-get state-data :sm-pending-queue))))) (jabber-send-sexp--immediate jc sexp success-callback failure-callback)))) (defun jabber-send-sexp-if-connected (jc sexp) "Send SEXP through JC only after its session is established." (fsm-send-sync jc (cons :send-if-connected sexp))) (defvar jabber-use-sasl) ; jabber-core.el (defsubst jabber-have-sasl-p () "Return non-nil when the SASL library is available." (featurep 'sasl)) (defun jabber-send-stream-header (jc) "Send the opening XML stream header to JC." (let* ((state-data (fsm-get-state-data jc)) (header (concat "\n"))) (jabber-log-xml jc "sending" header) (jabber-send-string jc header))) (defvar jabber-xml-data) ; jabber.el (defun jabber-process-input (jc xml-data) "Dispatch XML-DATA received on JC through its stanza handler chain." (let* ((jabber-xml-data xml-data) (tag (jabber-xml-node-name xml-data)) (handlers (pcase tag ('iq jabber-iq-chain) ('presence jabber-presence-chain) ('message jabber-message-chain)))) (dolist (entry handlers) (let ((handler (if (consp entry) (cdr entry) entry))) (condition-case err (funcall handler jc xml-data) ((debug error) (fsm-debug-output "Error %S while processing %S with function %s" err xml-data handler))))))) (provide 'jabber-stanza) ;;; jabber-stanza.el ends here emacs-jabber-0.13.1/lisp/jabber-state.el000066400000000000000000000044401523531702000177430ustar00rootroot00000000000000;;; jabber-state.el --- Shared Jabber state -*- 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. ;;; Commentary: ;; State shared by the connection FSM and protocol handlers lives here. This ;; module has no network, database, or user-interface effects. ;;; Code: (require 'cl-lib) (defvar jabber-connections nil "List of Jabber connection FSMs.") (define-obsolete-variable-alias '*jabber-roster* 'jabber-roster-list "0.11.0") (defvar jabber-roster-list nil "The roster list.") (defvar jabber-jid-obarray (make-vector 127 0) "Obarray for interned JIDs.") (define-obsolete-variable-alias '*jabber-disconnecting* 'jabber-disconnecting "0.11.0") (defvar jabber-disconnecting nil "Non-nil while voluntarily disconnecting.") (defvar jabber-message-chain nil "Ordered handlers for incoming message stanzas.") (defvar jabber-iq-chain nil "Ordered handlers for incoming IQ stanzas.") (defvar jabber-presence-chain nil "Ordered handlers for incoming presence stanzas.") ;;;###autoload (defun jabber-chain-add (chain-var handler &optional depth) "Add HANDLER to CHAIN-VAR at numeric priority DEPTH. Lower depths run first. Bare function entries from older versions are accepted when checking for an existing handler." (let ((entry (cons (or depth 0) handler)) (entry-depth (lambda (item) (if (consp item) (car item) 0))) (entry-function (lambda (item) (if (consp item) (cdr item) item)))) (unless (cl-find handler (symbol-value chain-var) :key entry-function) (set chain-var (sort (cons entry (symbol-value chain-var)) (lambda (a b) (< (funcall entry-depth a) (funcall entry-depth b)))))))) (defun jabber-clear-roster () "Clear all interned roster state." (mapatoms (lambda (jid) (unintern jid jabber-jid-obarray)) jabber-jid-obarray) (setq jabber-roster-list nil)) (provide 'jabber-state) ;;; jabber-state.el ends here emacs-jabber-0.13.1/lisp/jabber-styling.el000066400000000000000000000507321523531702000203210ustar00rootroot00000000000000;;; 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. ;; ;; Code blocks whose opening fence carries a language token ;; (```lang) are fontified with that language's major mode, so the ;; user's theme applies. The token has no meaning per XEP-0393. ;; ;; Message display area: a post-body printer in `jabber-chat-printers' ;; applies styling after `jabber-chat-print-body' inserts text. ;; ;; Composition area: jit-lock provides live styling preview as the ;; user types. ;;; Code: (require 'jabber-chat) (require 'jabber-disco) (require 'jit-lock) (require 'org-faces) (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) (defcustom jabber-styling-fontify-code-blocks t "Whether to fontify ```lang code blocks with the language's major mode. When nil, or when no major mode matches the language token, the code between the fences still gets the block background but no native syntax highlighting." :type 'boolean) (defcustom jabber-styling-code-lang-modes '(("elisp" . emacs-lisp-mode) ("el" . emacs-lisp-mode) ("shell" . sh-mode) ("bash" . sh-mode) ("sh" . sh-mode) ("cpp" . c++-mode) ("c++" . c++-mode) ("js" . js-mode)) "Alist mapping fence language tokens to major modes. Languages not listed here resolve as LANG-mode via `intern-soft'." :type '(alist :key-type (string :tag "Language") :value-type (function :tag "Major mode"))) (defcustom jabber-styling-fontify-max-size 10000 "Maximum code block size in characters to fontify natively. Larger blocks still get the block background but no native syntax highlighting." :type 'natnum) (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 org-block :extend t)) "Background face for the body of a ```code block```. Appended beneath the language mode's own font-lock faces, exactly as `org-src-font-lock-fontify-block' applies `org-block': being a background face, it tints the block without overriding the code's foreground colors. Inherits `org-block' so blocks match the user's Org theme.") (defface jabber-styling-pre-block-fence '((t :inherit org-block-begin-line :extend t)) "Face for the ``` fence lines delimiting a code block. Inherits `org-block-begin-line', mirroring Org's block delimiters.") (defface jabber-styling-quote '((t :inherit shadow)) "Face for > block quotes.") ;;; Span regexes ;; ;; Each regex matches: DIRECTIVE CONTENT DIRECTIVE ;; where content starts/ends with non-whitespace and does not contain ;; the directive char. Group 1 captures content without delimiters. ;; The [^D]* quantifier gives lazy semantics naturally since it ;; cannot consume the closing delimiter. (defconst jabber-styling--bold-re "\\*\\([^[:space:]*]\\(?:[^*]*[^[:space:]*]\\)?\\)\\*" "Regex for *bold* spans. Group 1 is content.") (defconst jabber-styling--italic-re "_\\([^[:space:]_]\\(?:[^_]*[^[:space:]_]\\)?\\)_" "Regex for _italic_ spans. Group 1 is content.") (defconst jabber-styling--strike-re "~\\([^[:space:]~]\\(?:[^~]*[^[:space:]~]\\)?\\)~" "Regex for ~strikethrough~ spans. Group 1 is content.") (defconst jabber-styling--pre-re "`\\([^[:space:]`]\\(?:[^`]*[^[:space:]`]\\)?\\)`" "Regex for `preformatted` spans. Group 1 is content.") ;;; Pure parsing functions (defun jabber-styling--valid-opening-p (str pos) "Non-nil if POS in STR is a valid XEP-0393 opening position. Opening must be at start, after whitespace, or after another opening directive." (or (zerop pos) (memq (aref str (1- pos)) '(?\s ?\t ?\n ?* ?_ ?~ ?`)))) (defun jabber-styling--in-region-p (pos regions) "Non-nil if POS falls inside any interval in REGIONS. REGIONS is a list of (START . END) cons cells." (cl-some (lambda (r) (and (>= pos (car r)) (< pos (cdr r)))) regions)) (defun jabber-styling--match-spans (str re face pre-regions) "Match span RE in STR, returning (START END FACE) triples. Skips matches whose opening falls inside PRE-REGIONS." (let ((spans nil) (pos 0)) (while (string-match re str pos) (let ((beg (match-beginning 0)) (end (match-end 0))) (if (and (jabber-styling--valid-opening-p str beg) (not (jabber-styling--in-region-p beg pre-regions))) (progn (push (list beg end face) spans) (setq pos end)) (setq pos (1+ beg))))) (nreverse spans))) (defun jabber-styling--parse-spans (line) "Parse XEP-0393 span directives in LINE. Return a list of (START END FACE) triples for styled regions. Preformatted spans are matched first and suppress inner directives." (let ((pre-regions nil) (spans nil)) ;; First pass: backtick spans (suppress inner directives) (let ((pos 0)) (while (string-match jabber-styling--pre-re line pos) (let ((beg (match-beginning 0)) (end (match-end 0))) (if (jabber-styling--valid-opening-p line beg) (progn (push (list beg end 'jabber-styling-pre) spans) (push (cons beg end) pre-regions) (setq pos end)) (setq pos (1+ beg)))))) ;; Second pass: other spans, skipping pre regions (dolist (pair `((,jabber-styling--bold-re . jabber-styling-bold) (,jabber-styling--italic-re . jabber-styling-italic) (,jabber-styling--strike-re . jabber-styling-strike))) (setq spans (nconc spans (jabber-styling--match-spans line (car pair) (cdr pair) pre-regions)))) (sort spans (lambda (a b) (< (car a) (car b)))))) (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 (in-pre (when (eq kind 'pre-close) (push (list 'pre pre-start line-end) blocks) (setq in-pre nil))) ((memq kind '(pre-open pre-close)) (setq in-pre t pre-start offset)) ((eq kind 'quote) (push (list 'quote offset line-end) blocks)) (t (push (list 'plain offset line-end) blocks))) (setq offset line-end))) (when in-pre (push (list 'pre pre-start len) blocks)) (nreverse blocks))) (defun jabber-styling--fence-lang (line) "Extract the language token from opening fence LINE. Return the downcased first whitespace-delimited token after ```, or nil if absent." (and (string-match "\\````\\([^ \t\n]+\\)" line) (downcase (match-string 1 line)))) (defun jabber-styling--pre-block-parts (text) "Decompose pre block TEXT into (LANG CODE-START CODE-END). TEXT is one block as delimited by `jabber-styling--parse-blocks'. LANG is the fence language token or nil. CODE-START and CODE-END are offsets into TEXT delimiting the code lines, excluding both fence lines. Unterminated blocks yield CODE-END = length of TEXT." (let* ((len (length text)) (first-nl (cl-position ?\n text)) (code-start (if first-nl (1+ first-nl) len)) (body (if (and (> len 0) (eq (aref text (1- len)) ?\n)) (substring text 0 (1- len)) text)) (last-start (let ((nl (cl-position ?\n body :from-end t))) (if nl (1+ nl) 0))) (code-end (if (eq (jabber-styling--classify-block (substring body last-start)) 'pre-close) (max code-start last-start) len))) (list (jabber-styling--fence-lang (substring text 0 (or first-nl len))) code-start code-end))) (defun jabber-styling--lang-mode (lang) "Resolve LANG to a major mode function, or nil. Consults `jabber-styling-code-lang-modes', then LANG-mode via `intern-soft', remaps through `major-mode-remap-alist', and requires the result to be `fboundp'." (and-let* ((lang) (mode (or (cdr (assoc lang jabber-styling-code-lang-modes)) (intern-soft (concat lang "-mode")))) (mode (alist-get mode major-mode-remap-alist mode)) ((fboundp mode))) mode)) ;;; Code block fontification (defun jabber-styling--fontification-buffer (mode) "Return the persistent hidden fontification buffer for MODE. Created on first use." (get-buffer-create (format " *jabber-styling-fontify:%s*" mode))) (defun jabber-styling--face-stretches (limit) "Collect (START END FACE) triples from the current buffer. START and END are 0-based offsets clamped to LIMIT. FACE is the non-nil face covering that stretch." (let ((pos (point-min)) (stretches nil)) (while (< (1- pos) limit) (let ((next (or (next-property-change pos) (point-max))) ;; Some modes apply font-lock-face instead of face in ;; buffers where font-lock-mode is off (the org-src gotcha). (face (or (get-text-property pos 'face) (get-text-property pos 'font-lock-face)))) (when face (push (list (1- pos) (min (1- next) limit) face) stretches)) (setq pos next))) (nreverse stretches))) (defun jabber-styling--fontify-code (code mode) "Fontify CODE string with major mode MODE. Return a list of (START END FACE) triples with 0-based offsets into CODE, computed in a hidden work buffer. Return nil if MODE fails to initialize. Like `org-src-font-lock-fontify-block', MODE is run with its full hooks, so minor modes the user enables for that language -- `rainbow-delimiters-mode' and the like -- also fontify the block. The buffer is reused per MODE, so the hooks run once." (with-current-buffer (jabber-styling--fontification-buffer mode) (erase-buffer) ;; Trailing space guarantees a final property change boundary. (insert code " ") ;; Guard the whole path: running a mode's full hooks and its ;; font-lock keywords can signal, and this feeds the chat printer. (condition-case err (progn (unless (eq major-mode mode) (funcall mode)) (font-lock-ensure) (jabber-styling--face-stretches (length code))) (error (message "jabber-styling: %s fontification failed: %s" mode (error-message-string err)) nil)))) ;;; 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-code-block (cbeg cend lang) "Natively fontify the code region between CBEG and CEND for LANG. Resolves LANG to a major mode; when found and the region fits `jabber-styling-fontify-max-size', sets the mode's font-lock faces exactly, as `org-src-font-lock-fontify-block' does, and marks the region with the `jabber-styling-fontified' text property. Return non-nil when faces were applied. The caller clears the region first and supplies the block backdrop; this only sets mode faces." (let ((mode (jabber-styling--lang-mode lang))) (when (and mode (<= (- cend cbeg) jabber-styling-fontify-max-size)) (let* ((code (buffer-substring-no-properties cbeg cend)) (stretches (jabber-styling--fontify-code code mode))) (when stretches (pcase-dolist (`(,s ,e ,face) stretches) (put-text-property (+ cbeg s) (+ cbeg e) 'face face)) (put-text-property cbeg cend 'jabber-styling-fontified t) t))))) (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 ;; org-src model: the ``` fence lines get the delimiter ;; face; the body is fontified by its language mode with ;; the block background appended beneath, so the tint never ;; overrides the mode's foreground colors. (pcase-let* ((`(,lang ,code-start ,code-end) (jabber-styling--pre-block-parts (buffer-substring-no-properties bstart bend))) (cbeg (+ bstart code-start)) (cend (min (+ bstart code-end) bend))) (when (< bstart cbeg) (font-lock-prepend-text-property bstart cbeg 'face 'jabber-styling-pre-block-fence)) (when (< cend bend) (font-lock-prepend-text-property cend bend 'face 'jabber-styling-pre-block-fence)) (when (< cbeg cend) ;; When fontifying, clear the body to a clean slate ;; first (org-src style) so every enabled block renders ;; uniformly, whether or not the language resolves to a ;; mode -- rather than only recognized languages losing ;; the surrounding chat face. (when jabber-styling-fontify-code-blocks (remove-text-properties cbeg cend '(face nil)) (jabber-styling--apply-code-block cbeg cend lang)) (font-lock-append-text-property cbeg cend 'face 'jabber-styling-pre-block)))) ('quote (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-pre-block-fence 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--remove-code-fontification (beg end) "Remove natively applied code faces between BEG and END. Clears the face property, plus the marker property, on stretches carrying `jabber-styling-fontified'." (let ((pos beg)) (while (setq pos (text-property-any pos end 'jabber-styling-fontified t)) (let ((next (or (next-single-property-change pos 'jabber-styling-fontified nil end) end))) (remove-text-properties pos next '(face nil jabber-styling-fontified nil)) (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-code-fontification compose-beg compose-end) (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) ;;; Chat printer integration (defvar jabber-chat--body-start) ; jabber-chat.el (defun jabber-styling--post-body (msg _who mode) "Apply XEP-0393 styling to the body from MSG just inserted. MODE must be :insert for styling to apply." (when (and (eq mode :insert) jabber-styling-enable (not (plist-get msg :unstyled))) (let ((start (or jabber-chat--body-start (point-min))) (end (point))) (when (< start end) (jabber-styling--apply-region start end))))) (defvar jabber-chat-printers) (add-hook 'jabber-chat-printers #'jabber-styling--post-body t) ;;; Disco (jabber-disco-advertise-feature jabber-styling-xmlns) (provide 'jabber-styling) ;;; jabber-styling.el ends here emacs-jabber-0.13.1/lisp/jabber-subscription.el000066400000000000000000000076361523531702000213610ustar00rootroot00000000000000;;; jabber-subscription.el --- Presence subscription UI -*- 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: ;; Displays subscription requests in chat buffers and handles replies. ;;; Code: (require 'ewoc) (require 'jabber-alert) (require 'jabber-buffer-registry) (require 'jabber-chat) (require 'jabber-chatbuffer) (require 'jabber-presence-events) (require 'jabber-util) (defun jabber-process-subscription-request (jc from presence-status) "Display a subscription request from FROM on JC with PRESENCE-STATUS." (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) "Accept the pending request and request a reciprocal subscription." (message "Subscription accepted; reciprocal subscription request sent") (jabber-subscription-reply "subscribed" "subscribe")) (defun jabber-subscription-accept-one-way (&rest _ignored) "Accept the pending subscription request without reciprocating." (message "Subscription accepted") (jabber-subscription-reply "subscribed")) (defun jabber-subscription-decline (&rest _ignored) "Decline the pending subscription request." (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." (when-let* ((buffer (jabber-buffer-registry-find 'chat (jabber-jid-user from)))) (with-current-buffer buffer (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))) (mapc #'jabber-chat-ewoc-delete to-delete)))))) (defun jabber-subscription-reply (&rest types) "Send one presence stanza per TYPES to the current peer." (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)) (add-hook 'jabber-presence-contact-functions #'jabber-subscription--remove-stale) (add-hook 'jabber-presence-subscription-request-functions #'jabber-process-subscription-request) (provide 'jabber-subscription) ;;; jabber-subscription.el ends here emacs-jabber-0.13.1/lisp/jabber-time.el000066400000000000000000000220711523531702000175610ustar00rootroot00000000000000;;; 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 from TO. 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 from TO. 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" `(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 TO 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 TO. 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) "Reply to a XEP-0012 last-activity query. JC is the Jabber connection. XML-DATA is the incoming IQ stanza." (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-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 here emacs-jabber-0.13.1/lisp/jabber-truncate.el000066400000000000000000000063261523531702000204550ustar00rootroot00000000000000;;; 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.") ;; Truncation and chat-buffer support form a reload cycle, so this reverse ;; call remains lazy. (defvar jabber-chat-ewoc) ; jabber-chatbuffer.el (defvar jabber-chat--msg-nodes) ; jabber-chatbuffer.el (declare-function jabber-chat-ewoc-unregister-node "jabber-chatbuffer" (node)) (autoload 'jabber-chat-ewoc-unregister-node "jabber-chatbuffer") (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 (jabber-chat-ewoc-unregister-node delete-before) (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 the MUC BUFFER. `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 BUFFER. `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 here emacs-jabber-0.13.1/lisp/jabber-uri.el000066400000000000000000000051401523531702000174200ustar00rootroot00000000000000;;; jabber-uri.el --- XMPP URI parsing and dispatch -*- 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, or (at your option) ;; any later version. ;;; Commentary: ;; Parse XMPP URIs separately from dispatching their interactive commands. ;;; Code: (require 'url-parse) (require 'jabber-ahc) (require 'jabber-chat) (require 'jabber-muc) (require 'jabber-register) (require 'jabber-util) (defun jabber-uri--parse-args (text) "Return decoded key-value pairs from URI argument TEXT." (when text (mapcar (lambda (pair) (pcase-let ((`(,key ,value) (split-string pair "="))) (cons key (jabber-unhex value)))) (split-string text ";")))) (defun jabber-uri-parse (uri) "Return the JID, method, and arguments parsed from XMPP URI." (when (string-match "//" uri) (error "URIs with authority part are not supported")) (unless (string-match "\\`xmpp:\\([^?]+\\)\\(?:\\?\\([a-z]+\\)\\(?:;\\(.*\\)\\)?\\)?\\'" uri) (error "Invalid XMPP URI '%s'" uri)) (list :jid (jabber-unhex (match-string 1 uri)) :method (match-string 2 uri) :args (jabber-uri--parse-args (match-string 3 uri)))) (defun jabber-uri--dispatch (uri-data) "Run the command described by parsed URI-DATA." (let ((account (jabber-read-account)) (jid (plist-get uri-data :jid)) (method (plist-get uri-data :method)) (args (plist-get uri-data :args))) (cond ((string= method "join") (jabber-muc-join account jid (jabber-muc-read-my-nickname account jid) t)) ((string= method "register") (jabber-get-register account jid)) ((string= method "command") (jabber-ahc-execute-command account jid (cdr (assoc "node" args)))) (t (jabber-chat-with account jid))))) (defun jabber-handle-uri (uri &rest _ignored-args) "Handle XMPP URI according to draft-saintandre-xmpp-iri-04. See Info node `(jabber)XMPP URIs'. IGNORED-ARGS are ignored arguments the handler may pass." (interactive "sEnter XMPP URI: ") (let ((uri-data (jabber-uri-parse uri))) (raise-frame) (jabber-uri--dispatch uri-data))) (defun jabber-url-xmpp (url) "Handle XMPP URLs from internal Emacs functions." (jabber-handle-uri (url-recreate-url url))) (fset 'url-xmpp #'jabber-url-xmpp) (provide 'jabber-uri) ;;; jabber-uri.el ends here emacs-jabber-0.13.1/lisp/jabber-util.el000066400000000000000000001034131523531702000176000ustar00rootroot00000000000000;;; 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 'crm) (require 'jabber-muc-state) (require 'jabber-presence-display) (require 'jabber-state) (require 'jabber-stanza) (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)) (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' with PROMPT, but always inheriting the current input method. INITIAL-CONTENTS, HISTORY and DEFAULT-VALUE are passed straight through." ;; Preserve input method when entering a minibuffer. (read-string prompt initial-contents history default-value t)) (defun jabber-completing-read-multiple (prompt collection defaults &optional require-match) "Read multiple values with PROMPT, preserving accepted DEFAULTS. COLLECTION and REQUIRE-MATCH are passed to `completing-read-multiple'." (let* ((default (and defaults (string-join defaults ","))) (values (completing-read-multiple prompt collection nil require-match nil nil default))) (if (and default (equal values (split-string default crm-separator t))) defaults values))) (defvar jabber-connections) (defun jabber-roster-contact-p (jc jid) "Return non-nil when JID's bare JID is on connection JC's roster." (and jc jid (memq (jabber-jid-symbol jid) (plist-get (fsm-get-state-data jc) :roster)))) (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-connection-active-p (jc) "Return non-nil when JC has an established XMPP session." (and (memq jc jabber-connections) (eq (get jc :state) :session-established))) (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))) (cl-find-if (lambda (jc) (and (jabber-connection-active-p jc) (string= jid (jabber-connection-bare-jid jc)))) jabber-connections))) (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))) (defconst jabber--presence-sort-order '("chat" "" "away" "dnd" "xa") "Presence shows from most to least available, for contact sorting. Offline contacts (nil show) sort last.") (defun jabber--presence-rank (sym) "Return sort rank of roster symbol SYM; lower is more available." (let ((tail (and sym (member (get sym 'show) jabber--presence-sort-order)))) (if tail (- (length jabber--presence-sort-order) (length tail)) (length jabber--presence-sort-order)))) (defun jabber--jid-candidate-lessp (a b table) "Order completion candidates A and B by availability, then name. TABLE maps candidate strings to roster symbols." (let ((rank-a (jabber--presence-rank (cdr (assoc-string a table t)))) (rank-b (jabber--presence-rank (cdr (assoc-string b table t))))) (if (= rank-a rank-b) (string-lessp (downcase a) (downcase b)) (< rank-a rank-b)))) (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. Candidates display sorted by availability, then name." (let ((alt-to-candidate (make-hash-table :test 'equal)) (use-names (eq jabber-jid-completion-display 'name)) (sort-candidates (lambda (candidates) (sort (copy-sequence candidates) (lambda (a b) (jabber--jid-candidate-lessp a b table)))))) ;; 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 (display-sort-function . ,sort-candidates) (cycle-sort-function . ,sort-candidates) (annotation-function . ,(lambda (candidate) (when-let* ((sym (cdr (assoc-string candidate table t)))) (let* ((jid (symbol-name sym)) (name (get sym 'name)) (alt (if use-names jid name)) (show (get sym 'show)) (presence (cdr (assoc show jabber-presence-strings))) (parts (list (and alt (not (string= alt candidate)) alt) presence))) (when-let* ((text (string-join (delq nil parts) " "))) (unless (string-empty-p text) (concat " " text))))))))) ;; 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)))))) (defun jabber-read-jid-completing (prompt &optional subset require-match default resource fulljids) "Read a JID out of the current roster from the minibuffer, with PROMPT. 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 with PROMPT, 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 for BARE-JID from minibuffer or auth-source." (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-let* ((contact-hint) (matching (cl-find-if (lambda (jc) (jabber-roster-contact-p jc contact-hint)) jabber-connections))) (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 Emacs time." (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 () "Return the local timezone formatted as an XEP-0082 numeric offset." (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 RAW-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 ERROR-XML tag and return a human-readable string. 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 ERROR-XML 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 ERROR-XML, 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-string>-numerical (s1 s2) "Return t when S1 collates after S2 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 (jabber-string>-numerical (substring s1 1) (substring s2 1))))) (define-obsolete-function-alias 'string>-numerical 'jabber-string>-numerical "0.11.0") (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)) (defun jabber--decrypt-failure-body-p (body) "Return non-nil when BODY is a decrypt-failure placeholder. Matches the \"[LABEL: could not decrypt]\" bodies produced by `jabber-chat--try-decrypt' so callers can avoid overwriting real message text with a placeholder." (and body (string-match-p "\\`\\[.*: could not decrypt\\]\\'" body))) (provide 'jabber-util) ;;; jabber-util.el ends here emacs-jabber-0.13.1/lisp/jabber-vcard-avatars.el000066400000000000000000000136471523531702000213720ustar00rootroot00000000000000;;; 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) (require 'jabber-muc-protocol) (defvar jabber-vcard-xmlns) ; jabber-vcard.el (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.") (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. IQ is the vCard result stanza. CLOSURE is (FROM-JID . SHA1-HASH)." (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 (jabber-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 (jabber-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) "Callback for the own-vCard fetch. JC is the Jabber connection. XML-DATA is the IQ response. SUCCESS is non-nil when the request succeeded." (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)))) (jabber-avatar-sha1-sum avatar))))))) (defun jabber-vcard-avatars-update-current (jc new-hash) "Update cached own-avatar hash for JC to NEW-HASH and resend presence." (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) "Return the vCard-avatar presence child element for connection JC." (when jabber-vcard-avatars-publish (when-let* ((hash (gethash (jabber-connection-bare-jid jc) jabber-vcard-avatars-current-hash))) `((x ((xmlns . ,jabber-vcard-update-xmlns)) (photo () ,hash)))))) (provide 'jabber-vcard-avatars) ;;; jabber-vcard-avatars.el ends here emacs-jabber-0.13.1/lisp/jabber-vcard.el000066400000000000000000000503301523531702000177210ustar00rootroot00000000000000;;; 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 'cl-lib) (require 'subr-x) (require 'jabber-core) (require 'jabber-iq) (require 'jabber-avatar) (require 'jabber-image) (require 'keymap-popup) (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" (jc new-hash)) (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 () ,(jabber-avatar-mime-type jabber-vcard-photo)) (BINVAL () ,(jabber-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"))))))) (defvar-local jabber-vcard--edit-data nil "Plain vCard alist edited in the current buffer.") (defun jabber-vcard--set (key value) "Set KEY to VALUE in the current plain vCard data." (setq-local jabber-vcard--edit-data (cons (cons key value) (assq-delete-all key jabber-vcard--edit-data)))) (defun jabber-vcard--render-editor () "Render current plain vCard edit state." (let ((inhibit-read-only t)) (erase-buffer) (insert (propertize "Edit vCard\n\n" 'face 'jabber-title)) (dolist (entry (reverse jabber-vcard--edit-data)) (insert (format "%s: %s\n" (car entry) (cdr entry)))) (insert "\nPress m for edit commands; C-c C-c to publish.\n") (goto-char (point-min)))) (defun jabber-vcard-edit-simple () "Edit one simple vCard field." (interactive) (let* ((candidates (mapcar (lambda (entry) (cons (cdr entry) (car entry))) jabber-vcard-fields)) (field-name (completing-read "Field: " candidates nil t)) (field (cdr (assoc field-name candidates))) (value (read-string (format "%s: " field-name) (cdr (assq field jabber-vcard--edit-data))))) (jabber-vcard--set field value) (jabber-vcard--render-editor))) (defun jabber-vcard-edit-name () "Edit one structured-name component." (interactive) (let* ((component (intern (completing-read "Name component: " '("PREFIX" "GIVEN" "MIDDLE" "FAMILY" "SUFFIX") nil t))) (name (copy-tree (cdr (assq 'N jabber-vcard--edit-data)))) (value (read-string (format "%s: " component) (cdr (assq component name))))) (jabber-vcard--set 'N (cons (cons component value) (assq-delete-all component name))) (jabber-vcard--render-editor))) (defun jabber-vcard--read-types (prompt choices) "Read zero or more vCard types with PROMPT from CHOICES." (mapcar #'intern (completing-read-multiple prompt choices nil t))) (defun jabber-vcard--add-value (key prompt types) "Add repeatable KEY value read with PROMPT and TYPES." (let ((value (read-string prompt)) (selected (jabber-vcard--read-types "Types: " types))) (jabber-vcard--set key (append (cdr (assq key jabber-vcard--edit-data)) (list (cons selected value)))) (jabber-vcard--render-editor))) (defun jabber-vcard-add-phone () "Add a phone number." (interactive) (jabber-vcard--add-value 'TEL "Number: " '("HOME" "WORK" "VOICE" "FAX" "PAGER" "MSG" "CELL" "VIDEO" "BBS" "MODEM" "ISDN" "PCS" "PREF"))) (defun jabber-vcard-add-email () "Add an email address." (interactive) (jabber-vcard--add-value 'EMAIL "Email: " '("HOME" "WORK" "INTERNET" "X400" "PREF"))) (defun jabber-vcard--delete-value (key) "Delete one repeatable value under KEY." (let* ((values (cdr (assq key jabber-vcard--edit-data))) (candidates (cl-loop for value in values for index from 1 collect (cons (format "%d: %s" index value) index))) (selected (cdr (assoc (completing-read "Delete: " candidates nil t) candidates)))) (jabber-vcard--set key (cl-loop for value in values for index from 1 unless (= index selected) collect value)) (jabber-vcard--render-editor))) (defun jabber-vcard-delete-phone () "Delete a phone number." (interactive) (jabber-vcard--delete-value 'TEL)) (defun jabber-vcard-delete-email () "Delete an email address." (interactive) (jabber-vcard--delete-value 'EMAIL)) (defun jabber-vcard-add-address () "Add a postal address." (interactive) (let ((types (jabber-vcard--read-types "Types: " '("HOME" "WORK" "POSTAL" "PARCEL" "DOM" "INTL" "PREF"))) fields) (dolist (field jabber-vcard-address-fields) (when-let* ((value (read-string (format "%s: " (cdr field)))) ((not (string-empty-p value)))) (push (cons (car field) value) fields))) (jabber-vcard--set 'ADR (append (cdr (assq 'ADR jabber-vcard--edit-data)) (list (cons types (nreverse fields))))) (jabber-vcard--render-editor))) (defun jabber-vcard-delete-address () "Delete a postal address." (interactive) (jabber-vcard--delete-value 'ADR)) (defun jabber-vcard-edit-avatar () "Keep, remove, or replace the vCard avatar." (interactive) (pcase (completing-read "Avatar: " '("Keep existing" "Remove" "Choose file") nil t) ("Remove" (jabber-vcard--set 'PHOTO nil)) ("Choose file" (jabber-vcard--set 'PHOTO (read-file-name "Avatar file: " nil nil t)))) (jabber-vcard--render-editor)) (keymap-popup-define jabber-vcard-edit-mode-map "Edit vCard fields." :parent special-mode-map :group "Basic" "s" ("Simple field" jabber-vcard-edit-simple) "n" ("Structured name" jabber-vcard-edit-name) :group "Repeatable" "t" ("Add phone" jabber-vcard-add-phone) "T" ("Delete phone" jabber-vcard-delete-phone) "e" ("Add email" jabber-vcard-add-email) "E" ("Delete email" jabber-vcard-delete-email) "a" ("Add address" jabber-vcard-add-address) "A" ("Delete address" jabber-vcard-delete-address) :group "Avatar" "p" ("Edit avatar" jabber-vcard-edit-avatar) :group "Actions" "C-c C-c" ("Publish" jabber-vcard-submit) "m" ("Menu" jabber-vcard-edit-menu)) (define-derived-mode jabber-vcard-edit-mode special-mode "Jabber-vCard" "Major mode for editing a vCard as explicit plain data.") (defun jabber-vcard-edit-menu () "Show grouped vCard edit commands." (interactive) (keymap-popup jabber-vcard-edit-mode-map)) (defun jabber-vcard-do-edit (jc xml-data _closure-data) "Open a plain-data editor for our own vCard. JC is the Jabber connection. XML-DATA holds current vCard contents." (let ((buffer (generate-new-buffer "*Edit Jabber vCard*")) (parsed (jabber-vcard-parse (jabber-iq-query xml-data)))) (with-current-buffer buffer (jabber-vcard-edit-mode) (setq-local jabber-buffer-connection jc jabber-vcard--edit-data parsed) (jabber-vcard--render-editor)) (pop-to-buffer buffer) (jabber-vcard-edit-menu))) (defun jabber-vcard-submit (&rest _ignore) "Publish the vCard edited in the current plain-data buffer." (interactive) (let ((to-publish (jabber-vcard-reassemble jabber-vcard--edit-data))) (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 (jabber-avatar-sha1-sum jabber-vcard-photo)))))) (provide 'jabber-vcard) ;;; jabber-vcard.el ends here emacs-jabber-0.13.1/lisp/jabber-version.el000066400000000000000000000075021523531702000203120ustar00rootroot00000000000000;;; 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 '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 of TO. 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. XML-DATA is the IQ result stanza. 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-0.13.1/lisp/jabber-widget.el000066400000000000000000000121401523531702000201020ustar00rootroot00000000000000;;; jabber-widget.el --- compatibility for legacy form entry points -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2007 Magnus Henoch ;; Copyright (C) 2002, 2003, 2004 Tom Berger ;; Copyright (C) 2026 Thanos Apollo ;; 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. ;;; Commentary: ;; Compatibility adapters for callers of the former widget-based form API. ;; Editors use the text-first XData model and do not load widget.el. ;;; Code: (require 'cl-lib) (require 'jabber-register) (require 'jabber-util) (require 'jabber-xdata) (require 'jabber-xdata-form) (defvar-local jabber-widget-alist nil "Legacy form state represented as plain XData fields.") (defvar-local jabber-widget-form-type nil "Legacy form type, either `register' or `xdata'.") (defvar-local jabber-widget-submit-to nil "JID receiving the current compatibility form.") (define-widget 'jabber-widget-jid 'string "JID widget retained for legacy callers of this adapter." :value-to-internal (lambda (_widget value) (if-let* ((displayname (jabber-jid-rostername value))) (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) "Complete the JID preceding point in legacy WIDGET." (require 'wid-edit) (let* ((prefix (buffer-substring-no-properties (funcall (symbol-function 'widget-field-start) widget) (point))) (candidates (append (mapcar #'symbol-name jabber-roster-list) (cl-loop for item in jabber-roster-list for name = (jabber-jid-rostername item) when name collect (format "%s <%s>" name item)))) (completion (try-completion prefix candidates))) (cond ((eq completion t) (message "Exact match")) ((null completion) (user-error "No completion for %s" prefix)) ((not (equal prefix completion)) (insert-and-inherit (substring completion (length prefix)))) (t (with-output-to-temp-buffer "*Completions*" (display-completion-list (all-completions prefix candidates))))))) (defun jabber-widget-init-buffer (submit-to) "Initialize compatibility form state targeting SUBMIT-TO." (setq-local jabber-widget-alist nil jabber-widget-submit-to submit-to) (setq buffer-read-only nil) (rename-uniquely)) (defun jabber-widget--show-form (form type) "Render plain XData FORM for legacy compatibility TYPE." (let ((submit-to jabber-widget-submit-to)) (jabber-xdata-form-mode) (setq-local jabber-widget-submit-to submit-to jabber-widget-form-type type jabber-widget-alist (plist-get form :fields) jabber-xdata-form--form form jabber-xdata-form--original-form form) (jabber-xdata-form--render))) (defun jabber-widget-render-register-form (query &optional default-username) "Render legacy registration QUERY with optional DEFAULT-USERNAME." (jabber-widget--show-form (jabber-register--legacy-form query default-username) 'register)) (defun jabber-widget-parse-register-form () "Return legacy registration elements from the current plain-data form." (cl-loop for field in (plist-get (jabber-xdata-form-form) :fields) collect (list (intern (plist-get field :var)) nil (or (car (plist-get field :values)) "")))) (defun jabber-widget-render-xdata-form (x &optional defaults) "Render XData form X, applying optional DEFAULTS alist." (let ((form (jabber-xdata-parse x))) (dolist (default defaults) (when (jabber-xdata-field form (car default)) (setq form (jabber-xdata-set-values form (car default) (list (cdr default)))))) (jabber-widget--show-form form 'xdata))) (defun jabber-widget-parse-xdata-form () "Return the current plain-data form encoded as XData submission." (jabber-xdata-form-submit-form)) (defun jabber-widget-xdata-value-convert (value type) "Convert legacy widget VALUE of XData TYPE to a list of strings." (cond ((string= type "boolean") (list (if value "1" "0"))) ((string= type "text-multi") (split-string value "[\n\r]")) ((string-empty-p value) nil) (t (list value)))) (defun jabber-widget-render-xdata-search-results (xdata) "Render search-result XDATA with the text-first renderer." (jabber-xdata-render-result xdata)) (defun jabber-widget-render-xdata-search-results-multi (xdata) "Render multi-record search-result XDATA." (jabber-xdata-render-result xdata)) (defun jabber-widget-render-xdata-search-results-single (xdata) "Render single-record search-result XDATA." (jabber-xdata-render-result xdata)) (provide 'jabber-widget) ;;; jabber-widget.el ends here emacs-jabber-0.13.1/lisp/jabber-xdata-form.el000066400000000000000000000445131523531702000206720ustar00rootroot00000000000000;;; jabber-xdata-form.el --- Text editor for XMPP data forms -*- 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, or (at your option) ;; any later version. ;;; Commentary: ;; Edit staged XEP-0004 forms in a text-first submission buffer. ;;; Code: (require 'button) (require 'cl-lib) (require 'seq) (require 'string-edit) (require 'subr-x) (require 'jabber-util) (require 'jabber-xdata) (defface jabber-xdata-form-changed-value '((t :inherit (warning button))) "Face for changed XEP-0004 field values." :group 'jabber) (defface jabber-xdata-form-pending-action '((t :inherit (warning button))) "Face for actions that submit changed XEP-0004 values." :group 'jabber) (defvar-local jabber-xdata-form--form nil "Plain-data XEP-0004 form edited in the current buffer.") (defvar-local jabber-xdata-form--original-form nil "Original XEP-0004 form used to detect staged changes.") (defvar-local jabber-xdata-form--actions nil "Submission actions available in the current form buffer.") (defun jabber-xdata-form-form () "Return the XEP-0004 form being edited in the current buffer." jabber-xdata-form--form) (defun jabber-xdata-form--option-candidates (field) "Return completion candidates for FIELD's advertised options." (mapcar (lambda (option) (let ((label (plist-get option :label)) (value (plist-get option :value))) (cons (if (equal label value) value (format "%s [%s]" label value)) value))) (plist-get field :options))) (defun jabber-xdata-form--clear-candidate (candidates) "Return a clear-selection candidate distinct from CANDIDATES." (let ((label "Clear selection")) (while (assoc label candidates) (setq label (concat label " "))) (cons label :clear))) (defun jabber-xdata-form--list-candidates (field) "Return completion candidates for list FIELD." (let ((candidates (jabber-xdata-form--option-candidates field))) (if (plist-get field :required) candidates (cons (jabber-xdata-form--clear-candidate candidates) candidates)))) (defun jabber-xdata-form--option-label (field value) "Return FIELD's display label for VALUE." (or (cl-loop for option in (plist-get field :options) when (equal value (plist-get option :value)) return (plist-get option :label)) value)) (defun jabber-xdata-form--prompt (field) "Return a minibuffer prompt for FIELD." (let ((label (or (plist-get field :label) (plist-get field :var))) (description (plist-get field :description))) (if description (format "%s (%s): " label description) (format "%s: " label)))) (defun jabber-xdata-form--summary (field) "Return a short display summary for FIELD." (let ((values (plist-get field :values))) (pcase (plist-get field :type) ("boolean" (if (equal values '("1")) "on" "off")) ("text-private" (if (seq-some (lambda (value) (not (string-empty-p value))) values) "set" "empty")) ((or "list-single" "list-multi") (mapconcat (lambda (value) (jabber-xdata-form--option-label field value)) values ", ")) (_ (mapconcat #'identity values ", "))))) (defun jabber-xdata-form--read-list-single (field) "Read one advertised value for FIELD." (let* ((candidates (jabber-xdata-form--list-candidates field)) (current (car (plist-get field :values))) (default (and current (car (rassoc current candidates)))) (selected (completing-read (jabber-xdata-form--prompt field) candidates nil t nil nil default))) (if (eq (cdr (assoc selected candidates)) :clear) nil (list (or (cdr (assoc selected candidates)) selected))))) (defun jabber-xdata-form--read-list-multi (field) "Read advertised values for FIELD." (let* ((candidates (jabber-xdata-form--list-candidates field)) (defaults (mapcar (lambda (value) (car (rassoc value candidates))) (plist-get field :values))) (selected (jabber-completing-read-multiple (jabber-xdata-form--prompt field) candidates defaults t))) (if (seq-some (lambda (value) (eq (cdr (assoc value candidates)) :clear)) selected) nil (mapcar (lambda (value) (or (cdr (assoc value candidates)) value)) selected)))) (defun jabber-xdata-form--read-jid-multi (field) "Read one or more JIDs for FIELD." (jabber-completing-read-multiple (jabber-xdata-form--prompt field) (mapcar #'symbol-name (jabber-concat-rosters)) (plist-get field :values))) (defun jabber-xdata-form--read-jid-single (field) "Read one JID for FIELD." (list (completing-read (jabber-xdata-form--prompt field) (mapcar #'symbol-name (jabber-concat-rosters)) nil nil nil nil (car (plist-get field :values))))) (defun jabber-xdata-form--read-values (field) "Read new values for FIELD according to its XEP-0004 type." (let* ((type (plist-get field :type)) (current (car (plist-get field :values)))) (pcase type ("boolean" (list (if (equal current "1") "0" "1"))) ("list-single" (jabber-xdata-form--read-list-single field)) ("list-multi" (jabber-xdata-form--read-list-multi field)) ("jid-multi" (jabber-xdata-form--read-jid-multi field)) ("jid-single" (jabber-xdata-form--read-jid-single field)) ("text-private" (list (read-passwd (jabber-xdata-form--prompt field) nil current))) ("text-multi" (split-string (read-string-from-buffer (jabber-xdata-form--prompt field) (string-join (plist-get field :values) "\n")) "[\n\r]" nil)) (_ (list (read-string (jabber-xdata-form--prompt field) current)))))) (defun jabber-xdata-form--dirty-p () "Return non-nil when the current form has staged changes." (not (equal jabber-xdata-form--form jabber-xdata-form--original-form))) (defun jabber-xdata-form--field-dirty-p (field) "Return non-nil when FIELD differs from its server value." (let ((original (jabber-xdata-field jabber-xdata-form--original-form (plist-get field :var)))) (not (equal (plist-get field :values) (plist-get original :values))))) (defun jabber-xdata-form--field-at-point () "Return the field variable at point, if any." (or (get-char-property (point) 'jabber-xdata-field) (get-char-property (line-beginning-position) 'jabber-xdata-field))) (defun jabber-xdata-form--goto-field (var) "Move point to the value button for field VAR." (goto-char (point-min)) (when-let* ((match (text-property-search-forward 'jabber-xdata-field var #'equal)) (button (next-button (prop-match-beginning match)))) (goto-char (button-start button)))) (defun jabber-xdata-form-edit-field (&optional var) "Edit field VAR, or the field at point." (interactive) (let* ((var (or var (jabber-xdata-form--field-at-point))) (field (and var (jabber-xdata-field jabber-xdata-form--form var)))) (unless field (user-error "No editable field at point")) (setq-local jabber-xdata-form--form (jabber-xdata-set-values jabber-xdata-form--form var (jabber-xdata-form--read-values field))) (jabber-xdata-form--render var))) (defun jabber-xdata-form-reset-field (&optional var) "Restore field VAR, or the field at point, to its server value." (interactive) (let* ((var (or var (jabber-xdata-form--field-at-point))) (original (and var (jabber-xdata-field jabber-xdata-form--original-form var)))) (unless original (user-error "No editable field at point")) (setq-local jabber-xdata-form--form (jabber-xdata-set-values jabber-xdata-form--form var (plist-get original :values))) (jabber-xdata-form--render var))) (defun jabber-xdata-form-reset () "Restore every field to its server-provided value." (interactive) (let ((var (jabber-xdata-form--field-at-point))) (setq-local jabber-xdata-form--form jabber-xdata-form--original-form) (jabber-xdata-form--render var))) (defun jabber-xdata-form--edit-button (button) "Edit the field represented by BUTTON." (jabber-xdata-form-edit-field (button-get button 'jabber-xdata-field))) (defun jabber-xdata-form--insert-fixed (field) "Insert the fixed text from FIELD." (when-let* ((text (string-join (plist-get field :values) "\n")) ((not (string-empty-p text)))) (unless (and (> (point) (1+ (point-min))) (eq (char-before) ?\n) (eq (char-before (1- (point))) ?\n)) (insert "\n")) (insert text "\n\n"))) (defun jabber-xdata-form--value-text (field) "Return FIELD's value text for display." (let ((summary (jabber-xdata-form--summary field))) (if (string-empty-p summary) "not set" summary))) (defun jabber-xdata-form--insert-field (field) "Insert one editable FIELD." (let* ((start (point)) (var (plist-get field :var)) (label (or (plist-get field :label) var)) (changed (jabber-xdata-form--field-dirty-p field))) (insert label) (when (plist-get field :required) (insert " *")) (insert ": ") (apply #'insert-text-button (jabber-xdata-form--value-text field) (append (list 'action #'jabber-xdata-form--edit-button 'jabber-xdata-field var 'follow-link t 'help-echo "Edit this field") (when changed (list 'face 'jabber-xdata-form-changed-value)))) (insert "\n") (when-let* ((description (plist-get field :description))) (insert (format " %s\n" description))) (add-text-properties start (point) (list 'jabber-xdata-field var 'rear-nonsticky '(jabber-xdata-field))))) (defun jabber-xdata-form--insert-fields () "Insert all visible fields from the current form." (dolist (field (plist-get jabber-xdata-form--form :fields)) (pcase (plist-get field :type) ("hidden") ("fixed" (jabber-xdata-form--insert-fixed field)) (_ (when (plist-get field :var) (jabber-xdata-form--insert-field field)))))) (defun jabber-xdata-form--action (key) "Return the current form action bound to KEY." (seq-find (lambda (action) (equal (plist-get action :key) key)) jabber-xdata-form--actions)) (defun jabber-xdata-form--action-key-label (key) "Return a display label for action KEY." (pcase key ("RET" "C-c C-c") ("q" "q/C-c C-k") (_ key))) (defun jabber-xdata-form--action-face (action) "Return the display face for ACTION." (and (jabber-xdata-form--dirty-p) (plist-get action :submits-form) 'jabber-xdata-form-pending-action)) (defun jabber-xdata-form--activate-action (button) "Run the action represented by BUTTON." (jabber-xdata-form--run-action (button-get button 'jabber-xdata-action))) (defun jabber-xdata-form--insert-action (action) "Insert one ACTION button." (let* ((key (plist-get action :key)) (label (plist-get action :label)) (text (format "[%s] %s" (jabber-xdata-form--action-key-label key) label))) (apply #'insert-text-button text (append (list 'action #'jabber-xdata-form--activate-action 'jabber-xdata-action action 'follow-link t 'help-echo (format "Run %s" label)) (when-let* ((face (jabber-xdata-form--action-face action))) (list 'face face)))))) (defun jabber-xdata-form--insert-actions () "Insert the current form actions." (when jabber-xdata-form--actions (insert "\nActions\n") (cl-loop for action in jabber-xdata-form--actions for first = t then nil unless first do (insert " ") do (jabber-xdata-form--insert-action action)) (insert "\n"))) (defun jabber-xdata-form--header-line () "Return the header line for the current form buffer." (concat (substitute-command-keys " Edit: \\\\[jabber-xdata-form-edit-field]") (if (jabber-xdata-form--action "RET") (substitute-command-keys " Submit: \\[jabber-xdata-form-submit]") " Choose an action below") (when (jabber-xdata-form--action "q") (substitute-command-keys " Cancel: \\[jabber-xdata-form-cancel]")) (when (jabber-xdata-form--dirty-p) (propertize " Pending changes" 'face 'warning)))) (defun jabber-xdata-form--render (&optional selected-var) "Render the current form and return to SELECTED-VAR." (let ((inhibit-read-only t) (dirty (jabber-xdata-form--dirty-p))) (erase-buffer) (insert (or (plist-get jabber-xdata-form--form :title) "XMPP data form") "\n") (dolist (instruction (plist-get jabber-xdata-form--form :instructions)) (insert instruction "\n")) (insert "\n") (jabber-xdata-form--insert-fields) (jabber-xdata-form--insert-actions) (setq-local header-line-format (jabber-xdata-form--header-line)) (set-buffer-modified-p dirty) (goto-char (point-min)) (if selected-var (jabber-xdata-form--goto-field selected-var) (when-let* ((button (next-button (point-min)))) (goto-char (button-start button)))))) (defun jabber-xdata-form-refresh () "Refresh the current XEP-0004 form buffer." (interactive) (jabber-xdata-form--render (jabber-xdata-form--field-at-point))) (defun jabber-xdata-form--ensure-complete () "Signal a user error when the current form is incomplete." (when-let* ((missing (jabber-xdata--missing-required-fields jabber-xdata-form--form))) (when-let* (((derived-mode-p 'jabber-xdata-form-mode)) (field (seq-find (lambda (candidate) (and (plist-get candidate :var) (not (equal (plist-get candidate :type) "hidden")))) missing))) (jabber-xdata-form--goto-field (plist-get field :var))) (let ((labels (mapcar (lambda (field) (or (plist-get field :label) (plist-get field :var) "Unnamed field")) missing))) (user-error "Required field%s missing: %s" (if (cdr labels) "s" "") (string-join labels ", "))))) (defun jabber-xdata-form--run-action (action) "Run ACTION from the current form buffer." (unless action (user-error "That action is not available")) (when (plist-get action :submits-form) (jabber-xdata-form--ensure-complete)) (let ((form-buffer (current-buffer)) (command (plist-get action :command))) (call-interactively command) (unless (plist-get action :stay-open) (when (buffer-live-p form-buffer) (with-current-buffer form-buffer (set-buffer-modified-p nil) (quit-window 'kill)))))) (defun jabber-xdata-form--run-key (key) "Run the current form action bound to KEY." (jabber-xdata-form--run-action (jabber-xdata-form--action key))) (defun jabber-xdata-form-submit () "Run the default submission action." (interactive) (jabber-xdata-form--run-key "RET")) (defun jabber-xdata-form-previous () "Run the previous-step action." (interactive) (jabber-xdata-form--run-key "p")) (defun jabber-xdata-form-next () "Run the next-step action." (interactive) (jabber-xdata-form--run-key "n")) (defun jabber-xdata-form-complete () "Run the completion action." (interactive) (jabber-xdata-form--run-key "c")) (defun jabber-xdata-form-cancel () "Run the cancellation action." (interactive) (jabber-xdata-form--run-key "q")) (defvar-keymap jabber-xdata-form-mode-map :doc "Keymap for staged XEP-0004 forms." :parent special-mode-map "RET" #'push-button "e" #'jabber-xdata-form-edit-field "u" #'jabber-xdata-form-reset-field "U" #'jabber-xdata-form-reset "TAB" #'forward-button "" #'backward-button "C-c C-c" #'jabber-xdata-form-submit "C-c C-k" #'jabber-xdata-form-cancel "p" #'jabber-xdata-form-previous "n" #'jabber-xdata-form-next "c" #'jabber-xdata-form-complete "q" #'jabber-xdata-form-cancel "g" #'jabber-xdata-form-refresh) (define-derived-mode jabber-xdata-form-mode special-mode "Jabber-Form" "Major mode for staging and submitting an XEP-0004 form. Edit the field at point with \\[jabber-xdata-form-edit-field]. Restore its server value with \\[jabber-xdata-form-reset-field], or restore the whole form with \\[jabber-xdata-form-reset]. Submit with \\[jabber-xdata-form-submit] and cancel with \\[jabber-xdata-form-cancel]." :interactive nil (setq-local truncate-lines nil)) (defun jabber-xdata-form-submit-form () "Return the edited form as an XEP-0004 submission. Signal a user error when required fields are empty." (jabber-xdata-form--ensure-complete) (jabber-xdata-submit jabber-xdata-form--form)) (defun jabber-xdata-form-open (form actions) "Edit plain-data XEP-0004 FORM with staged ACTIONS. Each action is a plist with :key, :label, and :command entries." (let* ((title (or (plist-get form :title) "XMPP data form")) (buffer (generate-new-buffer (format "*Jabber form: %s*" title)))) (with-current-buffer buffer (jabber-xdata-form-mode) (setq-local jabber-xdata-form--form form) (setq-local jabber-xdata-form--original-form form) (setq-local jabber-xdata-form--actions actions) (jabber-xdata-form--render)) (pop-to-buffer buffer) (message "%s" (substitute-command-keys (concat "Edit with \\" "\\[jabber-xdata-form-edit-field], submit with " "\\[jabber-xdata-form-submit], or cancel with " "\\[jabber-xdata-form-cancel]"))) buffer)) (provide 'jabber-xdata-form) ;;; jabber-xdata-form.el ends here emacs-jabber-0.13.1/lisp/jabber-xdata.el000066400000000000000000000230101523531702000177160ustar00rootroot00000000000000;;; jabber-xdata.el --- XMPP data form helpers -*- 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. ;;; Commentary: ;; Parse XMPP data forms without depending on widget rendering. ;;; Code: (require 'cl-lib) (require 'seq) (require 'subr-x) (require 'jabber-xml) (defconst jabber-xdata--field-types '("boolean" "fixed" "hidden" "jid-multi" "jid-single" "list-multi" "list-single" "text-multi" "text-private" "text-single") "Field types defined by XEP-0004.") (defun jabber-xdata--child-text (node child-name) "Return the text of NODE's first CHILD-NAME child." (when-let* ((child (car (jabber-xml-get-children node child-name)))) (car (jabber-xml-node-children child)))) (defun jabber-xdata--values (field) "Return FIELD's value strings in document order." (mapcar (lambda (value) (or (car (jabber-xml-node-children value)) "")) (jabber-xml-get-children field 'value))) (defun jabber-xdata--field-type (field) "Return FIELD's supported type, defaulting to text-single." (let ((type (jabber-xml-get-attribute field 'type))) (if (member type jabber-xdata--field-types) type "text-single"))) (defun jabber-xdata--option (option) "Return plain data for OPTION, or nil when it has no value." (when-let* ((value (jabber-xdata--child-text option 'value))) (list :label (or (jabber-xml-get-attribute option 'label) value) :value value))) (defun jabber-xdata--field (field) "Return plain data parsed from XEP-0004 FIELD." (let* ((type (jabber-xdata--field-type field)) (options (seq-keep #'jabber-xdata--option (jabber-xml-get-children field 'option))) (result (list :var (jabber-xml-get-attribute field 'var) :type type :label (jabber-xml-get-attribute field 'label) :description (jabber-xdata--child-text field 'desc) :required (not (null (jabber-xml-get-children field 'required))) :options options))) (plist-put result :values (jabber-xdata--normalized-values result (jabber-xdata--values field))))) (defun jabber-xdata-parse (x) "Return a plain-data representation of XEP-0004 form X." (list :title (jabber-xdata--child-text x 'title) :instructions (mapcar (lambda (instruction) (or (car (jabber-xml-node-children instruction)) "")) (jabber-xml-get-children x 'instructions)) :fields (mapcar #'jabber-xdata--field (jabber-xml-get-children x 'field)))) (defun jabber-xdata-field (form var) "Return the field named VAR from plain-data FORM." (seq-find (lambda (field) (equal (plist-get field :var) var)) (plist-get form :fields))) (defun jabber-xdata--list-values (field values) "Return advertised FIELD option VALUES in server order." (let ((selected (delete-dups (copy-sequence values)))) (cl-loop for option in (plist-get field :options) for value = (plist-get option :value) when (member value selected) collect value))) (defun jabber-xdata--normalized-values (field values) "Return VALUES normalized for FIELD's XEP-0004 type." (pcase (plist-get field :type) ("boolean" (when values (list (if (member (car values) '("1" "true")) "1" "0")))) ("list-multi" (jabber-xdata--list-values field values)) ("list-single" (seq-take (jabber-xdata--list-values field values) 1)) ("jid-multi" (seq-uniq values #'jabber-xdata--jid-equal-p)) ((or "text-multi" "hidden") (copy-sequence values)) (_ (seq-take values 1)))) (defun jabber-xdata--jid-equal-p (first second) "Return non-nil when JIDs FIRST and SECOND compare equal." (let ((split (lambda (jid) (if (string-match "\\`\\([^/]*\\)\\(?:/\\(.*\\)\\)?\\'" jid) (cons (downcase (match-string 1 jid)) (match-string 2 jid)) (cons (downcase jid) nil))))) (equal (funcall split first) (funcall split second)))) (defun jabber-xdata-set-values (form var values) "Return FORM with field VAR replaced by normalized VALUES." (or (jabber-xdata-field form var) (error "Unknown XEP-0004 field %s" var)) (let ((fields (mapcar (lambda (field) (if (equal (plist-get field :var) var) (plist-put (copy-sequence field) :values (jabber-xdata--normalized-values field values)) field)) (plist-get form :fields)))) (plist-put (copy-sequence form) :fields fields))) (defun jabber-xdata--missing-required-fields (form) "Return required field plists missing values in FORM." (cl-loop for field in (plist-get form :fields) for values = (plist-get field :values) when (and (plist-get field :required) (not (seq-some (lambda (value) (and (stringp value) (not (string-empty-p value)))) values))) collect field)) (defun jabber-xdata-missing-required-fields (form) "Return labels of required fields missing values in FORM." (mapcar (lambda (field) (or (plist-get field :label) (plist-get field :var) "Unnamed field")) (jabber-xdata--missing-required-fields form))) (defun jabber-xdata--submit-field (field) "Return FIELD encoded for an XEP-0004 submission." (when (and (plist-get field :var) (not (string= (plist-get field :type) "fixed"))) `(field ((var . ,(plist-get field :var))) ,@(mapcar (lambda (value) `(value nil ,value)) (plist-get field :values))))) (defun jabber-xdata-submit (form) "Return FORM encoded as an XEP-0004 submission." `(x ((xmlns . ,jabber-xdata-xmlns) (type . "submit")) ,@(seq-keep #'jabber-xdata--submit-field (plist-get form :fields)))) (defun jabber-xdata-form-type (x) "Return the form type of the XData form X. Return nil when X has no XEP-0068 FORM_TYPE field." (catch 'form-type (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 'form-type (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value))))))))) (define-obsolete-function-alias 'jabber-widget-xdata-formtype #'jabber-xdata-form-type "0.11.0") (defun jabber-xdata--result-value (field) "Return FIELD result values joined for display." (string-join (jabber-xdata--values field) ", ")) (defun jabber-xdata--render-result-row (item columns) "Insert one XEP-0004 result ITEM using COLUMNS metadata." (let ((start (point)) (jid-columns (cl-count "jid-single" columns :key (lambda (column) (plist-get column :type)) :test #'string=)) row-jid) (dolist (column columns) (let* ((var (plist-get column :var)) (field (seq-find (lambda (candidate) (equal var (jabber-xml-get-attribute candidate 'var))) (jabber-xml-get-children item 'field))) (value (and field (jabber-xdata--result-value field)))) (when (and value (string= (plist-get column :type) "jid-single")) (if (= jid-columns 1) (setq row-jid value) (setq value (propertize value 'jabber-jid value)))) (insert (format "%-20s" (or value ""))))) (when row-jid (put-text-property start (point) 'jabber-jid row-jid)) (insert "\n"))) (defun jabber-xdata-render-result (xdata) "Render XEP-0004 result XDATA at point without widget.el." (when-let* ((title (jabber-xdata--child-text xdata 'title))) (insert (propertize title 'face 'jabber-title) "\n")) (if-let* ((reported (car (jabber-xml-get-children xdata 'reported)))) (let ((columns (mapcar (lambda (field) (list :var (jabber-xml-get-attribute field 'var) :label (or (jabber-xml-get-attribute field 'label) (jabber-xml-get-attribute field 'var)) :type (jabber-xdata--field-type field))) (jabber-xml-get-children reported 'field)))) (dolist (column columns) (insert (propertize (format "%-20s" (plist-get column :label)) 'face 'bold))) (insert "\n\n") (dolist (item (jabber-xml-get-children xdata 'item)) (jabber-xdata--render-result-row item columns))) (dolist (field (jabber-xml-get-children xdata 'field)) (insert (propertize (concat (or (jabber-xml-get-attribute field 'label) (jabber-xml-get-attribute field 'var) "Field") ": ") 'face 'bold) (jabber-xdata--result-value field) "\n")))) (provide 'jabber-xdata) ;;; jabber-xdata.el ends here emacs-jabber-0.13.1/lisp/jabber-xml.el000066400000000000000000000274551523531702000174360ustar00rootroot00000000000000;;; 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 " ") ; 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 when XML-DATA carries an encryption child element. Check 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) "Rewrite namespace prefixes in XML-DATA to xmlns attributes. DEFAULT-NS is the inherited default namespace; PREFIXES is the alist of declared 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) "Return PREFIXES extended with any xmlns:* declarations found in ATTRS." ;; 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-0.13.1/lisp/jabber.el000066400000000000000000000200701523531702000166220ustar00rootroot00000000000000;;; jabber.el --- XMPP/Jabber client -*- lexical-binding: t; -*- ;; Author: Magnus Henoch ;; Maintainer: Thanos Apollo ;; Keywords: comm ;; Homepage: https://git.thanosapollo.org/emacs-jabber/about/ ;; Package-Requires: ((emacs "29.1") (fsm "0.2.0") (keymap-popup "0.2")) ;; Version: 0.13.1 ;; 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'. :proxy is a plist describing a SOCKS5 proxy. It has the form (:type socks5 :host HOST :port PORT). 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))) (cons :format "%v" (const :format "" :proxy) (list :tag "SOCKS5 proxy" (const :format "" :type) (const :format "" socks5) (const :format "" :host) (string :tag "Host") (const :format "" :port) (integer :tag "Port" 1080)))))) :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-keymap) (require 'jabber-util) (require 'jabber-xml) (require 'jabber-conn) (require 'jabber-core) (require 'jabber-keepalive) (require 'jabber-roster) (require 'jabber-presence) (require 'jabber-alert) (require 'jabber-chat) (require 'jabber-subscription) (require 'jabber-db) (require 'jabber-disco) (require 'jabber-iq) (require 'jabber-xdata) (require 'jabber-register) (require 'jabber-search) (require 'jabber-blocking) (require 'jabber-moderation) (require 'jabber-message-correct) (require 'jabber-message-reply) (require 'jabber-reactions) (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-rtt) (require 'jabber-vcard-avatars) (require 'jabber-autoaway) (require 'jabber-time) (require 'jabber-disco-menu) (require 'jabber-muc-menu) (require 'jabber-roster-menu) (require 'jabber-chat-commands) (jabber-disco-advertise-feature jabber-xdata-xmlns) (require 'jabber-uri) (require 'jabber-truncate) (when (featurep 'dbusbind) (require 'jabber-notifications nil t)) (define-obsolete-variable-alias '*jabber-current-status* 'jabber-current-status "0.11.0") ;;;###autoload (defvar jabber-current-status nil "The user's current presence status.") (define-obsolete-variable-alias '*jabber-current-show* 'jabber-current-show "0.11.0") ;;;###autoload (defvar jabber-current-show nil "The user's current presence show.") (define-obsolete-variable-alias '*jabber-current-priority* 'jabber-current-priority "0.11.0") ;;;###autoload (defvar jabber-current-priority nil "The user's current priority.") (define-obsolete-variable-alias '*jabber-status-history* 'jabber-status-history "0.11.0") (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 (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-0.13.1/src/000077500000000000000000000000001523531702000146745ustar00rootroot00000000000000emacs-jabber-0.13.1/src/Makefile000066400000000000000000000017611523531702000163410ustar00rootroot00000000000000CC = 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_MIN_VERSION = 3.0.0 MBED_CHECK = pkg-config --atleast-version=$(MBED_MIN_VERSION) mbedcrypto 2>/dev/null MBED_FLAGS ?= $(shell $(MBED_CHECK) && pkg-config --cflags --libs mbedcrypto 2>/dev/null) SRCS = jabber-omemo-core.c picomemo/omemo.c picomemo/hacl.c picomemo/mbedtls.c TARGET = jabber-omemo-core$(SOEXT) INSTALL_DIR ?= $(if $(wildcard ../lisp),../lisp,..) all: $(INSTALL_DIR)/$(TARGET) $(TARGET): $(SRCS) picomemo/omemo.h picomemo/driver.h ifeq ($(MBED_FLAGS),) $(error libmbedcrypto >= $(MBED_MIN_VERSION) 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-0.13.1/src/jabber-omemo-core.c000066400000000000000000001367461523531702000203460ustar00rootroot00000000000000/* * 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 #if defined(__ANDROID__) #include #include #define getrandom(buf,buflen,flags) syscall(SYS_getrandom,buf,buflen,flags) #endif #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 registry. picomemo hands skipped ratchet keys to the embedder through omemoStoreMessageKey and asks for them back in omemoLoadMessageKey. Both fire synchronously inside omemoDecryptKey, where no emacs_env is available, so keys live in a malloc'd per-session list here. The list is serialized with the native session so skipped keys survive restarts without separate database writes. */ struct skipped_key { uint32_t nr; uint8_t dh[32]; uint8_t mk[32]; }; struct native_session { struct omemoSession session; struct skipped_key *keys; size_t count, cap; size_t decrypt_new_count; }; /* Upper bound on retained skipped keys per session; a peer jumping further ahead than this in one ratchet aborts the decrypt with OMEMO_ESTORE instead of allocating without limit. */ #define SKIPPED_KEYS_MAX 1000 #define SESSION_MAGIC "JOMEMO\0\1" #define SESSION_MAGIC_SIZE 8 #define SESSION_VERSION 1 #define SESSION_HEADER_SIZE 20 #define SKIPPED_KEY_SIZE 68 static void skipped_clear(void *ptr, size_t size) { volatile unsigned char *p = ptr; while (size--) *p++ = 0; } static struct native_session * native_session(struct omemoSession *session) { return (struct native_session *)session; } static void skipped_drop(struct native_session *session) { if (session->keys) { skipped_clear(session->keys, session->cap * sizeof(struct skipped_key)); free(session->keys); } session->keys = NULL; session->count = session->cap = 0; } static int skipped_add(struct native_session *session, uint32_t nr, const uint8_t *dh, const uint8_t *mk) { if (session->count == SKIPPED_KEYS_MAX) { skipped_clear(&session->keys[0], sizeof session->keys[0]); memmove(&session->keys[0], &session->keys[1], (session->count - 1) * sizeof session->keys[0]); session->count--; } if (session->count == session->cap) { size_t ncap = session->cap ? session->cap * 2 : 16; if (ncap > SKIPPED_KEYS_MAX) ncap = SKIPPED_KEYS_MAX; struct skipped_key *n = realloc(session->keys, ncap * sizeof *n); if (!n) return 1; memset(n + session->cap, 0, (ncap - session->cap) * sizeof *n); session->keys = n; session->cap = ncap; } session->keys[session->count].nr = nr; memcpy(session->keys[session->count].dh, dh, 32); memcpy(session->keys[session->count].mk, mk, 32); session->count++; return 0; } int omemoLoadMessageKey(struct omemoSession *s, struct omemoMessageKey *k) { struct native_session *session = native_session(s); for (size_t i = 0; i < session->count; i++) { struct skipped_key *sk = &session->keys[i]; if (sk->nr == k->nr && !memcmp(sk->dh, k->dh, 32)) { memcpy(k->mk, sk->mk, 32); return 0; } } return 1; /* not found */ } int omemoRemoveMessageKey(struct omemoSession *s, const struct omemoMessageKey *k) { struct native_session *session = native_session(s); for (size_t i = 0; i < session->count; i++) { struct skipped_key *sk = &session->keys[i]; if (sk->nr == k->nr && !memcmp(sk->dh, k->dh, 32)) { skipped_clear(sk, sizeof *sk); memmove(sk, sk + 1, (session->count - i - 1) * sizeof *sk); skipped_clear(&session->keys[session->count - 1], sizeof(struct skipped_key)); session->count--; return 0; } } return OMEMO_ESTORE; } int omemoStoreMessageKey(struct omemoSession *s, const struct omemoMessageKey *k, uint64_t n) { (void)n; struct native_session *session = native_session(s); if (session->decrypt_new_count >= SKIPPED_KEYS_MAX || skipped_add(session, k->nr, k->dh, k->mk)) return OMEMO_ESTORE; session->decrypt_new_count++; 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 message = env->make_string(env, msg, strlen(msg)); emacs_value data = env->funcall(env, env->intern(env, "list"), 1, &message); 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; } static int extract_exact_unibyte(emacs_env *env, emacs_value arg, uint8_t *buf, size_t expected, const char *message) { ptrdiff_t len = 0; env->copy_string_contents(env, arg, NULL, &len); if (env->non_local_exit_check(env)) return -1; if (len != (ptrdiff_t)expected + 1) { signal_error(env, OMEMO_ESTORE, message); return -1; } return extract_unibyte(env, arg, buf, expected + 1, NULL); } /* Finalizers for user-ptr */ static void free_store(void *ptr) { free(ptr); } static void free_session(void *ptr) { struct native_session *session = ptr; skipped_drop(session); skipped_clear(&session->session, sizeof session->session); free(ptr); } static void * checked_user_ptr(emacs_env *env, emacs_value value, void (*expected)(void *), const char *message) { void (*finalizer)(void *) = env->get_user_finalizer(env, value); if (env->non_local_exit_check(env)) return NULL; if (finalizer != expected) { signal_error(env, OMEMO_ESTORE, message); return NULL; } return env->get_user_ptr(env, value); } static struct omemoStore * extract_store(emacs_env *env, emacs_value value) { return checked_user_ptr(env, value, free_store, "expected an OMEMO store pointer"); } static struct native_session * extract_session(emacs_env *env, emacs_value value) { return checked_user_ptr(env, value, free_session, "expected an OMEMO session pointer"); } static uint32_t read_u32(const uint8_t *p) { return ((uint32_t)p[0] << 24) | ((uint32_t)p[1] << 16) | ((uint32_t)p[2] << 8) | p[3]; } static void write_u32(uint8_t *p, uint32_t value) { p[0] = value >> 24; p[1] = value >> 16; p[2] = value >> 8; p[3] = value; } static bool session_envelope_p(const uint8_t *blob, size_t len) { return len >= SESSION_MAGIC_SIZE && !memcmp(blob, SESSION_MAGIC, SESSION_MAGIC_SIZE); } /* 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 = extract_store(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 = extract_store(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 = extract_store(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 = extract_store(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--remove-pre-key */ static emacs_value F_remove_pre_key(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; struct omemoStore *store = extract_store(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; intmax_t id = env->extract_integer(env, args[1]); if (env->non_local_exit_check(env)) return Qnil_v; if (id <= 0) return Qnil_v; for (int i = 0; i < OMEMO_NUMPREKEYS; i++) { if (store->prekeys[i].id == (uint32_t)id) { memset(&store->prekeys[i], 0, sizeof(struct omemoPreKey)); return Qt_v; } } return Qnil_v; } /* jabber-omemo--used-pre-key-id */ static emacs_value F_used_pre_key_id(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; struct native_session *native = extract_session(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; return env->make_integer(env, native->session.usedpk_id); } /* 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]; if (extract_exact_unibyte(env, args[0], key, 32, "message key must be exactly 32 bytes")) return Qnil_v; /* Extract IV (12 bytes) */ uint8_t iv[13]; if (extract_exact_unibyte(env, args[1], iv, 12, "message IV must be exactly 12 bytes")) 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, 32, 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 native_session *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 = extract_store(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; /* Extract signature (64 bytes) */ uint8_t sig[65]; if (extract_exact_unibyte(env, args[1], sig, 64, "signature must be exactly 64 bytes")) return Qnil_v; /* Extract signed pre-key (33 bytes) */ uint8_t spk[34]; if (extract_exact_unibyte(env, args[2], spk, 33, "signed pre-key must be exactly 33 bytes")) return Qnil_v; /* Extract identity key (33 bytes) */ uint8_t ik[34]; if (extract_exact_unibyte(env, args[3], ik, 33, "identity key must be exactly 33 bytes")) return Qnil_v; /* Extract pre-key (33 bytes) */ uint8_t pk[34]; if (extract_exact_unibyte(env, args[4], pk, 33, "pre-key must be exactly 33 bytes")) 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 native_session *session = calloc(1, sizeof(*session)); if (!session) { signal_error(env, -1, "calloc failed"); return Qnil_v; } int rc = omemoInitiateSession(&session->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 native_session *session = extract_session(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; size_t raw_size = omemoGetSerializedSessionSize(&session->session); if (session->count > SKIPPED_KEYS_MAX || raw_size > UINT32_MAX || session->count > (SIZE_MAX - SESSION_HEADER_SIZE - raw_size) / SKIPPED_KEY_SIZE) { signal_error(env, OMEMO_ESTORE, "session is too large to serialize"); return Qnil_v; } size_t sz = SESSION_HEADER_SIZE + raw_size + session->count * SKIPPED_KEY_SIZE; uint8_t *buf = malloc(sz); if (!buf) { signal_error(env, -1, "malloc failed"); return Qnil_v; } memcpy(buf, SESSION_MAGIC, SESSION_MAGIC_SIZE); write_u32(buf + 8, SESSION_VERSION); write_u32(buf + 12, (uint32_t)raw_size); write_u32(buf + 16, (uint32_t)session->count); omemoSerializeSession(buf + SESSION_HEADER_SIZE, &session->session); uint8_t *p = buf + SESSION_HEADER_SIZE + raw_size; for (size_t i = 0; i < session->count; i++, p += SKIPPED_KEY_SIZE) { write_u32(p, session->keys[i].nr); memcpy(p + 4, session->keys[i].dh, 32); memcpy(p + 36, session->keys[i].mk, 32); } emacs_value result = make_unibyte(env, buf, sz); skipped_clear(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 native_session *session = calloc(1, sizeof(*session)); if (!session) { free(blob); signal_error(env, -1, "calloc failed"); return Qnil_v; } const uint8_t *raw = blob; size_t raw_size = datalen; uint32_t key_count = 0; if (session_envelope_p(blob, datalen)) { if (datalen < SESSION_HEADER_SIZE || read_u32(blob + 8) != SESSION_VERSION) { skipped_clear(blob, datalen); free(blob); free(session); signal_error(env, OMEMO_ECORRUPT, "invalid session envelope"); return Qnil_v; } raw_size = read_u32(blob + 12); key_count = read_u32(blob + 16); if (key_count > SKIPPED_KEYS_MAX || raw_size > datalen - SESSION_HEADER_SIZE || key_count > (SIZE_MAX - SESSION_HEADER_SIZE - raw_size) / SKIPPED_KEY_SIZE || SESSION_HEADER_SIZE + raw_size + (size_t)key_count * SKIPPED_KEY_SIZE != datalen) { skipped_clear(blob, datalen); free(blob); free(session); signal_error(env, OMEMO_ECORRUPT, "malformed session envelope"); return Qnil_v; } raw = blob + SESSION_HEADER_SIZE; } int rc = omemoDeserializeSession(raw, raw_size, &session->session); if (!rc && key_count) { const uint8_t *p = raw + raw_size; for (uint32_t i = 0; i < key_count; i++, p += SKIPPED_KEY_SIZE) if (skipped_add(session, read_u32(p), p + 4, p + 36)) { rc = OMEMO_ESTORE; break; } } skipped_clear(blob, datalen); free(blob); if (rc) { skipped_drop(session); free(session); signal_error(env, rc, "omemoDeserializeSession failed"); return Qnil_v; } return env->make_user_ptr(env, free_session, session); } /* jabber-omemo--legacy-session-blob-p */ static emacs_value F_legacy_session_blob_p(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; } if (!env->copy_string_contents(env, args[0], (char *)blob, &bloblen)) { free(blob); return Qnil_v; } emacs_value result = session_envelope_p(blob, (size_t)bloblen - 1) ? Qnil_v : Qt_v; skipped_clear(blob, (size_t)bloblen - 1); free(blob); return result; } /* 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 native_session *native = extract_session(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(&native->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 native_session *native = extract_session(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; struct omemoStore *store = extract_store(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); size_t old_count = native->count; struct skipped_key *old_keys = NULL; if (old_count) { old_keys = malloc(old_count * sizeof *old_keys); if (!old_keys) { free(msgbuf); signal_error(env, OMEMO_ESTORE, "cannot snapshot skipped keys"); return Qnil_v; } memcpy(old_keys, native->keys, old_count * sizeof *old_keys); } native->decrypt_new_count = 0; int rc = omemoDecryptKey(&native->session, store, key, &keyn, isprekey, msgbuf, msglen); native->decrypt_new_count = 0; free(msgbuf); if (rc) { skipped_drop(native); native->keys = old_keys; native->count = native->cap = old_count; signal_error(env, rc, "omemoDecryptKey failed"); return Qnil_v; } if (old_keys) { skipped_clear(old_keys, old_count * sizeof *old_keys); free(old_keys); } return make_unibyte(env, key, keyn); } /* jabber-omemo--session-skipped-keys */ static emacs_value F_session_skipped_keys(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; struct native_session *session = extract_session(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; if (!session->count) return Qnil_v; size_t count = session->count; struct skipped_key *snapshot = malloc(count * sizeof *snapshot); if (!snapshot && count) { signal_error(env, OMEMO_ESTORE, "cannot snapshot skipped keys"); return Qnil_v; } memcpy(snapshot, session->keys, count * sizeof *snapshot); emacs_value Qlist = env->intern(env, "list"); emacs_value Qcons = env->intern(env, "cons"); emacs_value result = Qnil_v; for (size_t i = count; i > 0; i--) { struct skipped_key *sk = &snapshot[i - 1]; emacs_value entry_args[] = { env->make_integer(env, sk->nr), make_unibyte(env, sk->dh, 32), make_unibyte(env, sk->mk, 32), }; emacs_value entry = env->funcall(env, Qlist, 3, entry_args); emacs_value cons_args[] = { entry, result }; result = env->funcall(env, Qcons, 2, cons_args); } skipped_clear(snapshot, count * sizeof *snapshot); free(snapshot); return result; } /* jabber-omemo--session-set-skipped-keys */ struct skipped_key_symbols { emacs_value car, cdr, consp, integerp, stringp; }; static int intern_skipped_key_symbols(emacs_env *env, struct skipped_key_symbols *symbols) { symbols->car = env->intern(env, "car"); if (env->non_local_exit_check(env)) return -1; symbols->cdr = env->intern(env, "cdr"); if (env->non_local_exit_check(env)) return -1; symbols->consp = env->intern(env, "consp"); if (env->non_local_exit_check(env)) return -1; symbols->integerp = env->intern(env, "integerp"); if (env->non_local_exit_check(env)) return -1; symbols->stringp = env->intern(env, "stringp"); return env->non_local_exit_check(env) ? -1 : 0; } static int emacs_truth(emacs_env *env, emacs_value value, bool *result) { *result = env->is_not_nil(env, value); return env->non_local_exit_check(env) ? -1 : 0; } static int take_cons(emacs_env *env, const struct skipped_key_symbols *symbols, emacs_value *list, emacs_value *value, const char *message) { emacs_value proper = env->funcall(env, symbols->consp, 1, list); if (env->non_local_exit_check(env)) return -1; bool is_cons; if (emacs_truth(env, proper, &is_cons)) return -1; if (!is_cons) { signal_error(env, OMEMO_EPARAM, message); return -1; } *value = env->funcall(env, symbols->car, 1, list); if (env->non_local_exit_check(env)) return -1; *list = env->funcall(env, symbols->cdr, 1, list); return env->non_local_exit_check(env) ? -1 : 0; } static int require_type(emacs_env *env, emacs_value predicate, emacs_value value, const char *message) { emacs_value valid = env->funcall(env, predicate, 1, &value); if (env->non_local_exit_check(env)) return -1; bool matches; if (emacs_truth(env, valid, &matches)) return -1; if (!matches) { signal_error(env, OMEMO_EPARAM, message); return -1; } return 0; } static int parse_skipped_key(emacs_env *env, const struct skipped_key_symbols *symbols, emacs_value entry, struct skipped_key *key) { emacs_value nr, dh, mk; if (take_cons(env, symbols, &entry, &nr, "malformed skipped key entry") || take_cons(env, symbols, &entry, &dh, "malformed skipped key entry") || take_cons(env, symbols, &entry, &mk, "malformed skipped key entry")) return -1; bool has_tail; if (emacs_truth(env, entry, &has_tail)) return -1; if (has_tail) { signal_error(env, OMEMO_EPARAM, "malformed skipped key entry"); return -1; } if (require_type(env, symbols->integerp, nr, "skipped key message number must be an integer") || require_type(env, symbols->stringp, dh, "skipped dh key must be a string") || require_type(env, symbols->stringp, mk, "skipped message key must be a string")) return -1; intmax_t number = env->extract_integer(env, nr); if (env->non_local_exit_check(env)) return -1; if (number < 0 || number > UINT32_MAX) { signal_error(env, OMEMO_EPARAM, "skipped key message number is out of range"); return -1; } uint8_t dh_buf[33], mk_buf[33]; if (extract_exact_unibyte(env, dh, dh_buf, 32, "skipped dh key must be exactly 32 bytes") || extract_exact_unibyte(env, mk, mk_buf, 32, "skipped message key must be exactly 32 bytes")) return -1; key->nr = (uint32_t)number; memcpy(key->dh, dh_buf, sizeof key->dh); memcpy(key->mk, mk_buf, sizeof key->mk); return 0; } static emacs_value F_session_set_skipped_keys(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; struct native_session *session = extract_session(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; struct skipped_key_symbols symbols; if (intern_skipped_key_symbols(env, &symbols)) return Qnil_v; struct native_session temporary = {0}; emacs_value l = args[1]; for (;;) { bool more; if (emacs_truth(env, l, &more)) goto fail; if (!more) break; emacs_value entry; struct skipped_key key; if (take_cons(env, &symbols, &l, &entry, "skipped keys must be a proper list") || parse_skipped_key(env, &symbols, entry, &key)) goto fail; if (skipped_add(&temporary, key.nr, key.dh, key.mk)) { signal_error(env, OMEMO_ESTORE, "cannot store skipped key"); goto fail; } } skipped_drop(session); session->keys = temporary.keys; session->count = temporary.count; session->cap = temporary.cap; return Qnil_v; fail: skipped_drop(&temporary); return Qnil_v; } /* jabber-omemo--heartbeat */ static emacs_value F_heartbeat(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; struct native_session *native = extract_session(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; struct omemoStore *store = extract_store(env, args[1]); if (env->non_local_exit_check(env)) return Qnil_v; struct omemoKeyMessage msg; memset(&msg, 0, sizeof(msg)); int rc = omemoHeartbeat(&native->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--remove-pre-key", F_remove_pre_key, 2, 2, "Remove one-time pre-key ID from STORE-PTR (XEP-0384).\n" "Zeroes the matching slot; jabber-omemo--refill-pre-keys\n" "regenerates zeroed slots. Mutates the store; caller must\n" "re-serialize. Returns non-nil when a slot was removed."); DEFUN("jabber-omemo--used-pre-key-id", F_used_pre_key_id, 1, 1, "Return the one-time pre-key id consumed by SESSION-PTR.\n" "Non-zero only after a fresh session decrypted a pre-key\n" "message; the value persists in the serialized session."); 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--legacy-session-blob-p", F_legacy_session_blob_p, 1, 1, "Return non-nil when BLOB uses the legacy raw session format."); 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--session-skipped-keys", F_session_skipped_keys, 1, 1, "Return SESSION-PTR's in-memory skipped message keys.\n" "Each element is (NR DH MK) with NR an integer and DH/MK\n" "32-byte unibyte strings."); DEFUN("jabber-omemo--session-set-skipped-keys", F_session_set_skipped_keys, 2, 2, "Replace SESSION-PTR's in-memory skipped message keys with KEYS.\n" "KEYS is a list of (NR DH MK) entries as returned by\n" "jabber-omemo--session-skipped-keys."); 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-0.13.1/src/picomemo/000077500000000000000000000000001523531702000165045ustar00rootroot00000000000000emacs-jabber-0.13.1/src/picomemo/LICENSE000066400000000000000000000013411523531702000175100ustar00rootroot00000000000000ISC License Copyright 2024 mierenhoop Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. emacs-jabber-0.13.1/src/picomemo/README000066400000000000000000000005471523531702000173720ustar00rootroot00000000000000picomemo vendored source Repository: https://github.com/mierenhoop/picomemo Commit: b156667e922a8c518746629719e4348b6a46d84d Version: 1.2.0-5-gb156667 Vendored files: omemo.c, omemo.h, hacl.c, driver.h, mbedtls.c, LICENSE This tree intentionally keeps only the files needed to build the emacs-jabber OMEMO native module with the HACL* and Mbed TLS drivers. emacs-jabber-0.13.1/src/picomemo/driver.h000066400000000000000000000043031523531702000201500ustar00rootroot00000000000000/** * Copyright 2026 mierenhoop * * Permission to use, copy, modify, and/or distribute this software for * any purpose with or without fee is hereby granted, provided that the * above copyright notice and this permission notice appear in all * copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL * WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED * WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE * AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER * TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR * PERFORMANCE OF THIS SOFTWARE. */ #ifndef OMEMO_DRIVER_H_ #define OMEMO_DRIVER_H_ #include "omemo.h" int omemoDriverHmac(const omemoKey k, const uint8_t *in, size_t ilen, uint8_t out[static 32]); int omemoDriverAesEncrypt(omemoKey k, size_t n, uint8_t iv[static 16], const uint8_t *s, uint8_t *d); int omemoDriverAesDecrypt(omemoKey k, size_t n, uint8_t iv[static 16], const uint8_t *s, uint8_t *d); int omemoDriverHkdf(const uint8_t *salt, size_t saltn, const uint8_t *key, size_t keyn, const uint8_t *info, size_t infon, uint8_t *out, size_t outn); int omemoDriverGcmEncrypt(uint8_t *d, const uint8_t key[static 16], size_t n, const uint8_t iv[static 12], uint8_t tag[static 16], const uint8_t *s); int omemoDriverGcmDecrypt(uint8_t *d, const uint8_t key[static 16], size_t n, const uint8_t iv[static 12], const uint8_t *tag, size_t tagn, const uint8_t *s); int omemoDriverCompare(const void *a, const void *b, size_t n); void omemoDriverEdSignMod(omemoCurveSignature sig, omemoKey pub, omemoKey prv, uint8_t *msg, size_t msgn); bool omemoDriverEdVerify(omemoCurveSignature sig, omemoKey pub, uint8_t *msg, size_t msgn); void omemoDriverEdSeedToPubPrv(omemoKey pub, omemoKey prv, omemoKey seed); void omemoDriverEdPubToCvPub(omemoKey cv, omemoKey ed); void omemoDriverCvPrvToEdPub(omemoKey pub, omemoKey prv); void omemoDriverCvPubToEdPub(omemoKey ed, omemoKey cv); void omemoDriverCvPrvToPub(omemoKey pub, omemoKey prv); int omemoDriverX25519(omemoKey out, omemoKey prv, omemoKey pub); #endif emacs-jabber-0.13.1/src/picomemo/hacl.c000066400000000000000000010405611523531702000175660ustar00rootroot00000000000000#ifdef __x86_64__ #define HACL_CAN_COMPILE_INTRINSICS 1 #endif #define HACL_CAN_COMPILE_UINT128 1 #define KRML_HOST_PRINTF(...) (void)0 #define KRML_HOST_EPRINTF(...) (void)0 // Start of amalgamation /* Copyright (c) INRIA and Microsoft Corporation. All rights reserved. Licensed under the Apache 2.0 and MIT Licenses. */ #ifndef KRML_COMPAT_H #define KRML_COMPAT_H #include /* A series of macros that define C implementations of types that are not Low*, * to facilitate porting programs to Low*. */ typedef struct { uint32_t length; const char *data; } FStar_Bytes_bytes; typedef int32_t Prims_pos, Prims_nat, Prims_nonzero, Prims_int, krml_checked_int_t; #define RETURN_OR(x) \ do { \ int64_t __ret = x; \ if (__ret < INT32_MIN || INT32_MAX < __ret) { \ KRML_HOST_PRINTF( \ "Prims.{int,nat,pos} integer overflow at %s:%d\n", __FILE__, \ __LINE__); \ KRML_HOST_EXIT(252); \ } \ return (int32_t)__ret; \ } while (0) #endif /* Copyright (c) INRIA and Microsoft Corporation. All rights reserved. Licensed under the Apache 2.0 and MIT Licenses. */ #ifndef __KRML_TARGET_H #define __KRML_TARGET_H #include #include #include #include #include #include #include /* Since KaRaMeL emits the inline keyword unconditionally, we follow the * guidelines at https://gcc.gnu.org/onlinedocs/gcc/Inline.html and make this * __inline__ to ensure the code compiles with -std=c90 and earlier. */ #ifdef __GNUC__ # define inline __inline__ #endif /* There is no support for aligned_alloc() in macOS before Catalina, so * let's make a macro to use _mm_malloc() and _mm_free() functions * from mm_malloc.h. */ #if defined(__APPLE__) && defined(__MACH__) # include # if defined(MAC_OS_X_VERSION_MIN_REQUIRED) && \ (MAC_OS_X_VERSION_MIN_REQUIRED < 101500) # include # define LEGACY_MACOS # else # undef LEGACY_MACOS #endif #endif /******************************************************************************/ /* Macros that KaRaMeL will generate. */ /******************************************************************************/ /* For "bare" targets that do not have a C stdlib, the user might want to use * [-add-early-include '"mydefinitions.h"'] and override these. */ #ifndef KRML_HOST_PRINTF # define KRML_HOST_PRINTF printf #endif #if ( \ (defined __STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) && \ (!(defined KRML_HOST_EPRINTF))) # define KRML_HOST_EPRINTF(...) fprintf(stderr, __VA_ARGS__) #elif !(defined KRML_HOST_EPRINTF) && defined(_MSC_VER) # define KRML_HOST_EPRINTF(...) fprintf(stderr, __VA_ARGS__) #endif #ifndef KRML_HOST_EXIT # define KRML_HOST_EXIT exit #endif #ifndef KRML_HOST_MALLOC # define KRML_HOST_MALLOC malloc #endif #ifndef KRML_HOST_CALLOC # define KRML_HOST_CALLOC calloc #endif #ifndef KRML_HOST_FREE # define KRML_HOST_FREE free #endif #ifndef KRML_HOST_IGNORE # define KRML_HOST_IGNORE(x) (void)(x) #endif #ifndef KRML_MAYBE_UNUSED_VAR # define KRML_MAYBE_UNUSED_VAR(x) KRML_HOST_IGNORE(x) #endif #ifndef KRML_MAYBE_UNUSED # if defined(__GNUC__) || defined(__clang__) # define KRML_MAYBE_UNUSED __attribute__((unused)) # else # define KRML_MAYBE_UNUSED # endif #endif #ifndef KRML_ATTRIBUTE_TARGET # if defined(__GNUC__) || defined(__clang__) # define KRML_ATTRIBUTE_TARGET(x) __attribute__((target(x))) # else # define KRML_ATTRIBUTE_TARGET(x) # endif #endif #ifndef KRML_NOINLINE # if defined (__GNUC__) || defined (__clang__) # define KRML_NOINLINE __attribute__((noinline,unused)) # elif defined(_MSC_VER) # define KRML_NOINLINE __declspec(noinline) # elif defined (__SUNPRO_C) # define KRML_NOINLINE __attribute__((noinline)) # else # define KRML_NOINLINE # warning "The KRML_NOINLINE macro is not defined for this toolchain!" # warning "The compiler may defeat side-channel resistance with optimizations." # warning "Please locate target.h and try to fill it out with a suitable definition for this compiler." # endif #endif #ifndef KRML_MUSTINLINE # if defined(_MSC_VER) # define KRML_MUSTINLINE inline __forceinline # elif defined (__GNUC__) # define KRML_MUSTINLINE inline __attribute__((always_inline)) # elif defined (__SUNPRO_C) # define KRML_MUSTINLINE inline __attribute__((always_inline)) # else # define KRML_MUSTINLINE inline # warning "The KRML_MUSTINLINE macro defaults to plain inline for this toolchain!" # warning "Please locate target.h and try to fill it out with a suitable definition for this compiler." # endif #endif #ifndef KRML_PRE_ALIGN # ifdef _MSC_VER # define KRML_PRE_ALIGN(X) __declspec(align(X)) # else # define KRML_PRE_ALIGN(X) # endif #endif #ifndef KRML_POST_ALIGN # ifdef _MSC_VER # define KRML_POST_ALIGN(X) # else # define KRML_POST_ALIGN(X) __attribute__((aligned(X))) # endif #endif /* MinGW-W64 does not support C11 aligned_alloc, but it supports * MSVC's _aligned_malloc. */ #ifndef KRML_ALIGNED_MALLOC # ifdef __MINGW32__ # include <_mingw.h> # endif # if ( \ defined(_MSC_VER) || \ (defined(__MINGW32__) && defined(__MINGW64_VERSION_MAJOR))) # define KRML_ALIGNED_MALLOC(X, Y) _aligned_malloc(Y, X) # elif defined(LEGACY_MACOS) # define KRML_ALIGNED_MALLOC(X, Y) _mm_malloc(Y, X) # else # define KRML_ALIGNED_MALLOC(X, Y) aligned_alloc(X, Y) # endif #endif /* Since aligned allocations with MinGW-W64 are done with * _aligned_malloc (see above), such pointers must be freed with * _aligned_free. */ #ifndef KRML_ALIGNED_FREE # ifdef __MINGW32__ # include <_mingw.h> # endif # if ( \ defined(_MSC_VER) || \ (defined(__MINGW32__) && defined(__MINGW64_VERSION_MAJOR))) # define KRML_ALIGNED_FREE(X) _aligned_free(X) # elif defined(LEGACY_MACOS) # define KRML_ALIGNED_FREE(X) _mm_free(X) # else # define KRML_ALIGNED_FREE(X) free(X) # endif #endif #ifndef KRML_HOST_TIME # include /* Prims_nat not yet in scope */ inline static int32_t krml_time(void) { return (int32_t)time(NULL); } # define KRML_HOST_TIME krml_time #endif /* In statement position, exiting is easy. */ #define KRML_EXIT \ do { \ KRML_HOST_PRINTF("Unimplemented function at %s:%d\n", __FILE__, __LINE__); \ KRML_HOST_EXIT(254); \ } while (0) /* In expression position, use the comma-operator and a malloc to return an * expression of the right size. KaRaMeL passes t as the parameter to the macro. */ #define KRML_EABORT(t, msg) \ (KRML_HOST_PRINTF("KaRaMeL abort at %s:%d\n%s\n", __FILE__, __LINE__, msg), \ KRML_HOST_EXIT(255), *((t *)KRML_HOST_MALLOC(sizeof(t)))) /* In FStar.Buffer.fst, the size of arrays is uint32_t, but it's a number of * *elements*. Do an ugly, run-time check (some of which KaRaMeL can eliminate). */ #if defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ > 4)) # define _KRML_CHECK_SIZE_PRAGMA \ _Pragma("GCC diagnostic ignored \"-Wtype-limits\"") #else # define _KRML_CHECK_SIZE_PRAGMA #endif #define KRML_CHECK_SIZE(size_elt, sz) \ do { \ _KRML_CHECK_SIZE_PRAGMA \ if (((size_t)(sz)) > ((size_t)(SIZE_MAX / (size_elt)))) { \ KRML_HOST_PRINTF( \ "Maximum allocatable size exceeded, aborting before overflow at " \ "%s:%d\n", \ __FILE__, __LINE__); \ KRML_HOST_EXIT(253); \ } \ } while (0) #if defined(_MSC_VER) && _MSC_VER < 1900 # define KRML_HOST_SNPRINTF(buf, sz, fmt, arg) \ _snprintf_s(buf, sz, _TRUNCATE, fmt, arg) #else # define KRML_HOST_SNPRINTF(buf, sz, fmt, arg) snprintf(buf, sz, fmt, arg) #endif #if defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ > 4)) # define KRML_DEPRECATED(x) __attribute__((deprecated(x))) #elif defined(__GNUC__) /* deprecated attribute is not defined in GCC < 4.5. */ # define KRML_DEPRECATED(x) #elif defined(__SUNPRO_C) # define KRML_DEPRECATED(x) __attribute__((deprecated(x))) #elif defined(_MSC_VER) # define KRML_DEPRECATED(x) __declspec(deprecated(x)) #endif /* Macros for prettier unrolling of loops */ #define KRML_LOOP1(i, n, x) { \ x \ i += n; \ (void) i; \ } #define KRML_LOOP2(i, n, x) \ KRML_LOOP1(i, n, x) \ KRML_LOOP1(i, n, x) #define KRML_LOOP3(i, n, x) \ KRML_LOOP2(i, n, x) \ KRML_LOOP1(i, n, x) #define KRML_LOOP4(i, n, x) \ KRML_LOOP2(i, n, x) \ KRML_LOOP2(i, n, x) #define KRML_LOOP5(i, n, x) \ KRML_LOOP4(i, n, x) \ KRML_LOOP1(i, n, x) #define KRML_LOOP6(i, n, x) \ KRML_LOOP4(i, n, x) \ KRML_LOOP2(i, n, x) #define KRML_LOOP7(i, n, x) \ KRML_LOOP4(i, n, x) \ KRML_LOOP3(i, n, x) #define KRML_LOOP8(i, n, x) \ KRML_LOOP4(i, n, x) \ KRML_LOOP4(i, n, x) #define KRML_LOOP9(i, n, x) \ KRML_LOOP8(i, n, x) \ KRML_LOOP1(i, n, x) #define KRML_LOOP10(i, n, x) \ KRML_LOOP8(i, n, x) \ KRML_LOOP2(i, n, x) #define KRML_LOOP11(i, n, x) \ KRML_LOOP8(i, n, x) \ KRML_LOOP3(i, n, x) #define KRML_LOOP12(i, n, x) \ KRML_LOOP8(i, n, x) \ KRML_LOOP4(i, n, x) #define KRML_LOOP13(i, n, x) \ KRML_LOOP8(i, n, x) \ KRML_LOOP5(i, n, x) #define KRML_LOOP14(i, n, x) \ KRML_LOOP8(i, n, x) \ KRML_LOOP6(i, n, x) #define KRML_LOOP15(i, n, x) \ KRML_LOOP8(i, n, x) \ KRML_LOOP7(i, n, x) #define KRML_LOOP16(i, n, x) \ KRML_LOOP8(i, n, x) \ KRML_LOOP8(i, n, x) #define KRML_UNROLL_FOR(i, z, n, k, x) \ do { \ uint32_t i = z; \ KRML_LOOP##n(i, k, x) \ } while (0) #define KRML_ACTUAL_FOR(i, z, n, k, x) \ do { \ for (uint32_t i = z; i < n; i += k) { \ x \ } \ } while (0) #ifndef KRML_UNROLL_MAX # define KRML_UNROLL_MAX 16 #endif /* 1 is the number of loop iterations, i.e. (n - z)/k as evaluated by krml */ #if 0 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR0(i, z, n, k, x) #else # define KRML_MAYBE_FOR0(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 1 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR1(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 1, k, x) #else # define KRML_MAYBE_FOR1(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 2 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR2(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 2, k, x) #else # define KRML_MAYBE_FOR2(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 3 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR3(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 3, k, x) #else # define KRML_MAYBE_FOR3(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 4 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR4(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 4, k, x) #else # define KRML_MAYBE_FOR4(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 5 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR5(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 5, k, x) #else # define KRML_MAYBE_FOR5(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 6 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR6(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 6, k, x) #else # define KRML_MAYBE_FOR6(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 7 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR7(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 7, k, x) #else # define KRML_MAYBE_FOR7(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 8 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR8(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 8, k, x) #else # define KRML_MAYBE_FOR8(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 9 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR9(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 9, k, x) #else # define KRML_MAYBE_FOR9(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 10 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR10(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 10, k, x) #else # define KRML_MAYBE_FOR10(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 11 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR11(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 11, k, x) #else # define KRML_MAYBE_FOR11(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 12 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR12(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 12, k, x) #else # define KRML_MAYBE_FOR12(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 13 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR13(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 13, k, x) #else # define KRML_MAYBE_FOR13(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 14 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR14(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 14, k, x) #else # define KRML_MAYBE_FOR14(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 15 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR15(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 15, k, x) #else # define KRML_MAYBE_FOR15(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #if 16 <= KRML_UNROLL_MAX # define KRML_MAYBE_FOR16(i, z, n, k, x) KRML_UNROLL_FOR(i, z, 16, k, x) #else # define KRML_MAYBE_FOR16(i, z, n, k, x) KRML_ACTUAL_FOR(i, z, n, k, x) #endif #endif /* Copyright (c) INRIA and Microsoft Corporation. All rights reserved. Licensed under the Apache 2.0 and MIT Licenses. */ #ifndef KRML_TYPES_H #define KRML_TYPES_H #include #include #include #include /* Types which are either abstract, meaning that have to be implemented in C, or * which are models, meaning that they are swapped out at compile-time for * hand-written C types (in which case they're marked as noextract). */ typedef uint64_t FStar_UInt64_t, FStar_UInt64_t_; typedef int64_t FStar_Int64_t, FStar_Int64_t_; typedef uint32_t FStar_UInt32_t, FStar_UInt32_t_; typedef int32_t FStar_Int32_t, FStar_Int32_t_; typedef uint16_t FStar_UInt16_t, FStar_UInt16_t_; typedef int16_t FStar_Int16_t, FStar_Int16_t_; typedef uint8_t FStar_UInt8_t, FStar_UInt8_t_; typedef int8_t FStar_Int8_t, FStar_Int8_t_; /* Only useful when building krmllib, because it's in the dependency graph of * FStar.Int.Cast. */ typedef uint64_t FStar_UInt63_t, FStar_UInt63_t_; typedef int64_t FStar_Int63_t, FStar_Int63_t_; typedef double FStar_Float_float; typedef uint32_t FStar_Char_char; typedef FILE *FStar_IO_fd_read, *FStar_IO_fd_write; typedef void *FStar_Dyn_dyn; typedef const char *C_String_t, *C_String_t_, *C_Compat_String_t, *C_Compat_String_t_; typedef int exit_code; typedef FILE *channel; typedef unsigned long long TestLib_cycles; typedef uint64_t FStar_Date_dateTime, FStar_Date_timeSpan; /* Now Prims.string is no longer illegal with the new model in LowStar.Printf; * it's operations that produce Prims_string which are illegal. Bring the * definition into scope by default. */ typedef const char *Prims_string; #if (defined(_MSC_VER) && defined(_M_X64) && !defined(__clang__)) #define IS_MSVC64 1 #endif /* This code makes a number of assumptions and should be refined. In particular, * it assumes that: any non-MSVC amd64 compiler supports int128. Maybe it would * be easier to just test for defined(__SIZEOF_INT128__) only? */ #if (defined(__x86_64__) || \ defined(__x86_64) || \ defined(__aarch64__) || \ (defined(__powerpc64__) && defined(__LITTLE_ENDIAN__)) || \ defined(__s390x__) || \ (defined(_MSC_VER) && defined(_M_X64) && defined(__clang__)) || \ (defined(__mips__) && defined(__LP64__)) || \ (defined(__riscv) && __riscv_xlen == 64) || \ defined(__SIZEOF_INT128__)) #define HAS_INT128 1 #endif /* The uint128 type is a special case since we offer several implementations of * it, depending on the compiler and whether the user wants the verified * implementation or not. */ #if !defined(KRML_VERIFIED_UINT128) && defined(IS_MSVC64) # include typedef __m128i FStar_UInt128_uint128; #elif !defined(KRML_VERIFIED_UINT128) && defined(HAS_INT128) typedef unsigned __int128 FStar_UInt128_uint128; #else typedef struct FStar_UInt128_uint128_s { uint64_t low; uint64_t high; } FStar_UInt128_uint128; #endif /* The former is defined once, here (otherwise, conflicts for test-c89. The * latter is for internal use. */ typedef FStar_UInt128_uint128 FStar_UInt128_t, uint128_t; #endif /* Avoid a circular loop: if this header is included via FStar_UInt8_16_32_64, * then don't bring the uint128 definitions into scope. */ #ifndef __FStar_UInt_8_16_32_64_H #if !defined(KRML_VERIFIED_UINT128) && defined(IS_MSVC64) #elif !defined(KRML_VERIFIED_UINT128) && defined(HAS_INT128) #else #endif #endif /* Copyright (c) INRIA and Microsoft Corporation. All rights reserved. Licensed under the Apache 2.0 and MIT Licenses. */ #ifndef __LOWSTAR_ENDIANNESS_H #define __LOWSTAR_ENDIANNESS_H #include #include /******************************************************************************/ /* Implementing C.fst (part 2: endian-ness macros) */ /******************************************************************************/ /* ... for Linux */ #if defined(__linux__) || defined(__CYGWIN__) || defined (__USE_SYSTEM_ENDIAN_H__) || defined(__GLIBC__) # include /* ... for OSX */ #elif defined(__APPLE__) # include # define htole64(x) OSSwapHostToLittleInt64(x) # define le64toh(x) OSSwapLittleToHostInt64(x) # define htobe64(x) OSSwapHostToBigInt64(x) # define be64toh(x) OSSwapBigToHostInt64(x) # define htole16(x) OSSwapHostToLittleInt16(x) # define le16toh(x) OSSwapLittleToHostInt16(x) # define htobe16(x) OSSwapHostToBigInt16(x) # define be16toh(x) OSSwapBigToHostInt16(x) # define htole32(x) OSSwapHostToLittleInt32(x) # define le32toh(x) OSSwapLittleToHostInt32(x) # define htobe32(x) OSSwapHostToBigInt32(x) # define be32toh(x) OSSwapBigToHostInt32(x) /* ... for Solaris */ #elif defined(__sun__) # include # define htole64(x) LE_64(x) # define le64toh(x) LE_64(x) # define htobe64(x) BE_64(x) # define be64toh(x) BE_64(x) # define htole16(x) LE_16(x) # define le16toh(x) LE_16(x) # define htobe16(x) BE_16(x) # define be16toh(x) BE_16(x) # define htole32(x) LE_32(x) # define le32toh(x) LE_32(x) # define htobe32(x) BE_32(x) # define be32toh(x) BE_32(x) /* ... for the BSDs */ #elif defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) # include #elif defined(__OpenBSD__) # include /* ... for Windows (MSVC)... not targeting XBOX 360! */ #elif defined(_MSC_VER) # include # define htobe16(x) _byteswap_ushort(x) # define htole16(x) (x) # define be16toh(x) _byteswap_ushort(x) # define le16toh(x) (x) # define htobe32(x) _byteswap_ulong(x) # define htole32(x) (x) # define be32toh(x) _byteswap_ulong(x) # define le32toh(x) (x) # define htobe64(x) _byteswap_uint64(x) # define htole64(x) (x) # define be64toh(x) _byteswap_uint64(x) # define le64toh(x) (x) /* ... for Windows (GCC-like, e.g. mingw or clang) */ #elif (defined(_WIN32) || defined(_WIN64) || defined(__EMSCRIPTEN__)) && \ (defined(__GNUC__) || defined(__clang__)) # define htobe16(x) __builtin_bswap16(x) # define htole16(x) (x) # define be16toh(x) __builtin_bswap16(x) # define le16toh(x) (x) # define htobe32(x) __builtin_bswap32(x) # define htole32(x) (x) # define be32toh(x) __builtin_bswap32(x) # define le32toh(x) (x) # define htobe64(x) __builtin_bswap64(x) # define htole64(x) (x) # define be64toh(x) __builtin_bswap64(x) # define le64toh(x) (x) /* ... generic big-endian fallback code */ /* ... AIX doesn't have __BYTE_ORDER__ (with XLC compiler) & is always big-endian */ #elif (defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__) || defined(_AIX) /* byte swapping code inspired by: * https://github.com/rweather/arduinolibs/blob/master/libraries/Crypto/utility/EndianUtil.h * */ # define htobe32(x) (x) # define be32toh(x) (x) # define htole32(x) \ (__extension__({ \ uint32_t _temp = (x); \ ((_temp >> 24) & 0x000000FF) | ((_temp >> 8) & 0x0000FF00) | \ ((_temp << 8) & 0x00FF0000) | ((_temp << 24) & 0xFF000000); \ })) # define le32toh(x) (htole32((x))) # define htobe64(x) (x) # define be64toh(x) (x) # define htole64(x) \ (__extension__({ \ uint64_t __temp = (x); \ uint32_t __low = htobe32((uint32_t)__temp); \ uint32_t __high = htobe32((uint32_t)(__temp >> 32)); \ (((uint64_t)__low) << 32) | __high; \ })) # define le64toh(x) (htole64((x))) /* ... generic little-endian fallback code */ #elif defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ # define htole32(x) (x) # define le32toh(x) (x) # define htobe32(x) \ (__extension__({ \ uint32_t _temp = (x); \ ((_temp >> 24) & 0x000000FF) | ((_temp >> 8) & 0x0000FF00) | \ ((_temp << 8) & 0x00FF0000) | ((_temp << 24) & 0xFF000000); \ })) # define be32toh(x) (htobe32((x))) # define htole64(x) (x) # define le64toh(x) (x) # define htobe64(x) \ (__extension__({ \ uint64_t __temp = (x); \ uint32_t __low = htobe32((uint32_t)__temp); \ uint32_t __high = htobe32((uint32_t)(__temp >> 32)); \ (((uint64_t)__low) << 32) | __high; \ })) # define be64toh(x) (htobe64((x))) /* ... couldn't determine endian-ness of the target platform */ #else # error "Please define __BYTE_ORDER__!" #endif /* defined(__linux__) || ... */ /* Loads and stores. These avoid undefined behavior due to unaligned memory * accesses, via memcpy. */ inline static uint16_t load16(uint8_t *b) { uint16_t x; memcpy(&x, b, 2); return x; } inline static uint32_t load32(uint8_t *b) { uint32_t x; memcpy(&x, b, 4); return x; } inline static uint64_t load64(uint8_t *b) { uint64_t x; memcpy(&x, b, 8); return x; } inline static void store16(uint8_t *b, uint16_t i) { memcpy(b, &i, 2); } inline static void store32(uint8_t *b, uint32_t i) { memcpy(b, &i, 4); } inline static void store64(uint8_t *b, uint64_t i) { memcpy(b, &i, 8); } /* Legacy accessors so that this header can serve as an implementation of * C.Endianness */ #define load16_le(b) (le16toh(load16(b))) #define store16_le(b, i) (store16(b, htole16(i))) #define load16_be(b) (be16toh(load16(b))) #define store16_be(b, i) (store16(b, htobe16(i))) #define load32_le(b) (le32toh(load32(b))) #define store32_le(b, i) (store32(b, htole32(i))) #define load32_be(b) (be32toh(load32(b))) #define store32_be(b, i) (store32(b, htobe32(i))) #define load64_le(b) (le64toh(load64(b))) #define store64_le(b, i) (store64(b, htole64(i))) #define load64_be(b) (be64toh(load64(b))) #define store64_be(b, i) (store64(b, htobe64(i))) /* Co-existence of LowStar.Endianness and FStar.Endianness generates name * conflicts, because of course both insist on having no prefixes. Until a * prefix is added, or until we truly retire FStar.Endianness, solve this issue * in an elegant way. */ #define load16_le0 load16_le #define store16_le0 store16_le #define load16_be0 load16_be #define store16_be0 store16_be #define load32_le0 load32_le #define store32_le0 store32_le #define load32_be0 load32_be #define store32_be0 store32_be #define load64_le0 load64_le #define store64_le0 store64_le #define load64_be0 load64_be #define store64_be0 store64_be #define load128_le0 load128_le #define store128_le0 store128_le #define load128_be0 load128_be #define store128_be0 store128_be #endif /* Copyright (c) INRIA and Microsoft Corporation. All rights reserved. Licensed under the Apache 2.0 and MIT Licenses. */ #ifndef __FStar_UInt128_H #define __FStar_UInt128_H #include #include static inline FStar_UInt128_uint128 FStar_UInt128_add(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_add_underspec(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_add_mod(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_sub(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_sub_underspec(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_sub_mod(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_logand(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_logxor(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_logor(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_lognot(FStar_UInt128_uint128 a); static inline FStar_UInt128_uint128 FStar_UInt128_shift_left(FStar_UInt128_uint128 a, uint32_t s); static inline FStar_UInt128_uint128 FStar_UInt128_shift_right(FStar_UInt128_uint128 a, uint32_t s); static inline bool FStar_UInt128_eq(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline bool FStar_UInt128_gt(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline bool FStar_UInt128_lt(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline bool FStar_UInt128_gte(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline bool FStar_UInt128_lte(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_eq_mask(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_gte_mask(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_uint64_to_uint128(uint64_t a); static inline uint64_t FStar_UInt128_uint128_to_uint64(FStar_UInt128_uint128 a); static inline FStar_UInt128_uint128 FStar_UInt128_mul32(uint64_t x, uint32_t y); static inline FStar_UInt128_uint128 FStar_UInt128_mul_wide(uint64_t x, uint64_t y); #define __FStar_UInt128_H_DEFINED #endif /* Copyright (c) INRIA and Microsoft Corporation. All rights reserved. Licensed under the Apache 2.0 and MIT Licenses. */ #ifndef __LowStar_Endianness_H #define __LowStar_Endianness_H #include #include static inline void store128_le(uint8_t *x0, FStar_UInt128_uint128 x1); static inline FStar_UInt128_uint128 load128_le(uint8_t *x0); static inline void store128_be(uint8_t *x0, FStar_UInt128_uint128 x1); static inline FStar_UInt128_uint128 load128_be(uint8_t *x0); #define __LowStar_Endianness_H_DEFINED #endif /* Copyright (c) INRIA and Microsoft Corporation. All rights reserved. Licensed under the Apache 2.0 and MIT Licenses. */ #ifndef __FStar_UInt_8_16_32_64_H #define __FStar_UInt_8_16_32_64_H #include #include extern krml_checked_int_t FStar_UInt64_n; extern bool FStar_UInt64_uu___is_Mk(uint64_t projectee); extern krml_checked_int_t FStar_UInt64___proj__Mk__item__v(uint64_t projectee); extern krml_checked_int_t FStar_UInt64_v(uint64_t x); typedef void *FStar_UInt64_fits; extern uint64_t FStar_UInt64_uint_to_t(krml_checked_int_t x); extern uint64_t FStar_UInt64_zero; extern uint64_t FStar_UInt64_one; extern uint64_t FStar_UInt64_minus(uint64_t a); extern uint32_t FStar_UInt64_n_minus_one; static KRML_NOINLINE uint64_t FStar_UInt64_eq_mask(uint64_t a, uint64_t b) { uint64_t x = a ^ b; uint64_t minus_x = ~x + 1ULL; uint64_t x_or_minus_x = x | minus_x; uint64_t xnx = x_or_minus_x >> 63U; return xnx - 1ULL; } static KRML_NOINLINE uint64_t FStar_UInt64_gte_mask(uint64_t a, uint64_t b) { uint64_t x = a; uint64_t y = b; uint64_t x_xor_y = x ^ y; uint64_t x_sub_y = x - y; uint64_t x_sub_y_xor_y = x_sub_y ^ y; uint64_t q = x_xor_y | x_sub_y_xor_y; uint64_t x_xor_q = x ^ q; uint64_t x_xor_q_ = x_xor_q >> 63U; return x_xor_q_ - 1ULL; } extern Prims_string FStar_UInt64_to_string(uint64_t uu___); extern Prims_string FStar_UInt64_to_string_hex(uint64_t uu___); extern Prims_string FStar_UInt64_to_string_hex_pad(uint64_t uu___); extern uint64_t FStar_UInt64_of_string(Prims_string uu___); extern krml_checked_int_t FStar_UInt32_n; extern bool FStar_UInt32_uu___is_Mk(uint32_t projectee); extern krml_checked_int_t FStar_UInt32___proj__Mk__item__v(uint32_t projectee); extern krml_checked_int_t FStar_UInt32_v(uint32_t x); typedef void *FStar_UInt32_fits; extern uint32_t FStar_UInt32_uint_to_t(krml_checked_int_t x); extern uint32_t FStar_UInt32_zero; extern uint32_t FStar_UInt32_one; extern uint32_t FStar_UInt32_minus(uint32_t a); extern uint32_t FStar_UInt32_n_minus_one; static KRML_NOINLINE uint32_t FStar_UInt32_eq_mask(uint32_t a, uint32_t b) { uint32_t x = a ^ b; uint32_t minus_x = ~x + 1U; uint32_t x_or_minus_x = x | minus_x; uint32_t xnx = x_or_minus_x >> 31U; return xnx - 1U; } static KRML_NOINLINE uint32_t FStar_UInt32_gte_mask(uint32_t a, uint32_t b) { uint32_t x = a; uint32_t y = b; uint32_t x_xor_y = x ^ y; uint32_t x_sub_y = x - y; uint32_t x_sub_y_xor_y = x_sub_y ^ y; uint32_t q = x_xor_y | x_sub_y_xor_y; uint32_t x_xor_q = x ^ q; uint32_t x_xor_q_ = x_xor_q >> 31U; return x_xor_q_ - 1U; } extern Prims_string FStar_UInt32_to_string(uint32_t uu___); extern Prims_string FStar_UInt32_to_string_hex(uint32_t uu___); extern Prims_string FStar_UInt32_to_string_hex_pad(uint32_t uu___); extern uint32_t FStar_UInt32_of_string(Prims_string uu___); extern krml_checked_int_t FStar_UInt16_n; extern bool FStar_UInt16_uu___is_Mk(uint16_t projectee); extern krml_checked_int_t FStar_UInt16___proj__Mk__item__v(uint16_t projectee); extern krml_checked_int_t FStar_UInt16_v(uint16_t x); typedef void *FStar_UInt16_fits; extern uint16_t FStar_UInt16_uint_to_t(krml_checked_int_t x); extern uint16_t FStar_UInt16_zero; extern uint16_t FStar_UInt16_one; extern uint16_t FStar_UInt16_minus(uint16_t a); extern uint32_t FStar_UInt16_n_minus_one; static KRML_NOINLINE uint16_t FStar_UInt16_eq_mask(uint16_t a, uint16_t b) { uint16_t x = (uint32_t)a ^ (uint32_t)b; uint16_t minus_x = (uint32_t)~x + 1U; uint16_t x_or_minus_x = (uint32_t)x | (uint32_t)minus_x; uint16_t xnx = (uint32_t)x_or_minus_x >> 15U; return (uint32_t)xnx - 1U; } static KRML_NOINLINE uint16_t FStar_UInt16_gte_mask(uint16_t a, uint16_t b) { uint16_t x = a; uint16_t y = b; uint16_t x_xor_y = (uint32_t)x ^ (uint32_t)y; uint16_t x_sub_y = (uint32_t)x - (uint32_t)y; uint16_t x_sub_y_xor_y = (uint32_t)x_sub_y ^ (uint32_t)y; uint16_t q = (uint32_t)x_xor_y | (uint32_t)x_sub_y_xor_y; uint16_t x_xor_q = (uint32_t)x ^ (uint32_t)q; uint16_t x_xor_q_ = (uint32_t)x_xor_q >> 15U; return (uint32_t)x_xor_q_ - 1U; } extern Prims_string FStar_UInt16_to_string(uint16_t uu___); extern Prims_string FStar_UInt16_to_string_hex(uint16_t uu___); extern Prims_string FStar_UInt16_to_string_hex_pad(uint16_t uu___); extern uint16_t FStar_UInt16_of_string(Prims_string uu___); extern krml_checked_int_t FStar_UInt8_n; extern bool FStar_UInt8_uu___is_Mk(uint8_t projectee); extern krml_checked_int_t FStar_UInt8___proj__Mk__item__v(uint8_t projectee); extern krml_checked_int_t FStar_UInt8_v(uint8_t x); typedef void *FStar_UInt8_fits; extern uint8_t FStar_UInt8_uint_to_t(krml_checked_int_t x); extern uint8_t FStar_UInt8_zero; extern uint8_t FStar_UInt8_one; extern uint8_t FStar_UInt8_minus(uint8_t a); extern uint32_t FStar_UInt8_n_minus_one; static KRML_NOINLINE uint8_t FStar_UInt8_eq_mask(uint8_t a, uint8_t b) { uint8_t x = (uint32_t)a ^ (uint32_t)b; uint8_t minus_x = (uint32_t)~x + 1U; uint8_t x_or_minus_x = (uint32_t)x | (uint32_t)minus_x; uint8_t xnx = (uint32_t)x_or_minus_x >> 7U; return (uint32_t)xnx - 1U; } static KRML_NOINLINE uint8_t FStar_UInt8_gte_mask(uint8_t a, uint8_t b) { uint8_t x = a; uint8_t y = b; uint8_t x_xor_y = (uint32_t)x ^ (uint32_t)y; uint8_t x_sub_y = (uint32_t)x - (uint32_t)y; uint8_t x_sub_y_xor_y = (uint32_t)x_sub_y ^ (uint32_t)y; uint8_t q = (uint32_t)x_xor_y | (uint32_t)x_sub_y_xor_y; uint8_t x_xor_q = (uint32_t)x ^ (uint32_t)q; uint8_t x_xor_q_ = (uint32_t)x_xor_q >> 7U; return (uint32_t)x_xor_q_ - 1U; } extern Prims_string FStar_UInt8_to_string(uint8_t uu___); extern Prims_string FStar_UInt8_to_string_hex(uint8_t uu___); extern Prims_string FStar_UInt8_to_string_hex_pad(uint8_t uu___); extern uint8_t FStar_UInt8_of_string(Prims_string uu___); typedef uint8_t FStar_UInt8_byte; #define __FStar_UInt_8_16_32_64_H_DEFINED #endif /* Copyright (c) INRIA and Microsoft Corporation. All rights reserved. Licensed under the Apache 2.0 and MIT Licenses. */ /******************************************************************************/ /* Machine integers (128-bit arithmetic) */ /******************************************************************************/ /* This header contains two things. * * First, an implementation of 128-bit arithmetic suitable for 64-bit GCC and * Clang, i.e. all the operations from FStar.UInt128. * * Second, 128-bit operations from C.Endianness (or LowStar.Endianness), * suitable for any compiler and platform (via a series of ifdefs). This second * part is unfortunate, and should be fixed by moving {load,store}128_{be,le} to * FStar.UInt128 to avoid a maze of preprocessor guards and hand-written code. * */ /* This file is used for both the minimal and generic krmllib distributions. As * such, it assumes that the machine integers have been bundled the exact same * way in both cases. */ #ifndef FSTAR_UINT128_GCC64 #define FSTAR_UINT128_GCC64 /* GCC + using native unsigned __int128 support */ inline static uint128_t load128_le(uint8_t *b) { uint128_t l = (uint128_t)load64_le(b); uint128_t h = (uint128_t)load64_le(b + 8); return (h << 64 | l); } inline static void store128_le(uint8_t *b, uint128_t n) { store64_le(b, (uint64_t)n); store64_le(b + 8, (uint64_t)(n >> 64)); } inline static uint128_t load128_be(uint8_t *b) { uint128_t h = (uint128_t)load64_be(b); uint128_t l = (uint128_t)load64_be(b + 8); return (h << 64 | l); } inline static void store128_be(uint8_t *b, uint128_t n) { store64_be(b, (uint64_t)(n >> 64)); store64_be(b + 8, (uint64_t)n); } inline static uint128_t FStar_UInt128_add(uint128_t x, uint128_t y) { return x + y; } inline static uint128_t FStar_UInt128_mul(uint128_t x, uint128_t y) { return x * y; } inline static uint128_t FStar_UInt128_add_mod(uint128_t x, uint128_t y) { return x + y; } inline static uint128_t FStar_UInt128_sub(uint128_t x, uint128_t y) { return x - y; } inline static uint128_t FStar_UInt128_sub_mod(uint128_t x, uint128_t y) { return x - y; } inline static uint128_t FStar_UInt128_logand(uint128_t x, uint128_t y) { return x & y; } inline static uint128_t FStar_UInt128_logor(uint128_t x, uint128_t y) { return x | y; } inline static uint128_t FStar_UInt128_logxor(uint128_t x, uint128_t y) { return x ^ y; } inline static uint128_t FStar_UInt128_lognot(uint128_t x) { return ~x; } inline static uint128_t FStar_UInt128_shift_left(uint128_t x, uint32_t y) { return x << y; } inline static uint128_t FStar_UInt128_shift_right(uint128_t x, uint32_t y) { return x >> y; } inline static uint128_t FStar_UInt128_uint64_to_uint128(uint64_t x) { return (uint128_t)x; } inline static uint64_t FStar_UInt128_uint128_to_uint64(uint128_t x) { return (uint64_t)x; } inline static uint128_t FStar_UInt128_mul_wide(uint64_t x, uint64_t y) { return ((uint128_t) x) * y; } inline static uint128_t FStar_UInt128_eq_mask(uint128_t x, uint128_t y) { uint64_t mask = FStar_UInt64_eq_mask((uint64_t)(x >> 64), (uint64_t)(y >> 64)) & FStar_UInt64_eq_mask((uint64_t)x, (uint64_t)y); return ((uint128_t)mask) << 64 | mask; } inline static uint128_t FStar_UInt128_gte_mask(uint128_t x, uint128_t y) { uint64_t mask = (FStar_UInt64_gte_mask(x >> 64, y >> 64) & ~(FStar_UInt64_eq_mask(x >> 64, y >> 64))) | (FStar_UInt64_eq_mask(x >> 64, y >> 64) & FStar_UInt64_gte_mask((uint64_t)x, (uint64_t)y)); return ((uint128_t)mask) << 64 | mask; } inline static uint64_t FStar_UInt128___proj__Mkuint128__item__low(uint128_t x) { return (uint64_t) x; } inline static uint64_t FStar_UInt128___proj__Mkuint128__item__high(uint128_t x) { return (uint64_t) (x >> 64); } inline static uint128_t FStar_UInt128_add_underspec(uint128_t x, uint128_t y) { return x + y; } inline static uint128_t FStar_UInt128_sub_underspec(uint128_t x, uint128_t y) { return x - y; } inline static bool FStar_UInt128_eq(uint128_t x, uint128_t y) { return x == y; } inline static bool FStar_UInt128_gt(uint128_t x, uint128_t y) { return x > y; } inline static bool FStar_UInt128_lt(uint128_t x, uint128_t y) { return x < y; } inline static bool FStar_UInt128_gte(uint128_t x, uint128_t y) { return x >= y; } inline static bool FStar_UInt128_lte(uint128_t x, uint128_t y) { return x <= y; } inline static uint128_t FStar_UInt128_mul32(uint64_t x, uint32_t y) { return (uint128_t) x * (uint128_t) y; } #endif /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #ifndef __internal_Hacl_Krmllib_H #define __internal_Hacl_Krmllib_H #if defined(__cplusplus) extern "C" { #endif #include static KRML_NOINLINE uint32_t FStar_UInt32_eq_mask(uint32_t a, uint32_t b); static KRML_NOINLINE uint32_t FStar_UInt32_gte_mask(uint32_t a, uint32_t b); static KRML_NOINLINE uint8_t FStar_UInt8_eq_mask(uint8_t a, uint8_t b); static KRML_NOINLINE uint16_t FStar_UInt16_eq_mask(uint16_t a, uint16_t b); static inline FStar_UInt128_uint128 FStar_UInt128_add(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_logor(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_shift_left(FStar_UInt128_uint128 a, uint32_t s); static inline FStar_UInt128_uint128 FStar_UInt128_mul_wide(uint64_t x, uint64_t y); static inline void store128_be(uint8_t *x0, FStar_UInt128_uint128 x1); static inline FStar_UInt128_uint128 load128_be(uint8_t *x0); #if defined(__cplusplus) } #endif #define __internal_Hacl_Krmllib_H_DEFINED #endif /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #ifndef __Hacl_Krmllib_H #define __Hacl_Krmllib_H #if defined(__cplusplus) extern "C" { #endif #include static KRML_NOINLINE uint64_t FStar_UInt64_eq_mask(uint64_t a, uint64_t b); static KRML_NOINLINE uint64_t FStar_UInt64_gte_mask(uint64_t a, uint64_t b); static inline FStar_UInt128_uint128 FStar_UInt128_add_mod(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_sub_mod(FStar_UInt128_uint128 a, FStar_UInt128_uint128 b); static inline FStar_UInt128_uint128 FStar_UInt128_shift_right(FStar_UInt128_uint128 a, uint32_t s); static inline FStar_UInt128_uint128 FStar_UInt128_uint64_to_uint128(uint64_t a); static inline uint64_t FStar_UInt128_uint128_to_uint64(FStar_UInt128_uint128 a); #if defined(__cplusplus) } #endif #define __Hacl_Krmllib_H_DEFINED #endif #ifndef HACL_CAN_COMPILE_INTRINSICS /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #ifndef __Hacl_IntTypes_Intrinsics_H #define __Hacl_IntTypes_Intrinsics_H #if defined(__cplusplus) extern "C" { #endif #include static inline uint32_t Hacl_IntTypes_Intrinsics_add_carry_u32(uint32_t cin, uint32_t x, uint32_t y, uint32_t *r) { uint64_t res = (uint64_t)x + (uint64_t)cin + (uint64_t)y; uint32_t c = (uint32_t)(res >> 32U); r[0U] = (uint32_t)res; return c; } static inline uint32_t Hacl_IntTypes_Intrinsics_sub_borrow_u32(uint32_t cin, uint32_t x, uint32_t y, uint32_t *r) { uint64_t res = (uint64_t)x - (uint64_t)y - (uint64_t)cin; uint32_t c = (uint32_t)(res >> 32U) & 1U; r[0U] = (uint32_t)res; return c; } static inline uint64_t Hacl_IntTypes_Intrinsics_add_carry_u64(uint64_t cin, uint64_t x, uint64_t y, uint64_t *r) { uint64_t res = x + cin + y; uint64_t c = (~FStar_UInt64_gte_mask(res, x) | (FStar_UInt64_eq_mask(res, x) & cin)) & 1ULL; r[0U] = res; return c; } static inline uint64_t Hacl_IntTypes_Intrinsics_sub_borrow_u64(uint64_t cin, uint64_t x, uint64_t y, uint64_t *r) { uint64_t res = x - y - cin; uint64_t c = ((FStar_UInt64_gte_mask(res, x) & ~FStar_UInt64_eq_mask(res, x)) | (FStar_UInt64_eq_mask(res, x) & cin)) & 1ULL; r[0U] = res; return c; } #if defined(__cplusplus) } #endif #define __Hacl_IntTypes_Intrinsics_H_DEFINED #endif /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #ifndef __Hacl_IntTypes_Intrinsics_128_H #define __Hacl_IntTypes_Intrinsics_128_H #if defined(__cplusplus) extern "C" { #endif #include static inline uint64_t Hacl_IntTypes_Intrinsics_128_add_carry_u64(uint64_t cin, uint64_t x, uint64_t y, uint64_t *r) { FStar_UInt128_uint128 res = FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_uint64_to_uint128(x), FStar_UInt128_uint64_to_uint128(cin)), FStar_UInt128_uint64_to_uint128(y)); uint64_t c = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(res, 64U)); r[0U] = FStar_UInt128_uint128_to_uint64(res); return c; } static inline uint64_t Hacl_IntTypes_Intrinsics_128_sub_borrow_u64(uint64_t cin, uint64_t x, uint64_t y, uint64_t *r) { FStar_UInt128_uint128 res = FStar_UInt128_sub_mod(FStar_UInt128_sub_mod(FStar_UInt128_uint64_to_uint128(x), FStar_UInt128_uint64_to_uint128(y)), FStar_UInt128_uint64_to_uint128(cin)); uint64_t c = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(res, 64U)) & 1ULL; r[0U] = FStar_UInt128_uint128_to_uint64(res); return c; } #if defined(__cplusplus) } #endif #define __Hacl_IntTypes_Intrinsics_128_H_DEFINED #endif #endif #include #if defined(__has_include) #if __has_include("config.h") #endif #endif /* GCC versions prior to 5.5 incorrectly optimize certain intrinsics. See https://gcc.gnu.org/bugzilla/show_bug.cgi?id=81300 CLANG versions prior to 5 crash on certain intrinsics. See https://bugs.llvm.org/show_bug.cgi?id=24943 */ #if !defined(HACL_CAN_COMPILE_INTRINSICS) || \ (defined(__clang__) && (__clang_major__ < 5)) || \ (defined(__GNUC__) && !defined(__clang__) && \ (__GNUC__ < 5 || (__GNUC__ == 5 && (__GNUC_MINOR__ < 5)))) #if defined(HACL_CAN_COMPILE_UINT128) #define Lib_IntTypes_Intrinsics_add_carry_u64(x1, x2, x3, x4) \ (Hacl_IntTypes_Intrinsics_128_add_carry_u64(x1, x2, x3, x4)) #define Lib_IntTypes_Intrinsics_sub_borrow_u64(x1, x2, x3, x4) \ (Hacl_IntTypes_Intrinsics_128_sub_borrow_u64(x1, x2, x3, x4)) #else #define Lib_IntTypes_Intrinsics_add_carry_u64(x1, x2, x3, x4) \ (Hacl_IntTypes_Intrinsics_add_carry_u64(x1, x2, x3, x4)) #define Lib_IntTypes_Intrinsics_sub_borrow_u64(x1, x2, x3, x4) \ (Hacl_IntTypes_Intrinsics_sub_borrow_u64(x1, x2, x3, x4)) #endif // defined(HACL_CAN_COMPILE_UINT128) #define Lib_IntTypes_Intrinsics_add_carry_u32(x1, x2, x3, x4) \ (Hacl_IntTypes_Intrinsics_add_carry_u32(x1, x2, x3, x4)) #define Lib_IntTypes_Intrinsics_sub_borrow_u32(x1, x2, x3, x4) \ (Hacl_IntTypes_Intrinsics_sub_borrow_u32(x1, x2, x3, x4)) #else // !defined(HACL_CAN_COMPILE_INTRINSICS) #if defined(_MSC_VER) #include #else #include #endif #define Lib_IntTypes_Intrinsics_add_carry_u32(x1, x2, x3, x4) \ (_addcarry_u32(x1, x2, x3, (unsigned int *)x4)) #define Lib_IntTypes_Intrinsics_add_carry_u64(x1, x2, x3, x4) \ (_addcarry_u64(x1, x2, x3, (long long unsigned int *)x4)) /* GCC versions prior to 7.2 pass arguments to _subborrow_u{32,64} in an incorrect order. See https://gcc.gnu.org/bugzilla/show_bug.cgi?id=81294 */ #if defined(__GNUC__) && !defined(__clang__) && \ (__GNUC__ < 7 || (__GNUC__ == 7 && (__GNUC_MINOR__ < 2))) #define Lib_IntTypes_Intrinsics_sub_borrow_u32(x1, x2, x3, x4) \ (_subborrow_u32(x1, x3, x2, (unsigned int *)x4)) #define Lib_IntTypes_Intrinsics_sub_borrow_u64(x1, x2, x3, x4) \ (_subborrow_u64(x1, x3, x2, (long long unsigned int *)x4)) #else #define Lib_IntTypes_Intrinsics_sub_borrow_u32(x1, x2, x3, x4) \ (_subborrow_u32(x1, x2, x3, (unsigned int *)x4)) #define Lib_IntTypes_Intrinsics_sub_borrow_u64(x1, x2, x3, x4) \ (_subborrow_u64(x1, x2, x3, (long long unsigned int *)x4)) #endif // GCC < 7.2 #endif // !HACL_CAN_COMPILE_INTRINSICS /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #ifndef __internal_Hacl_Streaming_Types_H #define __internal_Hacl_Streaming_Types_H #if defined(__cplusplus) extern "C" { #endif #include #define Hacl_Streaming_Types_None 0 #define Hacl_Streaming_Types_Some 1 typedef uint8_t Hacl_Streaming_Types_optional; typedef struct Hacl_Streaming_Types_optional_32_s { Hacl_Streaming_Types_optional tag; uint32_t *v; } Hacl_Streaming_Types_optional_32; typedef struct Hacl_Streaming_Types_optional_64_s { Hacl_Streaming_Types_optional tag; uint64_t *v; } Hacl_Streaming_Types_optional_64; typedef struct Hacl_Streaming_Types_two_pointers_s { uint64_t *fst; uint64_t *snd; } Hacl_Streaming_Types_two_pointers; typedef struct Hacl_Streaming_MD_state_32_s { uint32_t *block_state; uint8_t *buf; uint64_t total_len; } Hacl_Streaming_MD_state_32; typedef struct Hacl_Streaming_MD_state_64_s { uint64_t *block_state; uint8_t *buf; uint64_t total_len; } Hacl_Streaming_MD_state_64; #if defined(__cplusplus) } #endif #define __internal_Hacl_Streaming_Types_H_DEFINED #endif /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #ifndef __Hacl_Streaming_Types_H #define __Hacl_Streaming_Types_H #if defined(__cplusplus) extern "C" { #endif #include #define Spec_Hash_Definitions_SHA2_224 0 #define Spec_Hash_Definitions_SHA2_256 1 #define Spec_Hash_Definitions_SHA2_384 2 #define Spec_Hash_Definitions_SHA2_512 3 #define Spec_Hash_Definitions_SHA1 4 #define Spec_Hash_Definitions_MD5 5 #define Spec_Hash_Definitions_Blake2S 6 #define Spec_Hash_Definitions_Blake2B 7 #define Spec_Hash_Definitions_SHA3_256 8 #define Spec_Hash_Definitions_SHA3_224 9 #define Spec_Hash_Definitions_SHA3_384 10 #define Spec_Hash_Definitions_SHA3_512 11 #define Spec_Hash_Definitions_Shake128 12 #define Spec_Hash_Definitions_Shake256 13 typedef uint8_t Spec_Hash_Definitions_hash_alg; #define Hacl_Streaming_Types_Success 0 #define Hacl_Streaming_Types_InvalidAlgorithm 1 #define Hacl_Streaming_Types_InvalidLength 2 #define Hacl_Streaming_Types_MaximumLengthExceeded 3 #define Hacl_Streaming_Types_OutOfMemory 4 typedef uint8_t Hacl_Streaming_Types_error_code; typedef struct Hacl_Streaming_MD_state_32_s Hacl_Streaming_MD_state_32; typedef struct Hacl_Streaming_MD_state_64_s Hacl_Streaming_MD_state_64; #if defined(__cplusplus) } #endif #define __Hacl_Streaming_Types_H_DEFINED #endif /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #ifndef __internal_Hacl_Bignum_Base_H #define __internal_Hacl_Bignum_Base_H #if defined(__cplusplus) extern "C" { #endif #include static inline uint32_t Hacl_Bignum_Base_mul_wide_add2_u32(uint32_t a, uint32_t b, uint32_t c_in, uint32_t *out) { uint32_t out0 = out[0U]; uint64_t res = (uint64_t)a * (uint64_t)b + (uint64_t)c_in + (uint64_t)out0; out[0U] = (uint32_t)res; return (uint32_t)(res >> 32U); } static inline uint64_t Hacl_Bignum_Base_mul_wide_add2_u64(uint64_t a, uint64_t b, uint64_t c_in, uint64_t *out) { uint64_t out0 = out[0U]; FStar_UInt128_uint128 res = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(a, b), FStar_UInt128_uint64_to_uint128(c_in)), FStar_UInt128_uint64_to_uint128(out0)); out[0U] = FStar_UInt128_uint128_to_uint64(res); return FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(res, 64U)); } static inline void Hacl_Bignum_Convert_bn_from_bytes_be_uint64(uint32_t len, uint8_t *b, uint64_t *res) { uint32_t bnLen = (len - 1U) / 8U + 1U; uint32_t tmpLen = 8U * bnLen; KRML_CHECK_SIZE(sizeof (uint8_t), tmpLen); uint8_t tmp[tmpLen]; memset(tmp, 0U, tmpLen * sizeof (uint8_t)); memcpy(tmp + tmpLen - len, b, len * sizeof (uint8_t)); for (uint32_t i = 0U; i < bnLen; i++) { uint64_t *os = res; uint64_t u = load64_be(tmp + (bnLen - i - 1U) * 8U); uint64_t x = u; os[i] = x; } } static inline void Hacl_Bignum_Convert_bn_to_bytes_be_uint64(uint32_t len, uint64_t *b, uint8_t *res) { uint32_t bnLen = (len - 1U) / 8U + 1U; uint32_t tmpLen = 8U * bnLen; KRML_CHECK_SIZE(sizeof (uint8_t), tmpLen); uint8_t tmp[tmpLen]; memset(tmp, 0U, tmpLen * sizeof (uint8_t)); for (uint32_t i = 0U; i < bnLen; i++) { store64_be(tmp + i * 8U, b[bnLen - i - 1U]); } memcpy(res, tmp + tmpLen - len, len * sizeof (uint8_t)); } static inline uint32_t Hacl_Bignum_Lib_bn_get_top_index_u32(uint32_t len, uint32_t *b) { uint32_t priv = 0U; for (uint32_t i = 0U; i < len; i++) { uint32_t mask = FStar_UInt32_eq_mask(b[i], 0U); priv = (mask & priv) | (~mask & i); } return priv; } static inline uint64_t Hacl_Bignum_Lib_bn_get_top_index_u64(uint32_t len, uint64_t *b) { uint64_t priv = 0ULL; for (uint32_t i = 0U; i < len; i++) { uint64_t mask = FStar_UInt64_eq_mask(b[i], 0ULL); priv = (mask & priv) | (~mask & (uint64_t)i); } return priv; } static inline uint32_t Hacl_Bignum_Lib_bn_get_bits_u32(uint32_t len, uint32_t *b, uint32_t i, uint32_t l) { uint32_t i1 = i / 32U; uint32_t j = i % 32U; uint32_t p1 = b[i1] >> j; uint32_t ite; if (i1 + 1U < len && 0U < j) { ite = p1 | b[i1 + 1U] << (32U - j); } else { ite = p1; } return ite & ((1U << l) - 1U); } static inline uint64_t Hacl_Bignum_Lib_bn_get_bits_u64(uint32_t len, uint64_t *b, uint32_t i, uint32_t l) { uint32_t i1 = i / 64U; uint32_t j = i % 64U; uint64_t p1 = b[i1] >> j; uint64_t ite; if (i1 + 1U < len && 0U < j) { ite = p1 | b[i1 + 1U] << (64U - j); } else { ite = p1; } return ite & ((1ULL << l) - 1ULL); } static inline uint32_t Hacl_Bignum_Addition_bn_sub_eq_len_u32(uint32_t aLen, uint32_t *a, uint32_t *b, uint32_t *res) { uint32_t c = 0U; for (uint32_t i = 0U; i < aLen / 4U; i++) { uint32_t t1 = a[4U * i]; uint32_t t20 = b[4U * i]; uint32_t *res_i0 = res + 4U * i; c = Lib_IntTypes_Intrinsics_sub_borrow_u32(c, t1, t20, res_i0); uint32_t t10 = a[4U * i + 1U]; uint32_t t21 = b[4U * i + 1U]; uint32_t *res_i1 = res + 4U * i + 1U; c = Lib_IntTypes_Intrinsics_sub_borrow_u32(c, t10, t21, res_i1); uint32_t t11 = a[4U * i + 2U]; uint32_t t22 = b[4U * i + 2U]; uint32_t *res_i2 = res + 4U * i + 2U; c = Lib_IntTypes_Intrinsics_sub_borrow_u32(c, t11, t22, res_i2); uint32_t t12 = a[4U * i + 3U]; uint32_t t2 = b[4U * i + 3U]; uint32_t *res_i = res + 4U * i + 3U; c = Lib_IntTypes_Intrinsics_sub_borrow_u32(c, t12, t2, res_i); } for (uint32_t i = aLen / 4U * 4U; i < aLen; i++) { uint32_t t1 = a[i]; uint32_t t2 = b[i]; uint32_t *res_i = res + i; c = Lib_IntTypes_Intrinsics_sub_borrow_u32(c, t1, t2, res_i); } return c; } static inline uint64_t Hacl_Bignum_Addition_bn_sub_eq_len_u64(uint32_t aLen, uint64_t *a, uint64_t *b, uint64_t *res) { uint64_t c = 0ULL; for (uint32_t i = 0U; i < aLen / 4U; i++) { uint64_t t1 = a[4U * i]; uint64_t t20 = b[4U * i]; uint64_t *res_i0 = res + 4U * i; c = Lib_IntTypes_Intrinsics_sub_borrow_u64(c, t1, t20, res_i0); uint64_t t10 = a[4U * i + 1U]; uint64_t t21 = b[4U * i + 1U]; uint64_t *res_i1 = res + 4U * i + 1U; c = Lib_IntTypes_Intrinsics_sub_borrow_u64(c, t10, t21, res_i1); uint64_t t11 = a[4U * i + 2U]; uint64_t t22 = b[4U * i + 2U]; uint64_t *res_i2 = res + 4U * i + 2U; c = Lib_IntTypes_Intrinsics_sub_borrow_u64(c, t11, t22, res_i2); uint64_t t12 = a[4U * i + 3U]; uint64_t t2 = b[4U * i + 3U]; uint64_t *res_i = res + 4U * i + 3U; c = Lib_IntTypes_Intrinsics_sub_borrow_u64(c, t12, t2, res_i); } for (uint32_t i = aLen / 4U * 4U; i < aLen; i++) { uint64_t t1 = a[i]; uint64_t t2 = b[i]; uint64_t *res_i = res + i; c = Lib_IntTypes_Intrinsics_sub_borrow_u64(c, t1, t2, res_i); } return c; } static inline uint32_t Hacl_Bignum_Addition_bn_add_eq_len_u32(uint32_t aLen, uint32_t *a, uint32_t *b, uint32_t *res) { uint32_t c = 0U; for (uint32_t i = 0U; i < aLen / 4U; i++) { uint32_t t1 = a[4U * i]; uint32_t t20 = b[4U * i]; uint32_t *res_i0 = res + 4U * i; c = Lib_IntTypes_Intrinsics_add_carry_u32(c, t1, t20, res_i0); uint32_t t10 = a[4U * i + 1U]; uint32_t t21 = b[4U * i + 1U]; uint32_t *res_i1 = res + 4U * i + 1U; c = Lib_IntTypes_Intrinsics_add_carry_u32(c, t10, t21, res_i1); uint32_t t11 = a[4U * i + 2U]; uint32_t t22 = b[4U * i + 2U]; uint32_t *res_i2 = res + 4U * i + 2U; c = Lib_IntTypes_Intrinsics_add_carry_u32(c, t11, t22, res_i2); uint32_t t12 = a[4U * i + 3U]; uint32_t t2 = b[4U * i + 3U]; uint32_t *res_i = res + 4U * i + 3U; c = Lib_IntTypes_Intrinsics_add_carry_u32(c, t12, t2, res_i); } for (uint32_t i = aLen / 4U * 4U; i < aLen; i++) { uint32_t t1 = a[i]; uint32_t t2 = b[i]; uint32_t *res_i = res + i; c = Lib_IntTypes_Intrinsics_add_carry_u32(c, t1, t2, res_i); } return c; } static inline uint64_t Hacl_Bignum_Addition_bn_add_eq_len_u64(uint32_t aLen, uint64_t *a, uint64_t *b, uint64_t *res) { uint64_t c = 0ULL; for (uint32_t i = 0U; i < aLen / 4U; i++) { uint64_t t1 = a[4U * i]; uint64_t t20 = b[4U * i]; uint64_t *res_i0 = res + 4U * i; c = Lib_IntTypes_Intrinsics_add_carry_u64(c, t1, t20, res_i0); uint64_t t10 = a[4U * i + 1U]; uint64_t t21 = b[4U * i + 1U]; uint64_t *res_i1 = res + 4U * i + 1U; c = Lib_IntTypes_Intrinsics_add_carry_u64(c, t10, t21, res_i1); uint64_t t11 = a[4U * i + 2U]; uint64_t t22 = b[4U * i + 2U]; uint64_t *res_i2 = res + 4U * i + 2U; c = Lib_IntTypes_Intrinsics_add_carry_u64(c, t11, t22, res_i2); uint64_t t12 = a[4U * i + 3U]; uint64_t t2 = b[4U * i + 3U]; uint64_t *res_i = res + 4U * i + 3U; c = Lib_IntTypes_Intrinsics_add_carry_u64(c, t12, t2, res_i); } for (uint32_t i = aLen / 4U * 4U; i < aLen; i++) { uint64_t t1 = a[i]; uint64_t t2 = b[i]; uint64_t *res_i = res + i; c = Lib_IntTypes_Intrinsics_add_carry_u64(c, t1, t2, res_i); } return c; } static inline void Hacl_Bignum_Multiplication_bn_mul_u32( uint32_t aLen, uint32_t *a, uint32_t bLen, uint32_t *b, uint32_t *res ) { memset(res, 0U, (aLen + bLen) * sizeof (uint32_t)); for (uint32_t i0 = 0U; i0 < bLen; i0++) { uint32_t bj = b[i0]; uint32_t *res_j = res + i0; uint32_t c = 0U; for (uint32_t i = 0U; i < aLen / 4U; i++) { uint32_t a_i = a[4U * i]; uint32_t *res_i0 = res_j + 4U * i; c = Hacl_Bignum_Base_mul_wide_add2_u32(a_i, bj, c, res_i0); uint32_t a_i0 = a[4U * i + 1U]; uint32_t *res_i1 = res_j + 4U * i + 1U; c = Hacl_Bignum_Base_mul_wide_add2_u32(a_i0, bj, c, res_i1); uint32_t a_i1 = a[4U * i + 2U]; uint32_t *res_i2 = res_j + 4U * i + 2U; c = Hacl_Bignum_Base_mul_wide_add2_u32(a_i1, bj, c, res_i2); uint32_t a_i2 = a[4U * i + 3U]; uint32_t *res_i = res_j + 4U * i + 3U; c = Hacl_Bignum_Base_mul_wide_add2_u32(a_i2, bj, c, res_i); } for (uint32_t i = aLen / 4U * 4U; i < aLen; i++) { uint32_t a_i = a[i]; uint32_t *res_i = res_j + i; c = Hacl_Bignum_Base_mul_wide_add2_u32(a_i, bj, c, res_i); } uint32_t r = c; res[aLen + i0] = r; } } static inline void Hacl_Bignum_Multiplication_bn_mul_u64( uint32_t aLen, uint64_t *a, uint32_t bLen, uint64_t *b, uint64_t *res ) { memset(res, 0U, (aLen + bLen) * sizeof (uint64_t)); for (uint32_t i0 = 0U; i0 < bLen; i0++) { uint64_t bj = b[i0]; uint64_t *res_j = res + i0; uint64_t c = 0ULL; for (uint32_t i = 0U; i < aLen / 4U; i++) { uint64_t a_i = a[4U * i]; uint64_t *res_i0 = res_j + 4U * i; c = Hacl_Bignum_Base_mul_wide_add2_u64(a_i, bj, c, res_i0); uint64_t a_i0 = a[4U * i + 1U]; uint64_t *res_i1 = res_j + 4U * i + 1U; c = Hacl_Bignum_Base_mul_wide_add2_u64(a_i0, bj, c, res_i1); uint64_t a_i1 = a[4U * i + 2U]; uint64_t *res_i2 = res_j + 4U * i + 2U; c = Hacl_Bignum_Base_mul_wide_add2_u64(a_i1, bj, c, res_i2); uint64_t a_i2 = a[4U * i + 3U]; uint64_t *res_i = res_j + 4U * i + 3U; c = Hacl_Bignum_Base_mul_wide_add2_u64(a_i2, bj, c, res_i); } for (uint32_t i = aLen / 4U * 4U; i < aLen; i++) { uint64_t a_i = a[i]; uint64_t *res_i = res_j + i; c = Hacl_Bignum_Base_mul_wide_add2_u64(a_i, bj, c, res_i); } uint64_t r = c; res[aLen + i0] = r; } } static inline void Hacl_Bignum_Multiplication_bn_sqr_u32(uint32_t aLen, uint32_t *a, uint32_t *res) { memset(res, 0U, (aLen + aLen) * sizeof (uint32_t)); for (uint32_t i0 = 0U; i0 < aLen; i0++) { uint32_t *ab = a; uint32_t a_j = a[i0]; uint32_t *res_j = res + i0; uint32_t c = 0U; for (uint32_t i = 0U; i < i0 / 4U; i++) { uint32_t a_i = ab[4U * i]; uint32_t *res_i0 = res_j + 4U * i; c = Hacl_Bignum_Base_mul_wide_add2_u32(a_i, a_j, c, res_i0); uint32_t a_i0 = ab[4U * i + 1U]; uint32_t *res_i1 = res_j + 4U * i + 1U; c = Hacl_Bignum_Base_mul_wide_add2_u32(a_i0, a_j, c, res_i1); uint32_t a_i1 = ab[4U * i + 2U]; uint32_t *res_i2 = res_j + 4U * i + 2U; c = Hacl_Bignum_Base_mul_wide_add2_u32(a_i1, a_j, c, res_i2); uint32_t a_i2 = ab[4U * i + 3U]; uint32_t *res_i = res_j + 4U * i + 3U; c = Hacl_Bignum_Base_mul_wide_add2_u32(a_i2, a_j, c, res_i); } for (uint32_t i = i0 / 4U * 4U; i < i0; i++) { uint32_t a_i = ab[i]; uint32_t *res_i = res_j + i; c = Hacl_Bignum_Base_mul_wide_add2_u32(a_i, a_j, c, res_i); } uint32_t r = c; res[i0 + i0] = r; } uint32_t c0 = Hacl_Bignum_Addition_bn_add_eq_len_u32(aLen + aLen, res, res, res); KRML_MAYBE_UNUSED_VAR(c0); KRML_CHECK_SIZE(sizeof (uint32_t), aLen + aLen); uint32_t tmp[aLen + aLen]; memset(tmp, 0U, (aLen + aLen) * sizeof (uint32_t)); for (uint32_t i = 0U; i < aLen; i++) { uint64_t res1 = (uint64_t)a[i] * (uint64_t)a[i]; uint32_t hi = (uint32_t)(res1 >> 32U); uint32_t lo = (uint32_t)res1; tmp[2U * i] = lo; tmp[2U * i + 1U] = hi; } uint32_t c1 = Hacl_Bignum_Addition_bn_add_eq_len_u32(aLen + aLen, res, tmp, res); KRML_MAYBE_UNUSED_VAR(c1); } static inline void Hacl_Bignum_Multiplication_bn_sqr_u64(uint32_t aLen, uint64_t *a, uint64_t *res) { memset(res, 0U, (aLen + aLen) * sizeof (uint64_t)); for (uint32_t i0 = 0U; i0 < aLen; i0++) { uint64_t *ab = a; uint64_t a_j = a[i0]; uint64_t *res_j = res + i0; uint64_t c = 0ULL; for (uint32_t i = 0U; i < i0 / 4U; i++) { uint64_t a_i = ab[4U * i]; uint64_t *res_i0 = res_j + 4U * i; c = Hacl_Bignum_Base_mul_wide_add2_u64(a_i, a_j, c, res_i0); uint64_t a_i0 = ab[4U * i + 1U]; uint64_t *res_i1 = res_j + 4U * i + 1U; c = Hacl_Bignum_Base_mul_wide_add2_u64(a_i0, a_j, c, res_i1); uint64_t a_i1 = ab[4U * i + 2U]; uint64_t *res_i2 = res_j + 4U * i + 2U; c = Hacl_Bignum_Base_mul_wide_add2_u64(a_i1, a_j, c, res_i2); uint64_t a_i2 = ab[4U * i + 3U]; uint64_t *res_i = res_j + 4U * i + 3U; c = Hacl_Bignum_Base_mul_wide_add2_u64(a_i2, a_j, c, res_i); } for (uint32_t i = i0 / 4U * 4U; i < i0; i++) { uint64_t a_i = ab[i]; uint64_t *res_i = res_j + i; c = Hacl_Bignum_Base_mul_wide_add2_u64(a_i, a_j, c, res_i); } uint64_t r = c; res[i0 + i0] = r; } uint64_t c0 = Hacl_Bignum_Addition_bn_add_eq_len_u64(aLen + aLen, res, res, res); KRML_MAYBE_UNUSED_VAR(c0); KRML_CHECK_SIZE(sizeof (uint64_t), aLen + aLen); uint64_t tmp[aLen + aLen]; memset(tmp, 0U, (aLen + aLen) * sizeof (uint64_t)); for (uint32_t i = 0U; i < aLen; i++) { FStar_UInt128_uint128 res1 = FStar_UInt128_mul_wide(a[i], a[i]); uint64_t hi = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(res1, 64U)); uint64_t lo = FStar_UInt128_uint128_to_uint64(res1); tmp[2U * i] = lo; tmp[2U * i + 1U] = hi; } uint64_t c1 = Hacl_Bignum_Addition_bn_add_eq_len_u64(aLen + aLen, res, tmp, res); KRML_MAYBE_UNUSED_VAR(c1); } #if defined(__cplusplus) } #endif #define __internal_Hacl_Bignum_Base_H_DEFINED #endif /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #ifndef __internal_Hacl_Bignum25519_51_H #define __internal_Hacl_Bignum25519_51_H #if defined(__cplusplus) extern "C" { #endif #include static inline void Hacl_Impl_Curve25519_Field51_fadd(uint64_t *out, uint64_t *f1, uint64_t *f2) { uint64_t f10 = f1[0U]; uint64_t f20 = f2[0U]; uint64_t f11 = f1[1U]; uint64_t f21 = f2[1U]; uint64_t f12 = f1[2U]; uint64_t f22 = f2[2U]; uint64_t f13 = f1[3U]; uint64_t f23 = f2[3U]; uint64_t f14 = f1[4U]; uint64_t f24 = f2[4U]; out[0U] = f10 + f20; out[1U] = f11 + f21; out[2U] = f12 + f22; out[3U] = f13 + f23; out[4U] = f14 + f24; } static inline void Hacl_Impl_Curve25519_Field51_fsub(uint64_t *out, uint64_t *f1, uint64_t *f2) { uint64_t f10 = f1[0U]; uint64_t f20 = f2[0U]; uint64_t f11 = f1[1U]; uint64_t f21 = f2[1U]; uint64_t f12 = f1[2U]; uint64_t f22 = f2[2U]; uint64_t f13 = f1[3U]; uint64_t f23 = f2[3U]; uint64_t f14 = f1[4U]; uint64_t f24 = f2[4U]; out[0U] = f10 + 0x3fffffffffff68ULL - f20; out[1U] = f11 + 0x3ffffffffffff8ULL - f21; out[2U] = f12 + 0x3ffffffffffff8ULL - f22; out[3U] = f13 + 0x3ffffffffffff8ULL - f23; out[4U] = f14 + 0x3ffffffffffff8ULL - f24; } static inline void Hacl_Impl_Curve25519_Field51_fmul( uint64_t *out, uint64_t *f1, uint64_t *f2, FStar_UInt128_uint128 *uu___ ) { KRML_MAYBE_UNUSED_VAR(uu___); uint64_t f10 = f1[0U]; uint64_t f11 = f1[1U]; uint64_t f12 = f1[2U]; uint64_t f13 = f1[3U]; uint64_t f14 = f1[4U]; uint64_t f20 = f2[0U]; uint64_t f21 = f2[1U]; uint64_t f22 = f2[2U]; uint64_t f23 = f2[3U]; uint64_t f24 = f2[4U]; uint64_t tmp1 = f21 * 19ULL; uint64_t tmp2 = f22 * 19ULL; uint64_t tmp3 = f23 * 19ULL; uint64_t tmp4 = f24 * 19ULL; FStar_UInt128_uint128 o00 = FStar_UInt128_mul_wide(f10, f20); FStar_UInt128_uint128 o10 = FStar_UInt128_mul_wide(f10, f21); FStar_UInt128_uint128 o20 = FStar_UInt128_mul_wide(f10, f22); FStar_UInt128_uint128 o30 = FStar_UInt128_mul_wide(f10, f23); FStar_UInt128_uint128 o40 = FStar_UInt128_mul_wide(f10, f24); FStar_UInt128_uint128 o01 = FStar_UInt128_add(o00, FStar_UInt128_mul_wide(f11, tmp4)); FStar_UInt128_uint128 o11 = FStar_UInt128_add(o10, FStar_UInt128_mul_wide(f11, f20)); FStar_UInt128_uint128 o21 = FStar_UInt128_add(o20, FStar_UInt128_mul_wide(f11, f21)); FStar_UInt128_uint128 o31 = FStar_UInt128_add(o30, FStar_UInt128_mul_wide(f11, f22)); FStar_UInt128_uint128 o41 = FStar_UInt128_add(o40, FStar_UInt128_mul_wide(f11, f23)); FStar_UInt128_uint128 o02 = FStar_UInt128_add(o01, FStar_UInt128_mul_wide(f12, tmp3)); FStar_UInt128_uint128 o12 = FStar_UInt128_add(o11, FStar_UInt128_mul_wide(f12, tmp4)); FStar_UInt128_uint128 o22 = FStar_UInt128_add(o21, FStar_UInt128_mul_wide(f12, f20)); FStar_UInt128_uint128 o32 = FStar_UInt128_add(o31, FStar_UInt128_mul_wide(f12, f21)); FStar_UInt128_uint128 o42 = FStar_UInt128_add(o41, FStar_UInt128_mul_wide(f12, f22)); FStar_UInt128_uint128 o03 = FStar_UInt128_add(o02, FStar_UInt128_mul_wide(f13, tmp2)); FStar_UInt128_uint128 o13 = FStar_UInt128_add(o12, FStar_UInt128_mul_wide(f13, tmp3)); FStar_UInt128_uint128 o23 = FStar_UInt128_add(o22, FStar_UInt128_mul_wide(f13, tmp4)); FStar_UInt128_uint128 o33 = FStar_UInt128_add(o32, FStar_UInt128_mul_wide(f13, f20)); FStar_UInt128_uint128 o43 = FStar_UInt128_add(o42, FStar_UInt128_mul_wide(f13, f21)); FStar_UInt128_uint128 o04 = FStar_UInt128_add(o03, FStar_UInt128_mul_wide(f14, tmp1)); FStar_UInt128_uint128 o14 = FStar_UInt128_add(o13, FStar_UInt128_mul_wide(f14, tmp2)); FStar_UInt128_uint128 o24 = FStar_UInt128_add(o23, FStar_UInt128_mul_wide(f14, tmp3)); FStar_UInt128_uint128 o34 = FStar_UInt128_add(o33, FStar_UInt128_mul_wide(f14, tmp4)); FStar_UInt128_uint128 o44 = FStar_UInt128_add(o43, FStar_UInt128_mul_wide(f14, f20)); FStar_UInt128_uint128 tmp_w0 = o04; FStar_UInt128_uint128 tmp_w1 = o14; FStar_UInt128_uint128 tmp_w2 = o24; FStar_UInt128_uint128 tmp_w3 = o34; FStar_UInt128_uint128 tmp_w4 = o44; FStar_UInt128_uint128 l_ = FStar_UInt128_add(tmp_w0, FStar_UInt128_uint64_to_uint128(0ULL)); uint64_t tmp01 = FStar_UInt128_uint128_to_uint64(l_) & 0x7ffffffffffffULL; uint64_t c0 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_, 51U)); FStar_UInt128_uint128 l_0 = FStar_UInt128_add(tmp_w1, FStar_UInt128_uint64_to_uint128(c0)); uint64_t tmp11 = FStar_UInt128_uint128_to_uint64(l_0) & 0x7ffffffffffffULL; uint64_t c1 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_0, 51U)); FStar_UInt128_uint128 l_1 = FStar_UInt128_add(tmp_w2, FStar_UInt128_uint64_to_uint128(c1)); uint64_t tmp21 = FStar_UInt128_uint128_to_uint64(l_1) & 0x7ffffffffffffULL; uint64_t c2 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_1, 51U)); FStar_UInt128_uint128 l_2 = FStar_UInt128_add(tmp_w3, FStar_UInt128_uint64_to_uint128(c2)); uint64_t tmp31 = FStar_UInt128_uint128_to_uint64(l_2) & 0x7ffffffffffffULL; uint64_t c3 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_2, 51U)); FStar_UInt128_uint128 l_3 = FStar_UInt128_add(tmp_w4, FStar_UInt128_uint64_to_uint128(c3)); uint64_t tmp41 = FStar_UInt128_uint128_to_uint64(l_3) & 0x7ffffffffffffULL; uint64_t c4 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_3, 51U)); uint64_t l_4 = tmp01 + c4 * 19ULL; uint64_t tmp0_ = l_4 & 0x7ffffffffffffULL; uint64_t c5 = l_4 >> 51U; uint64_t o0 = tmp0_; uint64_t o1 = tmp11 + c5; uint64_t o2 = tmp21; uint64_t o3 = tmp31; uint64_t o4 = tmp41; out[0U] = o0; out[1U] = o1; out[2U] = o2; out[3U] = o3; out[4U] = o4; } static inline void Hacl_Impl_Curve25519_Field51_fmul2( uint64_t *out, uint64_t *f1, uint64_t *f2, FStar_UInt128_uint128 *uu___ ) { KRML_MAYBE_UNUSED_VAR(uu___); uint64_t f10 = f1[0U]; uint64_t f11 = f1[1U]; uint64_t f12 = f1[2U]; uint64_t f13 = f1[3U]; uint64_t f14 = f1[4U]; uint64_t f20 = f2[0U]; uint64_t f21 = f2[1U]; uint64_t f22 = f2[2U]; uint64_t f23 = f2[3U]; uint64_t f24 = f2[4U]; uint64_t f30 = f1[5U]; uint64_t f31 = f1[6U]; uint64_t f32 = f1[7U]; uint64_t f33 = f1[8U]; uint64_t f34 = f1[9U]; uint64_t f40 = f2[5U]; uint64_t f41 = f2[6U]; uint64_t f42 = f2[7U]; uint64_t f43 = f2[8U]; uint64_t f44 = f2[9U]; uint64_t tmp11 = f21 * 19ULL; uint64_t tmp12 = f22 * 19ULL; uint64_t tmp13 = f23 * 19ULL; uint64_t tmp14 = f24 * 19ULL; uint64_t tmp21 = f41 * 19ULL; uint64_t tmp22 = f42 * 19ULL; uint64_t tmp23 = f43 * 19ULL; uint64_t tmp24 = f44 * 19ULL; FStar_UInt128_uint128 o00 = FStar_UInt128_mul_wide(f10, f20); FStar_UInt128_uint128 o15 = FStar_UInt128_mul_wide(f10, f21); FStar_UInt128_uint128 o25 = FStar_UInt128_mul_wide(f10, f22); FStar_UInt128_uint128 o30 = FStar_UInt128_mul_wide(f10, f23); FStar_UInt128_uint128 o40 = FStar_UInt128_mul_wide(f10, f24); FStar_UInt128_uint128 o010 = FStar_UInt128_add(o00, FStar_UInt128_mul_wide(f11, tmp14)); FStar_UInt128_uint128 o110 = FStar_UInt128_add(o15, FStar_UInt128_mul_wide(f11, f20)); FStar_UInt128_uint128 o210 = FStar_UInt128_add(o25, FStar_UInt128_mul_wide(f11, f21)); FStar_UInt128_uint128 o310 = FStar_UInt128_add(o30, FStar_UInt128_mul_wide(f11, f22)); FStar_UInt128_uint128 o410 = FStar_UInt128_add(o40, FStar_UInt128_mul_wide(f11, f23)); FStar_UInt128_uint128 o020 = FStar_UInt128_add(o010, FStar_UInt128_mul_wide(f12, tmp13)); FStar_UInt128_uint128 o120 = FStar_UInt128_add(o110, FStar_UInt128_mul_wide(f12, tmp14)); FStar_UInt128_uint128 o220 = FStar_UInt128_add(o210, FStar_UInt128_mul_wide(f12, f20)); FStar_UInt128_uint128 o320 = FStar_UInt128_add(o310, FStar_UInt128_mul_wide(f12, f21)); FStar_UInt128_uint128 o420 = FStar_UInt128_add(o410, FStar_UInt128_mul_wide(f12, f22)); FStar_UInt128_uint128 o030 = FStar_UInt128_add(o020, FStar_UInt128_mul_wide(f13, tmp12)); FStar_UInt128_uint128 o130 = FStar_UInt128_add(o120, FStar_UInt128_mul_wide(f13, tmp13)); FStar_UInt128_uint128 o230 = FStar_UInt128_add(o220, FStar_UInt128_mul_wide(f13, tmp14)); FStar_UInt128_uint128 o330 = FStar_UInt128_add(o320, FStar_UInt128_mul_wide(f13, f20)); FStar_UInt128_uint128 o430 = FStar_UInt128_add(o420, FStar_UInt128_mul_wide(f13, f21)); FStar_UInt128_uint128 o040 = FStar_UInt128_add(o030, FStar_UInt128_mul_wide(f14, tmp11)); FStar_UInt128_uint128 o140 = FStar_UInt128_add(o130, FStar_UInt128_mul_wide(f14, tmp12)); FStar_UInt128_uint128 o240 = FStar_UInt128_add(o230, FStar_UInt128_mul_wide(f14, tmp13)); FStar_UInt128_uint128 o340 = FStar_UInt128_add(o330, FStar_UInt128_mul_wide(f14, tmp14)); FStar_UInt128_uint128 o440 = FStar_UInt128_add(o430, FStar_UInt128_mul_wide(f14, f20)); FStar_UInt128_uint128 tmp_w10 = o040; FStar_UInt128_uint128 tmp_w11 = o140; FStar_UInt128_uint128 tmp_w12 = o240; FStar_UInt128_uint128 tmp_w13 = o340; FStar_UInt128_uint128 tmp_w14 = o440; FStar_UInt128_uint128 o0 = FStar_UInt128_mul_wide(f30, f40); FStar_UInt128_uint128 o1 = FStar_UInt128_mul_wide(f30, f41); FStar_UInt128_uint128 o2 = FStar_UInt128_mul_wide(f30, f42); FStar_UInt128_uint128 o3 = FStar_UInt128_mul_wide(f30, f43); FStar_UInt128_uint128 o4 = FStar_UInt128_mul_wide(f30, f44); FStar_UInt128_uint128 o01 = FStar_UInt128_add(o0, FStar_UInt128_mul_wide(f31, tmp24)); FStar_UInt128_uint128 o111 = FStar_UInt128_add(o1, FStar_UInt128_mul_wide(f31, f40)); FStar_UInt128_uint128 o211 = FStar_UInt128_add(o2, FStar_UInt128_mul_wide(f31, f41)); FStar_UInt128_uint128 o31 = FStar_UInt128_add(o3, FStar_UInt128_mul_wide(f31, f42)); FStar_UInt128_uint128 o41 = FStar_UInt128_add(o4, FStar_UInt128_mul_wide(f31, f43)); FStar_UInt128_uint128 o02 = FStar_UInt128_add(o01, FStar_UInt128_mul_wide(f32, tmp23)); FStar_UInt128_uint128 o121 = FStar_UInt128_add(o111, FStar_UInt128_mul_wide(f32, tmp24)); FStar_UInt128_uint128 o221 = FStar_UInt128_add(o211, FStar_UInt128_mul_wide(f32, f40)); FStar_UInt128_uint128 o32 = FStar_UInt128_add(o31, FStar_UInt128_mul_wide(f32, f41)); FStar_UInt128_uint128 o42 = FStar_UInt128_add(o41, FStar_UInt128_mul_wide(f32, f42)); FStar_UInt128_uint128 o03 = FStar_UInt128_add(o02, FStar_UInt128_mul_wide(f33, tmp22)); FStar_UInt128_uint128 o131 = FStar_UInt128_add(o121, FStar_UInt128_mul_wide(f33, tmp23)); FStar_UInt128_uint128 o231 = FStar_UInt128_add(o221, FStar_UInt128_mul_wide(f33, tmp24)); FStar_UInt128_uint128 o33 = FStar_UInt128_add(o32, FStar_UInt128_mul_wide(f33, f40)); FStar_UInt128_uint128 o43 = FStar_UInt128_add(o42, FStar_UInt128_mul_wide(f33, f41)); FStar_UInt128_uint128 o04 = FStar_UInt128_add(o03, FStar_UInt128_mul_wide(f34, tmp21)); FStar_UInt128_uint128 o141 = FStar_UInt128_add(o131, FStar_UInt128_mul_wide(f34, tmp22)); FStar_UInt128_uint128 o241 = FStar_UInt128_add(o231, FStar_UInt128_mul_wide(f34, tmp23)); FStar_UInt128_uint128 o34 = FStar_UInt128_add(o33, FStar_UInt128_mul_wide(f34, tmp24)); FStar_UInt128_uint128 o44 = FStar_UInt128_add(o43, FStar_UInt128_mul_wide(f34, f40)); FStar_UInt128_uint128 tmp_w20 = o04; FStar_UInt128_uint128 tmp_w21 = o141; FStar_UInt128_uint128 tmp_w22 = o241; FStar_UInt128_uint128 tmp_w23 = o34; FStar_UInt128_uint128 tmp_w24 = o44; FStar_UInt128_uint128 l_ = FStar_UInt128_add(tmp_w10, FStar_UInt128_uint64_to_uint128(0ULL)); uint64_t tmp00 = FStar_UInt128_uint128_to_uint64(l_) & 0x7ffffffffffffULL; uint64_t c00 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_, 51U)); FStar_UInt128_uint128 l_0 = FStar_UInt128_add(tmp_w11, FStar_UInt128_uint64_to_uint128(c00)); uint64_t tmp10 = FStar_UInt128_uint128_to_uint64(l_0) & 0x7ffffffffffffULL; uint64_t c10 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_0, 51U)); FStar_UInt128_uint128 l_1 = FStar_UInt128_add(tmp_w12, FStar_UInt128_uint64_to_uint128(c10)); uint64_t tmp20 = FStar_UInt128_uint128_to_uint64(l_1) & 0x7ffffffffffffULL; uint64_t c20 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_1, 51U)); FStar_UInt128_uint128 l_2 = FStar_UInt128_add(tmp_w13, FStar_UInt128_uint64_to_uint128(c20)); uint64_t tmp30 = FStar_UInt128_uint128_to_uint64(l_2) & 0x7ffffffffffffULL; uint64_t c30 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_2, 51U)); FStar_UInt128_uint128 l_3 = FStar_UInt128_add(tmp_w14, FStar_UInt128_uint64_to_uint128(c30)); uint64_t tmp40 = FStar_UInt128_uint128_to_uint64(l_3) & 0x7ffffffffffffULL; uint64_t c40 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_3, 51U)); uint64_t l_4 = tmp00 + c40 * 19ULL; uint64_t tmp0_ = l_4 & 0x7ffffffffffffULL; uint64_t c50 = l_4 >> 51U; uint64_t o100 = tmp0_; uint64_t o112 = tmp10 + c50; uint64_t o122 = tmp20; uint64_t o132 = tmp30; uint64_t o142 = tmp40; FStar_UInt128_uint128 l_5 = FStar_UInt128_add(tmp_w20, FStar_UInt128_uint64_to_uint128(0ULL)); uint64_t tmp0 = FStar_UInt128_uint128_to_uint64(l_5) & 0x7ffffffffffffULL; uint64_t c0 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_5, 51U)); FStar_UInt128_uint128 l_6 = FStar_UInt128_add(tmp_w21, FStar_UInt128_uint64_to_uint128(c0)); uint64_t tmp1 = FStar_UInt128_uint128_to_uint64(l_6) & 0x7ffffffffffffULL; uint64_t c1 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_6, 51U)); FStar_UInt128_uint128 l_7 = FStar_UInt128_add(tmp_w22, FStar_UInt128_uint64_to_uint128(c1)); uint64_t tmp2 = FStar_UInt128_uint128_to_uint64(l_7) & 0x7ffffffffffffULL; uint64_t c2 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_7, 51U)); FStar_UInt128_uint128 l_8 = FStar_UInt128_add(tmp_w23, FStar_UInt128_uint64_to_uint128(c2)); uint64_t tmp3 = FStar_UInt128_uint128_to_uint64(l_8) & 0x7ffffffffffffULL; uint64_t c3 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_8, 51U)); FStar_UInt128_uint128 l_9 = FStar_UInt128_add(tmp_w24, FStar_UInt128_uint64_to_uint128(c3)); uint64_t tmp4 = FStar_UInt128_uint128_to_uint64(l_9) & 0x7ffffffffffffULL; uint64_t c4 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_9, 51U)); uint64_t l_10 = tmp0 + c4 * 19ULL; uint64_t tmp0_0 = l_10 & 0x7ffffffffffffULL; uint64_t c5 = l_10 >> 51U; uint64_t o200 = tmp0_0; uint64_t o212 = tmp1 + c5; uint64_t o222 = tmp2; uint64_t o232 = tmp3; uint64_t o242 = tmp4; uint64_t o10 = o100; uint64_t o11 = o112; uint64_t o12 = o122; uint64_t o13 = o132; uint64_t o14 = o142; uint64_t o20 = o200; uint64_t o21 = o212; uint64_t o22 = o222; uint64_t o23 = o232; uint64_t o24 = o242; out[0U] = o10; out[1U] = o11; out[2U] = o12; out[3U] = o13; out[4U] = o14; out[5U] = o20; out[6U] = o21; out[7U] = o22; out[8U] = o23; out[9U] = o24; } static inline void Hacl_Impl_Curve25519_Field51_fmul1(uint64_t *out, uint64_t *f1, uint64_t f2) { uint64_t f10 = f1[0U]; uint64_t f11 = f1[1U]; uint64_t f12 = f1[2U]; uint64_t f13 = f1[3U]; uint64_t f14 = f1[4U]; FStar_UInt128_uint128 tmp_w0 = FStar_UInt128_mul_wide(f2, f10); FStar_UInt128_uint128 tmp_w1 = FStar_UInt128_mul_wide(f2, f11); FStar_UInt128_uint128 tmp_w2 = FStar_UInt128_mul_wide(f2, f12); FStar_UInt128_uint128 tmp_w3 = FStar_UInt128_mul_wide(f2, f13); FStar_UInt128_uint128 tmp_w4 = FStar_UInt128_mul_wide(f2, f14); FStar_UInt128_uint128 l_ = FStar_UInt128_add(tmp_w0, FStar_UInt128_uint64_to_uint128(0ULL)); uint64_t tmp0 = FStar_UInt128_uint128_to_uint64(l_) & 0x7ffffffffffffULL; uint64_t c0 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_, 51U)); FStar_UInt128_uint128 l_0 = FStar_UInt128_add(tmp_w1, FStar_UInt128_uint64_to_uint128(c0)); uint64_t tmp1 = FStar_UInt128_uint128_to_uint64(l_0) & 0x7ffffffffffffULL; uint64_t c1 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_0, 51U)); FStar_UInt128_uint128 l_1 = FStar_UInt128_add(tmp_w2, FStar_UInt128_uint64_to_uint128(c1)); uint64_t tmp2 = FStar_UInt128_uint128_to_uint64(l_1) & 0x7ffffffffffffULL; uint64_t c2 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_1, 51U)); FStar_UInt128_uint128 l_2 = FStar_UInt128_add(tmp_w3, FStar_UInt128_uint64_to_uint128(c2)); uint64_t tmp3 = FStar_UInt128_uint128_to_uint64(l_2) & 0x7ffffffffffffULL; uint64_t c3 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_2, 51U)); FStar_UInt128_uint128 l_3 = FStar_UInt128_add(tmp_w4, FStar_UInt128_uint64_to_uint128(c3)); uint64_t tmp4 = FStar_UInt128_uint128_to_uint64(l_3) & 0x7ffffffffffffULL; uint64_t c4 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_3, 51U)); uint64_t l_4 = tmp0 + c4 * 19ULL; uint64_t tmp0_ = l_4 & 0x7ffffffffffffULL; uint64_t c5 = l_4 >> 51U; uint64_t o0 = tmp0_; uint64_t o1 = tmp1 + c5; uint64_t o2 = tmp2; uint64_t o3 = tmp3; uint64_t o4 = tmp4; out[0U] = o0; out[1U] = o1; out[2U] = o2; out[3U] = o3; out[4U] = o4; } static inline void Hacl_Impl_Curve25519_Field51_fsqr(uint64_t *out, uint64_t *f, FStar_UInt128_uint128 *uu___) { KRML_MAYBE_UNUSED_VAR(uu___); uint64_t f0 = f[0U]; uint64_t f1 = f[1U]; uint64_t f2 = f[2U]; uint64_t f3 = f[3U]; uint64_t f4 = f[4U]; uint64_t d0 = 2ULL * f0; uint64_t d1 = 2ULL * f1; uint64_t d2 = 38ULL * f2; uint64_t d3 = 19ULL * f3; uint64_t d419 = 19ULL * f4; uint64_t d4 = 2ULL * d419; FStar_UInt128_uint128 s0 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(f0, f0), FStar_UInt128_mul_wide(d4, f1)), FStar_UInt128_mul_wide(d2, f3)); FStar_UInt128_uint128 s1 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(d0, f1), FStar_UInt128_mul_wide(d4, f2)), FStar_UInt128_mul_wide(d3, f3)); FStar_UInt128_uint128 s2 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(d0, f2), FStar_UInt128_mul_wide(f1, f1)), FStar_UInt128_mul_wide(d4, f3)); FStar_UInt128_uint128 s3 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(d0, f3), FStar_UInt128_mul_wide(d1, f2)), FStar_UInt128_mul_wide(f4, d419)); FStar_UInt128_uint128 s4 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(d0, f4), FStar_UInt128_mul_wide(d1, f3)), FStar_UInt128_mul_wide(f2, f2)); FStar_UInt128_uint128 o00 = s0; FStar_UInt128_uint128 o10 = s1; FStar_UInt128_uint128 o20 = s2; FStar_UInt128_uint128 o30 = s3; FStar_UInt128_uint128 o40 = s4; FStar_UInt128_uint128 l_ = FStar_UInt128_add(o00, FStar_UInt128_uint64_to_uint128(0ULL)); uint64_t tmp0 = FStar_UInt128_uint128_to_uint64(l_) & 0x7ffffffffffffULL; uint64_t c0 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_, 51U)); FStar_UInt128_uint128 l_0 = FStar_UInt128_add(o10, FStar_UInt128_uint64_to_uint128(c0)); uint64_t tmp1 = FStar_UInt128_uint128_to_uint64(l_0) & 0x7ffffffffffffULL; uint64_t c1 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_0, 51U)); FStar_UInt128_uint128 l_1 = FStar_UInt128_add(o20, FStar_UInt128_uint64_to_uint128(c1)); uint64_t tmp2 = FStar_UInt128_uint128_to_uint64(l_1) & 0x7ffffffffffffULL; uint64_t c2 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_1, 51U)); FStar_UInt128_uint128 l_2 = FStar_UInt128_add(o30, FStar_UInt128_uint64_to_uint128(c2)); uint64_t tmp3 = FStar_UInt128_uint128_to_uint64(l_2) & 0x7ffffffffffffULL; uint64_t c3 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_2, 51U)); FStar_UInt128_uint128 l_3 = FStar_UInt128_add(o40, FStar_UInt128_uint64_to_uint128(c3)); uint64_t tmp4 = FStar_UInt128_uint128_to_uint64(l_3) & 0x7ffffffffffffULL; uint64_t c4 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_3, 51U)); uint64_t l_4 = tmp0 + c4 * 19ULL; uint64_t tmp0_ = l_4 & 0x7ffffffffffffULL; uint64_t c5 = l_4 >> 51U; uint64_t o0 = tmp0_; uint64_t o1 = tmp1 + c5; uint64_t o2 = tmp2; uint64_t o3 = tmp3; uint64_t o4 = tmp4; out[0U] = o0; out[1U] = o1; out[2U] = o2; out[3U] = o3; out[4U] = o4; } static inline void Hacl_Impl_Curve25519_Field51_fsqr2(uint64_t *out, uint64_t *f, FStar_UInt128_uint128 *uu___) { KRML_MAYBE_UNUSED_VAR(uu___); uint64_t f10 = f[0U]; uint64_t f11 = f[1U]; uint64_t f12 = f[2U]; uint64_t f13 = f[3U]; uint64_t f14 = f[4U]; uint64_t f20 = f[5U]; uint64_t f21 = f[6U]; uint64_t f22 = f[7U]; uint64_t f23 = f[8U]; uint64_t f24 = f[9U]; uint64_t d00 = 2ULL * f10; uint64_t d10 = 2ULL * f11; uint64_t d20 = 38ULL * f12; uint64_t d30 = 19ULL * f13; uint64_t d4190 = 19ULL * f14; uint64_t d40 = 2ULL * d4190; FStar_UInt128_uint128 s00 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(f10, f10), FStar_UInt128_mul_wide(d40, f11)), FStar_UInt128_mul_wide(d20, f13)); FStar_UInt128_uint128 s10 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(d00, f11), FStar_UInt128_mul_wide(d40, f12)), FStar_UInt128_mul_wide(d30, f13)); FStar_UInt128_uint128 s20 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(d00, f12), FStar_UInt128_mul_wide(f11, f11)), FStar_UInt128_mul_wide(d40, f13)); FStar_UInt128_uint128 s30 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(d00, f13), FStar_UInt128_mul_wide(d10, f12)), FStar_UInt128_mul_wide(f14, d4190)); FStar_UInt128_uint128 s40 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(d00, f14), FStar_UInt128_mul_wide(d10, f13)), FStar_UInt128_mul_wide(f12, f12)); FStar_UInt128_uint128 o100 = s00; FStar_UInt128_uint128 o110 = s10; FStar_UInt128_uint128 o120 = s20; FStar_UInt128_uint128 o130 = s30; FStar_UInt128_uint128 o140 = s40; uint64_t d0 = 2ULL * f20; uint64_t d1 = 2ULL * f21; uint64_t d2 = 38ULL * f22; uint64_t d3 = 19ULL * f23; uint64_t d419 = 19ULL * f24; uint64_t d4 = 2ULL * d419; FStar_UInt128_uint128 s0 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(f20, f20), FStar_UInt128_mul_wide(d4, f21)), FStar_UInt128_mul_wide(d2, f23)); FStar_UInt128_uint128 s1 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(d0, f21), FStar_UInt128_mul_wide(d4, f22)), FStar_UInt128_mul_wide(d3, f23)); FStar_UInt128_uint128 s2 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(d0, f22), FStar_UInt128_mul_wide(f21, f21)), FStar_UInt128_mul_wide(d4, f23)); FStar_UInt128_uint128 s3 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(d0, f23), FStar_UInt128_mul_wide(d1, f22)), FStar_UInt128_mul_wide(f24, d419)); FStar_UInt128_uint128 s4 = FStar_UInt128_add(FStar_UInt128_add(FStar_UInt128_mul_wide(d0, f24), FStar_UInt128_mul_wide(d1, f23)), FStar_UInt128_mul_wide(f22, f22)); FStar_UInt128_uint128 o200 = s0; FStar_UInt128_uint128 o210 = s1; FStar_UInt128_uint128 o220 = s2; FStar_UInt128_uint128 o230 = s3; FStar_UInt128_uint128 o240 = s4; FStar_UInt128_uint128 l_ = FStar_UInt128_add(o100, FStar_UInt128_uint64_to_uint128(0ULL)); uint64_t tmp00 = FStar_UInt128_uint128_to_uint64(l_) & 0x7ffffffffffffULL; uint64_t c00 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_, 51U)); FStar_UInt128_uint128 l_0 = FStar_UInt128_add(o110, FStar_UInt128_uint64_to_uint128(c00)); uint64_t tmp10 = FStar_UInt128_uint128_to_uint64(l_0) & 0x7ffffffffffffULL; uint64_t c10 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_0, 51U)); FStar_UInt128_uint128 l_1 = FStar_UInt128_add(o120, FStar_UInt128_uint64_to_uint128(c10)); uint64_t tmp20 = FStar_UInt128_uint128_to_uint64(l_1) & 0x7ffffffffffffULL; uint64_t c20 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_1, 51U)); FStar_UInt128_uint128 l_2 = FStar_UInt128_add(o130, FStar_UInt128_uint64_to_uint128(c20)); uint64_t tmp30 = FStar_UInt128_uint128_to_uint64(l_2) & 0x7ffffffffffffULL; uint64_t c30 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_2, 51U)); FStar_UInt128_uint128 l_3 = FStar_UInt128_add(o140, FStar_UInt128_uint64_to_uint128(c30)); uint64_t tmp40 = FStar_UInt128_uint128_to_uint64(l_3) & 0x7ffffffffffffULL; uint64_t c40 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_3, 51U)); uint64_t l_4 = tmp00 + c40 * 19ULL; uint64_t tmp0_ = l_4 & 0x7ffffffffffffULL; uint64_t c50 = l_4 >> 51U; uint64_t o101 = tmp0_; uint64_t o111 = tmp10 + c50; uint64_t o121 = tmp20; uint64_t o131 = tmp30; uint64_t o141 = tmp40; FStar_UInt128_uint128 l_5 = FStar_UInt128_add(o200, FStar_UInt128_uint64_to_uint128(0ULL)); uint64_t tmp0 = FStar_UInt128_uint128_to_uint64(l_5) & 0x7ffffffffffffULL; uint64_t c0 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_5, 51U)); FStar_UInt128_uint128 l_6 = FStar_UInt128_add(o210, FStar_UInt128_uint64_to_uint128(c0)); uint64_t tmp1 = FStar_UInt128_uint128_to_uint64(l_6) & 0x7ffffffffffffULL; uint64_t c1 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_6, 51U)); FStar_UInt128_uint128 l_7 = FStar_UInt128_add(o220, FStar_UInt128_uint64_to_uint128(c1)); uint64_t tmp2 = FStar_UInt128_uint128_to_uint64(l_7) & 0x7ffffffffffffULL; uint64_t c2 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_7, 51U)); FStar_UInt128_uint128 l_8 = FStar_UInt128_add(o230, FStar_UInt128_uint64_to_uint128(c2)); uint64_t tmp3 = FStar_UInt128_uint128_to_uint64(l_8) & 0x7ffffffffffffULL; uint64_t c3 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_8, 51U)); FStar_UInt128_uint128 l_9 = FStar_UInt128_add(o240, FStar_UInt128_uint64_to_uint128(c3)); uint64_t tmp4 = FStar_UInt128_uint128_to_uint64(l_9) & 0x7ffffffffffffULL; uint64_t c4 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_shift_right(l_9, 51U)); uint64_t l_10 = tmp0 + c4 * 19ULL; uint64_t tmp0_0 = l_10 & 0x7ffffffffffffULL; uint64_t c5 = l_10 >> 51U; uint64_t o201 = tmp0_0; uint64_t o211 = tmp1 + c5; uint64_t o221 = tmp2; uint64_t o231 = tmp3; uint64_t o241 = tmp4; uint64_t o10 = o101; uint64_t o11 = o111; uint64_t o12 = o121; uint64_t o13 = o131; uint64_t o14 = o141; uint64_t o20 = o201; uint64_t o21 = o211; uint64_t o22 = o221; uint64_t o23 = o231; uint64_t o24 = o241; out[0U] = o10; out[1U] = o11; out[2U] = o12; out[3U] = o13; out[4U] = o14; out[5U] = o20; out[6U] = o21; out[7U] = o22; out[8U] = o23; out[9U] = o24; } static inline void Hacl_Impl_Curve25519_Field51_store_felem(uint64_t *u64s, uint64_t *f) { uint64_t f0 = f[0U]; uint64_t f1 = f[1U]; uint64_t f2 = f[2U]; uint64_t f3 = f[3U]; uint64_t f4 = f[4U]; uint64_t l_ = f0 + 0ULL; uint64_t tmp0 = l_ & 0x7ffffffffffffULL; uint64_t c0 = l_ >> 51U; uint64_t l_0 = f1 + c0; uint64_t tmp1 = l_0 & 0x7ffffffffffffULL; uint64_t c1 = l_0 >> 51U; uint64_t l_1 = f2 + c1; uint64_t tmp2 = l_1 & 0x7ffffffffffffULL; uint64_t c2 = l_1 >> 51U; uint64_t l_2 = f3 + c2; uint64_t tmp3 = l_2 & 0x7ffffffffffffULL; uint64_t c3 = l_2 >> 51U; uint64_t l_3 = f4 + c3; uint64_t tmp4 = l_3 & 0x7ffffffffffffULL; uint64_t c4 = l_3 >> 51U; uint64_t l_4 = tmp0 + c4 * 19ULL; uint64_t tmp0_ = l_4 & 0x7ffffffffffffULL; uint64_t c5 = l_4 >> 51U; uint64_t f01 = tmp0_; uint64_t f11 = tmp1 + c5; uint64_t f21 = tmp2; uint64_t f31 = tmp3; uint64_t f41 = tmp4; uint64_t m0 = FStar_UInt64_gte_mask(f01, 0x7ffffffffffedULL); uint64_t m1 = FStar_UInt64_eq_mask(f11, 0x7ffffffffffffULL); uint64_t m2 = FStar_UInt64_eq_mask(f21, 0x7ffffffffffffULL); uint64_t m3 = FStar_UInt64_eq_mask(f31, 0x7ffffffffffffULL); uint64_t m4 = FStar_UInt64_eq_mask(f41, 0x7ffffffffffffULL); uint64_t mask = (((m0 & m1) & m2) & m3) & m4; uint64_t f0_ = f01 - (mask & 0x7ffffffffffedULL); uint64_t f1_ = f11 - (mask & 0x7ffffffffffffULL); uint64_t f2_ = f21 - (mask & 0x7ffffffffffffULL); uint64_t f3_ = f31 - (mask & 0x7ffffffffffffULL); uint64_t f4_ = f41 - (mask & 0x7ffffffffffffULL); uint64_t f02 = f0_; uint64_t f12 = f1_; uint64_t f22 = f2_; uint64_t f32 = f3_; uint64_t f42 = f4_; uint64_t o00 = f02 | f12 << 51U; uint64_t o10 = f12 >> 13U | f22 << 38U; uint64_t o20 = f22 >> 26U | f32 << 25U; uint64_t o30 = f32 >> 39U | f42 << 12U; uint64_t o0 = o00; uint64_t o1 = o10; uint64_t o2 = o20; uint64_t o3 = o30; u64s[0U] = o0; u64s[1U] = o1; u64s[2U] = o2; u64s[3U] = o3; } static inline void Hacl_Impl_Curve25519_Field51_cswap2(uint64_t bit, uint64_t *p1, uint64_t *p2) { uint64_t mask = 0ULL - bit; KRML_MAYBE_FOR10(i, 0U, 10U, 1U, uint64_t dummy = mask & (p1[i] ^ p2[i]); p1[i] = p1[i] ^ dummy; p2[i] = p2[i] ^ dummy;); } #if defined(__cplusplus) } #endif #define __internal_Hacl_Bignum25519_51_H_DEFINED #endif /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #ifndef __internal_Hacl_Curve25519_51_H #define __internal_Hacl_Curve25519_51_H #if defined(__cplusplus) extern "C" { #endif #include void Hacl_Curve25519_51_fsquare_times( uint64_t *o, uint64_t *inp, FStar_UInt128_uint128 *tmp, uint32_t n ); void Hacl_Curve25519_51_finv(uint64_t *o, uint64_t *i, FStar_UInt128_uint128 *tmp); #if defined(__cplusplus) } #endif #define __internal_Hacl_Curve25519_51_H_DEFINED #endif /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #ifndef __Hacl_Curve25519_51_H #define __Hacl_Curve25519_51_H #if defined(__cplusplus) extern "C" { #endif #include /** Compute the scalar multiple of a point. @param out Pointer to 32 bytes of memory, allocated by the caller, where the resulting point is written to. @param priv Pointer to 32 bytes of memory where the secret/private key is read from. @param pub Pointer to 32 bytes of memory where the public point is read from. */ void Hacl_Curve25519_51_scalarmult(uint8_t *out, uint8_t *priv, uint8_t *pub); /** Calculate a public point from a secret/private key. This computes a scalar multiplication of the secret/private key with the curve's basepoint. @param pub Pointer to 32 bytes of memory, allocated by the caller, where the resulting point is written to. @param priv Pointer to 32 bytes of memory where the secret/private key is read from. */ void Hacl_Curve25519_51_secret_to_public(uint8_t *pub, uint8_t *priv); /** Execute the diffie-hellmann key exchange. @param out Pointer to 32 bytes of memory, allocated by the caller, where the resulting point is written to. @param priv Pointer to 32 bytes of memory where **our** secret/private key is read from. @param pub Pointer to 32 bytes of memory where **their** public point is read from. */ bool Hacl_Curve25519_51_ecdh(uint8_t *out, uint8_t *priv, uint8_t *pub); #if defined(__cplusplus) } #endif #define __Hacl_Curve25519_51_H_DEFINED #endif /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #ifndef __internal_Hacl_Hash_SHA2_H #define __internal_Hacl_Hash_SHA2_H #if defined(__cplusplus) extern "C" { #endif #include static const uint32_t Hacl_Hash_SHA2_h224[8U] = { 0xc1059ed8U, 0x367cd507U, 0x3070dd17U, 0xf70e5939U, 0xffc00b31U, 0x68581511U, 0x64f98fa7U, 0xbefa4fa4U }; static const uint32_t Hacl_Hash_SHA2_h256[8U] = { 0x6a09e667U, 0xbb67ae85U, 0x3c6ef372U, 0xa54ff53aU, 0x510e527fU, 0x9b05688cU, 0x1f83d9abU, 0x5be0cd19U }; static const uint64_t Hacl_Hash_SHA2_h384[8U] = { 0xcbbb9d5dc1059ed8ULL, 0x629a292a367cd507ULL, 0x9159015a3070dd17ULL, 0x152fecd8f70e5939ULL, 0x67332667ffc00b31ULL, 0x8eb44a8768581511ULL, 0xdb0c2e0d64f98fa7ULL, 0x47b5481dbefa4fa4ULL }; static const uint64_t Hacl_Hash_SHA2_h512[8U] = { 0x6a09e667f3bcc908ULL, 0xbb67ae8584caa73bULL, 0x3c6ef372fe94f82bULL, 0xa54ff53a5f1d36f1ULL, 0x510e527fade682d1ULL, 0x9b05688c2b3e6c1fULL, 0x1f83d9abfb41bd6bULL, 0x5be0cd19137e2179ULL }; static const uint32_t Hacl_Hash_SHA2_k224_256[64U] = { 0x428a2f98U, 0x71374491U, 0xb5c0fbcfU, 0xe9b5dba5U, 0x3956c25bU, 0x59f111f1U, 0x923f82a4U, 0xab1c5ed5U, 0xd807aa98U, 0x12835b01U, 0x243185beU, 0x550c7dc3U, 0x72be5d74U, 0x80deb1feU, 0x9bdc06a7U, 0xc19bf174U, 0xe49b69c1U, 0xefbe4786U, 0x0fc19dc6U, 0x240ca1ccU, 0x2de92c6fU, 0x4a7484aaU, 0x5cb0a9dcU, 0x76f988daU, 0x983e5152U, 0xa831c66dU, 0xb00327c8U, 0xbf597fc7U, 0xc6e00bf3U, 0xd5a79147U, 0x06ca6351U, 0x14292967U, 0x27b70a85U, 0x2e1b2138U, 0x4d2c6dfcU, 0x53380d13U, 0x650a7354U, 0x766a0abbU, 0x81c2c92eU, 0x92722c85U, 0xa2bfe8a1U, 0xa81a664bU, 0xc24b8b70U, 0xc76c51a3U, 0xd192e819U, 0xd6990624U, 0xf40e3585U, 0x106aa070U, 0x19a4c116U, 0x1e376c08U, 0x2748774cU, 0x34b0bcb5U, 0x391c0cb3U, 0x4ed8aa4aU, 0x5b9cca4fU, 0x682e6ff3U, 0x748f82eeU, 0x78a5636fU, 0x84c87814U, 0x8cc70208U, 0x90befffaU, 0xa4506cebU, 0xbef9a3f7U, 0xc67178f2U }; static const uint64_t Hacl_Hash_SHA2_k384_512[80U] = { 0x428a2f98d728ae22ULL, 0x7137449123ef65cdULL, 0xb5c0fbcfec4d3b2fULL, 0xe9b5dba58189dbbcULL, 0x3956c25bf348b538ULL, 0x59f111f1b605d019ULL, 0x923f82a4af194f9bULL, 0xab1c5ed5da6d8118ULL, 0xd807aa98a3030242ULL, 0x12835b0145706fbeULL, 0x243185be4ee4b28cULL, 0x550c7dc3d5ffb4e2ULL, 0x72be5d74f27b896fULL, 0x80deb1fe3b1696b1ULL, 0x9bdc06a725c71235ULL, 0xc19bf174cf692694ULL, 0xe49b69c19ef14ad2ULL, 0xefbe4786384f25e3ULL, 0x0fc19dc68b8cd5b5ULL, 0x240ca1cc77ac9c65ULL, 0x2de92c6f592b0275ULL, 0x4a7484aa6ea6e483ULL, 0x5cb0a9dcbd41fbd4ULL, 0x76f988da831153b5ULL, 0x983e5152ee66dfabULL, 0xa831c66d2db43210ULL, 0xb00327c898fb213fULL, 0xbf597fc7beef0ee4ULL, 0xc6e00bf33da88fc2ULL, 0xd5a79147930aa725ULL, 0x06ca6351e003826fULL, 0x142929670a0e6e70ULL, 0x27b70a8546d22ffcULL, 0x2e1b21385c26c926ULL, 0x4d2c6dfc5ac42aedULL, 0x53380d139d95b3dfULL, 0x650a73548baf63deULL, 0x766a0abb3c77b2a8ULL, 0x81c2c92e47edaee6ULL, 0x92722c851482353bULL, 0xa2bfe8a14cf10364ULL, 0xa81a664bbc423001ULL, 0xc24b8b70d0f89791ULL, 0xc76c51a30654be30ULL, 0xd192e819d6ef5218ULL, 0xd69906245565a910ULL, 0xf40e35855771202aULL, 0x106aa07032bbd1b8ULL, 0x19a4c116b8d2d0c8ULL, 0x1e376c085141ab53ULL, 0x2748774cdf8eeb99ULL, 0x34b0bcb5e19b48a8ULL, 0x391c0cb3c5c95a63ULL, 0x4ed8aa4ae3418acbULL, 0x5b9cca4f7763e373ULL, 0x682e6ff3d6b2b8a3ULL, 0x748f82ee5defb2fcULL, 0x78a5636f43172f60ULL, 0x84c87814a1f0ab72ULL, 0x8cc702081a6439ecULL, 0x90befffa23631e28ULL, 0xa4506cebde82bde9ULL, 0xbef9a3f7b2c67915ULL, 0xc67178f2e372532bULL, 0xca273eceea26619cULL, 0xd186b8c721c0c207ULL, 0xeada7dd6cde0eb1eULL, 0xf57d4f7fee6ed178ULL, 0x06f067aa72176fbaULL, 0x0a637dc5a2c898a6ULL, 0x113f9804bef90daeULL, 0x1b710b35131c471bULL, 0x28db77f523047d84ULL, 0x32caab7b40c72493ULL, 0x3c9ebe0a15c9bebcULL, 0x431d67c49c100d4cULL, 0x4cc5d4becb3e42b6ULL, 0x597f299cfc657e2aULL, 0x5fcb6fab3ad6faecULL, 0x6c44198c4a475817ULL }; void Hacl_Hash_SHA2_sha256_init(uint32_t *hash); void Hacl_Hash_SHA2_sha256_update_nblocks(uint32_t len, uint8_t *b, uint32_t *st); void Hacl_Hash_SHA2_sha256_update_last(uint64_t totlen, uint32_t len, uint8_t *b, uint32_t *hash); void Hacl_Hash_SHA2_sha256_finish(uint32_t *st, uint8_t *h); void Hacl_Hash_SHA2_sha224_init(uint32_t *hash); void Hacl_Hash_SHA2_sha224_update_nblocks(uint32_t len, uint8_t *b, uint32_t *st); void Hacl_Hash_SHA2_sha224_update_last(uint64_t totlen, uint32_t len, uint8_t *b, uint32_t *st); void Hacl_Hash_SHA2_sha224_finish(uint32_t *st, uint8_t *h); void Hacl_Hash_SHA2_sha512_init(uint64_t *hash); void Hacl_Hash_SHA2_sha512_update_nblocks(uint32_t len, uint8_t *b, uint64_t *st); void Hacl_Hash_SHA2_sha512_update_last( FStar_UInt128_uint128 totlen, uint32_t len, uint8_t *b, uint64_t *hash ); void Hacl_Hash_SHA2_sha512_finish(uint64_t *st, uint8_t *h); void Hacl_Hash_SHA2_sha384_init(uint64_t *hash); void Hacl_Hash_SHA2_sha384_update_nblocks(uint32_t len, uint8_t *b, uint64_t *st); void Hacl_Hash_SHA2_sha384_update_last( FStar_UInt128_uint128 totlen, uint32_t len, uint8_t *b, uint64_t *st ); void Hacl_Hash_SHA2_sha384_finish(uint64_t *st, uint8_t *h); #if defined(__cplusplus) } #endif #define __internal_Hacl_Hash_SHA2_H_DEFINED #endif /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #ifndef __Hacl_Hash_SHA2_H #define __Hacl_Hash_SHA2_H #if defined(__cplusplus) extern "C" { #endif #include typedef Hacl_Streaming_MD_state_32 Hacl_Hash_SHA2_state_t_224; typedef Hacl_Streaming_MD_state_32 Hacl_Hash_SHA2_state_t_256; typedef Hacl_Streaming_MD_state_64 Hacl_Hash_SHA2_state_t_384; typedef Hacl_Streaming_MD_state_64 Hacl_Hash_SHA2_state_t_512; /** Allocate initial state for the SHA2_256 hash. The state is to be freed by calling `free_256`. */ Hacl_Streaming_MD_state_32 *Hacl_Hash_SHA2_malloc_256(void); /** Copies the state passed as argument into a newly allocated state (deep copy). The state is to be freed by calling `free_256`. Cloning the state this way is useful, for instance, if your control-flow diverges and you need to feed more (different) data into the hash in each branch. */ Hacl_Streaming_MD_state_32 *Hacl_Hash_SHA2_copy_256(Hacl_Streaming_MD_state_32 *state); /** Reset an existing state to the initial hash state with empty data. */ void Hacl_Hash_SHA2_reset_256(Hacl_Streaming_MD_state_32 *state); /** Feed an arbitrary amount of data into the hash. This function returns 0 for success, or 1 if the combined length of all of the data passed to `update_256` (since the last call to `reset_256`) exceeds 2^61-1 bytes. This function is identical to the update function for SHA2_224. */ Hacl_Streaming_Types_error_code Hacl_Hash_SHA2_update_256( Hacl_Streaming_MD_state_32 *state, uint8_t *input, uint32_t input_len ); /** Write the resulting hash into `output`, an array of 32 bytes. The state remains valid after a call to `digest_256`, meaning the user may feed more data into the hash via `update_256`. (The digest_256 function operates on an internal copy of the state and therefore does not invalidate the client-held state `p`.) */ void Hacl_Hash_SHA2_digest_256(Hacl_Streaming_MD_state_32 *state, uint8_t *output); /** Free a state allocated with `malloc_256`. This function is identical to the free function for SHA2_224. */ void Hacl_Hash_SHA2_free_256(Hacl_Streaming_MD_state_32 *state); /** Hash `input`, of len `input_len`, into `output`, an array of 32 bytes. */ void Hacl_Hash_SHA2_hash_256(uint8_t *output, uint8_t *input, uint32_t input_len); Hacl_Streaming_MD_state_32 *Hacl_Hash_SHA2_malloc_224(void); void Hacl_Hash_SHA2_reset_224(Hacl_Streaming_MD_state_32 *state); Hacl_Streaming_Types_error_code Hacl_Hash_SHA2_update_224( Hacl_Streaming_MD_state_32 *state, uint8_t *input, uint32_t input_len ); /** Write the resulting hash into `output`, an array of 28 bytes. The state remains valid after a call to `digest_224`, meaning the user may feed more data into the hash via `update_224`. */ void Hacl_Hash_SHA2_digest_224(Hacl_Streaming_MD_state_32 *state, uint8_t *output); void Hacl_Hash_SHA2_free_224(Hacl_Streaming_MD_state_32 *state); /** Hash `input`, of len `input_len`, into `output`, an array of 28 bytes. */ void Hacl_Hash_SHA2_hash_224(uint8_t *output, uint8_t *input, uint32_t input_len); Hacl_Streaming_MD_state_64 *Hacl_Hash_SHA2_malloc_512(void); /** Copies the state passed as argument into a newly allocated state (deep copy). The state is to be freed by calling `free_512`. Cloning the state this way is useful, for instance, if your control-flow diverges and you need to feed more (different) data into the hash in each branch. */ Hacl_Streaming_MD_state_64 *Hacl_Hash_SHA2_copy_512(Hacl_Streaming_MD_state_64 *state); void Hacl_Hash_SHA2_reset_512(Hacl_Streaming_MD_state_64 *state); /** Feed an arbitrary amount of data into the hash. This function returns 0 for success, or 1 if the combined length of all of the data passed to `update_512` (since the last call to `reset_512`) exceeds 2^125-1 bytes. This function is identical to the update function for SHA2_384. */ Hacl_Streaming_Types_error_code Hacl_Hash_SHA2_update_512( Hacl_Streaming_MD_state_64 *state, uint8_t *input, uint32_t input_len ); /** Write the resulting hash into `output`, an array of 64 bytes. The state remains valid after a call to `digest_512`, meaning the user may feed more data into the hash via `update_512`. (The digest_512 function operates on an internal copy of the state and therefore does not invalidate the client-held state `p`.) */ void Hacl_Hash_SHA2_digest_512(Hacl_Streaming_MD_state_64 *state, uint8_t *output); /** Free a state allocated with `malloc_512`. This function is identical to the free function for SHA2_384. */ void Hacl_Hash_SHA2_free_512(Hacl_Streaming_MD_state_64 *state); /** Hash `input`, of len `input_len`, into `output`, an array of 64 bytes. */ void Hacl_Hash_SHA2_hash_512(uint8_t *output, uint8_t *input, uint32_t input_len); Hacl_Streaming_MD_state_64 *Hacl_Hash_SHA2_malloc_384(void); void Hacl_Hash_SHA2_reset_384(Hacl_Streaming_MD_state_64 *state); Hacl_Streaming_Types_error_code Hacl_Hash_SHA2_update_384( Hacl_Streaming_MD_state_64 *state, uint8_t *input, uint32_t input_len ); /** Write the resulting hash into `output`, an array of 48 bytes. The state remains valid after a call to `digest_384`, meaning the user may feed more data into the hash via `update_384`. */ void Hacl_Hash_SHA2_digest_384(Hacl_Streaming_MD_state_64 *state, uint8_t *output); void Hacl_Hash_SHA2_free_384(Hacl_Streaming_MD_state_64 *state); /** Hash `input`, of len `input_len`, into `output`, an array of 48 bytes. */ void Hacl_Hash_SHA2_hash_384(uint8_t *output, uint8_t *input, uint32_t input_len); #if defined(__cplusplus) } #endif #define __Hacl_Hash_SHA2_H_DEFINED #endif /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #ifndef __internal_Hacl_Ed25519_PrecompTable_H #define __internal_Hacl_Ed25519_PrecompTable_H #if defined(__cplusplus) extern "C" { #endif #include static const uint64_t Hacl_Ed25519_PrecompTable_precomp_basepoint_table_w4[320U] = { 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1738742601995546ULL, 1146398526822698ULL, 2070867633025821ULL, 562264141797630ULL, 587772402128613ULL, 1801439850948184ULL, 1351079888211148ULL, 450359962737049ULL, 900719925474099ULL, 1801439850948198ULL, 1ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1841354044333475ULL, 16398895984059ULL, 755974180946558ULL, 900171276175154ULL, 1821297809914039ULL, 1661154287933054ULL, 284530020860578ULL, 1390261174866914ULL, 1524110943907984ULL, 1045603498418422ULL, 928651508580478ULL, 1383326941296346ULL, 961937908925785ULL, 80455759693706ULL, 904734540352947ULL, 1507481815385608ULL, 2223447444246085ULL, 1083941587175919ULL, 2059929906842505ULL, 1581435440146976ULL, 782730187692425ULL, 9928394897574ULL, 1539449519985236ULL, 1923587931078510ULL, 552919286076056ULL, 376925408065760ULL, 447320488831784ULL, 1362918338468019ULL, 1470031896696846ULL, 2189796996539902ULL, 1337552949959847ULL, 1762287177775726ULL, 237994495816815ULL, 1277840395970544ULL, 543972849007241ULL, 1224692671618814ULL, 162359533289271ULL, 282240927125249ULL, 586909166382289ULL, 17726488197838ULL, 377014554985659ULL, 1433835303052512ULL, 702061469493692ULL, 1142253108318154ULL, 318297794307551ULL, 954362646308543ULL, 517363881452320ULL, 1868013482130416ULL, 262562472373260ULL, 902232853249919ULL, 2107343057055746ULL, 462368348619024ULL, 1893758677092974ULL, 2177729767846389ULL, 2168532543559143ULL, 443867094639821ULL, 730169342581022ULL, 1564589016879755ULL, 51218195700649ULL, 76684578423745ULL, 560266272480743ULL, 922517457707697ULL, 2066645939860874ULL, 1318277348414638ULL, 1576726809084003ULL, 1817337608563665ULL, 1874240939237666ULL, 754733726333910ULL, 97085310406474ULL, 751148364309235ULL, 1622159695715187ULL, 1444098819684916ULL, 130920805558089ULL, 1260449179085308ULL, 1860021740768461ULL, 110052860348509ULL, 193830891643810ULL, 164148413933881ULL, 180017794795332ULL, 1523506525254651ULL, 465981629225956ULL, 559733514964572ULL, 1279624874416974ULL, 2026642326892306ULL, 1425156829982409ULL, 2160936383793147ULL, 1061870624975247ULL, 2023497043036941ULL, 117942212883190ULL, 490339622800774ULL, 1729931303146295ULL, 422305932971074ULL, 529103152793096ULL, 1211973233775992ULL, 721364955929681ULL, 1497674430438813ULL, 342545521275073ULL, 2102107575279372ULL, 2108462244669966ULL, 1382582406064082ULL, 2206396818383323ULL, 2109093268641147ULL, 10809845110983ULL, 1605176920880099ULL, 744640650753946ULL, 1712758897518129ULL, 373410811281809ULL, 648838265800209ULL, 813058095530999ULL, 513987632620169ULL, 465516160703329ULL, 2136322186126330ULL, 1979645899422932ULL, 1197131006470786ULL, 1467836664863979ULL, 1340751381374628ULL, 1810066212667962ULL, 1009933588225499ULL, 1106129188080873ULL, 1388980405213901ULL, 533719246598044ULL, 1169435803073277ULL, 198920999285821ULL, 487492330629854ULL, 1807093008537778ULL, 1540899012923865ULL, 2075080271659867ULL, 1527990806921523ULL, 1323728742908002ULL, 1568595959608205ULL, 1388032187497212ULL, 2026968840050568ULL, 1396591153295755ULL, 820416950170901ULL, 520060313205582ULL, 2016404325094901ULL, 1584709677868520ULL, 272161374469956ULL, 1567188603996816ULL, 1986160530078221ULL, 553930264324589ULL, 1058426729027503ULL, 8762762886675ULL, 2216098143382988ULL, 1835145266889223ULL, 1712936431558441ULL, 1017009937844974ULL, 585361667812740ULL, 2114711541628181ULL, 2238729632971439ULL, 121257546253072ULL, 847154149018345ULL, 211972965476684ULL, 287499084460129ULL, 2098247259180197ULL, 839070411583329ULL, 339551619574372ULL, 1432951287640743ULL, 526481249498942ULL, 931991661905195ULL, 1884279965674487ULL, 200486405604411ULL, 364173020594788ULL, 518034455936955ULL, 1085564703965501ULL, 16030410467927ULL, 604865933167613ULL, 1695298441093964ULL, 498856548116159ULL, 2193030062787034ULL, 1706339802964179ULL, 1721199073493888ULL, 820740951039755ULL, 1216053436896834ULL, 23954895815139ULL, 1662515208920491ULL, 1705443427511899ULL, 1957928899570365ULL, 1189636258255725ULL, 1795695471103809ULL, 1691191297654118ULL, 282402585374360ULL, 460405330264832ULL, 63765529445733ULL, 469763447404473ULL, 733607089694996ULL, 685410420186959ULL, 1096682630419738ULL, 1162548510542362ULL, 1020949526456676ULL, 1211660396870573ULL, 613126398222696ULL, 1117829165843251ULL, 742432540886650ULL, 1483755088010658ULL, 942392007134474ULL, 1447834130944107ULL, 489368274863410ULL, 23192985544898ULL, 648442406146160ULL, 785438843373876ULL, 249464684645238ULL, 170494608205618ULL, 335112827260550ULL, 1462050123162735ULL, 1084803668439016ULL, 853459233600325ULL, 215777728187495ULL, 1965759433526974ULL, 1349482894446537ULL, 694163317612871ULL, 860536766165036ULL, 1178788094084321ULL, 1652739626626996ULL, 2115723946388185ULL, 1577204379094664ULL, 1083882859023240ULL, 1768759143381635ULL, 1737180992507258ULL, 246054513922239ULL, 577253134087234ULL, 356340280578042ULL, 1638917769925142ULL, 223550348130103ULL, 470592666638765ULL, 22663573966996ULL, 596552461152400ULL, 364143537069499ULL, 3942119457699ULL, 107951982889287ULL, 1843471406713209ULL, 1625773041610986ULL, 1466141092501702ULL, 1043024095021271ULL, 310429964047508ULL, 98559121500372ULL, 152746933782868ULL, 259407205078261ULL, 828123093322585ULL, 1576847274280091ULL, 1170871375757302ULL, 1588856194642775ULL, 984767822341977ULL, 1141497997993760ULL, 809325345150796ULL, 1879837728202511ULL, 201340910657893ULL, 1079157558888483ULL, 1052373448588065ULL, 1732036202501778ULL, 2105292670328445ULL, 679751387312402ULL, 1679682144926229ULL, 1695823455818780ULL, 498852317075849ULL, 1786555067788433ULL, 1670727545779425ULL, 117945875433544ULL, 407939139781844ULL, 854632120023778ULL, 1413383148360437ULL, 286030901733673ULL, 1207361858071196ULL, 461340408181417ULL, 1096919590360164ULL, 1837594897475685ULL, 533755561544165ULL, 1638688042247712ULL, 1431653684793005ULL, 1036458538873559ULL, 390822120341779ULL, 1920929837111618ULL, 543426740024168ULL, 645751357799929ULL, 2245025632994463ULL, 1550778638076452ULL, 223738153459949ULL, 1337209385492033ULL, 1276967236456531ULL, 1463815821063071ULL, 2070620870191473ULL, 1199170709413753ULL, 273230877394166ULL, 1873264887608046ULL, 890877152910775ULL }; static const uint64_t Hacl_Ed25519_PrecompTable_precomp_g_pow2_64_table_w4[320U] = { 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 13559344787725ULL, 2051621493703448ULL, 1947659315640708ULL, 626856790370168ULL, 1592804284034836ULL, 1781728767459187ULL, 278818420518009ULL, 2038030359908351ULL, 910625973862690ULL, 471887343142239ULL, 1298543306606048ULL, 794147365642417ULL, 129968992326749ULL, 523140861678572ULL, 1166419653909231ULL, 2009637196928390ULL, 1288020222395193ULL, 1007046974985829ULL, 208981102651386ULL, 2074009315253380ULL, 1564056062071967ULL, 276822668750618ULL, 206621292512572ULL, 470304361809269ULL, 895215438398493ULL, 1527859053868686ULL, 1624967223409369ULL, 811821865979736ULL, 350450534838340ULL, 219143807921807ULL, 507994540371254ULL, 986513794574720ULL, 1142661369967121ULL, 621278293399257ULL, 556189161519781ULL, 351964007865066ULL, 2011573453777822ULL, 1367125527151537ULL, 1691316722438196ULL, 731328817345164ULL, 1284781192709232ULL, 478439299539269ULL, 204842178076429ULL, 2085125369913651ULL, 1980773492792985ULL, 1480264409524940ULL, 688389585376233ULL, 612962643526972ULL, 165595382536676ULL, 1850300069212263ULL, 1176357203491551ULL, 1880164984292321ULL, 10786153104736ULL, 1242293560510203ULL, 1358399951884084ULL, 1901358796610357ULL, 1385092558795806ULL, 1734893785311348ULL, 2046201851951191ULL, 1233811309557352ULL, 1531160168656129ULL, 1543287181303358ULL, 516121446374119ULL, 723422668089935ULL, 1228176774959679ULL, 1598014722726267ULL, 1630810326658412ULL, 1343833067463760ULL, 1024397964362099ULL, 1157142161346781ULL, 56422174971792ULL, 544901687297092ULL, 1291559028869009ULL, 1336918672345120ULL, 1390874603281353ULL, 1127199512010904ULL, 992644979940964ULL, 1035213479783573ULL, 36043651196100ULL, 1220961519321221ULL, 1348190007756977ULL, 579420200329088ULL, 1703819961008985ULL, 1993919213460047ULL, 2225080008232251ULL, 392785893702372ULL, 464312521482632ULL, 1224525362116057ULL, 810394248933036ULL, 932513521649107ULL, 592314953488703ULL, 586334603791548ULL, 1310888126096549ULL, 650842674074281ULL, 1596447001791059ULL, 2086767406328284ULL, 1866377645879940ULL, 1721604362642743ULL, 738502322566890ULL, 1851901097729689ULL, 1158347571686914ULL, 2023626733470827ULL, 329625404653699ULL, 563555875598551ULL, 516554588079177ULL, 1134688306104598ULL, 186301198420809ULL, 1339952213563300ULL, 643605614625891ULL, 1947505332718043ULL, 1722071694852824ULL, 601679570440694ULL, 1821275721236351ULL, 1808307842870389ULL, 1654165204015635ULL, 1457334100715245ULL, 217784948678349ULL, 1820622417674817ULL, 1946121178444661ULL, 597980757799332ULL, 1745271227710764ULL, 2010952890941980ULL, 339811849696648ULL, 1066120666993872ULL, 261276166508990ULL, 323098645774553ULL, 207454744271283ULL, 941448672977675ULL, 71890920544375ULL, 840849789313357ULL, 1223996070717926ULL, 196832550853408ULL, 115986818309231ULL, 1586171527267675ULL, 1666169080973450ULL, 1456454731176365ULL, 44467854369003ULL, 2149656190691480ULL, 283446383597589ULL, 2040542647729974ULL, 305705593840224ULL, 475315822269791ULL, 648133452550632ULL, 169218658835720ULL, 24960052338251ULL, 938907951346766ULL, 425970950490510ULL, 1037622011013183ULL, 1026882082708180ULL, 1635699409504916ULL, 1644776942870488ULL, 2151820331175914ULL, 824120674069819ULL, 835744976610113ULL, 1991271032313190ULL, 96507354724855ULL, 400645405133260ULL, 343728076650825ULL, 1151585441385566ULL, 1403339955333520ULL, 230186314139774ULL, 1736248861506714ULL, 1010804378904572ULL, 1394932289845636ULL, 1901351256960852ULL, 2187471430089807ULL, 1003853262342670ULL, 1327743396767461ULL, 1465160415991740ULL, 366625359144534ULL, 1534791405247604ULL, 1790905930250187ULL, 1255484115292738ULL, 2223291365520443ULL, 210967717407408ULL, 26722916813442ULL, 1919574361907910ULL, 468825088280256ULL, 2230011775946070ULL, 1628365642214479ULL, 568871869234932ULL, 1066987968780488ULL, 1692242903745558ULL, 1678903997328589ULL, 214262165888021ULL, 1929686748607204ULL, 1790138967989670ULL, 1790261616022076ULL, 1559824537553112ULL, 1230364591311358ULL, 147531939886346ULL, 1528207085815487ULL, 477957922927292ULL, 285670243881618ULL, 264430080123332ULL, 1163108160028611ULL, 373201522147371ULL, 34903775270979ULL, 1750870048600662ULL, 1319328308741084ULL, 1547548634278984ULL, 1691259592202927ULL, 2247758037259814ULL, 329611399953677ULL, 1385555496268877ULL, 2242438354031066ULL, 1329523854843632ULL, 399895373846055ULL, 678005703193452ULL, 1496357700997771ULL, 71909969781942ULL, 1515391418612349ULL, 470110837888178ULL, 1981307309417466ULL, 1259888737412276ULL, 669991710228712ULL, 1048546834514303ULL, 1678323291295512ULL, 2172033978088071ULL, 1529278455500556ULL, 901984601941894ULL, 780867622403807ULL, 550105677282793ULL, 975860231176136ULL, 525188281689178ULL, 49966114807992ULL, 1776449263836645ULL, 267851776380338ULL, 2225969494054620ULL, 2016794225789822ULL, 1186108678266608ULL, 1023083271408882ULL, 1119289418565906ULL, 1248185897348801ULL, 1846081539082697ULL, 23756429626075ULL, 1441999021105403ULL, 724497586552825ULL, 1287761623605379ULL, 685303359654224ULL, 2217156930690570ULL, 163769288918347ULL, 1098423278284094ULL, 1391470723006008ULL, 570700152353516ULL, 744804507262556ULL, 2200464788609495ULL, 624141899161992ULL, 2249570166275684ULL, 378706441983561ULL, 122486379999375ULL, 430741162798924ULL, 113847463452574ULL, 266250457840685ULL, 2120743625072743ULL, 222186221043927ULL, 1964290018305582ULL, 1435278008132477ULL, 1670867456663734ULL, 2009989552599079ULL, 1348024113448744ULL, 1158423886300455ULL, 1356467152691569ULL, 306943042363674ULL, 926879628664255ULL, 1349295689598324ULL, 725558330071205ULL, 536569987519948ULL, 116436990335366ULL, 1551888573800376ULL, 2044698345945451ULL, 104279940291311ULL, 251526570943220ULL, 754735828122925ULL, 33448073576361ULL, 994605876754543ULL, 546007584022006ULL, 2217332798409487ULL, 706477052561591ULL, 131174619428653ULL, 2148698284087243ULL, 239290486205186ULL, 2161325796952184ULL, 1713452845607994ULL, 1297861562938913ULL, 1779539876828514ULL, 1926559018603871ULL, 296485747893968ULL, 1859208206640686ULL, 538513979002718ULL, 103998826506137ULL, 2025375396538469ULL, 1370680785701206ULL, 1698557311253840ULL, 1411096399076595ULL, 2132580530813677ULL, 2071564345845035ULL, 498581428556735ULL, 1136010486691371ULL, 1927619356993146ULL }; static const uint64_t Hacl_Ed25519_PrecompTable_precomp_g_pow2_128_table_w4[320U] = { 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 557549315715710ULL, 196756086293855ULL, 846062225082495ULL, 1865068224838092ULL, 991112090754908ULL, 522916421512828ULL, 2098523346722375ULL, 1135633221747012ULL, 858420432114866ULL, 186358544306082ULL, 1044420411868480ULL, 2080052304349321ULL, 557301814716724ULL, 1305130257814057ULL, 2126012765451197ULL, 1441004402875101ULL, 353948968859203ULL, 470765987164835ULL, 1507675957683570ULL, 1086650358745097ULL, 1911913434398388ULL, 66086091117182ULL, 1137511952425971ULL, 36958263512141ULL, 2193310025325256ULL, 1085191426269045ULL, 1232148267909446ULL, 1449894406170117ULL, 1241416717139557ULL, 1940876999212868ULL, 829758415918121ULL, 309608450373449ULL, 2228398547683851ULL, 1580623271960188ULL, 1675601502456740ULL, 1360363115493548ULL, 1098397313096815ULL, 1809255384359797ULL, 1458261916834384ULL, 210682545649705ULL, 1606836641068115ULL, 1230478270405318ULL, 1843192771547802ULL, 1794596343564051ULL, 229060710252162ULL, 2169742775467181ULL, 701467067318072ULL, 696018499035555ULL, 521051885339807ULL, 158329567901874ULL, 740426481832143ULL, 1369811177301441ULL, 503351589084015ULL, 1781114827942261ULL, 1650493549693035ULL, 2174562418345156ULL, 456517194809244ULL, 2052761522121179ULL, 2233342271123682ULL, 1445872925177435ULL, 1131882576902813ULL, 220765848055241ULL, 1280259961403769ULL, 1581497080160712ULL, 1477441080108824ULL, 218428165202767ULL, 1970598141278907ULL, 643366736173069ULL, 2167909426804014ULL, 834993711408259ULL, 1922437166463212ULL, 1900036281472252ULL, 513794844386304ULL, 1297904164900114ULL, 1147626295373268ULL, 1910101606251299ULL, 182933838633381ULL, 806229530787362ULL, 155511666433200ULL, 290522463375462ULL, 534373523491751ULL, 1302938814480515ULL, 1664979184120445ULL, 304235649499423ULL, 339284524318609ULL, 1881717946973483ULL, 1670802286833842ULL, 2223637120675737ULL, 135818919485814ULL, 1144856572842792ULL, 2234981613434386ULL, 963917024969826ULL, 402275378284993ULL, 141532417412170ULL, 921537468739387ULL, 963905069722607ULL, 1405442890733358ULL, 1567763927164655ULL, 1664776329195930ULL, 2095924165508507ULL, 994243110271379ULL, 1243925610609353ULL, 1029845815569727ULL, 1001968867985629ULL, 170368934002484ULL, 1100906131583801ULL, 1825190326449569ULL, 1462285121182096ULL, 1545240767016377ULL, 797859025652273ULL, 1062758326657530ULL, 1125600735118266ULL, 739325756774527ULL, 1420144485966996ULL, 1915492743426702ULL, 752968196344993ULL, 882156396938351ULL, 1909097048763227ULL, 849058590685611ULL, 840754951388500ULL, 1832926948808323ULL, 2023317100075297ULL, 322382745442827ULL, 1569741341737601ULL, 1678986113194987ULL, 757598994581938ULL, 29678659580705ULL, 1239680935977986ULL, 1509239427168474ULL, 1055981929287006ULL, 1894085471158693ULL, 916486225488490ULL, 642168890366120ULL, 300453362620010ULL, 1858797242721481ULL, 2077989823177130ULL, 510228455273334ULL, 1473284798689270ULL, 5173934574301ULL, 765285232030050ULL, 1007154707631065ULL, 1862128712885972ULL, 168873464821340ULL, 1967853269759318ULL, 1489896018263031ULL, 592451806166369ULL, 1242298565603883ULL, 1838918921339058ULL, 697532763910695ULL, 294335466239059ULL, 135687058387449ULL, 2133734403874176ULL, 2121911143127699ULL, 20222476737364ULL, 1200824626476747ULL, 1397731736540791ULL, 702378430231418ULL, 59059527640068ULL, 460992547183981ULL, 1016125857842765ULL, 1273530839608957ULL, 96724128829301ULL, 1313433042425233ULL, 3543822857227ULL, 761975685357118ULL, 110417360745248ULL, 1079634164577663ULL, 2044574510020457ULL, 338709058603120ULL, 94541336042799ULL, 127963233585039ULL, 94427896272258ULL, 1143501979342182ULL, 1217958006212230ULL, 2153887831492134ULL, 1519219513255575ULL, 251793195454181ULL, 392517349345200ULL, 1507033011868881ULL, 2208494254670752ULL, 1364389582694359ULL, 2214069430728063ULL, 1272814257105752ULL, 741450148906352ULL, 1105776675555685ULL, 824447222014984ULL, 528745219306376ULL, 589427609121575ULL, 1501786838809155ULL, 379067373073147ULL, 184909476589356ULL, 1346887560616185ULL, 1932023742314082ULL, 1633302311869264ULL, 1685314821133069ULL, 1836610282047884ULL, 1595571594397150ULL, 615441688872198ULL, 1926435616702564ULL, 235632180396480ULL, 1051918343571810ULL, 2150570051687050ULL, 879198845408738ULL, 1443966275205464ULL, 481362545245088ULL, 512807443532642ULL, 641147578283480ULL, 1594276116945596ULL, 1844812743300602ULL, 2044559316019485ULL, 202620777969020ULL, 852992984136302ULL, 1500869642692910ULL, 1085216217052457ULL, 1736294372259758ULL, 2009666354486552ULL, 1262389020715248ULL, 1166527705256867ULL, 1409917450806036ULL, 1705819160057637ULL, 1116901782584378ULL, 1278460472285473ULL, 257879811360157ULL, 40314007176886ULL, 701309846749639ULL, 1380457676672777ULL, 631519782380272ULL, 1196339573466793ULL, 955537708940017ULL, 532725633381530ULL, 641190593731833ULL, 7214357153807ULL, 481922072107983ULL, 1634886189207352ULL, 1247659758261633ULL, 1655809614786430ULL, 43105797900223ULL, 76205809912607ULL, 1936575107455823ULL, 1107927314642236ULL, 2199986333469333ULL, 802974829322510ULL, 718173128143482ULL, 539385184235615ULL, 2075693785611221ULL, 953281147333690ULL, 1623571637172587ULL, 655274535022250ULL, 1568078078819021ULL, 101142125049712ULL, 1488441673350881ULL, 1457969561944515ULL, 1492622544287712ULL, 2041460689280803ULL, 1961848091392887ULL, 461003520846938ULL, 934728060399807ULL, 117723291519705ULL, 1027773762863526ULL, 56765304991567ULL, 2184028379550479ULL, 1768767711894030ULL, 1304432068983172ULL, 498080974452325ULL, 2134905654858163ULL, 1446137427202647ULL, 551613831549590ULL, 680288767054205ULL, 1278113339140386ULL, 378149431842614ULL, 80520494426960ULL, 2080985256348782ULL, 673432591799820ULL, 739189463724560ULL, 1847191452197509ULL, 527737312871602ULL, 477609358840073ULL, 1891633072677946ULL, 1841456828278466ULL, 2242502936489002ULL, 524791829362709ULL, 276648168514036ULL, 991706903257619ULL, 512580228297906ULL, 1216855104975946ULL, 67030930303149ULL, 769593945208213ULL, 2048873385103577ULL, 455635274123107ULL, 2077404927176696ULL, 1803539634652306ULL, 1837579953843417ULL, 1564240068662828ULL, 1964310918970435ULL, 832822906252492ULL, 1516044634195010ULL, 770571447506889ULL, 602215152486818ULL, 1760828333136947ULL, 730156776030376ULL }; static const uint64_t Hacl_Ed25519_PrecompTable_precomp_g_pow2_192_table_w4[320U] = { 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1129953239743101ULL, 1240339163956160ULL, 61002583352401ULL, 2017604552196030ULL, 1576867829229863ULL, 1508654942849389ULL, 270111619664077ULL, 1253097517254054ULL, 721798270973250ULL, 161923365415298ULL, 828530877526011ULL, 1494851059386763ULL, 662034171193976ULL, 1315349646974670ULL, 2199229517308806ULL, 497078277852673ULL, 1310507715989956ULL, 1881315714002105ULL, 2214039404983803ULL, 1331036420272667ULL, 296286697520787ULL, 1179367922639127ULL, 25348441419697ULL, 2200984961703188ULL, 150893128908291ULL, 1978614888570852ULL, 1539657347172046ULL, 553810196523619ULL, 246017573977646ULL, 1440448985385485ULL, 346049108099981ULL, 601166606218546ULL, 855822004151713ULL, 1957521326383188ULL, 1114240380430887ULL, 1349639675122048ULL, 957375954499040ULL, 111551795360136ULL, 618586733648988ULL, 490708840688866ULL, 1267002049697314ULL, 1130723224930028ULL, 215603029480828ULL, 1277138555414710ULL, 1556750324971322ULL, 1407903521793741ULL, 1836836546590749ULL, 576500297444199ULL, 2074707599091135ULL, 1826239864380012ULL, 1935365705983312ULL, 239501825683682ULL, 1594236669034980ULL, 1283078975055301ULL, 856745636255925ULL, 1342128647959981ULL, 945216428379689ULL, 938746202496410ULL, 105775123333919ULL, 1379852610117266ULL, 1770216827500275ULL, 1016017267535704ULL, 1902885522469532ULL, 994184703730489ULL, 2227487538793763ULL, 53155967096055ULL, 1264120808114350ULL, 1334928769376729ULL, 393911808079997ULL, 826229239481845ULL, 1827903006733192ULL, 1449283706008465ULL, 1258040415217849ULL, 1641484112868370ULL, 1140150841968176ULL, 391113338021313ULL, 162138667815833ULL, 742204396566060ULL, 110709233440557ULL, 90179377432917ULL, 530511949644489ULL, 911568635552279ULL, 135869304780166ULL, 617719999563692ULL, 1802525001631319ULL, 1836394639510490ULL, 1862739456475085ULL, 1378284444664288ULL, 1617882529391756ULL, 876124429891172ULL, 1147654641445091ULL, 1476943370400542ULL, 688601222759067ULL, 2120281968990205ULL, 1387113236912611ULL, 2125245820685788ULL, 1030674016350092ULL, 1594684598654247ULL, 1165939511879820ULL, 271499323244173ULL, 546587254515484ULL, 945603425742936ULL, 1242252568170226ULL, 561598728058142ULL, 604827091794712ULL, 19869753585186ULL, 565367744708915ULL, 536755754533603ULL, 1767258313589487ULL, 907952975936127ULL, 292851652613937ULL, 163573546237963ULL, 837601408384564ULL, 591996990118301ULL, 2126051747693057ULL, 182247548824566ULL, 908369044122868ULL, 1335442699947273ULL, 2234292296528612ULL, 689537529333034ULL, 2174778663790714ULL, 1011407643592667ULL, 1856130618715473ULL, 1557437221651741ULL, 2250285407006102ULL, 1412384213410827ULL, 1428042038612456ULL, 962709733973660ULL, 313995703125919ULL, 1844969155869325ULL, 787716782673657ULL, 622504542173478ULL, 930119043384654ULL, 2128870043952488ULL, 537781531479523ULL, 1556666269904940ULL, 417333635741346ULL, 1986743846438415ULL, 877620478041197ULL, 2205624582983829ULL, 595260668884488ULL, 2025159350373157ULL, 2091659716088235ULL, 1423634716596391ULL, 653686638634080ULL, 1972388399989956ULL, 795575741798014ULL, 889240107997846ULL, 1446156876910732ULL, 1028507012221776ULL, 1071697574586478ULL, 1689630411899691ULL, 604092816502174ULL, 1909917373896122ULL, 1602544877643837ULL, 1227177032923867ULL, 62684197535630ULL, 186146290753883ULL, 414449055316766ULL, 1560555880866750ULL, 157579947096755ULL, 230526795502384ULL, 1197673369665894ULL, 593779215869037ULL, 214638834474097ULL, 1796344443484478ULL, 493550548257317ULL, 1628442824033694ULL, 1410811655893495ULL, 1009361960995171ULL, 604736219740352ULL, 392445928555351ULL, 1254295770295706ULL, 1958074535046128ULL, 508699942241019ULL, 739405911261325ULL, 1678760393882409ULL, 517763708545996ULL, 640040257898722ULL, 384966810872913ULL, 407454748380128ULL, 152604679407451ULL, 185102854927662ULL, 1448175503649595ULL, 100328519208674ULL, 1153263667012830ULL, 1643926437586490ULL, 609632142834154ULL, 980984004749261ULL, 855290732258779ULL, 2186022163021506ULL, 1254052618626070ULL, 1850030517182611ULL, 162348933090207ULL, 1948712273679932ULL, 1331832516262191ULL, 1219400369175863ULL, 89689036937483ULL, 1554886057235815ULL, 1520047528432789ULL, 81263957652811ULL, 146612464257008ULL, 2207945627164163ULL, 919846660682546ULL, 1925694087906686ULL, 2102027292388012ULL, 887992003198635ULL, 1817924871537027ULL, 746660005584342ULL, 753757153275525ULL, 91394270908699ULL, 511837226544151ULL, 736341543649373ULL, 1256371121466367ULL, 1977778299551813ULL, 817915174462263ULL, 1602323381418035ULL, 190035164572930ULL, 603796401391181ULL, 2152666873671669ULL, 1813900316324112ULL, 1292622433358041ULL, 888439870199892ULL, 978918155071994ULL, 534184417909805ULL, 466460084317313ULL, 1275223140288685ULL, 786407043883517ULL, 1620520623925754ULL, 1753625021290269ULL, 751937175104525ULL, 905301961820613ULL, 697059847245437ULL, 584919033981144ULL, 1272165506533156ULL, 1532180021450866ULL, 1901407354005301ULL, 1421319720492586ULL, 2179081609765456ULL, 2193253156667632ULL, 1080248329608584ULL, 2158422436462066ULL, 759167597017850ULL, 545759071151285ULL, 641600428493698ULL, 943791424499848ULL, 469571542427864ULL, 951117845222467ULL, 1780538594373407ULL, 614611122040309ULL, 1354826131886963ULL, 221898131992340ULL, 1145699723916219ULL, 798735379961769ULL, 1843560518208287ULL, 1424523160161545ULL, 205549016574779ULL, 2239491587362749ULL, 1918363582399888ULL, 1292183072788455ULL, 1783513123192567ULL, 1584027954317205ULL, 1890421443925740ULL, 1718459319874929ULL, 1522091040748809ULL, 399467600667219ULL, 1870973059066576ULL, 287514433150348ULL, 1397845311152885ULL, 1880440629872863ULL, 709302939340341ULL, 1813571361109209ULL, 86598795876860ULL, 1146964554310612ULL, 1590956584862432ULL, 2097004628155559ULL, 656227622102390ULL, 1808500445541891ULL, 958336726523135ULL, 2007604569465975ULL, 313504950390997ULL, 1399686004953620ULL, 1759732788465234ULL, 1562539721055836ULL, 1575722765016293ULL, 793318366641259ULL, 443876859384887ULL, 547308921989704ULL, 636698687503328ULL, 2179175835287340ULL, 498333551718258ULL, 932248760026176ULL, 1612395686304653ULL, 2179774103745626ULL, 1359658123541018ULL, 171488501802442ULL, 1625034951791350ULL, 520196922773633ULL, 1873787546341877ULL, 303457823885368ULL }; static const uint64_t Hacl_Ed25519_PrecompTable_precomp_basepoint_table_w5[640U] = { 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1738742601995546ULL, 1146398526822698ULL, 2070867633025821ULL, 562264141797630ULL, 587772402128613ULL, 1801439850948184ULL, 1351079888211148ULL, 450359962737049ULL, 900719925474099ULL, 1801439850948198ULL, 1ULL, 0ULL, 0ULL, 0ULL, 0ULL, 1841354044333475ULL, 16398895984059ULL, 755974180946558ULL, 900171276175154ULL, 1821297809914039ULL, 1661154287933054ULL, 284530020860578ULL, 1390261174866914ULL, 1524110943907984ULL, 1045603498418422ULL, 928651508580478ULL, 1383326941296346ULL, 961937908925785ULL, 80455759693706ULL, 904734540352947ULL, 1507481815385608ULL, 2223447444246085ULL, 1083941587175919ULL, 2059929906842505ULL, 1581435440146976ULL, 782730187692425ULL, 9928394897574ULL, 1539449519985236ULL, 1923587931078510ULL, 552919286076056ULL, 376925408065760ULL, 447320488831784ULL, 1362918338468019ULL, 1470031896696846ULL, 2189796996539902ULL, 1337552949959847ULL, 1762287177775726ULL, 237994495816815ULL, 1277840395970544ULL, 543972849007241ULL, 1224692671618814ULL, 162359533289271ULL, 282240927125249ULL, 586909166382289ULL, 17726488197838ULL, 377014554985659ULL, 1433835303052512ULL, 702061469493692ULL, 1142253108318154ULL, 318297794307551ULL, 954362646308543ULL, 517363881452320ULL, 1868013482130416ULL, 262562472373260ULL, 902232853249919ULL, 2107343057055746ULL, 462368348619024ULL, 1893758677092974ULL, 2177729767846389ULL, 2168532543559143ULL, 443867094639821ULL, 730169342581022ULL, 1564589016879755ULL, 51218195700649ULL, 76684578423745ULL, 560266272480743ULL, 922517457707697ULL, 2066645939860874ULL, 1318277348414638ULL, 1576726809084003ULL, 1817337608563665ULL, 1874240939237666ULL, 754733726333910ULL, 97085310406474ULL, 751148364309235ULL, 1622159695715187ULL, 1444098819684916ULL, 130920805558089ULL, 1260449179085308ULL, 1860021740768461ULL, 110052860348509ULL, 193830891643810ULL, 164148413933881ULL, 180017794795332ULL, 1523506525254651ULL, 465981629225956ULL, 559733514964572ULL, 1279624874416974ULL, 2026642326892306ULL, 1425156829982409ULL, 2160936383793147ULL, 1061870624975247ULL, 2023497043036941ULL, 117942212883190ULL, 490339622800774ULL, 1729931303146295ULL, 422305932971074ULL, 529103152793096ULL, 1211973233775992ULL, 721364955929681ULL, 1497674430438813ULL, 342545521275073ULL, 2102107575279372ULL, 2108462244669966ULL, 1382582406064082ULL, 2206396818383323ULL, 2109093268641147ULL, 10809845110983ULL, 1605176920880099ULL, 744640650753946ULL, 1712758897518129ULL, 373410811281809ULL, 648838265800209ULL, 813058095530999ULL, 513987632620169ULL, 465516160703329ULL, 2136322186126330ULL, 1979645899422932ULL, 1197131006470786ULL, 1467836664863979ULL, 1340751381374628ULL, 1810066212667962ULL, 1009933588225499ULL, 1106129188080873ULL, 1388980405213901ULL, 533719246598044ULL, 1169435803073277ULL, 198920999285821ULL, 487492330629854ULL, 1807093008537778ULL, 1540899012923865ULL, 2075080271659867ULL, 1527990806921523ULL, 1323728742908002ULL, 1568595959608205ULL, 1388032187497212ULL, 2026968840050568ULL, 1396591153295755ULL, 820416950170901ULL, 520060313205582ULL, 2016404325094901ULL, 1584709677868520ULL, 272161374469956ULL, 1567188603996816ULL, 1986160530078221ULL, 553930264324589ULL, 1058426729027503ULL, 8762762886675ULL, 2216098143382988ULL, 1835145266889223ULL, 1712936431558441ULL, 1017009937844974ULL, 585361667812740ULL, 2114711541628181ULL, 2238729632971439ULL, 121257546253072ULL, 847154149018345ULL, 211972965476684ULL, 287499084460129ULL, 2098247259180197ULL, 839070411583329ULL, 339551619574372ULL, 1432951287640743ULL, 526481249498942ULL, 931991661905195ULL, 1884279965674487ULL, 200486405604411ULL, 364173020594788ULL, 518034455936955ULL, 1085564703965501ULL, 16030410467927ULL, 604865933167613ULL, 1695298441093964ULL, 498856548116159ULL, 2193030062787034ULL, 1706339802964179ULL, 1721199073493888ULL, 820740951039755ULL, 1216053436896834ULL, 23954895815139ULL, 1662515208920491ULL, 1705443427511899ULL, 1957928899570365ULL, 1189636258255725ULL, 1795695471103809ULL, 1691191297654118ULL, 282402585374360ULL, 460405330264832ULL, 63765529445733ULL, 469763447404473ULL, 733607089694996ULL, 685410420186959ULL, 1096682630419738ULL, 1162548510542362ULL, 1020949526456676ULL, 1211660396870573ULL, 613126398222696ULL, 1117829165843251ULL, 742432540886650ULL, 1483755088010658ULL, 942392007134474ULL, 1447834130944107ULL, 489368274863410ULL, 23192985544898ULL, 648442406146160ULL, 785438843373876ULL, 249464684645238ULL, 170494608205618ULL, 335112827260550ULL, 1462050123162735ULL, 1084803668439016ULL, 853459233600325ULL, 215777728187495ULL, 1965759433526974ULL, 1349482894446537ULL, 694163317612871ULL, 860536766165036ULL, 1178788094084321ULL, 1652739626626996ULL, 2115723946388185ULL, 1577204379094664ULL, 1083882859023240ULL, 1768759143381635ULL, 1737180992507258ULL, 246054513922239ULL, 577253134087234ULL, 356340280578042ULL, 1638917769925142ULL, 223550348130103ULL, 470592666638765ULL, 22663573966996ULL, 596552461152400ULL, 364143537069499ULL, 3942119457699ULL, 107951982889287ULL, 1843471406713209ULL, 1625773041610986ULL, 1466141092501702ULL, 1043024095021271ULL, 310429964047508ULL, 98559121500372ULL, 152746933782868ULL, 259407205078261ULL, 828123093322585ULL, 1576847274280091ULL, 1170871375757302ULL, 1588856194642775ULL, 984767822341977ULL, 1141497997993760ULL, 809325345150796ULL, 1879837728202511ULL, 201340910657893ULL, 1079157558888483ULL, 1052373448588065ULL, 1732036202501778ULL, 2105292670328445ULL, 679751387312402ULL, 1679682144926229ULL, 1695823455818780ULL, 498852317075849ULL, 1786555067788433ULL, 1670727545779425ULL, 117945875433544ULL, 407939139781844ULL, 854632120023778ULL, 1413383148360437ULL, 286030901733673ULL, 1207361858071196ULL, 461340408181417ULL, 1096919590360164ULL, 1837594897475685ULL, 533755561544165ULL, 1638688042247712ULL, 1431653684793005ULL, 1036458538873559ULL, 390822120341779ULL, 1920929837111618ULL, 543426740024168ULL, 645751357799929ULL, 2245025632994463ULL, 1550778638076452ULL, 223738153459949ULL, 1337209385492033ULL, 1276967236456531ULL, 1463815821063071ULL, 2070620870191473ULL, 1199170709413753ULL, 273230877394166ULL, 1873264887608046ULL, 890877152910775ULL, 983226445635730ULL, 44873798519521ULL, 697147127512130ULL, 961631038239304ULL, 709966160696826ULL, 1706677689540366ULL, 502782733796035ULL, 812545535346033ULL, 1693622521296452ULL, 1955813093002510ULL, 1259937612881362ULL, 1873032503803559ULL, 1140330566016428ULL, 1675726082440190ULL, 60029928909786ULL, 170335608866763ULL, 766444312315022ULL, 2025049511434113ULL, 2200845622430647ULL, 1201269851450408ULL, 590071752404907ULL, 1400995030286946ULL, 2152637413853822ULL, 2108495473841983ULL, 3855406710349ULL, 1726137673168580ULL, 51004317200100ULL, 1749082328586939ULL, 1704088976144558ULL, 1977318954775118ULL, 2062602253162400ULL, 948062503217479ULL, 361953965048030ULL, 1528264887238440ULL, 62582552172290ULL, 2241602163389280ULL, 156385388121765ULL, 2124100319761492ULL, 388928050571382ULL, 1556123596922727ULL, 979310669812384ULL, 113043855206104ULL, 2023223924825469ULL, 643651703263034ULL, 2234446903655540ULL, 1577241261424997ULL, 860253174523845ULL, 1691026473082448ULL, 1091672764933872ULL, 1957463109756365ULL, 530699502660193ULL, 349587141723569ULL, 674661681919563ULL, 1633727303856240ULL, 708909037922144ULL, 2160722508518119ULL, 1302188051602540ULL, 976114603845777ULL, 120004758721939ULL, 1681630708873780ULL, 622274095069244ULL, 1822346309016698ULL, 1100921177951904ULL, 2216952659181677ULL, 1844020550362490ULL, 1976451368365774ULL, 1321101422068822ULL, 1189859436282668ULL, 2008801879735257ULL, 2219413454333565ULL, 424288774231098ULL, 359793146977912ULL, 270293357948703ULL, 587226003677000ULL, 1482071926139945ULL, 1419630774650359ULL, 1104739070570175ULL, 1662129023224130ULL, 1609203612533411ULL, 1250932720691980ULL, 95215711818495ULL, 498746909028150ULL, 158151296991874ULL, 1201379988527734ULL, 561599945143989ULL, 2211577425617888ULL, 2166577612206324ULL, 1057590354233512ULL, 1968123280416769ULL, 1316586165401313ULL, 762728164447634ULL, 2045395244316047ULL, 1531796898725716ULL, 315385971670425ULL, 1109421039396756ULL, 2183635256408562ULL, 1896751252659461ULL, 840236037179080ULL, 796245792277211ULL, 508345890111193ULL, 1275386465287222ULL, 513560822858784ULL, 1784735733120313ULL, 1346467478899695ULL, 601125231208417ULL, 701076661112726ULL, 1841998436455089ULL, 1156768600940434ULL, 1967853462343221ULL, 2178318463061452ULL, 481885520752741ULL, 675262828640945ULL, 1033539418596582ULL, 1743329872635846ULL, 159322641251283ULL, 1573076470127113ULL, 954827619308195ULL, 778834750662635ULL, 619912782122617ULL, 515681498488209ULL, 1675866144246843ULL, 811716020969981ULL, 1125515272217398ULL, 1398917918287342ULL, 1301680949183175ULL, 726474739583734ULL, 587246193475200ULL, 1096581582611864ULL, 1469911826213486ULL, 1990099711206364ULL, 1256496099816508ULL, 2019924615195672ULL, 1251232456707555ULL, 2042971196009755ULL, 214061878479265ULL, 115385726395472ULL, 1677875239524132ULL, 756888883383540ULL, 1153862117756233ULL, 503391530851096ULL, 946070017477513ULL, 1878319040542579ULL, 1101349418586920ULL, 793245696431613ULL, 397920495357645ULL, 2174023872951112ULL, 1517867915189593ULL, 1829855041462995ULL, 1046709983503619ULL, 424081940711857ULL, 2112438073094647ULL, 1504338467349861ULL, 2244574127374532ULL, 2136937537441911ULL, 1741150838990304ULL, 25894628400571ULL, 512213526781178ULL, 1168384260796379ULL, 1424607682379833ULL, 938677789731564ULL, 872882241891896ULL, 1713199397007700ULL, 1410496326218359ULL, 854379752407031ULL, 465141611727634ULL, 315176937037857ULL, 1020115054571233ULL, 1856290111077229ULL, 2028366269898204ULL, 1432980880307543ULL, 469932710425448ULL, 581165267592247ULL, 496399148156603ULL, 2063435226705903ULL, 2116841086237705ULL, 498272567217048ULL, 1829438076967906ULL, 1573925801278491ULL, 460763576329867ULL, 1705264723728225ULL, 999514866082412ULL, 29635061779362ULL, 1884233592281020ULL, 1449755591461338ULL, 42579292783222ULL, 1869504355369200ULL, 495506004805251ULL, 264073104888427ULL, 2088880861028612ULL, 104646456386576ULL, 1258445191399967ULL, 1348736801545799ULL, 2068276361286613ULL, 884897216646374ULL, 922387476801376ULL, 1043886580402805ULL, 1240883498470831ULL, 1601554651937110ULL, 804382935289482ULL, 512379564477239ULL, 1466384519077032ULL, 1280698500238386ULL, 211303836685749ULL, 2081725624793803ULL, 545247644516879ULL, 215313359330384ULL, 286479751145614ULL, 2213650281751636ULL, 2164927945999874ULL, 2072162991540882ULL, 1443769115444779ULL, 1581473274363095ULL, 434633875922699ULL, 340456055781599ULL, 373043091080189ULL, 839476566531776ULL, 1856706858509978ULL, 931616224909153ULL, 1888181317414065ULL, 213654322650262ULL, 1161078103416244ULL, 1822042328851513ULL, 915817709028812ULL, 1828297056698188ULL, 1212017130909403ULL, 60258343247333ULL, 342085800008230ULL, 930240559508270ULL, 1549884999174952ULL, 809895264249462ULL, 184726257947682ULL, 1157065433504828ULL, 1209999630381477ULL, 999920399374391ULL, 1714770150788163ULL, 2026130985413228ULL, 506776632883140ULL, 1349042668246528ULL, 1937232292976967ULL, 942302637530730ULL, 160211904766226ULL, 1042724500438571ULL, 212454865139142ULL, 244104425172642ULL, 1376990622387496ULL, 76126752421227ULL, 1027540886376422ULL, 1912210655133026ULL, 13410411589575ULL, 1475856708587773ULL, 615563352691682ULL, 1446629324872644ULL, 1683670301784014ULL, 1049873327197127ULL, 1826401704084838ULL, 2032577048760775ULL, 1922203607878853ULL, 836708788764806ULL, 2193084654695012ULL, 1342923183256659ULL, 849356986294271ULL, 1228863973965618ULL, 94886161081867ULL, 1423288430204892ULL, 2016167528707016ULL, 1633187660972877ULL, 1550621242301752ULL, 340630244512994ULL, 2103577710806901ULL, 221625016538931ULL, 421544147350960ULL, 580428704555156ULL, 1479831381265617ULL, 518057926544698ULL, 955027348790630ULL, 1326749172561598ULL, 1118304625755967ULL, 1994005916095176ULL, 1799757332780663ULL, 751343129396941ULL, 1468672898746144ULL, 1451689964451386ULL, 755070293921171ULL, 904857405877052ULL, 1276087530766984ULL, 403986562858511ULL, 1530661255035337ULL, 1644972908910502ULL, 1370170080438957ULL, 139839536695744ULL, 909930462436512ULL, 1899999215356933ULL, 635992381064566ULL, 788740975837654ULL, 224241231493695ULL, 1267090030199302ULL, 998908061660139ULL, 1784537499699278ULL, 859195370018706ULL, 1953966091439379ULL, 2189271820076010ULL, 2039067059943978ULL, 1526694380855202ULL, 2040321513194941ULL, 329922071218689ULL, 1953032256401326ULL, 989631424403521ULL, 328825014934242ULL, 9407151397696ULL, 63551373671268ULL, 1624728632895792ULL, 1608324920739262ULL, 1178239350351945ULL, 1198077399579702ULL, 277620088676229ULL, 1775359437312528ULL, 1653558177737477ULL, 1652066043408850ULL, 1063359889686622ULL, 1975063804860653ULL }; #if defined(__cplusplus) } #endif #define __internal_Hacl_Ed25519_PrecompTable_H_DEFINED #endif /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ #ifndef __internal_Hacl_Ed25519_H #define __internal_Hacl_Ed25519_H #if defined(__cplusplus) extern "C" { #endif #include void Hacl_Bignum25519_reduce_513(uint64_t *a); void Hacl_Bignum25519_inverse(uint64_t *out, uint64_t *a); void Hacl_Bignum25519_load_51(uint64_t *output, uint8_t *input); void Hacl_Bignum25519_store_51(uint8_t *output, uint64_t *input); void Hacl_Impl_Ed25519_PointDouble_point_double(uint64_t *out, uint64_t *p); void Hacl_Impl_Ed25519_PointAdd_point_add(uint64_t *out, uint64_t *p, uint64_t *q); void Hacl_Impl_Ed25519_PointConstants_make_point_inf(uint64_t *b); bool Hacl_Impl_Ed25519_PointDecompress_point_decompress(uint64_t *out, uint8_t *s); void Hacl_Impl_Ed25519_PointCompress_point_compress(uint8_t *z, uint64_t *p); bool Hacl_Impl_Ed25519_PointEqual_point_equal(uint64_t *p, uint64_t *q); void Hacl_Impl_Ed25519_PointNegate_point_negate(uint64_t *p, uint64_t *out); void Hacl_Impl_Ed25519_Ladder_point_mul(uint64_t *out, uint8_t *scalar, uint64_t *q); #if defined(__cplusplus) } #endif #define __internal_Hacl_Ed25519_H_DEFINED #endif /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ static const uint8_t g25519[32U] = { 9U }; static void point_add_and_double(uint64_t *q, uint64_t *p01_tmp1, FStar_UInt128_uint128 *tmp2) { uint64_t *nq = p01_tmp1; uint64_t *nq_p1 = p01_tmp1 + 10U; uint64_t *tmp1 = p01_tmp1 + 20U; uint64_t *x1 = q; uint64_t *x2 = nq; uint64_t *z2 = nq + 5U; uint64_t *z3 = nq_p1 + 5U; uint64_t *a = tmp1; uint64_t *b = tmp1 + 5U; uint64_t *ab = tmp1; uint64_t *dc = tmp1 + 10U; Hacl_Impl_Curve25519_Field51_fadd(a, x2, z2); Hacl_Impl_Curve25519_Field51_fsub(b, x2, z2); uint64_t *x3 = nq_p1; uint64_t *z31 = nq_p1 + 5U; uint64_t *d0 = dc; uint64_t *c0 = dc + 5U; Hacl_Impl_Curve25519_Field51_fadd(c0, x3, z31); Hacl_Impl_Curve25519_Field51_fsub(d0, x3, z31); Hacl_Impl_Curve25519_Field51_fmul2(dc, dc, ab, tmp2); Hacl_Impl_Curve25519_Field51_fadd(x3, d0, c0); Hacl_Impl_Curve25519_Field51_fsub(z31, d0, c0); uint64_t *a1 = tmp1; uint64_t *b1 = tmp1 + 5U; uint64_t *d = tmp1 + 10U; uint64_t *c = tmp1 + 15U; uint64_t *ab1 = tmp1; uint64_t *dc1 = tmp1 + 10U; Hacl_Impl_Curve25519_Field51_fsqr2(dc1, ab1, tmp2); Hacl_Impl_Curve25519_Field51_fsqr2(nq_p1, nq_p1, tmp2); a1[0U] = c[0U]; a1[1U] = c[1U]; a1[2U] = c[2U]; a1[3U] = c[3U]; a1[4U] = c[4U]; Hacl_Impl_Curve25519_Field51_fsub(c, d, c); Hacl_Impl_Curve25519_Field51_fmul1(b1, c, 121665ULL); Hacl_Impl_Curve25519_Field51_fadd(b1, b1, d); Hacl_Impl_Curve25519_Field51_fmul2(nq, dc1, ab1, tmp2); Hacl_Impl_Curve25519_Field51_fmul(z3, z3, x1, tmp2); } static void point_double(uint64_t *nq, uint64_t *tmp1, FStar_UInt128_uint128 *tmp2) { uint64_t *x2 = nq; uint64_t *z2 = nq + 5U; uint64_t *a = tmp1; uint64_t *b = tmp1 + 5U; uint64_t *d = tmp1 + 10U; uint64_t *c = tmp1 + 15U; uint64_t *ab = tmp1; uint64_t *dc = tmp1 + 10U; Hacl_Impl_Curve25519_Field51_fadd(a, x2, z2); Hacl_Impl_Curve25519_Field51_fsub(b, x2, z2); Hacl_Impl_Curve25519_Field51_fsqr2(dc, ab, tmp2); a[0U] = c[0U]; a[1U] = c[1U]; a[2U] = c[2U]; a[3U] = c[3U]; a[4U] = c[4U]; Hacl_Impl_Curve25519_Field51_fsub(c, d, c); Hacl_Impl_Curve25519_Field51_fmul1(b, c, 121665ULL); Hacl_Impl_Curve25519_Field51_fadd(b, b, d); Hacl_Impl_Curve25519_Field51_fmul2(nq, dc, ab, tmp2); } static void montgomery_ladder(uint64_t *out, uint8_t *key, uint64_t *init) { FStar_UInt128_uint128 tmp2[10U]; for (uint32_t _i = 0U; _i < 10U; ++_i) tmp2[_i] = FStar_UInt128_uint64_to_uint128(0ULL); uint64_t p01_tmp1_swap[41U] = { 0U }; uint64_t *p0 = p01_tmp1_swap; uint64_t *p01 = p01_tmp1_swap; uint64_t *p03 = p01; uint64_t *p11 = p01 + 10U; memcpy(p11, init, 10U * sizeof (uint64_t)); uint64_t *x0 = p03; uint64_t *z0 = p03 + 5U; x0[0U] = 1ULL; x0[1U] = 0ULL; x0[2U] = 0ULL; x0[3U] = 0ULL; x0[4U] = 0ULL; z0[0U] = 0ULL; z0[1U] = 0ULL; z0[2U] = 0ULL; z0[3U] = 0ULL; z0[4U] = 0ULL; uint64_t *p01_tmp1 = p01_tmp1_swap; uint64_t *p01_tmp11 = p01_tmp1_swap; uint64_t *nq1 = p01_tmp1_swap; uint64_t *nq_p11 = p01_tmp1_swap + 10U; uint64_t *swap = p01_tmp1_swap + 40U; Hacl_Impl_Curve25519_Field51_cswap2(1ULL, nq1, nq_p11); point_add_and_double(init, p01_tmp11, tmp2); swap[0U] = 1ULL; for (uint32_t i = 0U; i < 251U; i++) { uint64_t *p01_tmp12 = p01_tmp1_swap; uint64_t *swap1 = p01_tmp1_swap + 40U; uint64_t *nq2 = p01_tmp12; uint64_t *nq_p12 = p01_tmp12 + 10U; uint64_t bit = (uint64_t)((uint32_t)key[(253U - i) / 8U] >> (253U - i) % 8U & 1U); uint64_t sw = swap1[0U] ^ bit; Hacl_Impl_Curve25519_Field51_cswap2(sw, nq2, nq_p12); point_add_and_double(init, p01_tmp12, tmp2); swap1[0U] = bit; } uint64_t sw = swap[0U]; Hacl_Impl_Curve25519_Field51_cswap2(sw, nq1, nq_p11); uint64_t *nq10 = p01_tmp1; uint64_t *tmp1 = p01_tmp1 + 20U; point_double(nq10, tmp1, tmp2); point_double(nq10, tmp1, tmp2); point_double(nq10, tmp1, tmp2); memcpy(out, p0, 10U * sizeof (uint64_t)); } void Hacl_Curve25519_51_fsquare_times( uint64_t *o, uint64_t *inp, FStar_UInt128_uint128 *tmp, uint32_t n ) { Hacl_Impl_Curve25519_Field51_fsqr(o, inp, tmp); for (uint32_t i = 0U; i < n - 1U; i++) { Hacl_Impl_Curve25519_Field51_fsqr(o, o, tmp); } } void Hacl_Curve25519_51_finv(uint64_t *o, uint64_t *i, FStar_UInt128_uint128 *tmp) { uint64_t t1[20U] = { 0U }; uint64_t *a1 = t1; uint64_t *b1 = t1 + 5U; uint64_t *t010 = t1 + 15U; FStar_UInt128_uint128 *tmp10 = tmp; Hacl_Curve25519_51_fsquare_times(a1, i, tmp10, 1U); Hacl_Curve25519_51_fsquare_times(t010, a1, tmp10, 2U); Hacl_Impl_Curve25519_Field51_fmul(b1, t010, i, tmp); Hacl_Impl_Curve25519_Field51_fmul(a1, b1, a1, tmp); Hacl_Curve25519_51_fsquare_times(t010, a1, tmp10, 1U); Hacl_Impl_Curve25519_Field51_fmul(b1, t010, b1, tmp); Hacl_Curve25519_51_fsquare_times(t010, b1, tmp10, 5U); Hacl_Impl_Curve25519_Field51_fmul(b1, t010, b1, tmp); uint64_t *b10 = t1 + 5U; uint64_t *c10 = t1 + 10U; uint64_t *t011 = t1 + 15U; FStar_UInt128_uint128 *tmp11 = tmp; Hacl_Curve25519_51_fsquare_times(t011, b10, tmp11, 10U); Hacl_Impl_Curve25519_Field51_fmul(c10, t011, b10, tmp); Hacl_Curve25519_51_fsquare_times(t011, c10, tmp11, 20U); Hacl_Impl_Curve25519_Field51_fmul(t011, t011, c10, tmp); Hacl_Curve25519_51_fsquare_times(t011, t011, tmp11, 10U); Hacl_Impl_Curve25519_Field51_fmul(b10, t011, b10, tmp); Hacl_Curve25519_51_fsquare_times(t011, b10, tmp11, 50U); Hacl_Impl_Curve25519_Field51_fmul(c10, t011, b10, tmp); uint64_t *b11 = t1 + 5U; uint64_t *c1 = t1 + 10U; uint64_t *t01 = t1 + 15U; FStar_UInt128_uint128 *tmp1 = tmp; Hacl_Curve25519_51_fsquare_times(t01, c1, tmp1, 100U); Hacl_Impl_Curve25519_Field51_fmul(t01, t01, c1, tmp); Hacl_Curve25519_51_fsquare_times(t01, t01, tmp1, 50U); Hacl_Impl_Curve25519_Field51_fmul(t01, t01, b11, tmp); Hacl_Curve25519_51_fsquare_times(t01, t01, tmp1, 5U); uint64_t *a = t1; uint64_t *t0 = t1 + 15U; Hacl_Impl_Curve25519_Field51_fmul(o, t0, a, tmp); } static void encode_point(uint8_t *o, uint64_t *i) { uint64_t *x = i; uint64_t *z = i + 5U; uint64_t tmp[5U] = { 0U }; uint64_t u64s[4U] = { 0U }; FStar_UInt128_uint128 tmp_w[10U]; for (uint32_t _i = 0U; _i < 10U; ++_i) tmp_w[_i] = FStar_UInt128_uint64_to_uint128(0ULL); Hacl_Curve25519_51_finv(tmp, z, tmp_w); Hacl_Impl_Curve25519_Field51_fmul(tmp, tmp, x, tmp_w); Hacl_Impl_Curve25519_Field51_store_felem(u64s, tmp); KRML_MAYBE_FOR4(i0, 0U, 4U, 1U, store64_le(o + i0 * 8U, u64s[i0]);); } /** Compute the scalar multiple of a point. @param out Pointer to 32 bytes of memory, allocated by the caller, where the resulting point is written to. @param priv Pointer to 32 bytes of memory where the secret/private key is read from. @param pub Pointer to 32 bytes of memory where the public point is read from. */ void Hacl_Curve25519_51_scalarmult(uint8_t *out, uint8_t *priv, uint8_t *pub) { uint64_t init[10U] = { 0U }; uint64_t tmp[4U] = { 0U }; KRML_MAYBE_FOR4(i, 0U, 4U, 1U, uint64_t *os = tmp; uint8_t *bj = pub + i * 8U; uint64_t u = load64_le(bj); uint64_t r = u; uint64_t x = r; os[i] = x;); uint64_t tmp3 = tmp[3U]; tmp[3U] = tmp3 & 0x7fffffffffffffffULL; uint64_t *x = init; uint64_t *z = init + 5U; z[0U] = 1ULL; z[1U] = 0ULL; z[2U] = 0ULL; z[3U] = 0ULL; z[4U] = 0ULL; uint64_t f0l = tmp[0U] & 0x7ffffffffffffULL; uint64_t f0h = tmp[0U] >> 51U; uint64_t f1l = (tmp[1U] & 0x3fffffffffULL) << 13U; uint64_t f1h = tmp[1U] >> 38U; uint64_t f2l = (tmp[2U] & 0x1ffffffULL) << 26U; uint64_t f2h = tmp[2U] >> 25U; uint64_t f3l = (tmp[3U] & 0xfffULL) << 39U; uint64_t f3h = tmp[3U] >> 12U; x[0U] = f0l; x[1U] = f0h | f1l; x[2U] = f1h | f2l; x[3U] = f2h | f3l; x[4U] = f3h; montgomery_ladder(init, priv, init); encode_point(out, init); } /** Calculate a public point from a secret/private key. This computes a scalar multiplication of the secret/private key with the curve's basepoint. @param pub Pointer to 32 bytes of memory, allocated by the caller, where the resulting point is written to. @param priv Pointer to 32 bytes of memory where the secret/private key is read from. */ void Hacl_Curve25519_51_secret_to_public(uint8_t *pub, uint8_t *priv) { uint8_t basepoint[32U] = { 0U }; for (uint32_t i = 0U; i < 32U; i++) { uint8_t *os = basepoint; uint8_t x = g25519[i]; os[i] = x; } Hacl_Curve25519_51_scalarmult(pub, priv, basepoint); } /** Execute the diffie-hellmann key exchange. @param out Pointer to 32 bytes of memory, allocated by the caller, where the resulting point is written to. @param priv Pointer to 32 bytes of memory where **our** secret/private key is read from. @param pub Pointer to 32 bytes of memory where **their** public point is read from. */ bool Hacl_Curve25519_51_ecdh(uint8_t *out, uint8_t *priv, uint8_t *pub) { uint8_t zeros[32U] = { 0U }; Hacl_Curve25519_51_scalarmult(out, priv, pub); uint8_t res = 255U; for (uint32_t i = 0U; i < 32U; i++) { uint8_t uu____0 = FStar_UInt8_eq_mask(out[i], zeros[i]); res = (uint32_t)uu____0 & (uint32_t)res; } uint8_t z = res; bool r = z == 255U; return !r; } /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ void Hacl_Hash_SHA2_sha256_init(uint32_t *hash) { KRML_MAYBE_FOR8(i, 0U, 8U, 1U, uint32_t *os = hash; uint32_t x = Hacl_Hash_SHA2_h256[i]; os[i] = x;); } static inline void sha256_update(uint8_t *b, uint32_t *hash) { uint32_t hash_old[8U] = { 0U }; uint32_t ws[16U] = { 0U }; memcpy(hash_old, hash, 8U * sizeof (uint32_t)); uint8_t *b10 = b; uint32_t u = load32_be(b10); ws[0U] = u; uint32_t u0 = load32_be(b10 + 4U); ws[1U] = u0; uint32_t u1 = load32_be(b10 + 8U); ws[2U] = u1; uint32_t u2 = load32_be(b10 + 12U); ws[3U] = u2; uint32_t u3 = load32_be(b10 + 16U); ws[4U] = u3; uint32_t u4 = load32_be(b10 + 20U); ws[5U] = u4; uint32_t u5 = load32_be(b10 + 24U); ws[6U] = u5; uint32_t u6 = load32_be(b10 + 28U); ws[7U] = u6; uint32_t u7 = load32_be(b10 + 32U); ws[8U] = u7; uint32_t u8 = load32_be(b10 + 36U); ws[9U] = u8; uint32_t u9 = load32_be(b10 + 40U); ws[10U] = u9; uint32_t u10 = load32_be(b10 + 44U); ws[11U] = u10; uint32_t u11 = load32_be(b10 + 48U); ws[12U] = u11; uint32_t u12 = load32_be(b10 + 52U); ws[13U] = u12; uint32_t u13 = load32_be(b10 + 56U); ws[14U] = u13; uint32_t u14 = load32_be(b10 + 60U); ws[15U] = u14; KRML_MAYBE_FOR4(i0, 0U, 4U, 1U, KRML_MAYBE_FOR16(i, 0U, 16U, 1U, uint32_t k_t = Hacl_Hash_SHA2_k224_256[16U * i0 + i]; uint32_t ws_t = ws[i]; uint32_t a0 = hash[0U]; uint32_t b0 = hash[1U]; uint32_t c0 = hash[2U]; uint32_t d0 = hash[3U]; uint32_t e0 = hash[4U]; uint32_t f0 = hash[5U]; uint32_t g0 = hash[6U]; uint32_t h02 = hash[7U]; uint32_t k_e_t = k_t; uint32_t t1 = h02 + ((e0 << 26U | e0 >> 6U) ^ ((e0 << 21U | e0 >> 11U) ^ (e0 << 7U | e0 >> 25U))) + ((e0 & f0) ^ (~e0 & g0)) + k_e_t + ws_t; uint32_t t2 = ((a0 << 30U | a0 >> 2U) ^ ((a0 << 19U | a0 >> 13U) ^ (a0 << 10U | a0 >> 22U))) + ((a0 & b0) ^ ((a0 & c0) ^ (b0 & c0))); uint32_t a1 = t1 + t2; uint32_t b1 = a0; uint32_t c1 = b0; uint32_t d1 = c0; uint32_t e1 = d0 + t1; uint32_t f1 = e0; uint32_t g1 = f0; uint32_t h12 = g0; hash[0U] = a1; hash[1U] = b1; hash[2U] = c1; hash[3U] = d1; hash[4U] = e1; hash[5U] = f1; hash[6U] = g1; hash[7U] = h12;); if (i0 < 3U) { KRML_MAYBE_FOR16(i, 0U, 16U, 1U, uint32_t t16 = ws[i]; uint32_t t15 = ws[(i + 1U) % 16U]; uint32_t t7 = ws[(i + 9U) % 16U]; uint32_t t2 = ws[(i + 14U) % 16U]; uint32_t s1 = (t2 << 15U | t2 >> 17U) ^ ((t2 << 13U | t2 >> 19U) ^ t2 >> 10U); uint32_t s0 = (t15 << 25U | t15 >> 7U) ^ ((t15 << 14U | t15 >> 18U) ^ t15 >> 3U); ws[i] = s1 + t7 + s0 + t16;); }); KRML_MAYBE_FOR8(i, 0U, 8U, 1U, uint32_t *os = hash; uint32_t x = hash[i] + hash_old[i]; os[i] = x;); } void Hacl_Hash_SHA2_sha256_update_nblocks(uint32_t len, uint8_t *b, uint32_t *st) { uint32_t blocks = len / 64U; for (uint32_t i = 0U; i < blocks; i++) { uint8_t *b0 = b; uint8_t *mb = b0 + i * 64U; sha256_update(mb, st); } } void Hacl_Hash_SHA2_sha256_update_last(uint64_t totlen, uint32_t len, uint8_t *b, uint32_t *hash) { uint32_t blocks; if (len + 8U + 1U <= 64U) { blocks = 1U; } else { blocks = 2U; } uint32_t fin = blocks * 64U; uint8_t last[128U] = { 0U }; uint8_t totlen_buf[8U] = { 0U }; uint64_t total_len_bits = totlen << 3U; store64_be(totlen_buf, total_len_bits); uint8_t *b0 = b; memcpy(last, b0, len * sizeof (uint8_t)); last[len] = 0x80U; memcpy(last + fin - 8U, totlen_buf, 8U * sizeof (uint8_t)); uint8_t *last00 = last; uint8_t *last10 = last + 64U; uint8_t *l0 = last00; uint8_t *l1 = last10; uint8_t *lb0 = l0; uint8_t *lb1 = l1; uint8_t *last0 = lb0; uint8_t *last1 = lb1; sha256_update(last0, hash); if (blocks > 1U) { sha256_update(last1, hash); return; } } void Hacl_Hash_SHA2_sha256_finish(uint32_t *st, uint8_t *h) { uint8_t hbuf[32U] = { 0U }; KRML_MAYBE_FOR8(i, 0U, 8U, 1U, store32_be(hbuf + i * 4U, st[i]);); memcpy(h, hbuf, 32U * sizeof (uint8_t)); } void Hacl_Hash_SHA2_sha224_init(uint32_t *hash) { KRML_MAYBE_FOR8(i, 0U, 8U, 1U, uint32_t *os = hash; uint32_t x = Hacl_Hash_SHA2_h224[i]; os[i] = x;); } void Hacl_Hash_SHA2_sha224_update_nblocks(uint32_t len, uint8_t *b, uint32_t *st) { Hacl_Hash_SHA2_sha256_update_nblocks(len, b, st); } void Hacl_Hash_SHA2_sha224_update_last(uint64_t totlen, uint32_t len, uint8_t *b, uint32_t *st) { Hacl_Hash_SHA2_sha256_update_last(totlen, len, b, st); } void Hacl_Hash_SHA2_sha224_finish(uint32_t *st, uint8_t *h) { uint8_t hbuf[32U] = { 0U }; KRML_MAYBE_FOR8(i, 0U, 8U, 1U, store32_be(hbuf + i * 4U, st[i]);); memcpy(h, hbuf, 28U * sizeof (uint8_t)); } void Hacl_Hash_SHA2_sha512_init(uint64_t *hash) { KRML_MAYBE_FOR8(i, 0U, 8U, 1U, uint64_t *os = hash; uint64_t x = Hacl_Hash_SHA2_h512[i]; os[i] = x;); } static inline void sha512_update(uint8_t *b, uint64_t *hash) { uint64_t hash_old[8U] = { 0U }; uint64_t ws[16U] = { 0U }; memcpy(hash_old, hash, 8U * sizeof (uint64_t)); uint8_t *b10 = b; uint64_t u = load64_be(b10); ws[0U] = u; uint64_t u0 = load64_be(b10 + 8U); ws[1U] = u0; uint64_t u1 = load64_be(b10 + 16U); ws[2U] = u1; uint64_t u2 = load64_be(b10 + 24U); ws[3U] = u2; uint64_t u3 = load64_be(b10 + 32U); ws[4U] = u3; uint64_t u4 = load64_be(b10 + 40U); ws[5U] = u4; uint64_t u5 = load64_be(b10 + 48U); ws[6U] = u5; uint64_t u6 = load64_be(b10 + 56U); ws[7U] = u6; uint64_t u7 = load64_be(b10 + 64U); ws[8U] = u7; uint64_t u8 = load64_be(b10 + 72U); ws[9U] = u8; uint64_t u9 = load64_be(b10 + 80U); ws[10U] = u9; uint64_t u10 = load64_be(b10 + 88U); ws[11U] = u10; uint64_t u11 = load64_be(b10 + 96U); ws[12U] = u11; uint64_t u12 = load64_be(b10 + 104U); ws[13U] = u12; uint64_t u13 = load64_be(b10 + 112U); ws[14U] = u13; uint64_t u14 = load64_be(b10 + 120U); ws[15U] = u14; KRML_MAYBE_FOR5(i0, 0U, 5U, 1U, KRML_MAYBE_FOR16(i, 0U, 16U, 1U, uint64_t k_t = Hacl_Hash_SHA2_k384_512[16U * i0 + i]; uint64_t ws_t = ws[i]; uint64_t a0 = hash[0U]; uint64_t b0 = hash[1U]; uint64_t c0 = hash[2U]; uint64_t d0 = hash[3U]; uint64_t e0 = hash[4U]; uint64_t f0 = hash[5U]; uint64_t g0 = hash[6U]; uint64_t h02 = hash[7U]; uint64_t k_e_t = k_t; uint64_t t1 = h02 + ((e0 << 50U | e0 >> 14U) ^ ((e0 << 46U | e0 >> 18U) ^ (e0 << 23U | e0 >> 41U))) + ((e0 & f0) ^ (~e0 & g0)) + k_e_t + ws_t; uint64_t t2 = ((a0 << 36U | a0 >> 28U) ^ ((a0 << 30U | a0 >> 34U) ^ (a0 << 25U | a0 >> 39U))) + ((a0 & b0) ^ ((a0 & c0) ^ (b0 & c0))); uint64_t a1 = t1 + t2; uint64_t b1 = a0; uint64_t c1 = b0; uint64_t d1 = c0; uint64_t e1 = d0 + t1; uint64_t f1 = e0; uint64_t g1 = f0; uint64_t h12 = g0; hash[0U] = a1; hash[1U] = b1; hash[2U] = c1; hash[3U] = d1; hash[4U] = e1; hash[5U] = f1; hash[6U] = g1; hash[7U] = h12;); if (i0 < 4U) { KRML_MAYBE_FOR16(i, 0U, 16U, 1U, uint64_t t16 = ws[i]; uint64_t t15 = ws[(i + 1U) % 16U]; uint64_t t7 = ws[(i + 9U) % 16U]; uint64_t t2 = ws[(i + 14U) % 16U]; uint64_t s1 = (t2 << 45U | t2 >> 19U) ^ ((t2 << 3U | t2 >> 61U) ^ t2 >> 6U); uint64_t s0 = (t15 << 63U | t15 >> 1U) ^ ((t15 << 56U | t15 >> 8U) ^ t15 >> 7U); ws[i] = s1 + t7 + s0 + t16;); }); KRML_MAYBE_FOR8(i, 0U, 8U, 1U, uint64_t *os = hash; uint64_t x = hash[i] + hash_old[i]; os[i] = x;); } void Hacl_Hash_SHA2_sha512_update_nblocks(uint32_t len, uint8_t *b, uint64_t *st) { uint32_t blocks = len / 128U; for (uint32_t i = 0U; i < blocks; i++) { uint8_t *b0 = b; uint8_t *mb = b0 + i * 128U; sha512_update(mb, st); } } void Hacl_Hash_SHA2_sha512_update_last( FStar_UInt128_uint128 totlen, uint32_t len, uint8_t *b, uint64_t *hash ) { uint32_t blocks; if (len + 16U + 1U <= 128U) { blocks = 1U; } else { blocks = 2U; } uint32_t fin = blocks * 128U; uint8_t last[256U] = { 0U }; uint8_t totlen_buf[16U] = { 0U }; FStar_UInt128_uint128 total_len_bits = FStar_UInt128_shift_left(totlen, 3U); store128_be(totlen_buf, total_len_bits); uint8_t *b0 = b; memcpy(last, b0, len * sizeof (uint8_t)); last[len] = 0x80U; memcpy(last + fin - 16U, totlen_buf, 16U * sizeof (uint8_t)); uint8_t *last00 = last; uint8_t *last10 = last + 128U; uint8_t *l0 = last00; uint8_t *l1 = last10; uint8_t *lb0 = l0; uint8_t *lb1 = l1; uint8_t *last0 = lb0; uint8_t *last1 = lb1; sha512_update(last0, hash); if (blocks > 1U) { sha512_update(last1, hash); return; } } void Hacl_Hash_SHA2_sha512_finish(uint64_t *st, uint8_t *h) { uint8_t hbuf[64U] = { 0U }; KRML_MAYBE_FOR8(i, 0U, 8U, 1U, store64_be(hbuf + i * 8U, st[i]);); memcpy(h, hbuf, 64U * sizeof (uint8_t)); } void Hacl_Hash_SHA2_sha384_init(uint64_t *hash) { KRML_MAYBE_FOR8(i, 0U, 8U, 1U, uint64_t *os = hash; uint64_t x = Hacl_Hash_SHA2_h384[i]; os[i] = x;); } void Hacl_Hash_SHA2_sha384_update_nblocks(uint32_t len, uint8_t *b, uint64_t *st) { Hacl_Hash_SHA2_sha512_update_nblocks(len, b, st); } void Hacl_Hash_SHA2_sha384_update_last( FStar_UInt128_uint128 totlen, uint32_t len, uint8_t *b, uint64_t *st ) { Hacl_Hash_SHA2_sha512_update_last(totlen, len, b, st); } void Hacl_Hash_SHA2_sha384_finish(uint64_t *st, uint8_t *h) { uint8_t hbuf[64U] = { 0U }; KRML_MAYBE_FOR8(i, 0U, 8U, 1U, store64_be(hbuf + i * 8U, st[i]);); memcpy(h, hbuf, 48U * sizeof (uint8_t)); } /** Allocate initial state for the SHA2_256 hash. The state is to be freed by calling `free_256`. */ Hacl_Streaming_MD_state_32 *Hacl_Hash_SHA2_malloc_256(void) { uint8_t *buf = (uint8_t *)KRML_HOST_CALLOC(64U, sizeof (uint8_t)); if (buf == NULL) { return NULL; } uint8_t *buf1 = buf; uint32_t *b = (uint32_t *)KRML_HOST_CALLOC(8U, sizeof (uint32_t)); Hacl_Streaming_Types_optional_32 block_state; if (b == NULL) { block_state = ((Hacl_Streaming_Types_optional_32){ .tag = Hacl_Streaming_Types_None }); } else { block_state = ((Hacl_Streaming_Types_optional_32){ .tag = Hacl_Streaming_Types_Some, .v = b }); } if (block_state.tag == Hacl_Streaming_Types_None) { KRML_HOST_FREE(buf1); return NULL; } if (block_state.tag == Hacl_Streaming_Types_Some) { uint32_t *block_state1 = block_state.v; Hacl_Streaming_Types_optional k_ = Hacl_Streaming_Types_Some; switch (k_) { case Hacl_Streaming_Types_None: { return NULL; } case Hacl_Streaming_Types_Some: { Hacl_Streaming_MD_state_32 s = { .block_state = block_state1, .buf = buf1, .total_len = (uint64_t)0U }; Hacl_Streaming_MD_state_32 *p = (Hacl_Streaming_MD_state_32 *)KRML_HOST_MALLOC(sizeof (Hacl_Streaming_MD_state_32)); if (p != NULL) { p[0U] = s; } if (p == NULL) { KRML_HOST_FREE(block_state1); KRML_HOST_FREE(buf1); return NULL; } Hacl_Hash_SHA2_sha256_init(block_state1); return p; } default: { KRML_HOST_EPRINTF("KaRaMeL incomplete match at %s:%d\n", __FILE__, __LINE__); KRML_HOST_EXIT(253U); } } } KRML_HOST_EPRINTF("KaRaMeL abort at %s:%d\n%s\n", __FILE__, __LINE__, "unreachable (pattern matches are exhaustive in F*)"); KRML_HOST_EXIT(255U); } /** Copies the state passed as argument into a newly allocated state (deep copy). The state is to be freed by calling `free_256`. Cloning the state this way is useful, for instance, if your control-flow diverges and you need to feed more (different) data into the hash in each branch. */ Hacl_Streaming_MD_state_32 *Hacl_Hash_SHA2_copy_256(Hacl_Streaming_MD_state_32 *state) { Hacl_Streaming_MD_state_32 scrut = *state; uint32_t *block_state0 = scrut.block_state; uint8_t *buf0 = scrut.buf; uint64_t total_len0 = scrut.total_len; uint8_t *buf = (uint8_t *)KRML_HOST_CALLOC(64U, sizeof (uint8_t)); if (buf == NULL) { return NULL; } memcpy(buf, buf0, 64U * sizeof (uint8_t)); uint32_t *b = (uint32_t *)KRML_HOST_CALLOC(8U, sizeof (uint32_t)); Hacl_Streaming_Types_optional_32 block_state; if (b == NULL) { block_state = ((Hacl_Streaming_Types_optional_32){ .tag = Hacl_Streaming_Types_None }); } else { block_state = ((Hacl_Streaming_Types_optional_32){ .tag = Hacl_Streaming_Types_Some, .v = b }); } if (block_state.tag == Hacl_Streaming_Types_None) { KRML_HOST_FREE(buf); return NULL; } if (block_state.tag == Hacl_Streaming_Types_Some) { uint32_t *block_state1 = block_state.v; memcpy(block_state1, block_state0, 8U * sizeof (uint32_t)); Hacl_Streaming_Types_optional k_ = Hacl_Streaming_Types_Some; switch (k_) { case Hacl_Streaming_Types_None: { return NULL; } case Hacl_Streaming_Types_Some: { Hacl_Streaming_MD_state_32 s = { .block_state = block_state1, .buf = buf, .total_len = total_len0 }; Hacl_Streaming_MD_state_32 *p = (Hacl_Streaming_MD_state_32 *)KRML_HOST_MALLOC(sizeof (Hacl_Streaming_MD_state_32)); if (p != NULL) { p[0U] = s; } if (p == NULL) { KRML_HOST_FREE(block_state1); KRML_HOST_FREE(buf); return NULL; } return p; } default: { KRML_HOST_EPRINTF("KaRaMeL incomplete match at %s:%d\n", __FILE__, __LINE__); KRML_HOST_EXIT(253U); } } } KRML_HOST_EPRINTF("KaRaMeL abort at %s:%d\n%s\n", __FILE__, __LINE__, "unreachable (pattern matches are exhaustive in F*)"); KRML_HOST_EXIT(255U); } /** Reset an existing state to the initial hash state with empty data. */ void Hacl_Hash_SHA2_reset_256(Hacl_Streaming_MD_state_32 *state) { Hacl_Streaming_MD_state_32 scrut = *state; uint8_t *buf = scrut.buf; uint32_t *block_state = scrut.block_state; Hacl_Hash_SHA2_sha256_init(block_state); Hacl_Streaming_MD_state_32 tmp = { .block_state = block_state, .buf = buf, .total_len = (uint64_t)0U }; state[0U] = tmp; } static inline Hacl_Streaming_Types_error_code update_224_256(Hacl_Streaming_MD_state_32 *state, uint8_t *chunk, uint32_t chunk_len) { Hacl_Streaming_MD_state_32 s = *state; uint64_t total_len = s.total_len; if ((uint64_t)chunk_len > 2305843009213693951ULL - total_len) { return Hacl_Streaming_Types_MaximumLengthExceeded; } uint32_t sz; if (total_len % (uint64_t)64U == 0ULL && total_len > 0ULL) { sz = 64U; } else { sz = (uint32_t)(total_len % (uint64_t)64U); } if (chunk_len <= 64U - sz) { Hacl_Streaming_MD_state_32 s1 = *state; uint32_t *block_state1 = s1.block_state; uint8_t *buf = s1.buf; uint64_t total_len1 = s1.total_len; uint32_t sz1; if (total_len1 % (uint64_t)64U == 0ULL && total_len1 > 0ULL) { sz1 = 64U; } else { sz1 = (uint32_t)(total_len1 % (uint64_t)64U); } uint8_t *buf2 = buf + sz1; memcpy(buf2, chunk, chunk_len * sizeof (uint8_t)); uint64_t total_len2 = total_len1 + (uint64_t)chunk_len; *state = ( (Hacl_Streaming_MD_state_32){ .block_state = block_state1, .buf = buf, .total_len = total_len2 } ); } else if (sz == 0U) { Hacl_Streaming_MD_state_32 s1 = *state; uint32_t *block_state1 = s1.block_state; uint8_t *buf = s1.buf; uint64_t total_len1 = s1.total_len; uint32_t sz1; if (total_len1 % (uint64_t)64U == 0ULL && total_len1 > 0ULL) { sz1 = 64U; } else { sz1 = (uint32_t)(total_len1 % (uint64_t)64U); } if (!(sz1 == 0U)) { Hacl_Hash_SHA2_sha256_update_nblocks(64U, buf, block_state1); } uint32_t ite; if ((uint64_t)chunk_len % (uint64_t)64U == 0ULL && (uint64_t)chunk_len > 0ULL) { ite = 64U; } else { ite = (uint32_t)((uint64_t)chunk_len % (uint64_t)64U); } uint32_t n_blocks = (chunk_len - ite) / 64U; uint32_t data1_len = n_blocks * 64U; uint32_t data2_len = chunk_len - data1_len; uint8_t *data1 = chunk; uint8_t *data2 = chunk + data1_len; Hacl_Hash_SHA2_sha256_update_nblocks(data1_len / 64U * 64U, data1, block_state1); uint8_t *dst = buf; memcpy(dst, data2, data2_len * sizeof (uint8_t)); *state = ( (Hacl_Streaming_MD_state_32){ .block_state = block_state1, .buf = buf, .total_len = total_len1 + (uint64_t)chunk_len } ); } else { uint32_t diff = 64U - sz; uint8_t *chunk1 = chunk; uint8_t *chunk2 = chunk + diff; Hacl_Streaming_MD_state_32 s1 = *state; uint32_t *block_state10 = s1.block_state; uint8_t *buf0 = s1.buf; uint64_t total_len10 = s1.total_len; uint32_t sz10; if (total_len10 % (uint64_t)64U == 0ULL && total_len10 > 0ULL) { sz10 = 64U; } else { sz10 = (uint32_t)(total_len10 % (uint64_t)64U); } uint8_t *buf2 = buf0 + sz10; memcpy(buf2, chunk1, diff * sizeof (uint8_t)); uint64_t total_len2 = total_len10 + (uint64_t)diff; *state = ( (Hacl_Streaming_MD_state_32){ .block_state = block_state10, .buf = buf0, .total_len = total_len2 } ); Hacl_Streaming_MD_state_32 s10 = *state; uint32_t *block_state1 = s10.block_state; uint8_t *buf = s10.buf; uint64_t total_len1 = s10.total_len; uint32_t sz1; if (total_len1 % (uint64_t)64U == 0ULL && total_len1 > 0ULL) { sz1 = 64U; } else { sz1 = (uint32_t)(total_len1 % (uint64_t)64U); } if (!(sz1 == 0U)) { Hacl_Hash_SHA2_sha256_update_nblocks(64U, buf, block_state1); } uint32_t ite; if ((uint64_t)(chunk_len - diff) % (uint64_t)64U == 0ULL && (uint64_t)(chunk_len - diff) > 0ULL) { ite = 64U; } else { ite = (uint32_t)((uint64_t)(chunk_len - diff) % (uint64_t)64U); } uint32_t n_blocks = (chunk_len - diff - ite) / 64U; uint32_t data1_len = n_blocks * 64U; uint32_t data2_len = chunk_len - diff - data1_len; uint8_t *data1 = chunk2; uint8_t *data2 = chunk2 + data1_len; Hacl_Hash_SHA2_sha256_update_nblocks(data1_len / 64U * 64U, data1, block_state1); uint8_t *dst = buf; memcpy(dst, data2, data2_len * sizeof (uint8_t)); *state = ( (Hacl_Streaming_MD_state_32){ .block_state = block_state1, .buf = buf, .total_len = total_len1 + (uint64_t)(chunk_len - diff) } ); } return Hacl_Streaming_Types_Success; } /** Feed an arbitrary amount of data into the hash. This function returns 0 for success, or 1 if the combined length of all of the data passed to `update_256` (since the last call to `reset_256`) exceeds 2^61-1 bytes. This function is identical to the update function for SHA2_224. */ Hacl_Streaming_Types_error_code Hacl_Hash_SHA2_update_256( Hacl_Streaming_MD_state_32 *state, uint8_t *input, uint32_t input_len ) { return update_224_256(state, input, input_len); } /** Write the resulting hash into `output`, an array of 32 bytes. The state remains valid after a call to `digest_256`, meaning the user may feed more data into the hash via `update_256`. (The digest_256 function operates on an internal copy of the state and therefore does not invalidate the client-held state `p`.) */ void Hacl_Hash_SHA2_digest_256(Hacl_Streaming_MD_state_32 *state, uint8_t *output) { Hacl_Streaming_MD_state_32 scrut = *state; uint32_t *block_state = scrut.block_state; uint8_t *buf_ = scrut.buf; uint64_t total_len = scrut.total_len; uint32_t r; if (total_len % (uint64_t)64U == 0ULL && total_len > 0ULL) { r = 64U; } else { r = (uint32_t)(total_len % (uint64_t)64U); } uint8_t *buf_1 = buf_; uint32_t tmp_block_state[8U] = { 0U }; memcpy(tmp_block_state, block_state, 8U * sizeof (uint32_t)); uint32_t ite; if (r % 64U == 0U && r > 0U) { ite = 64U; } else { ite = r % 64U; } uint8_t *buf_last = buf_1 + r - ite; uint8_t *buf_multi = buf_1; Hacl_Hash_SHA2_sha256_update_nblocks(0U, buf_multi, tmp_block_state); uint64_t prev_len_last = total_len - (uint64_t)r; Hacl_Hash_SHA2_sha256_update_last(prev_len_last + (uint64_t)r, r, buf_last, tmp_block_state); Hacl_Hash_SHA2_sha256_finish(tmp_block_state, output); } /** Free a state allocated with `malloc_256`. This function is identical to the free function for SHA2_224. */ void Hacl_Hash_SHA2_free_256(Hacl_Streaming_MD_state_32 *state) { Hacl_Streaming_MD_state_32 scrut = *state; uint8_t *buf = scrut.buf; uint32_t *block_state = scrut.block_state; KRML_HOST_FREE(block_state); KRML_HOST_FREE(buf); KRML_HOST_FREE(state); } /** Hash `input`, of len `input_len`, into `output`, an array of 32 bytes. */ void Hacl_Hash_SHA2_hash_256(uint8_t *output, uint8_t *input, uint32_t input_len) { uint8_t *ib = input; uint8_t *rb = output; uint32_t st[8U] = { 0U }; Hacl_Hash_SHA2_sha256_init(st); uint32_t rem = input_len % 64U; uint64_t len_ = (uint64_t)input_len; Hacl_Hash_SHA2_sha256_update_nblocks(input_len, ib, st); uint32_t rem1 = input_len % 64U; uint8_t *b0 = ib; uint8_t *lb = b0 + input_len - rem1; Hacl_Hash_SHA2_sha256_update_last(len_, rem, lb, st); Hacl_Hash_SHA2_sha256_finish(st, rb); } Hacl_Streaming_MD_state_32 *Hacl_Hash_SHA2_malloc_224(void) { uint8_t *buf = (uint8_t *)KRML_HOST_CALLOC(64U, sizeof (uint8_t)); if (buf == NULL) { return NULL; } uint8_t *buf1 = buf; uint32_t *b = (uint32_t *)KRML_HOST_CALLOC(8U, sizeof (uint32_t)); Hacl_Streaming_Types_optional_32 block_state; if (b == NULL) { block_state = ((Hacl_Streaming_Types_optional_32){ .tag = Hacl_Streaming_Types_None }); } else { block_state = ((Hacl_Streaming_Types_optional_32){ .tag = Hacl_Streaming_Types_Some, .v = b }); } if (block_state.tag == Hacl_Streaming_Types_None) { KRML_HOST_FREE(buf1); return NULL; } if (block_state.tag == Hacl_Streaming_Types_Some) { uint32_t *block_state1 = block_state.v; Hacl_Streaming_Types_optional k_ = Hacl_Streaming_Types_Some; switch (k_) { case Hacl_Streaming_Types_None: { return NULL; } case Hacl_Streaming_Types_Some: { Hacl_Streaming_MD_state_32 s = { .block_state = block_state1, .buf = buf1, .total_len = (uint64_t)0U }; Hacl_Streaming_MD_state_32 *p = (Hacl_Streaming_MD_state_32 *)KRML_HOST_MALLOC(sizeof (Hacl_Streaming_MD_state_32)); if (p != NULL) { p[0U] = s; } if (p == NULL) { KRML_HOST_FREE(block_state1); KRML_HOST_FREE(buf1); return NULL; } Hacl_Hash_SHA2_sha224_init(block_state1); return p; } default: { KRML_HOST_EPRINTF("KaRaMeL incomplete match at %s:%d\n", __FILE__, __LINE__); KRML_HOST_EXIT(253U); } } } KRML_HOST_EPRINTF("KaRaMeL abort at %s:%d\n%s\n", __FILE__, __LINE__, "unreachable (pattern matches are exhaustive in F*)"); KRML_HOST_EXIT(255U); } void Hacl_Hash_SHA2_reset_224(Hacl_Streaming_MD_state_32 *state) { Hacl_Streaming_MD_state_32 scrut = *state; uint8_t *buf = scrut.buf; uint32_t *block_state = scrut.block_state; Hacl_Hash_SHA2_sha224_init(block_state); Hacl_Streaming_MD_state_32 tmp = { .block_state = block_state, .buf = buf, .total_len = (uint64_t)0U }; state[0U] = tmp; } Hacl_Streaming_Types_error_code Hacl_Hash_SHA2_update_224( Hacl_Streaming_MD_state_32 *state, uint8_t *input, uint32_t input_len ) { return update_224_256(state, input, input_len); } /** Write the resulting hash into `output`, an array of 28 bytes. The state remains valid after a call to `digest_224`, meaning the user may feed more data into the hash via `update_224`. */ void Hacl_Hash_SHA2_digest_224(Hacl_Streaming_MD_state_32 *state, uint8_t *output) { Hacl_Streaming_MD_state_32 scrut = *state; uint32_t *block_state = scrut.block_state; uint8_t *buf_ = scrut.buf; uint64_t total_len = scrut.total_len; uint32_t r; if (total_len % (uint64_t)64U == 0ULL && total_len > 0ULL) { r = 64U; } else { r = (uint32_t)(total_len % (uint64_t)64U); } uint8_t *buf_1 = buf_; uint32_t tmp_block_state[8U] = { 0U }; memcpy(tmp_block_state, block_state, 8U * sizeof (uint32_t)); uint32_t ite; if (r % 64U == 0U && r > 0U) { ite = 64U; } else { ite = r % 64U; } uint8_t *buf_last = buf_1 + r - ite; uint8_t *buf_multi = buf_1; Hacl_Hash_SHA2_sha224_update_nblocks(0U, buf_multi, tmp_block_state); uint64_t prev_len_last = total_len - (uint64_t)r; Hacl_Hash_SHA2_sha224_update_last(prev_len_last + (uint64_t)r, r, buf_last, tmp_block_state); Hacl_Hash_SHA2_sha224_finish(tmp_block_state, output); } void Hacl_Hash_SHA2_free_224(Hacl_Streaming_MD_state_32 *state) { Hacl_Hash_SHA2_free_256(state); } /** Hash `input`, of len `input_len`, into `output`, an array of 28 bytes. */ void Hacl_Hash_SHA2_hash_224(uint8_t *output, uint8_t *input, uint32_t input_len) { uint8_t *ib = input; uint8_t *rb = output; uint32_t st[8U] = { 0U }; Hacl_Hash_SHA2_sha224_init(st); uint32_t rem = input_len % 64U; uint64_t len_ = (uint64_t)input_len; Hacl_Hash_SHA2_sha224_update_nblocks(input_len, ib, st); uint32_t rem1 = input_len % 64U; uint8_t *b0 = ib; uint8_t *lb = b0 + input_len - rem1; Hacl_Hash_SHA2_sha224_update_last(len_, rem, lb, st); Hacl_Hash_SHA2_sha224_finish(st, rb); } Hacl_Streaming_MD_state_64 *Hacl_Hash_SHA2_malloc_512(void) { uint8_t *buf = (uint8_t *)KRML_HOST_CALLOC(128U, sizeof (uint8_t)); if (buf == NULL) { return NULL; } uint8_t *buf1 = buf; uint64_t *b = (uint64_t *)KRML_HOST_CALLOC(8U, sizeof (uint64_t)); Hacl_Streaming_Types_optional_64 block_state; if (b == NULL) { block_state = ((Hacl_Streaming_Types_optional_64){ .tag = Hacl_Streaming_Types_None }); } else { block_state = ((Hacl_Streaming_Types_optional_64){ .tag = Hacl_Streaming_Types_Some, .v = b }); } if (block_state.tag == Hacl_Streaming_Types_None) { KRML_HOST_FREE(buf1); return NULL; } if (block_state.tag == Hacl_Streaming_Types_Some) { uint64_t *block_state1 = block_state.v; Hacl_Streaming_Types_optional k_ = Hacl_Streaming_Types_Some; switch (k_) { case Hacl_Streaming_Types_None: { return NULL; } case Hacl_Streaming_Types_Some: { Hacl_Streaming_MD_state_64 s = { .block_state = block_state1, .buf = buf1, .total_len = (uint64_t)0U }; Hacl_Streaming_MD_state_64 *p = (Hacl_Streaming_MD_state_64 *)KRML_HOST_MALLOC(sizeof (Hacl_Streaming_MD_state_64)); if (p != NULL) { p[0U] = s; } if (p == NULL) { KRML_HOST_FREE(block_state1); KRML_HOST_FREE(buf1); return NULL; } Hacl_Hash_SHA2_sha512_init(block_state1); return p; } default: { KRML_HOST_EPRINTF("KaRaMeL incomplete match at %s:%d\n", __FILE__, __LINE__); KRML_HOST_EXIT(253U); } } } KRML_HOST_EPRINTF("KaRaMeL abort at %s:%d\n%s\n", __FILE__, __LINE__, "unreachable (pattern matches are exhaustive in F*)"); KRML_HOST_EXIT(255U); } /** Copies the state passed as argument into a newly allocated state (deep copy). The state is to be freed by calling `free_512`. Cloning the state this way is useful, for instance, if your control-flow diverges and you need to feed more (different) data into the hash in each branch. */ Hacl_Streaming_MD_state_64 *Hacl_Hash_SHA2_copy_512(Hacl_Streaming_MD_state_64 *state) { Hacl_Streaming_MD_state_64 scrut = *state; uint64_t *block_state0 = scrut.block_state; uint8_t *buf0 = scrut.buf; uint64_t total_len0 = scrut.total_len; uint8_t *buf = (uint8_t *)KRML_HOST_CALLOC(128U, sizeof (uint8_t)); if (buf == NULL) { return NULL; } memcpy(buf, buf0, 128U * sizeof (uint8_t)); uint64_t *b = (uint64_t *)KRML_HOST_CALLOC(8U, sizeof (uint64_t)); Hacl_Streaming_Types_optional_64 block_state; if (b == NULL) { block_state = ((Hacl_Streaming_Types_optional_64){ .tag = Hacl_Streaming_Types_None }); } else { block_state = ((Hacl_Streaming_Types_optional_64){ .tag = Hacl_Streaming_Types_Some, .v = b }); } if (block_state.tag == Hacl_Streaming_Types_None) { KRML_HOST_FREE(buf); return NULL; } if (block_state.tag == Hacl_Streaming_Types_Some) { uint64_t *block_state1 = block_state.v; memcpy(block_state1, block_state0, 8U * sizeof (uint64_t)); Hacl_Streaming_Types_optional k_ = Hacl_Streaming_Types_Some; switch (k_) { case Hacl_Streaming_Types_None: { return NULL; } case Hacl_Streaming_Types_Some: { Hacl_Streaming_MD_state_64 s = { .block_state = block_state1, .buf = buf, .total_len = total_len0 }; Hacl_Streaming_MD_state_64 *p = (Hacl_Streaming_MD_state_64 *)KRML_HOST_MALLOC(sizeof (Hacl_Streaming_MD_state_64)); if (p != NULL) { p[0U] = s; } if (p == NULL) { KRML_HOST_FREE(block_state1); KRML_HOST_FREE(buf); return NULL; } return p; } default: { KRML_HOST_EPRINTF("KaRaMeL incomplete match at %s:%d\n", __FILE__, __LINE__); KRML_HOST_EXIT(253U); } } } KRML_HOST_EPRINTF("KaRaMeL abort at %s:%d\n%s\n", __FILE__, __LINE__, "unreachable (pattern matches are exhaustive in F*)"); KRML_HOST_EXIT(255U); } void Hacl_Hash_SHA2_reset_512(Hacl_Streaming_MD_state_64 *state) { Hacl_Streaming_MD_state_64 scrut = *state; uint8_t *buf = scrut.buf; uint64_t *block_state = scrut.block_state; Hacl_Hash_SHA2_sha512_init(block_state); Hacl_Streaming_MD_state_64 tmp = { .block_state = block_state, .buf = buf, .total_len = (uint64_t)0U }; state[0U] = tmp; } static inline Hacl_Streaming_Types_error_code update_384_512(Hacl_Streaming_MD_state_64 *state, uint8_t *chunk, uint32_t chunk_len) { Hacl_Streaming_MD_state_64 s = *state; uint64_t total_len = s.total_len; if ((uint64_t)chunk_len > 18446744073709551615ULL - total_len) { return Hacl_Streaming_Types_MaximumLengthExceeded; } uint32_t sz; if (total_len % (uint64_t)128U == 0ULL && total_len > 0ULL) { sz = 128U; } else { sz = (uint32_t)(total_len % (uint64_t)128U); } if (chunk_len <= 128U - sz) { Hacl_Streaming_MD_state_64 s1 = *state; uint64_t *block_state1 = s1.block_state; uint8_t *buf = s1.buf; uint64_t total_len1 = s1.total_len; uint32_t sz1; if (total_len1 % (uint64_t)128U == 0ULL && total_len1 > 0ULL) { sz1 = 128U; } else { sz1 = (uint32_t)(total_len1 % (uint64_t)128U); } uint8_t *buf2 = buf + sz1; memcpy(buf2, chunk, chunk_len * sizeof (uint8_t)); uint64_t total_len2 = total_len1 + (uint64_t)chunk_len; *state = ( (Hacl_Streaming_MD_state_64){ .block_state = block_state1, .buf = buf, .total_len = total_len2 } ); } else if (sz == 0U) { Hacl_Streaming_MD_state_64 s1 = *state; uint64_t *block_state1 = s1.block_state; uint8_t *buf = s1.buf; uint64_t total_len1 = s1.total_len; uint32_t sz1; if (total_len1 % (uint64_t)128U == 0ULL && total_len1 > 0ULL) { sz1 = 128U; } else { sz1 = (uint32_t)(total_len1 % (uint64_t)128U); } if (!(sz1 == 0U)) { Hacl_Hash_SHA2_sha512_update_nblocks(128U, buf, block_state1); } uint32_t ite; if ((uint64_t)chunk_len % (uint64_t)128U == 0ULL && (uint64_t)chunk_len > 0ULL) { ite = 128U; } else { ite = (uint32_t)((uint64_t)chunk_len % (uint64_t)128U); } uint32_t n_blocks = (chunk_len - ite) / 128U; uint32_t data1_len = n_blocks * 128U; uint32_t data2_len = chunk_len - data1_len; uint8_t *data1 = chunk; uint8_t *data2 = chunk + data1_len; Hacl_Hash_SHA2_sha512_update_nblocks(data1_len / 128U * 128U, data1, block_state1); uint8_t *dst = buf; memcpy(dst, data2, data2_len * sizeof (uint8_t)); *state = ( (Hacl_Streaming_MD_state_64){ .block_state = block_state1, .buf = buf, .total_len = total_len1 + (uint64_t)chunk_len } ); } else { uint32_t diff = 128U - sz; uint8_t *chunk1 = chunk; uint8_t *chunk2 = chunk + diff; Hacl_Streaming_MD_state_64 s1 = *state; uint64_t *block_state10 = s1.block_state; uint8_t *buf0 = s1.buf; uint64_t total_len10 = s1.total_len; uint32_t sz10; if (total_len10 % (uint64_t)128U == 0ULL && total_len10 > 0ULL) { sz10 = 128U; } else { sz10 = (uint32_t)(total_len10 % (uint64_t)128U); } uint8_t *buf2 = buf0 + sz10; memcpy(buf2, chunk1, diff * sizeof (uint8_t)); uint64_t total_len2 = total_len10 + (uint64_t)diff; *state = ( (Hacl_Streaming_MD_state_64){ .block_state = block_state10, .buf = buf0, .total_len = total_len2 } ); Hacl_Streaming_MD_state_64 s10 = *state; uint64_t *block_state1 = s10.block_state; uint8_t *buf = s10.buf; uint64_t total_len1 = s10.total_len; uint32_t sz1; if (total_len1 % (uint64_t)128U == 0ULL && total_len1 > 0ULL) { sz1 = 128U; } else { sz1 = (uint32_t)(total_len1 % (uint64_t)128U); } if (!(sz1 == 0U)) { Hacl_Hash_SHA2_sha512_update_nblocks(128U, buf, block_state1); } uint32_t ite; if ((uint64_t)(chunk_len - diff) % (uint64_t)128U == 0ULL && (uint64_t)(chunk_len - diff) > 0ULL) { ite = 128U; } else { ite = (uint32_t)((uint64_t)(chunk_len - diff) % (uint64_t)128U); } uint32_t n_blocks = (chunk_len - diff - ite) / 128U; uint32_t data1_len = n_blocks * 128U; uint32_t data2_len = chunk_len - diff - data1_len; uint8_t *data1 = chunk2; uint8_t *data2 = chunk2 + data1_len; Hacl_Hash_SHA2_sha512_update_nblocks(data1_len / 128U * 128U, data1, block_state1); uint8_t *dst = buf; memcpy(dst, data2, data2_len * sizeof (uint8_t)); *state = ( (Hacl_Streaming_MD_state_64){ .block_state = block_state1, .buf = buf, .total_len = total_len1 + (uint64_t)(chunk_len - diff) } ); } return Hacl_Streaming_Types_Success; } /** Feed an arbitrary amount of data into the hash. This function returns 0 for success, or 1 if the combined length of all of the data passed to `update_512` (since the last call to `reset_512`) exceeds 2^125-1 bytes. This function is identical to the update function for SHA2_384. */ Hacl_Streaming_Types_error_code Hacl_Hash_SHA2_update_512( Hacl_Streaming_MD_state_64 *state, uint8_t *input, uint32_t input_len ) { return update_384_512(state, input, input_len); } /** Write the resulting hash into `output`, an array of 64 bytes. The state remains valid after a call to `digest_512`, meaning the user may feed more data into the hash via `update_512`. (The digest_512 function operates on an internal copy of the state and therefore does not invalidate the client-held state `p`.) */ void Hacl_Hash_SHA2_digest_512(Hacl_Streaming_MD_state_64 *state, uint8_t *output) { Hacl_Streaming_MD_state_64 scrut = *state; uint64_t *block_state = scrut.block_state; uint8_t *buf_ = scrut.buf; uint64_t total_len = scrut.total_len; uint32_t r; if (total_len % (uint64_t)128U == 0ULL && total_len > 0ULL) { r = 128U; } else { r = (uint32_t)(total_len % (uint64_t)128U); } uint8_t *buf_1 = buf_; uint64_t tmp_block_state[8U] = { 0U }; memcpy(tmp_block_state, block_state, 8U * sizeof (uint64_t)); uint32_t ite; if (r % 128U == 0U && r > 0U) { ite = 128U; } else { ite = r % 128U; } uint8_t *buf_last = buf_1 + r - ite; uint8_t *buf_multi = buf_1; Hacl_Hash_SHA2_sha512_update_nblocks(0U, buf_multi, tmp_block_state); uint64_t prev_len_last = total_len - (uint64_t)r; Hacl_Hash_SHA2_sha512_update_last(FStar_UInt128_add(FStar_UInt128_uint64_to_uint128(prev_len_last), FStar_UInt128_uint64_to_uint128((uint64_t)r)), r, buf_last, tmp_block_state); Hacl_Hash_SHA2_sha512_finish(tmp_block_state, output); } /** Free a state allocated with `malloc_512`. This function is identical to the free function for SHA2_384. */ void Hacl_Hash_SHA2_free_512(Hacl_Streaming_MD_state_64 *state) { Hacl_Streaming_MD_state_64 scrut = *state; uint8_t *buf = scrut.buf; uint64_t *block_state = scrut.block_state; KRML_HOST_FREE(block_state); KRML_HOST_FREE(buf); KRML_HOST_FREE(state); } /** Hash `input`, of len `input_len`, into `output`, an array of 64 bytes. */ void Hacl_Hash_SHA2_hash_512(uint8_t *output, uint8_t *input, uint32_t input_len) { uint8_t *ib = input; uint8_t *rb = output; uint64_t st[8U] = { 0U }; Hacl_Hash_SHA2_sha512_init(st); uint32_t rem = input_len % 128U; FStar_UInt128_uint128 len_ = FStar_UInt128_uint64_to_uint128((uint64_t)input_len); Hacl_Hash_SHA2_sha512_update_nblocks(input_len, ib, st); uint32_t rem1 = input_len % 128U; uint8_t *b0 = ib; uint8_t *lb = b0 + input_len - rem1; Hacl_Hash_SHA2_sha512_update_last(len_, rem, lb, st); Hacl_Hash_SHA2_sha512_finish(st, rb); } Hacl_Streaming_MD_state_64 *Hacl_Hash_SHA2_malloc_384(void) { uint8_t *buf = (uint8_t *)KRML_HOST_CALLOC(128U, sizeof (uint8_t)); if (buf == NULL) { return NULL; } uint8_t *buf1 = buf; uint64_t *b = (uint64_t *)KRML_HOST_CALLOC(8U, sizeof (uint64_t)); Hacl_Streaming_Types_optional_64 block_state; if (b == NULL) { block_state = ((Hacl_Streaming_Types_optional_64){ .tag = Hacl_Streaming_Types_None }); } else { block_state = ((Hacl_Streaming_Types_optional_64){ .tag = Hacl_Streaming_Types_Some, .v = b }); } if (block_state.tag == Hacl_Streaming_Types_None) { KRML_HOST_FREE(buf1); return NULL; } if (block_state.tag == Hacl_Streaming_Types_Some) { uint64_t *block_state1 = block_state.v; Hacl_Streaming_Types_optional k_ = Hacl_Streaming_Types_Some; switch (k_) { case Hacl_Streaming_Types_None: { return NULL; } case Hacl_Streaming_Types_Some: { Hacl_Streaming_MD_state_64 s = { .block_state = block_state1, .buf = buf1, .total_len = (uint64_t)0U }; Hacl_Streaming_MD_state_64 *p = (Hacl_Streaming_MD_state_64 *)KRML_HOST_MALLOC(sizeof (Hacl_Streaming_MD_state_64)); if (p != NULL) { p[0U] = s; } if (p == NULL) { KRML_HOST_FREE(block_state1); KRML_HOST_FREE(buf1); return NULL; } Hacl_Hash_SHA2_sha384_init(block_state1); return p; } default: { KRML_HOST_EPRINTF("KaRaMeL incomplete match at %s:%d\n", __FILE__, __LINE__); KRML_HOST_EXIT(253U); } } } KRML_HOST_EPRINTF("KaRaMeL abort at %s:%d\n%s\n", __FILE__, __LINE__, "unreachable (pattern matches are exhaustive in F*)"); KRML_HOST_EXIT(255U); } void Hacl_Hash_SHA2_reset_384(Hacl_Streaming_MD_state_64 *state) { Hacl_Streaming_MD_state_64 scrut = *state; uint8_t *buf = scrut.buf; uint64_t *block_state = scrut.block_state; Hacl_Hash_SHA2_sha384_init(block_state); Hacl_Streaming_MD_state_64 tmp = { .block_state = block_state, .buf = buf, .total_len = (uint64_t)0U }; state[0U] = tmp; } Hacl_Streaming_Types_error_code Hacl_Hash_SHA2_update_384( Hacl_Streaming_MD_state_64 *state, uint8_t *input, uint32_t input_len ) { return update_384_512(state, input, input_len); } /** Write the resulting hash into `output`, an array of 48 bytes. The state remains valid after a call to `digest_384`, meaning the user may feed more data into the hash via `update_384`. */ void Hacl_Hash_SHA2_digest_384(Hacl_Streaming_MD_state_64 *state, uint8_t *output) { Hacl_Streaming_MD_state_64 scrut = *state; uint64_t *block_state = scrut.block_state; uint8_t *buf_ = scrut.buf; uint64_t total_len = scrut.total_len; uint32_t r; if (total_len % (uint64_t)128U == 0ULL && total_len > 0ULL) { r = 128U; } else { r = (uint32_t)(total_len % (uint64_t)128U); } uint8_t *buf_1 = buf_; uint64_t tmp_block_state[8U] = { 0U }; memcpy(tmp_block_state, block_state, 8U * sizeof (uint64_t)); uint32_t ite; if (r % 128U == 0U && r > 0U) { ite = 128U; } else { ite = r % 128U; } uint8_t *buf_last = buf_1 + r - ite; uint8_t *buf_multi = buf_1; Hacl_Hash_SHA2_sha384_update_nblocks(0U, buf_multi, tmp_block_state); uint64_t prev_len_last = total_len - (uint64_t)r; Hacl_Hash_SHA2_sha384_update_last(FStar_UInt128_add(FStar_UInt128_uint64_to_uint128(prev_len_last), FStar_UInt128_uint64_to_uint128((uint64_t)r)), r, buf_last, tmp_block_state); Hacl_Hash_SHA2_sha384_finish(tmp_block_state, output); } void Hacl_Hash_SHA2_free_384(Hacl_Streaming_MD_state_64 *state) { Hacl_Hash_SHA2_free_512(state); } /** Hash `input`, of len `input_len`, into `output`, an array of 48 bytes. */ void Hacl_Hash_SHA2_hash_384(uint8_t *output, uint8_t *input, uint32_t input_len) { uint8_t *ib = input; uint8_t *rb = output; uint64_t st[8U] = { 0U }; Hacl_Hash_SHA2_sha384_init(st); uint32_t rem = input_len % 128U; FStar_UInt128_uint128 len_ = FStar_UInt128_uint64_to_uint128((uint64_t)input_len); Hacl_Hash_SHA2_sha384_update_nblocks(input_len, ib, st); uint32_t rem1 = input_len % 128U; uint8_t *b0 = ib; uint8_t *lb = b0 + input_len - rem1; Hacl_Hash_SHA2_sha384_update_last(len_, rem, lb, st); Hacl_Hash_SHA2_sha384_finish(st, rb); } /* MIT License * * Copyright (c) 2016-2022 INRIA, CMU and Microsoft Corporation * Copyright (c) 2022-2023 HACL* Contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all * copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. */ static inline void fsum(uint64_t *out, uint64_t *a, uint64_t *b) { Hacl_Impl_Curve25519_Field51_fadd(out, a, b); } static inline void fdifference(uint64_t *out, uint64_t *a, uint64_t *b) { Hacl_Impl_Curve25519_Field51_fsub(out, a, b); } void Hacl_Bignum25519_reduce_513(uint64_t *a) { uint64_t f0 = a[0U]; uint64_t f1 = a[1U]; uint64_t f2 = a[2U]; uint64_t f3 = a[3U]; uint64_t f4 = a[4U]; uint64_t l_ = f0 + 0ULL; uint64_t tmp0 = l_ & 0x7ffffffffffffULL; uint64_t c0 = l_ >> 51U; uint64_t l_0 = f1 + c0; uint64_t tmp1 = l_0 & 0x7ffffffffffffULL; uint64_t c1 = l_0 >> 51U; uint64_t l_1 = f2 + c1; uint64_t tmp2 = l_1 & 0x7ffffffffffffULL; uint64_t c2 = l_1 >> 51U; uint64_t l_2 = f3 + c2; uint64_t tmp3 = l_2 & 0x7ffffffffffffULL; uint64_t c3 = l_2 >> 51U; uint64_t l_3 = f4 + c3; uint64_t tmp4 = l_3 & 0x7ffffffffffffULL; uint64_t c4 = l_3 >> 51U; uint64_t l_4 = tmp0 + c4 * 19ULL; uint64_t tmp0_ = l_4 & 0x7ffffffffffffULL; uint64_t c5 = l_4 >> 51U; a[0U] = tmp0_; a[1U] = tmp1 + c5; a[2U] = tmp2; a[3U] = tmp3; a[4U] = tmp4; } static inline void fmul0(uint64_t *output, uint64_t *input, uint64_t *input2) { FStar_UInt128_uint128 tmp[10U]; for (uint32_t _i = 0U; _i < 10U; ++_i) tmp[_i] = FStar_UInt128_uint64_to_uint128(0ULL); Hacl_Impl_Curve25519_Field51_fmul(output, input, input2, tmp); } static inline void times_2(uint64_t *out, uint64_t *a) { uint64_t a0 = a[0U]; uint64_t a1 = a[1U]; uint64_t a2 = a[2U]; uint64_t a3 = a[3U]; uint64_t a4 = a[4U]; uint64_t o0 = 2ULL * a0; uint64_t o1 = 2ULL * a1; uint64_t o2 = 2ULL * a2; uint64_t o3 = 2ULL * a3; uint64_t o4 = 2ULL * a4; out[0U] = o0; out[1U] = o1; out[2U] = o2; out[3U] = o3; out[4U] = o4; } static inline void times_d(uint64_t *out, uint64_t *a) { uint64_t d[5U] = { 0U }; d[0U] = 0x00034dca135978a3ULL; d[1U] = 0x0001a8283b156ebdULL; d[2U] = 0x0005e7a26001c029ULL; d[3U] = 0x000739c663a03cbbULL; d[4U] = 0x00052036cee2b6ffULL; fmul0(out, d, a); } static inline void times_2d(uint64_t *out, uint64_t *a) { uint64_t d2[5U] = { 0U }; d2[0U] = 0x00069b9426b2f159ULL; d2[1U] = 0x00035050762add7aULL; d2[2U] = 0x0003cf44c0038052ULL; d2[3U] = 0x0006738cc7407977ULL; d2[4U] = 0x0002406d9dc56dffULL; fmul0(out, d2, a); } static inline void fsquare(uint64_t *out, uint64_t *a) { FStar_UInt128_uint128 tmp[5U]; for (uint32_t _i = 0U; _i < 5U; ++_i) tmp[_i] = FStar_UInt128_uint64_to_uint128(0ULL); Hacl_Impl_Curve25519_Field51_fsqr(out, a, tmp); } static inline void fsquare_times(uint64_t *output, uint64_t *input, uint32_t count) { FStar_UInt128_uint128 tmp[5U]; for (uint32_t _i = 0U; _i < 5U; ++_i) tmp[_i] = FStar_UInt128_uint64_to_uint128(0ULL); Hacl_Curve25519_51_fsquare_times(output, input, tmp, count); } static inline void fsquare_times_inplace(uint64_t *output, uint32_t count) { FStar_UInt128_uint128 tmp[5U]; for (uint32_t _i = 0U; _i < 5U; ++_i) tmp[_i] = FStar_UInt128_uint64_to_uint128(0ULL); Hacl_Curve25519_51_fsquare_times(output, output, tmp, count); } void Hacl_Bignum25519_inverse(uint64_t *out, uint64_t *a) { FStar_UInt128_uint128 tmp[10U]; for (uint32_t _i = 0U; _i < 10U; ++_i) tmp[_i] = FStar_UInt128_uint64_to_uint128(0ULL); Hacl_Curve25519_51_finv(out, a, tmp); } static inline void reduce(uint64_t *out) { uint64_t o0 = out[0U]; uint64_t o1 = out[1U]; uint64_t o2 = out[2U]; uint64_t o3 = out[3U]; uint64_t o4 = out[4U]; uint64_t l_ = o0 + 0ULL; uint64_t tmp0 = l_ & 0x7ffffffffffffULL; uint64_t c0 = l_ >> 51U; uint64_t l_0 = o1 + c0; uint64_t tmp1 = l_0 & 0x7ffffffffffffULL; uint64_t c1 = l_0 >> 51U; uint64_t l_1 = o2 + c1; uint64_t tmp2 = l_1 & 0x7ffffffffffffULL; uint64_t c2 = l_1 >> 51U; uint64_t l_2 = o3 + c2; uint64_t tmp3 = l_2 & 0x7ffffffffffffULL; uint64_t c3 = l_2 >> 51U; uint64_t l_3 = o4 + c3; uint64_t tmp4 = l_3 & 0x7ffffffffffffULL; uint64_t c4 = l_3 >> 51U; uint64_t l_4 = tmp0 + c4 * 19ULL; uint64_t tmp0_ = l_4 & 0x7ffffffffffffULL; uint64_t c5 = l_4 >> 51U; uint64_t f0 = tmp0_; uint64_t f1 = tmp1 + c5; uint64_t f2 = tmp2; uint64_t f3 = tmp3; uint64_t f4 = tmp4; uint64_t m0 = FStar_UInt64_gte_mask(f0, 0x7ffffffffffedULL); uint64_t m1 = FStar_UInt64_eq_mask(f1, 0x7ffffffffffffULL); uint64_t m2 = FStar_UInt64_eq_mask(f2, 0x7ffffffffffffULL); uint64_t m3 = FStar_UInt64_eq_mask(f3, 0x7ffffffffffffULL); uint64_t m4 = FStar_UInt64_eq_mask(f4, 0x7ffffffffffffULL); uint64_t mask = (((m0 & m1) & m2) & m3) & m4; uint64_t f0_ = f0 - (mask & 0x7ffffffffffedULL); uint64_t f1_ = f1 - (mask & 0x7ffffffffffffULL); uint64_t f2_ = f2 - (mask & 0x7ffffffffffffULL); uint64_t f3_ = f3 - (mask & 0x7ffffffffffffULL); uint64_t f4_ = f4 - (mask & 0x7ffffffffffffULL); uint64_t f01 = f0_; uint64_t f11 = f1_; uint64_t f21 = f2_; uint64_t f31 = f3_; uint64_t f41 = f4_; out[0U] = f01; out[1U] = f11; out[2U] = f21; out[3U] = f31; out[4U] = f41; } void Hacl_Bignum25519_load_51(uint64_t *output, uint8_t *input) { uint64_t u64s[4U] = { 0U }; KRML_MAYBE_FOR4(i, 0U, 4U, 1U, uint64_t *os = u64s; uint8_t *bj = input + i * 8U; uint64_t u = load64_le(bj); uint64_t r = u; uint64_t x = r; os[i] = x;); uint64_t u64s3 = u64s[3U]; u64s[3U] = u64s3 & 0x7fffffffffffffffULL; output[0U] = u64s[0U] & 0x7ffffffffffffULL; output[1U] = u64s[0U] >> 51U | (u64s[1U] & 0x3fffffffffULL) << 13U; output[2U] = u64s[1U] >> 38U | (u64s[2U] & 0x1ffffffULL) << 26U; output[3U] = u64s[2U] >> 25U | (u64s[3U] & 0xfffULL) << 39U; output[4U] = u64s[3U] >> 12U; } void Hacl_Bignum25519_store_51(uint8_t *output, uint64_t *input) { uint64_t u64s[4U] = { 0U }; Hacl_Impl_Curve25519_Field51_store_felem(u64s, input); KRML_MAYBE_FOR4(i, 0U, 4U, 1U, store64_le(output + i * 8U, u64s[i]);); } void Hacl_Impl_Ed25519_PointDouble_point_double(uint64_t *out, uint64_t *p) { uint64_t tmp[20U] = { 0U }; uint64_t *tmp1 = tmp; uint64_t *tmp20 = tmp + 5U; uint64_t *tmp30 = tmp + 10U; uint64_t *tmp40 = tmp + 15U; uint64_t *x10 = p; uint64_t *y10 = p + 5U; uint64_t *z1 = p + 10U; fsquare(tmp1, x10); fsquare(tmp20, y10); fsum(tmp30, tmp1, tmp20); fdifference(tmp40, tmp1, tmp20); fsquare(tmp1, z1); times_2(tmp1, tmp1); uint64_t *tmp10 = tmp; uint64_t *tmp2 = tmp + 5U; uint64_t *tmp3 = tmp + 10U; uint64_t *tmp4 = tmp + 15U; uint64_t *x1 = p; uint64_t *y1 = p + 5U; fsum(tmp2, x1, y1); fsquare(tmp2, tmp2); Hacl_Bignum25519_reduce_513(tmp3); fdifference(tmp2, tmp3, tmp2); Hacl_Bignum25519_reduce_513(tmp10); Hacl_Bignum25519_reduce_513(tmp4); fsum(tmp10, tmp10, tmp4); uint64_t *tmp_f = tmp; uint64_t *tmp_e = tmp + 5U; uint64_t *tmp_h = tmp + 10U; uint64_t *tmp_g = tmp + 15U; uint64_t *x3 = out; uint64_t *y3 = out + 5U; uint64_t *z3 = out + 10U; uint64_t *t3 = out + 15U; fmul0(x3, tmp_e, tmp_f); fmul0(y3, tmp_g, tmp_h); fmul0(t3, tmp_e, tmp_h); fmul0(z3, tmp_f, tmp_g); } void Hacl_Impl_Ed25519_PointAdd_point_add(uint64_t *out, uint64_t *p, uint64_t *q) { uint64_t tmp[30U] = { 0U }; uint64_t *tmp1 = tmp; uint64_t *tmp20 = tmp + 5U; uint64_t *tmp30 = tmp + 10U; uint64_t *tmp40 = tmp + 15U; uint64_t *x1 = p; uint64_t *y1 = p + 5U; uint64_t *x2 = q; uint64_t *y2 = q + 5U; fdifference(tmp1, y1, x1); fdifference(tmp20, y2, x2); fmul0(tmp30, tmp1, tmp20); fsum(tmp1, y1, x1); fsum(tmp20, y2, x2); fmul0(tmp40, tmp1, tmp20); uint64_t *tmp10 = tmp; uint64_t *tmp2 = tmp + 5U; uint64_t *tmp3 = tmp + 10U; uint64_t *tmp4 = tmp + 15U; uint64_t *tmp5 = tmp + 20U; uint64_t *tmp6 = tmp + 25U; uint64_t *z1 = p + 10U; uint64_t *t1 = p + 15U; uint64_t *z2 = q + 10U; uint64_t *t2 = q + 15U; times_2d(tmp10, t1); fmul0(tmp10, tmp10, t2); times_2(tmp2, z1); fmul0(tmp2, tmp2, z2); fdifference(tmp5, tmp4, tmp3); fdifference(tmp6, tmp2, tmp10); fsum(tmp10, tmp2, tmp10); fsum(tmp2, tmp4, tmp3); uint64_t *tmp_g = tmp; uint64_t *tmp_h = tmp + 5U; uint64_t *tmp_e = tmp + 20U; uint64_t *tmp_f = tmp + 25U; uint64_t *x3 = out; uint64_t *y3 = out + 5U; uint64_t *z3 = out + 10U; uint64_t *t3 = out + 15U; fmul0(x3, tmp_e, tmp_f); fmul0(y3, tmp_g, tmp_h); fmul0(t3, tmp_e, tmp_h); fmul0(z3, tmp_f, tmp_g); } void Hacl_Impl_Ed25519_PointConstants_make_point_inf(uint64_t *b) { uint64_t *x = b; uint64_t *y = b + 5U; uint64_t *z = b + 10U; uint64_t *t = b + 15U; x[0U] = 0ULL; x[1U] = 0ULL; x[2U] = 0ULL; x[3U] = 0ULL; x[4U] = 0ULL; y[0U] = 1ULL; y[1U] = 0ULL; y[2U] = 0ULL; y[3U] = 0ULL; y[4U] = 0ULL; z[0U] = 1ULL; z[1U] = 0ULL; z[2U] = 0ULL; z[3U] = 0ULL; z[4U] = 0ULL; t[0U] = 0ULL; t[1U] = 0ULL; t[2U] = 0ULL; t[3U] = 0ULL; t[4U] = 0ULL; } static inline void pow2_252m2(uint64_t *out, uint64_t *z) { uint64_t buf[20U] = { 0U }; uint64_t *a = buf; uint64_t *t00 = buf + 5U; uint64_t *b0 = buf + 10U; uint64_t *c0 = buf + 15U; fsquare_times(a, z, 1U); fsquare_times(t00, a, 2U); fmul0(b0, t00, z); fmul0(a, b0, a); fsquare_times(t00, a, 1U); fmul0(b0, t00, b0); fsquare_times(t00, b0, 5U); fmul0(b0, t00, b0); fsquare_times(t00, b0, 10U); fmul0(c0, t00, b0); fsquare_times(t00, c0, 20U); fmul0(t00, t00, c0); fsquare_times_inplace(t00, 10U); fmul0(b0, t00, b0); fsquare_times(t00, b0, 50U); uint64_t *a0 = buf; uint64_t *t0 = buf + 5U; uint64_t *b = buf + 10U; uint64_t *c = buf + 15U; fsquare_times(a0, z, 1U); fmul0(c, t0, b); fsquare_times(t0, c, 100U); fmul0(t0, t0, c); fsquare_times_inplace(t0, 50U); fmul0(t0, t0, b); fsquare_times_inplace(t0, 2U); fmul0(out, t0, a0); } static inline bool is_0(uint64_t *x) { uint64_t x0 = x[0U]; uint64_t x1 = x[1U]; uint64_t x2 = x[2U]; uint64_t x3 = x[3U]; uint64_t x4 = x[4U]; return x0 == 0ULL && x1 == 0ULL && x2 == 0ULL && x3 == 0ULL && x4 == 0ULL; } static inline void mul_modp_sqrt_m1(uint64_t *x) { uint64_t sqrt_m1[5U] = { 0U }; sqrt_m1[0U] = 0x00061b274a0ea0b0ULL; sqrt_m1[1U] = 0x0000d5a5fc8f189dULL; sqrt_m1[2U] = 0x0007ef5e9cbd0c60ULL; sqrt_m1[3U] = 0x00078595a6804c9eULL; sqrt_m1[4U] = 0x0002b8324804fc1dULL; fmul0(x, x, sqrt_m1); } static inline bool recover_x(uint64_t *x, uint64_t *y, uint64_t sign) { uint64_t tmp[15U] = { 0U }; uint64_t *x2 = tmp; uint64_t x00 = y[0U]; uint64_t x1 = y[1U]; uint64_t x21 = y[2U]; uint64_t x30 = y[3U]; uint64_t x4 = y[4U]; bool b = x00 >= 0x7ffffffffffedULL && x1 == 0x7ffffffffffffULL && x21 == 0x7ffffffffffffULL && x30 == 0x7ffffffffffffULL && x4 == 0x7ffffffffffffULL; bool res; if (b) { res = false; } else { uint64_t tmp1[20U] = { 0U }; uint64_t *one = tmp1; uint64_t *y2 = tmp1 + 5U; uint64_t *dyyi = tmp1 + 10U; uint64_t *dyy = tmp1 + 15U; one[0U] = 1ULL; one[1U] = 0ULL; one[2U] = 0ULL; one[3U] = 0ULL; one[4U] = 0ULL; fsquare(y2, y); times_d(dyy, y2); fsum(dyy, dyy, one); Hacl_Bignum25519_reduce_513(dyy); Hacl_Bignum25519_inverse(dyyi, dyy); fdifference(x2, y2, one); fmul0(x2, x2, dyyi); reduce(x2); bool x2_is_0 = is_0(x2); uint8_t z; if (x2_is_0) { if (sign == 0ULL) { x[0U] = 0ULL; x[1U] = 0ULL; x[2U] = 0ULL; x[3U] = 0ULL; x[4U] = 0ULL; z = 1U; } else { z = 0U; } } else { z = 2U; } if (z == 0U) { res = false; } else if (z == 1U) { res = true; } else { uint64_t *x210 = tmp; uint64_t *x31 = tmp + 5U; uint64_t *t00 = tmp + 10U; pow2_252m2(x31, x210); fsquare(t00, x31); fdifference(t00, t00, x210); Hacl_Bignum25519_reduce_513(t00); reduce(t00); bool t0_is_0 = is_0(t00); if (!t0_is_0) { mul_modp_sqrt_m1(x31); } uint64_t *x211 = tmp; uint64_t *x3 = tmp + 5U; uint64_t *t01 = tmp + 10U; fsquare(t01, x3); fdifference(t01, t01, x211); Hacl_Bignum25519_reduce_513(t01); reduce(t01); bool z1 = is_0(t01); if (z1) { uint64_t *x32 = tmp + 5U; uint64_t *t0 = tmp + 10U; reduce(x32); uint64_t x0 = x32[0U]; uint64_t x01 = x0 & 1ULL; if (!(x01 == sign)) { t0[0U] = 0ULL; t0[1U] = 0ULL; t0[2U] = 0ULL; t0[3U] = 0ULL; t0[4U] = 0ULL; fdifference(x32, t0, x32); Hacl_Bignum25519_reduce_513(x32); reduce(x32); } memcpy(x, x32, 5U * sizeof (uint64_t)); res = true; } else { res = false; } } } bool res0 = res; return res0; } bool Hacl_Impl_Ed25519_PointDecompress_point_decompress(uint64_t *out, uint8_t *s) { uint64_t tmp[10U] = { 0U }; uint64_t *y = tmp; uint64_t *x = tmp + 5U; uint8_t s31 = s[31U]; uint8_t z = (uint32_t)s31 >> 7U; uint64_t sign = (uint64_t)z; Hacl_Bignum25519_load_51(y, s); bool z0 = recover_x(x, y, sign); bool res; if (z0) { uint64_t *outx = out; uint64_t *outy = out + 5U; uint64_t *outz = out + 10U; uint64_t *outt = out + 15U; memcpy(outx, x, 5U * sizeof (uint64_t)); memcpy(outy, y, 5U * sizeof (uint64_t)); outz[0U] = 1ULL; outz[1U] = 0ULL; outz[2U] = 0ULL; outz[3U] = 0ULL; outz[4U] = 0ULL; fmul0(outt, x, y); res = true; } else { res = false; } bool res0 = res; return res0; } void Hacl_Impl_Ed25519_PointCompress_point_compress(uint8_t *z, uint64_t *p) { uint64_t tmp[15U] = { 0U }; uint64_t *x = tmp + 5U; uint64_t *out = tmp + 10U; uint64_t *zinv1 = tmp; uint64_t *x1 = tmp + 5U; uint64_t *out1 = tmp + 10U; uint64_t *px = p; uint64_t *py = p + 5U; uint64_t *pz = p + 10U; Hacl_Bignum25519_inverse(zinv1, pz); fmul0(x1, px, zinv1); reduce(x1); fmul0(out1, py, zinv1); Hacl_Bignum25519_reduce_513(out1); uint64_t x0 = x[0U]; uint64_t b = x0 & 1ULL; Hacl_Bignum25519_store_51(z, out); uint8_t xbyte = (uint8_t)b; uint8_t o31 = z[31U]; z[31U] = (uint32_t)o31 + ((uint32_t)xbyte << 7U); } static inline void barrett_reduction(uint64_t *z, uint64_t *t) { uint64_t t0 = t[0U]; uint64_t t1 = t[1U]; uint64_t t2 = t[2U]; uint64_t t3 = t[3U]; uint64_t t4 = t[4U]; uint64_t t5 = t[5U]; uint64_t t6 = t[6U]; uint64_t t7 = t[7U]; uint64_t t8 = t[8U]; uint64_t t9 = t[9U]; uint64_t m00 = 0x12631a5cf5d3edULL; uint64_t m10 = 0xf9dea2f79cd658ULL; uint64_t m20 = 0x000000000014deULL; uint64_t m30 = 0x00000000000000ULL; uint64_t m40 = 0x00000010000000ULL; uint64_t m0 = m00; uint64_t m1 = m10; uint64_t m2 = m20; uint64_t m3 = m30; uint64_t m4 = m40; uint64_t m010 = 0x9ce5a30a2c131bULL; uint64_t m110 = 0x215d086329a7edULL; uint64_t m210 = 0xffffffffeb2106ULL; uint64_t m310 = 0xffffffffffffffULL; uint64_t m410 = 0x00000fffffffffULL; uint64_t mu0 = m010; uint64_t mu1 = m110; uint64_t mu2 = m210; uint64_t mu3 = m310; uint64_t mu4 = m410; uint64_t y_ = (t5 & 0xffffffULL) << 32U; uint64_t x_ = t4 >> 24U; uint64_t z00 = x_ | y_; uint64_t y_0 = (t6 & 0xffffffULL) << 32U; uint64_t x_0 = t5 >> 24U; uint64_t z10 = x_0 | y_0; uint64_t y_1 = (t7 & 0xffffffULL) << 32U; uint64_t x_1 = t6 >> 24U; uint64_t z20 = x_1 | y_1; uint64_t y_2 = (t8 & 0xffffffULL) << 32U; uint64_t x_2 = t7 >> 24U; uint64_t z30 = x_2 | y_2; uint64_t y_3 = (t9 & 0xffffffULL) << 32U; uint64_t x_3 = t8 >> 24U; uint64_t z40 = x_3 | y_3; uint64_t q0 = z00; uint64_t q1 = z10; uint64_t q2 = z20; uint64_t q3 = z30; uint64_t q4 = z40; FStar_UInt128_uint128 xy000 = FStar_UInt128_mul_wide(q0, mu0); FStar_UInt128_uint128 xy010 = FStar_UInt128_mul_wide(q0, mu1); FStar_UInt128_uint128 xy020 = FStar_UInt128_mul_wide(q0, mu2); FStar_UInt128_uint128 xy030 = FStar_UInt128_mul_wide(q0, mu3); FStar_UInt128_uint128 xy040 = FStar_UInt128_mul_wide(q0, mu4); FStar_UInt128_uint128 xy100 = FStar_UInt128_mul_wide(q1, mu0); FStar_UInt128_uint128 xy110 = FStar_UInt128_mul_wide(q1, mu1); FStar_UInt128_uint128 xy120 = FStar_UInt128_mul_wide(q1, mu2); FStar_UInt128_uint128 xy130 = FStar_UInt128_mul_wide(q1, mu3); FStar_UInt128_uint128 xy14 = FStar_UInt128_mul_wide(q1, mu4); FStar_UInt128_uint128 xy200 = FStar_UInt128_mul_wide(q2, mu0); FStar_UInt128_uint128 xy210 = FStar_UInt128_mul_wide(q2, mu1); FStar_UInt128_uint128 xy220 = FStar_UInt128_mul_wide(q2, mu2); FStar_UInt128_uint128 xy23 = FStar_UInt128_mul_wide(q2, mu3); FStar_UInt128_uint128 xy24 = FStar_UInt128_mul_wide(q2, mu4); FStar_UInt128_uint128 xy300 = FStar_UInt128_mul_wide(q3, mu0); FStar_UInt128_uint128 xy310 = FStar_UInt128_mul_wide(q3, mu1); FStar_UInt128_uint128 xy32 = FStar_UInt128_mul_wide(q3, mu2); FStar_UInt128_uint128 xy33 = FStar_UInt128_mul_wide(q3, mu3); FStar_UInt128_uint128 xy34 = FStar_UInt128_mul_wide(q3, mu4); FStar_UInt128_uint128 xy400 = FStar_UInt128_mul_wide(q4, mu0); FStar_UInt128_uint128 xy41 = FStar_UInt128_mul_wide(q4, mu1); FStar_UInt128_uint128 xy42 = FStar_UInt128_mul_wide(q4, mu2); FStar_UInt128_uint128 xy43 = FStar_UInt128_mul_wide(q4, mu3); FStar_UInt128_uint128 xy44 = FStar_UInt128_mul_wide(q4, mu4); FStar_UInt128_uint128 z01 = xy000; FStar_UInt128_uint128 z11 = FStar_UInt128_add_mod(xy010, xy100); FStar_UInt128_uint128 z21 = FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy020, xy110), xy200); FStar_UInt128_uint128 z31 = FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy030, xy120), xy210), xy300); FStar_UInt128_uint128 z41 = FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy040, xy130), xy220), xy310), xy400); FStar_UInt128_uint128 z5 = FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy14, xy23), xy32), xy41); FStar_UInt128_uint128 z6 = FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy24, xy33), xy42); FStar_UInt128_uint128 z7 = FStar_UInt128_add_mod(xy34, xy43); FStar_UInt128_uint128 z8 = xy44; FStar_UInt128_uint128 carry0 = FStar_UInt128_shift_right(z01, 56U); FStar_UInt128_uint128 c00 = carry0; FStar_UInt128_uint128 carry1 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z11, c00), 56U); FStar_UInt128_uint128 c10 = carry1; FStar_UInt128_uint128 carry2 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z21, c10), 56U); FStar_UInt128_uint128 c20 = carry2; FStar_UInt128_uint128 carry3 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z31, c20), 56U); FStar_UInt128_uint128 c30 = carry3; FStar_UInt128_uint128 carry4 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z41, c30), 56U); uint64_t t100 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(z41, c30)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c40 = carry4; uint64_t t410 = t100; FStar_UInt128_uint128 carry5 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z5, c40), 56U); uint64_t t101 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(z5, c40)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c5 = carry5; uint64_t t51 = t101; FStar_UInt128_uint128 carry6 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z6, c5), 56U); uint64_t t102 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(z6, c5)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c6 = carry6; uint64_t t61 = t102; FStar_UInt128_uint128 carry7 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z7, c6), 56U); uint64_t t103 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(z7, c6)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c7 = carry7; uint64_t t71 = t103; FStar_UInt128_uint128 carry8 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z8, c7), 56U); uint64_t t104 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(z8, c7)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c8 = carry8; uint64_t t81 = t104; uint64_t t91 = FStar_UInt128_uint128_to_uint64(c8); uint64_t qmu4_ = t410; uint64_t qmu5_ = t51; uint64_t qmu6_ = t61; uint64_t qmu7_ = t71; uint64_t qmu8_ = t81; uint64_t qmu9_ = t91; uint64_t y_4 = (qmu5_ & 0xffffffffffULL) << 16U; uint64_t x_4 = qmu4_ >> 40U; uint64_t z02 = x_4 | y_4; uint64_t y_5 = (qmu6_ & 0xffffffffffULL) << 16U; uint64_t x_5 = qmu5_ >> 40U; uint64_t z12 = x_5 | y_5; uint64_t y_6 = (qmu7_ & 0xffffffffffULL) << 16U; uint64_t x_6 = qmu6_ >> 40U; uint64_t z22 = x_6 | y_6; uint64_t y_7 = (qmu8_ & 0xffffffffffULL) << 16U; uint64_t x_7 = qmu7_ >> 40U; uint64_t z32 = x_7 | y_7; uint64_t y_8 = (qmu9_ & 0xffffffffffULL) << 16U; uint64_t x_8 = qmu8_ >> 40U; uint64_t z42 = x_8 | y_8; uint64_t qdiv0 = z02; uint64_t qdiv1 = z12; uint64_t qdiv2 = z22; uint64_t qdiv3 = z32; uint64_t qdiv4 = z42; uint64_t r0 = t0; uint64_t r1 = t1; uint64_t r2 = t2; uint64_t r3 = t3; uint64_t r4 = t4 & 0xffffffffffULL; FStar_UInt128_uint128 xy00 = FStar_UInt128_mul_wide(qdiv0, m0); FStar_UInt128_uint128 xy01 = FStar_UInt128_mul_wide(qdiv0, m1); FStar_UInt128_uint128 xy02 = FStar_UInt128_mul_wide(qdiv0, m2); FStar_UInt128_uint128 xy03 = FStar_UInt128_mul_wide(qdiv0, m3); FStar_UInt128_uint128 xy04 = FStar_UInt128_mul_wide(qdiv0, m4); FStar_UInt128_uint128 xy10 = FStar_UInt128_mul_wide(qdiv1, m0); FStar_UInt128_uint128 xy11 = FStar_UInt128_mul_wide(qdiv1, m1); FStar_UInt128_uint128 xy12 = FStar_UInt128_mul_wide(qdiv1, m2); FStar_UInt128_uint128 xy13 = FStar_UInt128_mul_wide(qdiv1, m3); FStar_UInt128_uint128 xy20 = FStar_UInt128_mul_wide(qdiv2, m0); FStar_UInt128_uint128 xy21 = FStar_UInt128_mul_wide(qdiv2, m1); FStar_UInt128_uint128 xy22 = FStar_UInt128_mul_wide(qdiv2, m2); FStar_UInt128_uint128 xy30 = FStar_UInt128_mul_wide(qdiv3, m0); FStar_UInt128_uint128 xy31 = FStar_UInt128_mul_wide(qdiv3, m1); FStar_UInt128_uint128 xy40 = FStar_UInt128_mul_wide(qdiv4, m0); FStar_UInt128_uint128 carry9 = FStar_UInt128_shift_right(xy00, 56U); uint64_t t105 = FStar_UInt128_uint128_to_uint64(xy00) & 0xffffffffffffffULL; FStar_UInt128_uint128 c0 = carry9; uint64_t t010 = t105; FStar_UInt128_uint128 carry10 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy01, xy10), c0), 56U); uint64_t t106 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy01, xy10), c0)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c11 = carry10; uint64_t t110 = t106; FStar_UInt128_uint128 carry11 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy02, xy11), xy20), c11), 56U); uint64_t t107 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy02, xy11), xy20), c11)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c21 = carry11; uint64_t t210 = t107; FStar_UInt128_uint128 carry = FStar_UInt128_shift_right(FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy03, xy12), xy21), xy30), c21), 56U); uint64_t t108 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy03, xy12), xy21), xy30), c21)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c31 = carry; uint64_t t310 = t108; uint64_t t411 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy04, xy13), xy22), xy31), xy40), c31)) & 0xffffffffffULL; uint64_t qmul0 = t010; uint64_t qmul1 = t110; uint64_t qmul2 = t210; uint64_t qmul3 = t310; uint64_t qmul4 = t411; uint64_t b5 = (r0 - qmul0) >> 63U; uint64_t t109 = (b5 << 56U) + r0 - qmul0; uint64_t c1 = b5; uint64_t t011 = t109; uint64_t b6 = (r1 - (qmul1 + c1)) >> 63U; uint64_t t1010 = (b6 << 56U) + r1 - (qmul1 + c1); uint64_t c2 = b6; uint64_t t111 = t1010; uint64_t b7 = (r2 - (qmul2 + c2)) >> 63U; uint64_t t1011 = (b7 << 56U) + r2 - (qmul2 + c2); uint64_t c3 = b7; uint64_t t211 = t1011; uint64_t b8 = (r3 - (qmul3 + c3)) >> 63U; uint64_t t1012 = (b8 << 56U) + r3 - (qmul3 + c3); uint64_t c4 = b8; uint64_t t311 = t1012; uint64_t b9 = (r4 - (qmul4 + c4)) >> 63U; uint64_t t1013 = (b9 << 40U) + r4 - (qmul4 + c4); uint64_t t412 = t1013; uint64_t s0 = t011; uint64_t s1 = t111; uint64_t s2 = t211; uint64_t s3 = t311; uint64_t s4 = t412; uint64_t m01 = 0x12631a5cf5d3edULL; uint64_t m11 = 0xf9dea2f79cd658ULL; uint64_t m21 = 0x000000000014deULL; uint64_t m31 = 0x00000000000000ULL; uint64_t m41 = 0x00000010000000ULL; uint64_t y0 = m01; uint64_t y1 = m11; uint64_t y2 = m21; uint64_t y3 = m31; uint64_t y4 = m41; uint64_t b10 = (s0 - y0) >> 63U; uint64_t t1014 = (b10 << 56U) + s0 - y0; uint64_t b0 = b10; uint64_t t01 = t1014; uint64_t b11 = (s1 - (y1 + b0)) >> 63U; uint64_t t1015 = (b11 << 56U) + s1 - (y1 + b0); uint64_t b1 = b11; uint64_t t11 = t1015; uint64_t b12 = (s2 - (y2 + b1)) >> 63U; uint64_t t1016 = (b12 << 56U) + s2 - (y2 + b1); uint64_t b2 = b12; uint64_t t21 = t1016; uint64_t b13 = (s3 - (y3 + b2)) >> 63U; uint64_t t1017 = (b13 << 56U) + s3 - (y3 + b2); uint64_t b3 = b13; uint64_t t31 = t1017; uint64_t b = (s4 - (y4 + b3)) >> 63U; uint64_t t10 = (b << 56U) + s4 - (y4 + b3); uint64_t b4 = b; uint64_t t41 = t10; uint64_t mask = b4 - 1ULL; uint64_t z03 = s0 ^ (mask & (s0 ^ t01)); uint64_t z13 = s1 ^ (mask & (s1 ^ t11)); uint64_t z23 = s2 ^ (mask & (s2 ^ t21)); uint64_t z33 = s3 ^ (mask & (s3 ^ t31)); uint64_t z43 = s4 ^ (mask & (s4 ^ t41)); uint64_t z04 = z03; uint64_t z14 = z13; uint64_t z24 = z23; uint64_t z34 = z33; uint64_t z44 = z43; uint64_t o0 = z04; uint64_t o1 = z14; uint64_t o2 = z24; uint64_t o3 = z34; uint64_t o4 = z44; uint64_t z0 = o0; uint64_t z1 = o1; uint64_t z2 = o2; uint64_t z3 = o3; uint64_t z4 = o4; z[0U] = z0; z[1U] = z1; z[2U] = z2; z[3U] = z3; z[4U] = z4; } static inline void mul_modq(uint64_t *out, uint64_t *x, uint64_t *y) { uint64_t tmp[10U] = { 0U }; uint64_t x0 = x[0U]; uint64_t x1 = x[1U]; uint64_t x2 = x[2U]; uint64_t x3 = x[3U]; uint64_t x4 = x[4U]; uint64_t y0 = y[0U]; uint64_t y1 = y[1U]; uint64_t y2 = y[2U]; uint64_t y3 = y[3U]; uint64_t y4 = y[4U]; FStar_UInt128_uint128 xy00 = FStar_UInt128_mul_wide(x0, y0); FStar_UInt128_uint128 xy01 = FStar_UInt128_mul_wide(x0, y1); FStar_UInt128_uint128 xy02 = FStar_UInt128_mul_wide(x0, y2); FStar_UInt128_uint128 xy03 = FStar_UInt128_mul_wide(x0, y3); FStar_UInt128_uint128 xy04 = FStar_UInt128_mul_wide(x0, y4); FStar_UInt128_uint128 xy10 = FStar_UInt128_mul_wide(x1, y0); FStar_UInt128_uint128 xy11 = FStar_UInt128_mul_wide(x1, y1); FStar_UInt128_uint128 xy12 = FStar_UInt128_mul_wide(x1, y2); FStar_UInt128_uint128 xy13 = FStar_UInt128_mul_wide(x1, y3); FStar_UInt128_uint128 xy14 = FStar_UInt128_mul_wide(x1, y4); FStar_UInt128_uint128 xy20 = FStar_UInt128_mul_wide(x2, y0); FStar_UInt128_uint128 xy21 = FStar_UInt128_mul_wide(x2, y1); FStar_UInt128_uint128 xy22 = FStar_UInt128_mul_wide(x2, y2); FStar_UInt128_uint128 xy23 = FStar_UInt128_mul_wide(x2, y3); FStar_UInt128_uint128 xy24 = FStar_UInt128_mul_wide(x2, y4); FStar_UInt128_uint128 xy30 = FStar_UInt128_mul_wide(x3, y0); FStar_UInt128_uint128 xy31 = FStar_UInt128_mul_wide(x3, y1); FStar_UInt128_uint128 xy32 = FStar_UInt128_mul_wide(x3, y2); FStar_UInt128_uint128 xy33 = FStar_UInt128_mul_wide(x3, y3); FStar_UInt128_uint128 xy34 = FStar_UInt128_mul_wide(x3, y4); FStar_UInt128_uint128 xy40 = FStar_UInt128_mul_wide(x4, y0); FStar_UInt128_uint128 xy41 = FStar_UInt128_mul_wide(x4, y1); FStar_UInt128_uint128 xy42 = FStar_UInt128_mul_wide(x4, y2); FStar_UInt128_uint128 xy43 = FStar_UInt128_mul_wide(x4, y3); FStar_UInt128_uint128 xy44 = FStar_UInt128_mul_wide(x4, y4); FStar_UInt128_uint128 z00 = xy00; FStar_UInt128_uint128 z10 = FStar_UInt128_add_mod(xy01, xy10); FStar_UInt128_uint128 z20 = FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy02, xy11), xy20); FStar_UInt128_uint128 z30 = FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy03, xy12), xy21), xy30); FStar_UInt128_uint128 z40 = FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy04, xy13), xy22), xy31), xy40); FStar_UInt128_uint128 z50 = FStar_UInt128_add_mod(FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy14, xy23), xy32), xy41); FStar_UInt128_uint128 z60 = FStar_UInt128_add_mod(FStar_UInt128_add_mod(xy24, xy33), xy42); FStar_UInt128_uint128 z70 = FStar_UInt128_add_mod(xy34, xy43); FStar_UInt128_uint128 z80 = xy44; FStar_UInt128_uint128 carry0 = FStar_UInt128_shift_right(z00, 56U); uint64_t t10 = FStar_UInt128_uint128_to_uint64(z00) & 0xffffffffffffffULL; FStar_UInt128_uint128 c0 = carry0; uint64_t t0 = t10; FStar_UInt128_uint128 carry1 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z10, c0), 56U); uint64_t t11 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(z10, c0)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c1 = carry1; uint64_t t1 = t11; FStar_UInt128_uint128 carry2 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z20, c1), 56U); uint64_t t12 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(z20, c1)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c2 = carry2; uint64_t t2 = t12; FStar_UInt128_uint128 carry3 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z30, c2), 56U); uint64_t t13 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(z30, c2)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c3 = carry3; uint64_t t3 = t13; FStar_UInt128_uint128 carry4 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z40, c3), 56U); uint64_t t14 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(z40, c3)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c4 = carry4; uint64_t t4 = t14; FStar_UInt128_uint128 carry5 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z50, c4), 56U); uint64_t t15 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(z50, c4)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c5 = carry5; uint64_t t5 = t15; FStar_UInt128_uint128 carry6 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z60, c5), 56U); uint64_t t16 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(z60, c5)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c6 = carry6; uint64_t t6 = t16; FStar_UInt128_uint128 carry7 = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z70, c6), 56U); uint64_t t17 = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(z70, c6)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c7 = carry7; uint64_t t7 = t17; FStar_UInt128_uint128 carry = FStar_UInt128_shift_right(FStar_UInt128_add_mod(z80, c7), 56U); uint64_t t = FStar_UInt128_uint128_to_uint64(FStar_UInt128_add_mod(z80, c7)) & 0xffffffffffffffULL; FStar_UInt128_uint128 c8 = carry; uint64_t t8 = t; uint64_t t9 = FStar_UInt128_uint128_to_uint64(c8); uint64_t z0 = t0; uint64_t z1 = t1; uint64_t z2 = t2; uint64_t z3 = t3; uint64_t z4 = t4; uint64_t z5 = t5; uint64_t z6 = t6; uint64_t z7 = t7; uint64_t z8 = t8; uint64_t z9 = t9; tmp[0U] = z0; tmp[1U] = z1; tmp[2U] = z2; tmp[3U] = z3; tmp[4U] = z4; tmp[5U] = z5; tmp[6U] = z6; tmp[7U] = z7; tmp[8U] = z8; tmp[9U] = z9; barrett_reduction(out, tmp); } static inline void add_modq(uint64_t *out, uint64_t *x, uint64_t *y) { uint64_t x0 = x[0U]; uint64_t x1 = x[1U]; uint64_t x2 = x[2U]; uint64_t x3 = x[3U]; uint64_t x4 = x[4U]; uint64_t y0 = y[0U]; uint64_t y1 = y[1U]; uint64_t y2 = y[2U]; uint64_t y3 = y[3U]; uint64_t y4 = y[4U]; uint64_t carry0 = (x0 + y0) >> 56U; uint64_t t0 = (x0 + y0) & 0xffffffffffffffULL; uint64_t t00 = t0; uint64_t c0 = carry0; uint64_t carry1 = (x1 + y1 + c0) >> 56U; uint64_t t1 = (x1 + y1 + c0) & 0xffffffffffffffULL; uint64_t t10 = t1; uint64_t c1 = carry1; uint64_t carry2 = (x2 + y2 + c1) >> 56U; uint64_t t2 = (x2 + y2 + c1) & 0xffffffffffffffULL; uint64_t t20 = t2; uint64_t c2 = carry2; uint64_t carry = (x3 + y3 + c2) >> 56U; uint64_t t3 = (x3 + y3 + c2) & 0xffffffffffffffULL; uint64_t t30 = t3; uint64_t c3 = carry; uint64_t t4 = x4 + y4 + c3; uint64_t m0 = 0x12631a5cf5d3edULL; uint64_t m1 = 0xf9dea2f79cd658ULL; uint64_t m2 = 0x000000000014deULL; uint64_t m3 = 0x00000000000000ULL; uint64_t m4 = 0x00000010000000ULL; uint64_t y01 = m0; uint64_t y11 = m1; uint64_t y21 = m2; uint64_t y31 = m3; uint64_t y41 = m4; uint64_t b5 = (t00 - y01) >> 63U; uint64_t t5 = (b5 << 56U) + t00 - y01; uint64_t b0 = b5; uint64_t t01 = t5; uint64_t b6 = (t10 - (y11 + b0)) >> 63U; uint64_t t6 = (b6 << 56U) + t10 - (y11 + b0); uint64_t b1 = b6; uint64_t t11 = t6; uint64_t b7 = (t20 - (y21 + b1)) >> 63U; uint64_t t7 = (b7 << 56U) + t20 - (y21 + b1); uint64_t b2 = b7; uint64_t t21 = t7; uint64_t b8 = (t30 - (y31 + b2)) >> 63U; uint64_t t8 = (b8 << 56U) + t30 - (y31 + b2); uint64_t b3 = b8; uint64_t t31 = t8; uint64_t b = (t4 - (y41 + b3)) >> 63U; uint64_t t = (b << 56U) + t4 - (y41 + b3); uint64_t b4 = b; uint64_t t41 = t; uint64_t mask = b4 - 1ULL; uint64_t z00 = t00 ^ (mask & (t00 ^ t01)); uint64_t z10 = t10 ^ (mask & (t10 ^ t11)); uint64_t z20 = t20 ^ (mask & (t20 ^ t21)); uint64_t z30 = t30 ^ (mask & (t30 ^ t31)); uint64_t z40 = t4 ^ (mask & (t4 ^ t41)); uint64_t z01 = z00; uint64_t z11 = z10; uint64_t z21 = z20; uint64_t z31 = z30; uint64_t z41 = z40; uint64_t o0 = z01; uint64_t o1 = z11; uint64_t o2 = z21; uint64_t o3 = z31; uint64_t o4 = z41; uint64_t z0 = o0; uint64_t z1 = o1; uint64_t z2 = o2; uint64_t z3 = o3; uint64_t z4 = o4; out[0U] = z0; out[1U] = z1; out[2U] = z2; out[3U] = z3; out[4U] = z4; } static inline bool gte_q(uint64_t *s) { uint64_t s0 = s[0U]; uint64_t s1 = s[1U]; uint64_t s2 = s[2U]; uint64_t s3 = s[3U]; uint64_t s4 = s[4U]; if (s4 > 0x00000010000000ULL) { return true; } if (s4 < 0x00000010000000ULL) { return false; } if (s3 > 0x00000000000000ULL || s2 > 0x000000000014deULL) { return true; } if (s2 < 0x000000000014deULL) { return false; } if (s1 > 0xf9dea2f79cd658ULL) { return true; } if (s1 < 0xf9dea2f79cd658ULL) { return false; } return s0 >= 0x12631a5cf5d3edULL; } static inline bool eq(uint64_t *a, uint64_t *b) { uint64_t a0 = a[0U]; uint64_t a1 = a[1U]; uint64_t a2 = a[2U]; uint64_t a3 = a[3U]; uint64_t a4 = a[4U]; uint64_t b0 = b[0U]; uint64_t b1 = b[1U]; uint64_t b2 = b[2U]; uint64_t b3 = b[3U]; uint64_t b4 = b[4U]; return a0 == b0 && a1 == b1 && a2 == b2 && a3 == b3 && a4 == b4; } bool Hacl_Impl_Ed25519_PointEqual_point_equal(uint64_t *p, uint64_t *q) { uint64_t tmp[20U] = { 0U }; uint64_t *pxqz = tmp; uint64_t *qxpz = tmp + 5U; fmul0(pxqz, p, q + 10U); reduce(pxqz); fmul0(qxpz, q, p + 10U); reduce(qxpz); bool b = eq(pxqz, qxpz); if (b) { uint64_t *pyqz = tmp + 10U; uint64_t *qypz = tmp + 15U; fmul0(pyqz, p + 5U, q + 10U); reduce(pyqz); fmul0(qypz, q + 5U, p + 10U); reduce(qypz); return eq(pyqz, qypz); } return false; } void Hacl_Impl_Ed25519_PointNegate_point_negate(uint64_t *p, uint64_t *out) { uint64_t zero[5U] = { 0U }; zero[0U] = 0ULL; zero[1U] = 0ULL; zero[2U] = 0ULL; zero[3U] = 0ULL; zero[4U] = 0ULL; uint64_t *x = p; uint64_t *y = p + 5U; uint64_t *z = p + 10U; uint64_t *t = p + 15U; uint64_t *x1 = out; uint64_t *y1 = out + 5U; uint64_t *z1 = out + 10U; uint64_t *t1 = out + 15U; fdifference(x1, zero, x); Hacl_Bignum25519_reduce_513(x1); memcpy(y1, y, 5U * sizeof (uint64_t)); memcpy(z1, z, 5U * sizeof (uint64_t)); fdifference(t1, zero, t); Hacl_Bignum25519_reduce_513(t1); } void Hacl_Impl_Ed25519_Ladder_point_mul(uint64_t *out, uint8_t *scalar, uint64_t *q) { uint64_t bscalar[4U] = { 0U }; KRML_MAYBE_FOR4(i, 0U, 4U, 1U, uint64_t *os = bscalar; uint8_t *bj = scalar + i * 8U; uint64_t u = load64_le(bj); uint64_t r = u; uint64_t x = r; os[i] = x;); uint64_t table[320U] = { 0U }; uint64_t tmp[20U] = { 0U }; uint64_t *t0 = table; uint64_t *t1 = table + 20U; Hacl_Impl_Ed25519_PointConstants_make_point_inf(t0); memcpy(t1, q, 20U * sizeof (uint64_t)); KRML_MAYBE_FOR7(i, 0U, 7U, 1U, uint64_t *t11 = table + (i + 1U) * 20U; Hacl_Impl_Ed25519_PointDouble_point_double(tmp, t11); memcpy(table + (2U * i + 2U) * 20U, tmp, 20U * sizeof (uint64_t)); uint64_t *t2 = table + (2U * i + 2U) * 20U; Hacl_Impl_Ed25519_PointAdd_point_add(tmp, q, t2); memcpy(table + (2U * i + 3U) * 20U, tmp, 20U * sizeof (uint64_t));); Hacl_Impl_Ed25519_PointConstants_make_point_inf(out); uint64_t tmp0[20U] = { 0U }; for (uint32_t i0 = 0U; i0 < 64U; i0++) { KRML_MAYBE_FOR4(i, 0U, 4U, 1U, Hacl_Impl_Ed25519_PointDouble_point_double(out, out);); uint32_t k = 256U - 4U * i0 - 4U; uint64_t bits_l = Hacl_Bignum_Lib_bn_get_bits_u64(4U, bscalar, k, 4U); memcpy(tmp0, (uint64_t *)table, 20U * sizeof (uint64_t)); KRML_MAYBE_FOR15(i1, 0U, 15U, 1U, uint64_t c = FStar_UInt64_eq_mask(bits_l, (uint64_t)(i1 + 1U)); const uint64_t *res_j = table + (i1 + 1U) * 20U; for (uint32_t i = 0U; i < 20U; i++) { uint64_t *os = tmp0; uint64_t x = (c & res_j[i]) | (~c & tmp0[i]); os[i] = x; }); Hacl_Impl_Ed25519_PointAdd_point_add(out, out, tmp0); } } static inline void precomp_get_consttime(const uint64_t *table, uint64_t bits_l, uint64_t *tmp) { memcpy(tmp, (uint64_t *)table, 20U * sizeof (uint64_t)); KRML_MAYBE_FOR15(i0, 0U, 15U, 1U, uint64_t c = FStar_UInt64_eq_mask(bits_l, (uint64_t)(i0 + 1U)); const uint64_t *res_j = table + (i0 + 1U) * 20U; for (uint32_t i = 0U; i < 20U; i++) { uint64_t *os = tmp; uint64_t x = (c & res_j[i]) | (~c & tmp[i]); os[i] = x; }); } static inline void point_mul_g(uint64_t *out, uint8_t *scalar) { uint64_t bscalar[4U] = { 0U }; KRML_MAYBE_FOR4(i, 0U, 4U, 1U, uint64_t *os = bscalar; uint8_t *bj = scalar + i * 8U; uint64_t u = load64_le(bj); uint64_t r = u; uint64_t x = r; os[i] = x;); uint64_t q1[20U] = { 0U }; uint64_t *gx = q1; uint64_t *gy = q1 + 5U; uint64_t *gz = q1 + 10U; uint64_t *gt = q1 + 15U; gx[0U] = 0x00062d608f25d51aULL; gx[1U] = 0x000412a4b4f6592aULL; gx[2U] = 0x00075b7171a4b31dULL; gx[3U] = 0x0001ff60527118feULL; gx[4U] = 0x000216936d3cd6e5ULL; gy[0U] = 0x0006666666666658ULL; gy[1U] = 0x0004ccccccccccccULL; gy[2U] = 0x0001999999999999ULL; gy[3U] = 0x0003333333333333ULL; gy[4U] = 0x0006666666666666ULL; gz[0U] = 1ULL; gz[1U] = 0ULL; gz[2U] = 0ULL; gz[3U] = 0ULL; gz[4U] = 0ULL; gt[0U] = 0x00068ab3a5b7dda3ULL; gt[1U] = 0x00000eea2a5eadbbULL; gt[2U] = 0x0002af8df483c27eULL; gt[3U] = 0x000332b375274732ULL; gt[4U] = 0x00067875f0fd78b7ULL; uint64_t q2[20U] = { 13559344787725ULL, 2051621493703448ULL, 1947659315640708ULL, 626856790370168ULL, 1592804284034836ULL, 1781728767459187ULL, 278818420518009ULL, 2038030359908351ULL, 910625973862690ULL, 471887343142239ULL, 1298543306606048ULL, 794147365642417ULL, 129968992326749ULL, 523140861678572ULL, 1166419653909231ULL, 2009637196928390ULL, 1288020222395193ULL, 1007046974985829ULL, 208981102651386ULL, 2074009315253380ULL }; uint64_t q3[20U] = { 557549315715710ULL, 196756086293855ULL, 846062225082495ULL, 1865068224838092ULL, 991112090754908ULL, 522916421512828ULL, 2098523346722375ULL, 1135633221747012ULL, 858420432114866ULL, 186358544306082ULL, 1044420411868480ULL, 2080052304349321ULL, 557301814716724ULL, 1305130257814057ULL, 2126012765451197ULL, 1441004402875101ULL, 353948968859203ULL, 470765987164835ULL, 1507675957683570ULL, 1086650358745097ULL }; uint64_t q4[20U] = { 1129953239743101ULL, 1240339163956160ULL, 61002583352401ULL, 2017604552196030ULL, 1576867829229863ULL, 1508654942849389ULL, 270111619664077ULL, 1253097517254054ULL, 721798270973250ULL, 161923365415298ULL, 828530877526011ULL, 1494851059386763ULL, 662034171193976ULL, 1315349646974670ULL, 2199229517308806ULL, 497078277852673ULL, 1310507715989956ULL, 1881315714002105ULL, 2214039404983803ULL, 1331036420272667ULL }; uint64_t *r1 = bscalar; uint64_t *r2 = bscalar + 1U; uint64_t *r3 = bscalar + 2U; uint64_t *r4 = bscalar + 3U; Hacl_Impl_Ed25519_PointConstants_make_point_inf(out); uint64_t tmp[20U] = { 0U }; KRML_MAYBE_FOR16(i, 0U, 16U, 1U, KRML_MAYBE_FOR4(i0, 0U, 4U, 1U, Hacl_Impl_Ed25519_PointDouble_point_double(out, out);); uint32_t k = 64U - 4U * i - 4U; uint64_t bits_l = Hacl_Bignum_Lib_bn_get_bits_u64(1U, r4, k, 4U); precomp_get_consttime(Hacl_Ed25519_PrecompTable_precomp_g_pow2_192_table_w4, bits_l, tmp); Hacl_Impl_Ed25519_PointAdd_point_add(out, out, tmp); uint32_t k0 = 64U - 4U * i - 4U; uint64_t bits_l0 = Hacl_Bignum_Lib_bn_get_bits_u64(1U, r3, k0, 4U); precomp_get_consttime(Hacl_Ed25519_PrecompTable_precomp_g_pow2_128_table_w4, bits_l0, tmp); Hacl_Impl_Ed25519_PointAdd_point_add(out, out, tmp); uint32_t k1 = 64U - 4U * i - 4U; uint64_t bits_l1 = Hacl_Bignum_Lib_bn_get_bits_u64(1U, r2, k1, 4U); precomp_get_consttime(Hacl_Ed25519_PrecompTable_precomp_g_pow2_64_table_w4, bits_l1, tmp); Hacl_Impl_Ed25519_PointAdd_point_add(out, out, tmp); uint32_t k2 = 64U - 4U * i - 4U; uint64_t bits_l2 = Hacl_Bignum_Lib_bn_get_bits_u64(1U, r1, k2, 4U); precomp_get_consttime(Hacl_Ed25519_PrecompTable_precomp_basepoint_table_w4, bits_l2, tmp); Hacl_Impl_Ed25519_PointAdd_point_add(out, out, tmp);); KRML_MAYBE_UNUSED_VAR(q2); KRML_MAYBE_UNUSED_VAR(q3); KRML_MAYBE_UNUSED_VAR(q4); } static inline void point_mul_g_double_vartime(uint64_t *out, uint8_t *scalar1, uint8_t *scalar2, uint64_t *q2) { uint64_t tmp[28U] = { 0U }; uint64_t *g = tmp; uint64_t *bscalar1 = tmp + 20U; uint64_t *bscalar2 = tmp + 24U; uint64_t *gx = g; uint64_t *gy = g + 5U; uint64_t *gz = g + 10U; uint64_t *gt = g + 15U; gx[0U] = 0x00062d608f25d51aULL; gx[1U] = 0x000412a4b4f6592aULL; gx[2U] = 0x00075b7171a4b31dULL; gx[3U] = 0x0001ff60527118feULL; gx[4U] = 0x000216936d3cd6e5ULL; gy[0U] = 0x0006666666666658ULL; gy[1U] = 0x0004ccccccccccccULL; gy[2U] = 0x0001999999999999ULL; gy[3U] = 0x0003333333333333ULL; gy[4U] = 0x0006666666666666ULL; gz[0U] = 1ULL; gz[1U] = 0ULL; gz[2U] = 0ULL; gz[3U] = 0ULL; gz[4U] = 0ULL; gt[0U] = 0x00068ab3a5b7dda3ULL; gt[1U] = 0x00000eea2a5eadbbULL; gt[2U] = 0x0002af8df483c27eULL; gt[3U] = 0x000332b375274732ULL; gt[4U] = 0x00067875f0fd78b7ULL; KRML_MAYBE_FOR4(i, 0U, 4U, 1U, uint64_t *os = bscalar1; uint8_t *bj = scalar1 + i * 8U; uint64_t u = load64_le(bj); uint64_t r = u; uint64_t x = r; os[i] = x;); KRML_MAYBE_FOR4(i, 0U, 4U, 1U, uint64_t *os = bscalar2; uint8_t *bj = scalar2 + i * 8U; uint64_t u = load64_le(bj); uint64_t r = u; uint64_t x = r; os[i] = x;); uint64_t table2[640U] = { 0U }; uint64_t tmp1[20U] = { 0U }; uint64_t *t0 = table2; uint64_t *t1 = table2 + 20U; Hacl_Impl_Ed25519_PointConstants_make_point_inf(t0); memcpy(t1, q2, 20U * sizeof (uint64_t)); KRML_MAYBE_FOR15(i, 0U, 15U, 1U, uint64_t *t11 = table2 + (i + 1U) * 20U; Hacl_Impl_Ed25519_PointDouble_point_double(tmp1, t11); memcpy(table2 + (2U * i + 2U) * 20U, tmp1, 20U * sizeof (uint64_t)); uint64_t *t2 = table2 + (2U * i + 2U) * 20U; Hacl_Impl_Ed25519_PointAdd_point_add(tmp1, q2, t2); memcpy(table2 + (2U * i + 3U) * 20U, tmp1, 20U * sizeof (uint64_t));); uint64_t tmp10[20U] = { 0U }; uint32_t i0 = 255U; uint64_t bits_c = Hacl_Bignum_Lib_bn_get_bits_u64(4U, bscalar1, i0, 5U); uint32_t bits_l32 = (uint32_t)bits_c; const uint64_t *a_bits_l = Hacl_Ed25519_PrecompTable_precomp_basepoint_table_w5 + bits_l32 * 20U; memcpy(out, (uint64_t *)a_bits_l, 20U * sizeof (uint64_t)); uint32_t i1 = 255U; uint64_t bits_c0 = Hacl_Bignum_Lib_bn_get_bits_u64(4U, bscalar2, i1, 5U); uint32_t bits_l320 = (uint32_t)bits_c0; const uint64_t *a_bits_l0 = table2 + bits_l320 * 20U; memcpy(tmp10, (uint64_t *)a_bits_l0, 20U * sizeof (uint64_t)); Hacl_Impl_Ed25519_PointAdd_point_add(out, out, tmp10); uint64_t tmp11[20U] = { 0U }; for (uint32_t i = 0U; i < 51U; i++) { KRML_MAYBE_FOR5(i2, 0U, 5U, 1U, Hacl_Impl_Ed25519_PointDouble_point_double(out, out);); uint32_t k = 255U - 5U * i - 5U; uint64_t bits_l = Hacl_Bignum_Lib_bn_get_bits_u64(4U, bscalar2, k, 5U); uint32_t bits_l321 = (uint32_t)bits_l; const uint64_t *a_bits_l1 = table2 + bits_l321 * 20U; memcpy(tmp11, (uint64_t *)a_bits_l1, 20U * sizeof (uint64_t)); Hacl_Impl_Ed25519_PointAdd_point_add(out, out, tmp11); uint32_t k0 = 255U - 5U * i - 5U; uint64_t bits_l0 = Hacl_Bignum_Lib_bn_get_bits_u64(4U, bscalar1, k0, 5U); uint32_t bits_l322 = (uint32_t)bits_l0; const uint64_t *a_bits_l2 = Hacl_Ed25519_PrecompTable_precomp_basepoint_table_w5 + bits_l322 * 20U; memcpy(tmp11, (uint64_t *)a_bits_l2, 20U * sizeof (uint64_t)); Hacl_Impl_Ed25519_PointAdd_point_add(out, out, tmp11); } } static inline void point_negate_mul_double_g_vartime( uint64_t *out, uint8_t *scalar1, uint8_t *scalar2, uint64_t *q2 ) { uint64_t q2_neg[20U] = { 0U }; Hacl_Impl_Ed25519_PointNegate_point_negate(q2, q2_neg); point_mul_g_double_vartime(out, scalar1, scalar2, q2_neg); } static inline void store_56(uint8_t *out, uint64_t *b) { uint64_t b0 = b[0U]; uint64_t b1 = b[1U]; uint64_t b2 = b[2U]; uint64_t b3 = b[3U]; uint64_t b4 = b[4U]; uint32_t b4_ = (uint32_t)b4; uint8_t *b8 = out; store64_le(b8, b0); uint8_t *b80 = out + 7U; store64_le(b80, b1); uint8_t *b81 = out + 14U; store64_le(b81, b2); uint8_t *b82 = out + 21U; store64_le(b82, b3); store32_le(out + 28U, b4_); } static inline void load_64_bytes(uint64_t *out, uint8_t *b) { uint8_t *b80 = b; uint64_t u = load64_le(b80); uint64_t z = u; uint64_t b0 = z & 0xffffffffffffffULL; uint8_t *b81 = b + 7U; uint64_t u0 = load64_le(b81); uint64_t z0 = u0; uint64_t b1 = z0 & 0xffffffffffffffULL; uint8_t *b82 = b + 14U; uint64_t u1 = load64_le(b82); uint64_t z1 = u1; uint64_t b2 = z1 & 0xffffffffffffffULL; uint8_t *b83 = b + 21U; uint64_t u2 = load64_le(b83); uint64_t z2 = u2; uint64_t b3 = z2 & 0xffffffffffffffULL; uint8_t *b84 = b + 28U; uint64_t u3 = load64_le(b84); uint64_t z3 = u3; uint64_t b4 = z3 & 0xffffffffffffffULL; uint8_t *b85 = b + 35U; uint64_t u4 = load64_le(b85); uint64_t z4 = u4; uint64_t b5 = z4 & 0xffffffffffffffULL; uint8_t *b86 = b + 42U; uint64_t u5 = load64_le(b86); uint64_t z5 = u5; uint64_t b6 = z5 & 0xffffffffffffffULL; uint8_t *b87 = b + 49U; uint64_t u6 = load64_le(b87); uint64_t z6 = u6; uint64_t b7 = z6 & 0xffffffffffffffULL; uint8_t *b8 = b + 56U; uint64_t u7 = load64_le(b8); uint64_t z7 = u7; uint64_t b88 = z7 & 0xffffffffffffffULL; uint8_t b63 = b[63U]; uint64_t b9 = (uint64_t)b63; out[0U] = b0; out[1U] = b1; out[2U] = b2; out[3U] = b3; out[4U] = b4; out[5U] = b5; out[6U] = b6; out[7U] = b7; out[8U] = b88; out[9U] = b9; } static inline void load_32_bytes(uint64_t *out, uint8_t *b) { uint8_t *b80 = b; uint64_t u0 = load64_le(b80); uint64_t z = u0; uint64_t b0 = z & 0xffffffffffffffULL; uint8_t *b81 = b + 7U; uint64_t u1 = load64_le(b81); uint64_t z0 = u1; uint64_t b1 = z0 & 0xffffffffffffffULL; uint8_t *b82 = b + 14U; uint64_t u2 = load64_le(b82); uint64_t z1 = u2; uint64_t b2 = z1 & 0xffffffffffffffULL; uint8_t *b8 = b + 21U; uint64_t u3 = load64_le(b8); uint64_t z2 = u3; uint64_t b3 = z2 & 0xffffffffffffffULL; uint32_t u = load32_le(b + 28U); uint32_t b4 = u; uint64_t b41 = (uint64_t)b4; out[0U] = b0; out[1U] = b1; out[2U] = b2; out[3U] = b3; out[4U] = b41; } static inline void sha512_pre_msg(uint8_t *hash, uint8_t *prefix, uint32_t len, uint8_t *input) { uint8_t buf[128U] = { 0U }; uint64_t block_state[8U] = { 0U }; Hacl_Streaming_MD_state_64 s = { .block_state = block_state, .buf = buf, .total_len = (uint64_t)0U }; Hacl_Streaming_MD_state_64 p = s; Hacl_Hash_SHA2_sha512_init(block_state); Hacl_Streaming_MD_state_64 *st = &p; Hacl_Streaming_Types_error_code err0 = Hacl_Hash_SHA2_update_512(st, prefix, 32U); Hacl_Streaming_Types_error_code err1 = Hacl_Hash_SHA2_update_512(st, input, len); KRML_MAYBE_UNUSED_VAR(err0); KRML_MAYBE_UNUSED_VAR(err1); Hacl_Hash_SHA2_digest_512(st, hash); } static inline void sha512_pre_pre2_msg( uint8_t *hash, uint8_t *prefix, uint8_t *prefix2, uint32_t len, uint8_t *input ) { uint8_t buf[128U] = { 0U }; uint64_t block_state[8U] = { 0U }; Hacl_Streaming_MD_state_64 s = { .block_state = block_state, .buf = buf, .total_len = (uint64_t)0U }; Hacl_Streaming_MD_state_64 p = s; Hacl_Hash_SHA2_sha512_init(block_state); Hacl_Streaming_MD_state_64 *st = &p; Hacl_Streaming_Types_error_code err0 = Hacl_Hash_SHA2_update_512(st, prefix, 32U); Hacl_Streaming_Types_error_code err1 = Hacl_Hash_SHA2_update_512(st, prefix2, 32U); Hacl_Streaming_Types_error_code err2 = Hacl_Hash_SHA2_update_512(st, input, len); KRML_MAYBE_UNUSED_VAR(err0); KRML_MAYBE_UNUSED_VAR(err1); KRML_MAYBE_UNUSED_VAR(err2); Hacl_Hash_SHA2_digest_512(st, hash); } static inline void sha512_modq_pre(uint64_t *out, uint8_t *prefix, uint32_t len, uint8_t *input) { uint64_t tmp[10U] = { 0U }; uint8_t hash[64U] = { 0U }; sha512_pre_msg(hash, prefix, len, input); load_64_bytes(tmp, hash); barrett_reduction(out, tmp); } static inline void sha512_modq_pre_pre2( uint64_t *out, uint8_t *prefix, uint8_t *prefix2, uint32_t len, uint8_t *input ) { uint64_t tmp[10U] = { 0U }; uint8_t hash[64U] = { 0U }; sha512_pre_pre2_msg(hash, prefix, prefix2, len, input); load_64_bytes(tmp, hash); barrett_reduction(out, tmp); } static inline void point_mul_g_compress(uint8_t *out, uint8_t *s) { uint64_t tmp[20U] = { 0U }; point_mul_g(tmp, s); Hacl_Impl_Ed25519_PointCompress_point_compress(out, tmp); } static inline void secret_expand(uint8_t *expanded, uint8_t *secret) { Hacl_Hash_SHA2_hash_512(expanded, secret, 32U); uint8_t *h_low = expanded; uint8_t h_low0 = h_low[0U]; uint8_t h_low31 = h_low[31U]; h_low[0U] = (uint32_t)h_low0 & 0xf8U; h_low[31U] = ((uint32_t)h_low31 & 127U) | 64U; } /******************************************************************************** Verified C library for EdDSA signing and verification on the edwards25519 curve. ********************************************************************************/ /** Compute the public key from the private key. @param[out] public_key Points to 32 bytes of valid memory, i.e., `uint8_t[32]`. Must not overlap the memory location of `private_key`. @param[in] private_key Points to 32 bytes of valid memory containing the private key, i.e., `uint8_t[32]`. */ void Hacl_Ed25519_secret_to_public(uint8_t *public_key, uint8_t *private_key) { uint8_t expanded_secret[64U] = { 0U }; secret_expand(expanded_secret, private_key); uint8_t *a = expanded_secret; point_mul_g_compress(public_key, a); } /** Compute the expanded keys for an Ed25519 signature. @param[out] expanded_keys Points to 96 bytes of valid memory, i.e., `uint8_t[96]`. Must not overlap the memory location of `private_key`. @param[in] private_key Points to 32 bytes of valid memory containing the private key, i.e., `uint8_t[32]`. If one needs to sign several messages under the same private key, it is more efficient to call `expand_keys` only once and `sign_expanded` multiple times, for each message. */ void Hacl_Ed25519_expand_keys(uint8_t *expanded_keys, uint8_t *private_key) { uint8_t *public_key = expanded_keys; uint8_t *s_prefix = expanded_keys + 32U; uint8_t *s = expanded_keys + 32U; secret_expand(s_prefix, private_key); point_mul_g_compress(public_key, s); } /** Create an Ed25519 signature with the (precomputed) expanded keys. @param[out] signature Points to 64 bytes of valid memory, i.e., `uint8_t[64]`. Must not overlap the memory locations of `expanded_keys` nor `msg`. @param[in] expanded_keys Points to 96 bytes of valid memory, i.e., `uint8_t[96]`, containing the expanded keys obtained by invoking `expand_keys`. @param[in] msg_len Length of `msg`. @param[in] msg Points to `msg_len` bytes of valid memory containing the message, i.e., `uint8_t[msg_len]`. If one needs to sign several messages under the same private key, it is more efficient to call `expand_keys` only once and `sign_expanded` multiple times, for each message. */ void Hacl_Ed25519_sign_expanded( uint8_t *signature, uint8_t *expanded_keys, uint32_t msg_len, uint8_t *msg ) { uint8_t *rs = signature; uint8_t *ss = signature + 32U; uint64_t rq[5U] = { 0U }; uint64_t hq[5U] = { 0U }; uint8_t rb[32U] = { 0U }; uint8_t *public_key = expanded_keys; uint8_t *s = expanded_keys + 32U; uint8_t *prefix = expanded_keys + 64U; sha512_modq_pre(rq, prefix, msg_len, msg); store_56(rb, rq); point_mul_g_compress(rs, rb); sha512_modq_pre_pre2(hq, rs, public_key, msg_len, msg); uint64_t aq[5U] = { 0U }; load_32_bytes(aq, s); mul_modq(aq, hq, aq); add_modq(aq, rq, aq); store_56(ss, aq); } /** Create an Ed25519 signature. @param[out] signature Points to 64 bytes of valid memory, i.e., `uint8_t[64]`. Must not overlap the memory locations of `private_key` nor `msg`. @param[in] private_key Points to 32 bytes of valid memory containing the private key, i.e., `uint8_t[32]`. @param[in] msg_len Length of `msg`. @param[in] msg Points to `msg_len` bytes of valid memory containing the message, i.e., `uint8_t[msg_len]`. The function first calls `expand_keys` and then invokes `sign_expanded`. If one needs to sign several messages under the same private key, it is more efficient to call `expand_keys` only once and `sign_expanded` multiple times, for each message. */ void Hacl_Ed25519_sign(uint8_t *signature, uint8_t *private_key, uint32_t msg_len, uint8_t *msg) { uint8_t expanded_keys[96U] = { 0U }; Hacl_Ed25519_expand_keys(expanded_keys, private_key); Hacl_Ed25519_sign_expanded(signature, expanded_keys, msg_len, msg); } /** Verify an Ed25519 signature. @param public_key Points to 32 bytes of valid memory containing the public key, i.e., `uint8_t[32]`. @param msg_len Length of `msg`. @param msg Points to `msg_len` bytes of valid memory containing the message, i.e., `uint8_t[msg_len]`. @param signature Points to 64 bytes of valid memory containing the signature, i.e., `uint8_t[64]`. @return Returns `true` if the signature is valid and `false` otherwise. */ bool Hacl_Ed25519_verify(uint8_t *public_key, uint32_t msg_len, uint8_t *msg, uint8_t *signature) { uint64_t a_[20U] = { 0U }; bool b = Hacl_Impl_Ed25519_PointDecompress_point_decompress(a_, public_key); if (b) { uint64_t r_[20U] = { 0U }; uint8_t *rs = signature; bool b_ = Hacl_Impl_Ed25519_PointDecompress_point_decompress(r_, rs); if (b_) { uint8_t hb[32U] = { 0U }; uint8_t *rs1 = signature; uint8_t *sb = signature + 32U; uint64_t tmp[5U] = { 0U }; load_32_bytes(tmp, sb); bool b1 = gte_q(tmp); bool b10 = b1; if (b10) { return false; } uint64_t tmp0[5U] = { 0U }; sha512_modq_pre_pre2(tmp0, rs1, public_key, msg_len, msg); store_56(hb, tmp0); uint64_t exp_d[20U] = { 0U }; point_negate_mul_double_g_vartime(exp_d, sb, hb, a_); bool b2 = Hacl_Impl_Ed25519_PointEqual_point_equal(exp_d, r_); return b2; } return false; } return false; } // OMEMO Additions #include "omemo.h" #include "driver.h" void omemoDriverEdSignMod( omemoCurveSignature signature, omemoKey public_key, omemoKey s, uint8_t *msg, size_t msg_len ) { signature[0] = 0xfe; memset(signature + 1, 0xff, 31); memcpy(signature + 32, s, 32); uint8_t *rs = signature; uint8_t *ss = signature + 32U; uint64_t rq[5U] = { 0U }; uint64_t hq[5U] = { 0U }; uint8_t rb[32U] = { 0U }; sha512_modq_pre_pre2(rq, signature, signature + 32, msg_len + 64, msg); store_56(rb, rq); point_mul_g_compress(rs, rb); sha512_modq_pre_pre2(hq, rs, public_key, msg_len, msg); uint64_t aq[5U] = { 0U }; load_32_bytes(aq, s); mul_modq(aq, hq, aq); add_modq(aq, rq, aq); store_56(ss, aq); } bool omemoDriverEdVerify(omemoCurveSignature sig, omemoKey pub, uint8_t *msg, size_t msgn) { return Hacl_Ed25519_verify(pub, msgn, msg, sig); } void omemoDriverCvPrvToEdPub(omemoKey pub, omemoKey sec) { point_mul_g_compress(pub, sec); } void omemoDriverEdSeedToPubPrv(omemoKey public_key, omemoKey private_key, omemoKey seed) { uint8_t expanded_secret[64U] = { 0U }; secret_expand(expanded_secret, seed); uint8_t *a = expanded_secret; point_mul_g_compress(public_key, a); memcpy(private_key, a, 32); } void omemoDriverEdPubToCvPub(omemoKey m, omemoKey e) { uint64_t ey[5], um[5], yplus[5], yminus[5], one[5] = {1,0,0,0,0}; Hacl_Bignum25519_load_51(ey, e); fdifference(yplus, one, ey); Hacl_Bignum25519_inverse(yminus, yplus); fsum(yplus, one, ey); fmul0(um, yplus, yminus); Hacl_Bignum25519_store_51(m, um); } void omemoDriverCvPubToEdPub(omemoKey e, omemoKey m) { uint64_t ey[5], mx[5], n[5], d[5], one[5] = {1,0,0,0,0}; Hacl_Bignum25519_load_51(mx, m); fsum(n, mx, one); Hacl_Bignum25519_inverse(d, n); fdifference(n, mx, one); fmul0(ey, n, d); Hacl_Bignum25519_store_51(e, ey); } void omemoDriverCvPrvToPub(omemoKey pub, omemoKey prv) { Hacl_Curve25519_51_secret_to_public(pub, prv); } int omemoDriverX25519(omemoKey out, omemoKey prv, omemoKey pub) { return Hacl_Curve25519_51_ecdh(out, prv, pub) ? 0 : OMEMO_ECORRUPT; } emacs-jabber-0.13.1/src/picomemo/mbedtls.c000066400000000000000000000057511523531702000203120ustar00rootroot00000000000000/** * Copyright 2026 mierenhoop * * Permission to use, copy, modify, and/or distribute this software for * any purpose with or without fee is hereby granted, provided that the * above copyright notice and this permission notice appear in all * copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL * WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED * WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE * AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER * TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR * PERFORMANCE OF THIS SOFTWARE. */ #include #include #include #include #include "omemo.h" #include "driver.h" #define TRY(r) do { if (r) return OMEMO_ECRYPTO; } while (0) int omemoDriverHmac(const omemoKey k, const uint8_t *in, size_t ilen, uint8_t out[static 32]) { TRY(mbedtls_md_hmac(mbedtls_md_info_from_type(MBEDTLS_MD_SHA256), k, 32, in, ilen, out)); return 0; } int omemoDriverAesEncrypt(omemoKey k, size_t n, uint8_t iv[static 16], const uint8_t *s, uint8_t *d) { mbedtls_aes_context aes; TRY(mbedtls_aes_setkey_enc(&aes, k, 256)); TRY(mbedtls_aes_crypt_cbc(&aes, MBEDTLS_AES_ENCRYPT, n, iv, s, d)); return 0; } int omemoDriverAesDecrypt(omemoKey k, size_t n, uint8_t iv[static 16], const uint8_t *s, uint8_t *d) { mbedtls_aes_context aes; TRY(mbedtls_aes_setkey_dec(&aes, k, 256)); TRY(mbedtls_aes_crypt_cbc(&aes, MBEDTLS_AES_DECRYPT, n, iv, s, d)); return 0; } int omemoDriverHkdf(const uint8_t *salt, size_t saltn, const uint8_t *key, size_t keyn, const uint8_t *info, size_t infon, uint8_t *out, size_t outn) { TRY(mbedtls_hkdf(mbedtls_md_info_from_type(MBEDTLS_MD_SHA256), salt, saltn, key, keyn, info, infon, out, outn)); return 0; } int omemoDriverGcmEncrypt(uint8_t *d, const uint8_t key[static 16], size_t n, const uint8_t iv[static 12], uint8_t tag[static 16], const uint8_t *s) { int r; mbedtls_gcm_context ctx; mbedtls_gcm_init(&ctx); if (!(r = mbedtls_gcm_setkey(&ctx, MBEDTLS_CIPHER_ID_AES, key, 128))) r = mbedtls_gcm_crypt_and_tag(&ctx, MBEDTLS_GCM_ENCRYPT, n, iv, 12, "", 0, s, d, 16, tag); mbedtls_gcm_free(&ctx); TRY(r); return 0; } int omemoDriverGcmDecrypt(uint8_t *d, const uint8_t key[static 16], size_t n, const uint8_t iv[static 12], const uint8_t *tag, size_t tagn, const uint8_t *s) { int r; mbedtls_gcm_context ctx; mbedtls_gcm_init(&ctx); if (!(r = mbedtls_gcm_setkey(&ctx, MBEDTLS_CIPHER_ID_AES, key, 128))) r = mbedtls_gcm_auth_decrypt(&ctx, n, iv, 12, "", 0, tag, tagn, s, d); mbedtls_gcm_free(&ctx); TRY(r); return 0; } int omemoDriverCompare(const void *a, const void *b, size_t n) { return mbedtls_ct_memcmp(a, b, n); } emacs-jabber-0.13.1/src/picomemo/omemo.c000066400000000000000000001241121523531702000177650ustar00rootroot00000000000000/** * Copyright 2024 mierenhoop * * Permission to use, copy, modify, and/or distribute this software for * any purpose with or without fee is hereby granted, provided that the * above copyright notice and this permission notice appear in all * copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL * WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED * WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE * AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER * TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR * PERFORMANCE OF THIS SOFTWARE. */ #ifdef __linux__ #include #endif #if defined(__ANDROID__) #include #include #define getrandom(buf,buflen,flags) syscall(SYS_getrandom,buf,buflen,flags) #endif #include #include #include #include #include #include "omemo.h" #include "driver.h" #ifdef OMEMO2 #define HkdfInfoKeyExchange "OMEMO X3DH" #define HkdfInfoRootChain "OMEMO Root Chain" #define HkdfInfoMessageKeys "OMEMO Message Key Material" #define HkdfInfoPayload "OMEMO Payload" #define PbMsg_n 1 #define PbMsg_pn 2 #define PbMsg_dh_pub 3 #define PbMsg_ciphertext 4 #define PbKeyEx_pk_id 1 #define PbKeyEx_spk_id 2 #define PbKeyEx_ik 3 #define PbKeyEx_ek 4 #define PbKeyEx_message 5 #else #define HkdfInfoKeyExchange "WhisperText" #define HkdfInfoRootChain "WhisperRatchet" #define HkdfInfoMessageKeys "WhisperMessageKeys" #define PbMsg_n 2 #define PbMsg_pn 3 #define PbMsg_dh_pub 1 #define PbMsg_ciphertext 4 #define PbKeyEx_pk_id 1 #define PbKeyEx_spk_id 6 #define PbKeyEx_ik 3 #define PbKeyEx_ek 2 #define PbKeyEx_message 4 #endif #define TRY(expr) \ do { \ int _r_; \ if ((_r_ = expr)) \ return _r_; \ } while (0) #define ASSERT(expr) \ do { \ int _r_ = expr; \ assert(_r_); \ } while (0) enum { SESSION_UNINIT = 0, SESSION_INIT, SESSION_READY, SESSION_HEARTBEAT, }; #define SerLen sizeof(omemoSerializedKey) static omemoLoadMessageKeyCallback g_lmkcb; static omemoStoreMessageKeyCallback g_smkcb; static omemoRandomCallback g_rndcb; #define WEAK __attribute__((weak)) int WEAK omemoLoadMessageKey(struct omemoSession *s, struct omemoMessageKey *sk) { if (g_lmkcb) return g_lmkcb(s, sk); return 1; } int WEAK omemoRemoveMessageKey(struct omemoSession *s, const struct omemoMessageKey *sk) { (void)s; (void)sk; return 0; } int WEAK omemoStoreMessageKey(struct omemoSession *s, const struct omemoMessageKey *sk, uint64_t n) { if (g_smkcb) return g_smkcb(s, sk, n); return 0; } int WEAK omemoRandom(void *p, size_t n) { if (g_rndcb) return g_rndcb(p, n); #ifdef __linux__ return getrandom(p, n, 0) == n ? 0 : OMEMO_ERANDOM; #endif return OMEMO_ERANDOM; } void omemoSetCallbacks(omemoLoadMessageKeyCallback lmk, omemoStoreMessageKeyCallback smk, omemoRandomCallback rnd) { g_lmkcb = lmk; g_smkcb = smk; g_rndcb = rnd; } void omemoSerializeKey(omemoSerializedKey k, const omemoKey pub) { #ifdef OMEMO2 memcpy(k, pub, SerLen); #else k[0] = 5; memcpy(k + 1, pub, SerLen - 1); #endif } static inline const uint8_t *GetRawKey(const omemoSerializedKey k) { #ifdef OMEMO2 return k; #else return k + 1; #endif } /***************************** PROTOBUF ******************************/ // Protobuf: https://protobuf.dev/programming-guides/encoding/ // Only supports uint32 and len prefixed. struct ProtobufField { int type; // PB_* uint32_t v; // destination varint or LEN const uint8_t *p; // LEN element data pointer or NULL }; #define PB_REQUIRED (1 << 3) #define PB_UINT32 0 #define PB_LEN 2 /** * Parse Protobuf varint. * * Only supports uint32. Encodings wider than five bytes and values * whose fifth byte exceeds the remaining four bits are rejected. * * @param s points to the location of the varint in the protobuf data * @param e points to the end of the protobuf data * @param v (out) points to the location where the parsed varint will be * written * @returns pointer to first byte after the varint or NULL if parsing is * not finished before reaching e */ static const uint8_t *ParseVarInt(const uint8_t *s, const uint8_t *e, uint32_t *v) { *v = 0; for (unsigned int i = 0; i < 5; i++) { if (s >= e) return NULL; uint8_t byte = *s++; if (i == 4 && (byte & 0x7f) > 0x0f) return NULL; *v |= (uint32_t)(byte & 0x7f) << (7 * i); if (!(byte & 0x80)) return s; } return NULL; } /** * Parse data in Protobuf format. * * For each field encountered it does the following: * - Make sure the field number can be stored in `fields` and that the * type corresponds with the one specified in the associated field. * - Mark the field number as found which later will be used to check * whether all required fields are found. * - Parse the value. * - If there already is a non-zero value specified in the field, it is * used to check whether the parsed value is the same. * `nfields` should have the value of the highest possible field number * + 1. `nfields` must be less than or equal to 16 because we only * support a single byte field number, the number is stored like this in * the byte: 0nnnnttt where n is the field number and t is the type. * * @param s is protobuf data * @param n is the length of said data * @param nfields is the amount of fields in the `fields` array * @returns false if successful, true if error */ static bool ParseProtobuf(const uint8_t *s, size_t n, struct ProtobufField *fields, int nfields) { int type, id; uint32_t v; const uint8_t *e = s + n; uint32_t found = 0; ASSERT(nfields <= 16); while (s < e) { // This is actually a varint, but we only support id < 16 and return // an error otherwise, so we don't have to account for multiple-byte // tags. type = *s & 7; id = *s >> 3; s++; if (id >= nfields || type != (fields[id].type & 7)) return true; found |= 1 << id; if (!(s = ParseVarInt(s, e, &v))) return true; // If field is fixed size, enforce it if (fields[id].v && v != fields[id].v) return true; fields[id].v = v; if (type == PB_LEN) { if ((size_t)(e - s) < fields[id].v) return true; fields[id].p = s; s += fields[id].v; } } if (s > e) return true; for (int i = 0; i < nfields; i++) { if ((fields[i].type & PB_REQUIRED) && !(found & (1 << i))) return true; } return false; } static bool ParseRepeatingField(const uint8_t *s, const uint8_t *e, struct ProtobufField *field, int fieldid) { int type, id; uint32_t v; ASSERT(fieldid <= 16); while (s < e) { type = *s & 7; id = *s >> 3; s++; if (id >= 16 || (id == fieldid && type != (field->type & 7))) return true; if (!(s = ParseVarInt(s, e, &v))) return true; if (id == fieldid) field->v = v; if (type == PB_LEN) { if ((size_t)(e - s) < v) return true; if (id == fieldid) field->p = s; s += v; } if (id == fieldid) break; } return s > e; } /** * Get the size of a properly formatted varint in bytes. */ static inline int GetVarIntSize(uint32_t v) { return 1 + (v > 0x7f) + (v > 0x3fff) + (v > 0x1fffff) + (v > 0xfffffff); } static uint8_t *FormatVarInt(uint8_t d[static 6], int type, int id, uint32_t v) { ASSERT(id < 16); *d++ = (id << 3) | type; do { *d = v & 0x7f; v >>= 7; *d++ |= (!!v << 7); } while (v); return d; } #ifndef OMEMO2 static uint8_t *FormatSerializedKey(uint8_t d[static 35], int id, const omemoKey k) { ASSERT(id < 16); *d++ = (id << 3) | PB_LEN; *d++ = 33; omemoSerializeKey(d, k); return d + 33; } #endif static uint8_t *FormatKey(uint8_t d[static 34], int id, const omemoKey k) { ASSERT(id < 16); *d++ = (id << 3) | PB_LEN; *d++ = 32; memcpy(d, k, 32); return d + 32; } // Format Protobuf PreKeyWhisperMessage without message (it should be // appended right after this call). // This is OMEMOKeyExchange in schema static size_t FormatPreKeyMessage( uint8_t d[static OMEMO_INTERNAL_PREKEYHEADER_MAXSIZE], uint32_t pk_id, uint32_t spk_id, const omemoKey ik, const omemoKey ek, uint32_t msgsz) { uint8_t *p = d; #ifdef OMEMO2 p = FormatVarInt(p, PB_UINT32, 1, pk_id); p = FormatVarInt(p, PB_UINT32, 2, spk_id); p = FormatKey(p, 3, ik); p = FormatKey(p, 4, ek); // msgsz can be > 127 so we reserve 3 bytes for this p = FormatVarInt(p, PB_LEN, 5, msgsz); #else *p++ = (3 << 4) | 3; p = FormatVarInt(p, PB_UINT32, 5, 0); // registration id p = FormatVarInt(p, PB_UINT32, 1, pk_id); p = FormatVarInt(p, PB_UINT32, 6, spk_id); p = FormatSerializedKey(p, 3, ik); p = FormatSerializedKey(p, 2, ek); ASSERT(msgsz < 128); p = FormatVarInt(p, PB_LEN, 4, msgsz); #endif return p - d; } // Format Protobuf WhisperMessage without ciphertext. // HEADER(dh_pair, pn, n) static size_t FormatMessageHeader(uint8_t d[static OMEMO_INTERNAL_HEADER_MAXSIZE], uint32_t n, uint32_t pn, const omemoKey dhs, size_t keyn) { uint8_t *p = d; #ifdef OMEMO2 p = FormatVarInt(p, PB_UINT32, 1, n); p = FormatVarInt(p, PB_UINT32, 2, pn); p = FormatKey(p, 3, dhs); p = FormatVarInt(p, PB_LEN, 4, keyn); #else *p++ = (3 << 4) | 3; p = FormatSerializedKey(p, 1, dhs); p = FormatVarInt(p, PB_UINT32, 2, n); p = FormatVarInt(p, PB_UINT32, 3, pn); p = FormatVarInt(p, PB_LEN, 4, keyn); #endif return p - d; } /*************************** CRYPTOGRAPHY ****************************/ /** * @returns OMEMO_ECORRUPT if the generated shared secret is not secure */ static int DoX25519(omemoKey shared, const omemoKey prv, const omemoKey pub) { omemoKey tmp, tmp2; memcpy(tmp, prv, 32); memcpy(tmp2, pub, 32); return omemoDriverX25519(shared, tmp, tmp2); } // For OMEMO 0.3, we use the sign_modified as is required. // For OMEMO >0.3 (OMEMO2 here), the spec describes two options. // 1: XEdDSA w/ Curve25519 ik // 2: Any other EdDSA-compatible signature scheme w/ Ed25519 ik // // We mix the two: Ed25519 ik with XEdDSA-inspired signatures. // // The XEdDSA implementation in libsignal-protocol-c reuses // sign_modified with code for calculate_key_pair beforehand to convert // the Curve25519 pub to Ed25519 while handling the sign bit. As we use // an Ed25519 key internally AND distribute it, thus also not removing // the sign bit for any party, we can skip the whole generate_key part. // Essentially the only deviations from regular EdDSA is the // addition of a randomized nonce to msg and the usage of the hash1(X) // variation on SHA-512. static int CalculateCurveSignature(omemoCurveSignature sig, const struct omemoKeyPair *ik, const uint8_t rnd[static 64], const uint8_t *msg, size_t msgn) { ASSERT(msgn <= SerLen); uint8_t msgbuf[SerLen + 64]; memcpy(msgbuf, msg, msgn); memcpy(msgbuf + msgn, rnd, 64); omemoKey ikprv, ikpub; memcpy(ikprv, ik->prv, 32); memcpy(ikpub, ik->pub, 32); #ifdef OMEMO2 omemoDriverEdSignMod(sig, ikpub, ikprv, msgbuf, msgn); #else omemoKey ed; omemoDriverCvPrvToEdPub(ed, ikprv); int sign = ed[31] & 0x80; omemoDriverEdSignMod(sig, ed, ikprv, msgbuf, msgn); sig[63] &= 0x7f; sig[63] |= sign; #endif return 0; } // Sig(PK, M) static bool VerifySignature(const omemoCurveSignature sig, const omemoKey pub, const uint8_t *msg, size_t msgn) { ASSERT(msgn <= SerLen); uint8_t msgbuf[SerLen]; memcpy(msgbuf, msg, msgn); omemoKey pubcpy; memcpy(pubcpy, pub, 32); omemoCurveSignature sig2; memcpy(sig2, sig, 64); #ifdef OMEMO2 return omemoDriverEdVerify(sig2, pubcpy, msgbuf, msgn); #else omemoKey ed; omemoDriverCvPubToEdPub(ed, pubcpy); ed[31] &= 0x7f; ed[31] |= sig[63] & 0x80; sig2[63] &= 0x7f; return omemoDriverEdVerify(sig2, ed, msgbuf, msgn); #endif } static int GenerateKeyPair(struct omemoKeyPair *kp) { TRY(omemoRandom(kp->prv, sizeof(kp->prv))); kp->prv[0] &= 0xf8; kp->prv[31] &= 0x7f; kp->prv[31] |= 0x40; omemoDriverCvPrvToPub(kp->pub, kp->prv); return 0; } #ifdef OMEMO2 static int GenerateEdKeyPair(struct omemoKeyPair *kp) { omemoKey seed; TRY(omemoRandom(seed, 32)); omemoDriverEdSeedToPubPrv(kp->pub, kp->prv, seed); return 0; } #endif static int GenerateSignedPreKey(struct omemoSignedPreKey *spk, uint32_t id, const struct omemoKeyPair *idkp) { omemoSerializedKey ser; spk->id = id; TRY(GenerateKeyPair(&spk->kp)); omemoSerializeKey(ser, spk->kp.pub); uint8_t rnd[64]; TRY(omemoRandom(rnd, 64)); return CalculateCurveSignature(spk->sig, idkp, rnd, ser, SerLen); } /****************************** STORE ********************************/ static inline uint32_t IncrementWrapSkipZero(uint32_t n) { n++; return n + !n; } int omemoRefillPreKeys(struct omemoStore *store) { if (!store) return OMEMO_EPARAM; int i; for (i = 0; i < OMEMO_NUMPREKEYS; i++) { if (!store->prekeys[i].id) { struct omemoPreKey pk; uint32_t n = IncrementWrapSkipZero(store->pkcounter); pk.id = n; TRY(GenerateKeyPair(&pk.kp)); memcpy(store->prekeys + i, &pk, sizeof(struct omemoPreKey)); store->pkcounter = n; } } return 0; } static int omemoSetupStoreImpl(struct omemoStore *store) { if (!store) return OMEMO_EPARAM; memset(store, 0, sizeof(struct omemoStore)); #ifdef OMEMO2 TRY(GenerateEdKeyPair(&store->identity)); #else TRY(GenerateKeyPair(&store->identity)); #endif TRY(GenerateSignedPreKey(&store->cursignedprekey, 1, &store->identity)); TRY(omemoRefillPreKeys(store)); store->init = true; return 0; } int omemoSetupStore(struct omemoStore *store) { if (!store) return OMEMO_EPARAM; int r; if ((r = omemoSetupStoreImpl(store))) memset(store, 0, sizeof(struct omemoStore)); return r; } /*********************************************************************/ #define ADSIZE (2 * SerLen) #ifdef OMEMO2 #define MACSIZE 16 #else #define MACSIZE 8 #endif // AD = Encode(IKA) || Encode(IKB) static void GetAd(uint8_t ad[static ADSIZE], const omemoKey ika, const omemoKey ikb) { omemoSerializeKey(ad, ika); omemoSerializeKey(ad + SerLen, ikb); } static int GetMac(uint8_t d[static MACSIZE], const omemoKey ika, const omemoKey ikb, const omemoKey mk, const uint8_t *msg, size_t msgn) { // This could theoretically happen while decrypting when the protobuf // is needlessly large. if (msgn > OMEMO_INTERNAL_FULLMSG_MAXSIZE + 4) return OMEMO_ECORRUPT; // Adding 4 in case some client has a large registration id uint8_t macinput[ADSIZE + OMEMO_INTERNAL_FULLMSG_MAXSIZE + 4], mac[32]; GetAd(macinput, ika, ikb); memcpy(macinput + ADSIZE, msg, msgn); TRY(omemoDriverHmac(mk, macinput, ADSIZE + msgn, mac)); memcpy(d, mac, MACSIZE); return 0; } #define GetPad(n) (16 - ((n) % 16)) static int Encrypt(uint8_t out[OMEMO_INTERNAL_PAYLOAD_MAXPADDEDSIZE], const uint8_t *in, size_t n, omemoKey key, uint8_t iv[static 16]) { uint8_t tmp[OMEMO_INTERNAL_PAYLOAD_MAXPADDEDSIZE]; int pad = GetPad(n); memcpy(tmp, in, n); memset(tmp + n, pad, pad); TRY(omemoDriverAesEncrypt(key, n+pad, iv, tmp, out)); return n + pad; } static const uint8_t Zero32[32]; #define DeriveKey(salt, secret, info, out) \ omemoDriverHkdf(salt, \ sizeof(salt), secret, sizeof(secret), info, \ sizeof(info) - 1, (uint8_t *)out, sizeof(out)) struct __attribute__((__packed__)) DeriveChainKeyOutput { omemoKey cipher, mac; uint8_t iv[16]; }; // d may be the same pointer as ck // ck, mk = KDF_CK(ck) static int GetBaseMaterials(omemoKey d, omemoKey mk, const omemoKey ck) { uint8_t data[1] = {1}; TRY(omemoDriverHmac(ck, data, 1, mk)); data[0] = 2; TRY(omemoDriverHmac(ck, data, 1, d)); return 0; } // CKs, mk = KDF_CK(CKs) // header = HEADER(DHs, PN, Ns) // Ns += 1 // return header, ENCRYPT(mk, plaintext, CONCAT(AD, header)) static int EncryptKeyImpl(struct omemoSession *session, struct omemoKeyMessage *msg, const uint8_t *key, size_t keyn) { if (!session->init) return OMEMO_ESTATE; omemoKey mk; TRY(GetBaseMaterials(session->state.cks, mk, session->state.cks)); struct DeriveChainKeyOutput kdfout[1]; TRY(DeriveKey(Zero32, mk, HkdfInfoMessageKeys, kdfout)); msg->n = 0; #ifdef OMEMO2 msg->p[msg->n++] = (1 << 3) | PB_LEN; msg->p[msg->n++] = 16; msg->n += 16; msg->p[msg->n++] = (2 << 3) | PB_LEN; // Hmac'd message will always be smaller than 128 msg->p[msg->n++] = 0x55; // replaced with actual size #endif msg->n += FormatMessageHeader( msg->p + msg->n, session->state.ns, session->state.pn, session->state.dhs.pub, keyn + GetPad(keyn)); msg->n += Encrypt(msg->p + msg->n, key, keyn, kdfout->cipher, kdfout->iv); #ifdef OMEMO2 msg->p[19] = msg->n - 20; TRY(GetMac(msg->p + 2, session->identity, session->remoteidentity, kdfout->mac, msg->p + 20, msg->n - 20)); #else TRY(GetMac(msg->p + msg->n, session->identity, session->remoteidentity, kdfout->mac, msg->p, msg->n)); msg->n += 8; #endif session->state.ns++; if (session->init == SESSION_INIT) { msg->isprekey = true; // [message 00...] -> [00... message] -> [header 00... message] -> // [header message] memmove(msg->p + OMEMO_INTERNAL_PREKEYHEADER_MAXSIZE, msg->p, msg->n); int headersz = FormatPreKeyMessage( msg->p, session->usedpk_id, session->usedspk_id, session->identity, session->usedek, msg->n); memmove(msg->p + headersz, msg->p + OMEMO_INTERNAL_PREKEYHEADER_MAXSIZE, msg->n); msg->n += headersz; } return 0; } int omemoEncryptKey(struct omemoSession *session, struct omemoKeyMessage *msg, const uint8_t *key, size_t keyn) { if (!session || !msg || keyn > OMEMO_KEYSIZE) return OMEMO_EPARAM; int r; // Fields outside of session->state are not modified in // EncryptKeyImpl() but we'll back them up to save a future headache. struct omemoSession backup; memcpy(&backup, session, sizeof(struct omemoSession)); memset(msg, 0, sizeof(struct omemoKeyMessage)); if ((r = EncryptKeyImpl(session, msg, key, keyn))) { memcpy(session, &backup, sizeof(struct omemoSession)); memset(msg, 0, sizeof(struct omemoKeyMessage)); } return r; } // RK, ck = KDF_RK(RK, DH(DHs, DHr)) static int DeriveRootKey(struct omemoState *state, omemoKey ck) { uint8_t secret[32], masterkey[64]; TRY(DoX25519(secret, state->dhs.prv, state->dhr)); TRY(DeriveKey(state->rk, secret, HkdfInfoRootChain, masterkey)); memcpy(state->rk, masterkey, 32); memcpy(ck, masterkey + 32, 32); return 0; } // DH1 = DH(IKA, SPKB) // DH2 = DH(EKA, IKB) // DH3 = DH(EKA, SPKB) // DH4 = DH(EKA, OPKB) // SK = KDF(DH1 || DH2 || DH3 || DH4) static int GetSharedSecret(omemoKey sk, bool isbob, const omemoKey ika, const omemoKey ska, const omemoKey eka, const omemoKey ikb, const omemoKey spkb, const omemoKey opkb) { uint8_t secret[32 * 5] = {0}, tmpkey[32]; memset(secret, 0xff, 32); // When we are bob, we must swap the first two. TRY(DoX25519(secret + 32, isbob ? ska : ika, isbob ? ikb : spkb)); TRY(DoX25519(secret + 64, isbob ? ika : ska, isbob ? spkb : ikb)); TRY(DoX25519(secret + 96, ska, spkb)); // OMEMO mandates that the bundle MUST contain a prekey. TRY(DoX25519(secret + 128, eka, opkb)); TRY(DeriveKey(Zero32, secret, HkdfInfoKeyExchange, tmpkey)); memcpy(sk, tmpkey, 32); return 0; } // state.DHs = GENERATE_DH() // state.DHr = bob_dh_public_key // state.RK, state.CKs = KDF_RK(SK, DH(state.DHs, state.DHr)) // state.CKr = None // state.Ns = 0 // state.Nr = 0 // state.PN = 0 // state.MKSKIPPED = {} static int RatchetInitAlice(struct omemoState *state, const omemoKey sk, const omemoKey ekb, const struct omemoKeyPair *eka) { memset(state, 0, sizeof(struct omemoState)); memcpy(&state->dhs, eka, sizeof(struct omemoKeyPair)); memcpy(state->rk, sk, 32); memcpy(state->dhr, ekb, 32); return DeriveRootKey(state, state->cks); } int omemoInitiateSession(struct omemoSession *session, const struct omemoStore *store, const omemoCurveSignature spks, const omemoSerializedKey spk, const omemoSerializedKey ik, const omemoSerializedKey pk, uint32_t spk_id, uint32_t pk_id) { if (!session || !store) return OMEMO_EPARAM; if (!VerifySignature(spks, GetRawKey(ik), spk, SerLen)) { return OMEMO_ECORRUPT; } struct omemoKeyPair eka; TRY(GenerateKeyPair(&eka)); omemoKey sk; #ifdef OMEMO2 omemoKey ikx, edy; memcpy(edy, GetRawKey(ik), 32); edy[31] &= 0x7f; omemoDriverEdPubToCvPub(ikx, edy); TRY(GetSharedSecret(sk, false, store->identity.prv, eka.prv, eka.prv, ikx, GetRawKey(spk), GetRawKey(pk))); #else TRY(GetSharedSecret(sk, false, store->identity.prv, eka.prv, eka.prv, GetRawKey(ik), GetRawKey(spk), GetRawKey(pk))); #endif int r = RatchetInitAlice(&session->state, sk, GetRawKey(spk), &eka); if (r) { memset(&session->state, 0, sizeof(struct omemoState)); return r; } memcpy(session->usedek, eka.pub, 32); memcpy(session->identity, store->identity.pub, 32); memcpy(session->remoteidentity, GetRawKey(ik), 32); session->usedpk_id = pk_id; session->usedspk_id = spk_id; session->init = SESSION_INIT; return 0; } static const struct omemoPreKey *FindPreKey(const struct omemoStore *store, uint32_t pk_id) { for (int i = 0; i < OMEMO_NUMPREKEYS; i++) { if (store->prekeys[i].id == pk_id) return store->prekeys + i; } return NULL; } static const struct omemoSignedPreKey * FindSignedPreKey(const struct omemoStore *store, uint32_t spk_id) { if (spk_id == 0) return NULL; if (store->cursignedprekey.id == spk_id) return &store->cursignedprekey; if (store->prevsignedprekey.id == spk_id) return &store->prevsignedprekey; return NULL; } int omemoRotateSignedPreKey(struct omemoStore *store) { if (!store) return OMEMO_EPARAM; struct omemoSignedPreKey spk; int r = GenerateSignedPreKey( &spk, IncrementWrapSkipZero(store->cursignedprekey.id), &store->identity); if (!r) { memcpy(&store->prevsignedprekey, &store->cursignedprekey, sizeof(struct omemoSignedPreKey)); memcpy(&store->cursignedprekey, &spk, sizeof(spk)); } return r; } // PN = Ns // Ns = 0 // Nr = 0 // DHr = dh // RK, CKr = KDF_RK(RK, DH(DHs, DHr)) // DHs = GENERATE_DH() // RK, CKs = KDF_RK(RK, DH(DHs, DHr)) static int DHRatchet(struct omemoState *state, const omemoKey dh) { state->pn = state->ns; state->ns = 0; state->nr = 0; memcpy(state->dhr, dh, 32); TRY(DeriveRootKey(state, state->ckr)); TRY(GenerateKeyPair(&state->dhs)); TRY(DeriveRootKey(state, state->cks)); return 0; } static void RatchetInitBob(struct omemoState *state, const omemoKey sk, const struct omemoKeyPair *ekb) { memcpy(&state->dhs, ekb, sizeof(struct omemoKeyPair)); memcpy(state->rk, sk, 32); } #define CLAMP0(v) ((v) > 0 ? (v) : 0) static inline uint32_t GetAmountSkipped(int64_t nr, int64_t n) { return CLAMP0(n - nr); } static int SkipMessageKeys(struct omemoSession *session, uint32_t n, uint64_t fullamount) { struct omemoMessageKey k; while (session->state.nr < n) { TRY(GetBaseMaterials(session->state.ckr, k.mk, session->state.ckr)); memcpy(k.dh, session->state.dhr, 32); k.nr = session->state.nr; TRY(omemoStoreMessageKey(session, &k, fullamount--)); session->state.nr++; } return 0; } static int DecryptKeyImpl(struct omemoSession *session, uint8_t *key, size_t *keyn, const uint8_t *msg, size_t msgn) { #ifdef OMEMO2 struct ProtobufField fields1[3] = { [1] = {PB_REQUIRED | PB_LEN, 16}, // mac [2] = {PB_REQUIRED | PB_LEN}, // message }; if (ParseProtobuf(msg, msgn, fields1, 3)) return OMEMO_EPROTOBUF; struct ProtobufField fields[5] = { [PbMsg_n] = {PB_REQUIRED | PB_UINT32}, [PbMsg_pn] = {PB_REQUIRED | PB_UINT32}, [PbMsg_dh_pub] = {PB_REQUIRED | PB_LEN, SerLen}, [PbMsg_ciphertext] = {PB_REQUIRED | PB_LEN}, }; if (ParseProtobuf(fields1[2].p, fields1[2].v, fields, 5)) return OMEMO_EPROTOBUF; const uint8_t *realmac = fields1[1].p; #else if (msgn < 9 || msg[0] != ((3 << 4) | 3)) return OMEMO_ECORRUPT; struct ProtobufField fields[5] = { [PbMsg_dh_pub] = {PB_REQUIRED | PB_LEN, SerLen}, [PbMsg_n] = {PB_REQUIRED | PB_UINT32}, [PbMsg_pn] = {PB_REQUIRED | PB_UINT32}, [PbMsg_ciphertext] = {PB_REQUIRED | PB_LEN}, }; if (ParseProtobuf(msg + 1, msgn - 9, fields, 5)) return OMEMO_EPROTOBUF; const uint8_t *realmac = msg + msgn - 8; #endif uint32_t encn = fields[PbMsg_ciphertext].v; if (encn < 16 || encn % 16 || encn > OMEMO_INTERNAL_PAYLOAD_MAXPADDEDSIZE) return OMEMO_ECORRUPT; uint32_t headern = fields[PbMsg_n].v; uint32_t headerpn = fields[PbMsg_pn].v; const uint8_t *headerdh = GetRawKey(fields[PbMsg_dh_pub].p); bool shouldstep = !!memcmp(session->state.dhr, headerdh, 32); // We first check for maxskip, if that does not pass we should not // process the message. If it does pass, we know the total capacity of // the array is large enough because c >= maxskip. Then we check if // the new keys fit in the remaining space. If that is not the case we // return and let the user either remove the old message keys or // ignore the message. omemoKey mk; struct omemoMessageKey mkey = {0}; bool loadedmkey = false; memcpy(mkey.dh, headerdh, 32); mkey.nr = headern; int r; if (!(r = omemoLoadMessageKey(session, &mkey))) { memcpy(mk, mkey.mk, 32); loadedmkey = true; } else if (r < 0) { return r; } else { if (!shouldstep && headern < session->state.nr) return OMEMO_EKEYGONE; uint64_t nskips = shouldstep ? GetAmountSkipped(session->state.nr, headerpn) + headern : GetAmountSkipped(session->state.nr, headern); if (shouldstep) { TRY(SkipMessageKeys(session, headerpn, nskips)); nskips -= headern; TRY(DHRatchet(&session->state, headerdh)); } TRY(SkipMessageKeys(session, headern, nskips)); TRY(GetBaseMaterials(session->state.ckr, mk, session->state.ckr)); session->state.nr++; } struct DeriveChainKeyOutput kdfout[1]; TRY(DeriveKey(Zero32, mk, HkdfInfoMessageKeys, kdfout)); uint8_t mac[MACSIZE]; #ifdef OMEMO2 TRY(GetMac(mac, session->remoteidentity, session->identity, kdfout->mac, fields1[2].p, fields1[2].v)); #else TRY(GetMac(mac, session->remoteidentity, session->identity, kdfout->mac, msg, msgn - 8)); #endif if (omemoDriverCompare(mac, realmac, MACSIZE)) return OMEMO_ECORRUPT; uint8_t tmp[OMEMO_INTERNAL_PAYLOAD_MAXPADDEDSIZE]; TRY(omemoDriverAesDecrypt(kdfout->cipher, encn, kdfout->iv, fields[PbMsg_ciphertext].p, tmp)); uint8_t pad = tmp[encn - 1]; if (pad > 16 || pad > encn || encn - pad > *keyn) return OMEMO_ECORRUPT; if (loadedmkey && omemoRemoveMessageKey(session, &mkey)) return OMEMO_ESTORE; memcpy(key, tmp, encn - pad); *keyn = encn - pad; session->init = SESSION_READY; return 0; } static int DecryptGenericKeyImpl(struct omemoSession *session, const struct omemoStore *store, uint8_t *key, size_t *keyn, bool isprekey, const uint8_t *msg, size_t msgn) { const struct omemoPreKey *pk = NULL; if (isprekey) { // Can't receive prekey when we sent a prekey... if (session->init == SESSION_INIT) return OMEMO_ESTATE; #ifdef OMEMO2 // OMEMOKeyExchange struct ProtobufField fields[6] = { [PbKeyEx_pk_id] = {PB_REQUIRED | PB_UINT32}, [PbKeyEx_spk_id] = {PB_REQUIRED | PB_UINT32}, [PbKeyEx_ik] = {PB_REQUIRED | PB_LEN, SerLen}, [PbKeyEx_ek] = {PB_REQUIRED | PB_LEN, SerLen}, [PbKeyEx_message] = {PB_REQUIRED | PB_LEN}, }; if (ParseProtobuf(msg, msgn, fields, 6)) return OMEMO_EPROTOBUF; #else if (msgn == 0 || msg[0] != ((3 << 4) | 3)) return OMEMO_ECORRUPT; // PreKeyWhisperMessage struct ProtobufField fields[7] = { [5] = {PB_UINT32}, // registrationid [PbKeyEx_pk_id] = {PB_REQUIRED | PB_UINT32}, [PbKeyEx_spk_id] = {PB_REQUIRED | PB_UINT32}, [PbKeyEx_ek] = {PB_REQUIRED | PB_LEN, SerLen}, [PbKeyEx_ik] = {PB_REQUIRED | PB_LEN, SerLen}, [PbKeyEx_message] = {PB_REQUIRED | PB_LEN}, }; if (ParseProtobuf(msg + 1, msgn - 1, fields, 7)) return OMEMO_EPROTOBUF; #endif if (session->init == SESSION_UNINIT) { pk = FindPreKey(store, fields[PbKeyEx_pk_id].v); const struct omemoSignedPreKey *spk = FindSignedPreKey(store, fields[PbKeyEx_spk_id].v); if (!pk || !spk) return OMEMO_ECORRUPT; session->usedpk_id = fields[PbKeyEx_pk_id].v; omemoKey sk; memcpy(session->identity, store->identity.pub, 32); memcpy(session->remoteidentity, GetRawKey(fields[PbKeyEx_ik].p), 32); #ifdef OMEMO2 omemoKey ik, edy; memcpy(edy, fields[PbKeyEx_ik].p, 32); edy[31] &= 0x7f; omemoDriverEdPubToCvPub(ik, edy); TRY(GetSharedSecret(sk, true, store->identity.prv, spk->kp.prv, pk->kp.prv, ik, fields[PbKeyEx_ek].p, fields[PbKeyEx_ek].p)); #else TRY(GetSharedSecret(sk, true, store->identity.prv, spk->kp.prv, pk->kp.prv, GetRawKey(fields[PbKeyEx_ik].p), GetRawKey(fields[PbKeyEx_ek].p), GetRawKey(fields[PbKeyEx_ek].p))); #endif RatchetInitBob(&session->state, sk, &spk->kp); } msg = fields[PbKeyEx_message].p; msgn = fields[PbKeyEx_message].v; } else if (session->init == SESSION_INIT) { // We don't need these anymore session->usedpk_id = 0; session->usedspk_id = 0; memset(session->usedek, 0, 32); } else if (session->init == SESSION_UNINIT) { return OMEMO_ESTATE; } if (memcmp(session->identity, store->identity.pub, 32)) return OMEMO_ESTORE; return DecryptKeyImpl(session, key, keyn, msg, msgn); } int omemoDecryptKey(struct omemoSession *session, const struct omemoStore *store, uint8_t *key, size_t *keyn, bool isprekey, const uint8_t *msg, size_t msgn) { if (!session || !store || !key || !keyn || !store->init || !msg) return OMEMO_EPARAM; // We only have to backup session->state functionality wise, but to // ensure session stays the same before and after an error we backup // everything. struct omemoSession backup; memcpy(&backup, session, sizeof(struct omemoSession)); int r; if ((r = DecryptGenericKeyImpl(session, store, key, keyn, isprekey, msg, msgn))) { memcpy(session, &backup, sizeof(struct omemoSession)); } return r; } int omemoHeartbeat(struct omemoSession *session, const struct omemoStore *store, struct omemoKeyMessage *msg) { if (!session || !store || !msg) return OMEMO_EPARAM; if (session->state.nr >= 53) { if (session->init == SESSION_READY) { uint8_t empty[32] = { 0 }; int r = omemoEncryptKey(session, msg, empty, 32); if (!r) session->init = SESSION_HEARTBEAT; return r; } } else if (session->init == SESSION_HEARTBEAT) { session->init = SESSION_READY; } return 0; } /******************** MESSAGE CONTENT ENCRYPTION *********************/ #ifdef OMEMO2 int omemoDecryptMessage(uint8_t *d, size_t *olen, const uint8_t *key, size_t keyn, const uint8_t *s, size_t n) { if (!d || !olen || !key || !s) return OMEMO_EPARAM; if (keyn != 48) return OMEMO_ECORRUPT; if (n < 16 || n % 16) return OMEMO_ECORRUPT; uint8_t k[32]; memcpy(k, key, 32); struct DeriveChainKeyOutput kdfout[1]; TRY(DeriveKey(Zero32, k, HkdfInfoPayload, kdfout)); uint8_t mac[32]; TRY(omemoDriverHmac(kdfout->mac, s, n, mac)); if (omemoDriverCompare(mac, key + 32, 16)) return OMEMO_ECORRUPT; TRY(omemoDriverAesDecrypt(kdfout->cipher, n, kdfout->iv, s, d)); uint8_t p = d[n - 1]; if (p > n) return OMEMO_ECORRUPT; memset(d + n - p, 0, p); *olen = n - p; return 0; } #else int omemoDecryptMessage(uint8_t *d, const uint8_t *key, size_t keyn, const uint8_t iv[12], const uint8_t *s, size_t n) { if (!d || !key || !iv || !s) return OMEMO_EPARAM; int r = 0; if (keyn < 32) return OMEMO_ECORRUPT; TRY(omemoDriverGcmDecrypt(d, key, n, iv, key+16, keyn-16, s)); return r ? OMEMO_ECRYPTO : 0; } #endif #ifdef OMEMO2 int omemoEncryptMessage(uint8_t *d, uint8_t key[48], uint8_t *s, size_t n) { if (!d || !key || !s) return OMEMO_EPARAM; uint8_t k[32]; TRY(omemoRandom(k, 32)); struct DeriveChainKeyOutput kdfout[1]; TRY(DeriveKey(Zero32, k, HkdfInfoPayload, kdfout)); // PKCS#7 size_t extend = omemoGetMessagePadSize(n); memset(s + n, extend, extend); TRY(omemoDriverAesEncrypt(kdfout->cipher, n + extend, kdfout->iv, s, d)); uint8_t mac[32]; TRY(omemoDriverHmac(kdfout->mac, d, n + extend, mac)); memcpy(key, k, 32); memcpy(key + 32, mac, 16); return 0; } #else int omemoEncryptMessage(uint8_t *d, uint8_t key[32], uint8_t iv[12], const uint8_t *s, size_t n) { if (!d || !key || !iv || !s) return OMEMO_EPARAM; int r = 0; if ((r = omemoRandom(key, 16)) || (r = omemoRandom(iv, 12))) return r; return omemoDriverGcmEncrypt(d, key, n, iv, key + 16, s); } #endif /************************** SERIALIZATION ****************************/ size_t omemoGetSerializedStoreSize(const struct omemoStore *store) { if (!store) return 0; size_t sum = 34 * 6 + (2 + 64) * 2 + 1 * 4 + GetVarIntSize(store->init) + GetVarIntSize(store->cursignedprekey.id) + GetVarIntSize(store->prevsignedprekey.id) + GetVarIntSize(store->pkcounter); for (int i = 0; i < OMEMO_NUMPREKEYS; i++) sum += 2 + 1 + GetVarIntSize(store->prekeys[i].id) + 2 * 34; return sum; } void omemoSerializeStore(uint8_t *p, const struct omemoStore *store) { if (!p || !store) return; uint8_t *d = p; d = FormatVarInt(d, PB_UINT32, 1, store->init); d = FormatKey(d, 2, store->identity.prv); d = FormatKey(d, 3, store->identity.pub); d = FormatVarInt(d, PB_UINT32, 4, store->cursignedprekey.id); d = FormatKey(d, 5, store->cursignedprekey.kp.prv); d = FormatKey(d, 6, store->cursignedprekey.kp.pub); d = FormatVarInt(d, PB_LEN, 7, 64); d = (memcpy(d, store->cursignedprekey.sig, 64), d + 64); d = FormatVarInt(d, PB_UINT32, 8, store->prevsignedprekey.id); d = FormatKey(d, 9, store->prevsignedprekey.kp.prv); d = FormatKey(d, 10, store->prevsignedprekey.kp.pub); d = FormatVarInt(d, PB_LEN, 11, 64); d = (memcpy(d, store->prevsignedprekey.sig, 64), d + 64); d = FormatVarInt(d, PB_UINT32, 12, store->pkcounter); for (int i = 0; i < OMEMO_NUMPREKEYS; i++) { const struct omemoPreKey *pk = store->prekeys + i; d = FormatVarInt(d, PB_LEN, 13, 1 + GetVarIntSize(pk->id) + 2 * 34); d = FormatVarInt(d, PB_UINT32, 1, pk->id); d = FormatKey(d, 2, pk->kp.prv); d = FormatKey(d, 3, pk->kp.pub); } ASSERT(d - p == omemoGetSerializedStoreSize(store)); } int omemoDeserializeStore(const uint8_t *p, size_t n, struct omemoStore *store) { if (!p || !store) return OMEMO_EPARAM; struct ProtobufField fields[] = { [1] = {PB_REQUIRED | PB_UINT32}, [2] = {PB_REQUIRED | PB_LEN, 32}, [3] = {PB_REQUIRED | PB_LEN, 32}, [4] = {PB_REQUIRED | PB_UINT32}, [5] = {PB_REQUIRED | PB_LEN, 32}, [6] = {PB_REQUIRED | PB_LEN, 32}, [7] = {PB_REQUIRED | PB_LEN, 64}, [8] = {PB_REQUIRED | PB_UINT32}, [9] = {PB_REQUIRED | PB_LEN, 32}, [10] = {PB_REQUIRED | PB_LEN, 32}, [11] = {PB_REQUIRED | PB_LEN, 64}, [12] = {PB_REQUIRED | PB_UINT32}, [13] = {/*PB_REQUIRED |*/ PB_LEN}, }; if (ParseProtobuf(p, n, fields, 14)) return OMEMO_EPROTOBUF; store->init = fields[1].v; memcpy(store->identity.prv, fields[2].p, 32); memcpy(store->identity.pub, fields[3].p, 32); store->cursignedprekey.id = fields[4].v; memcpy(store->cursignedprekey.kp.prv, fields[5].p, 32); memcpy(store->cursignedprekey.kp.pub, fields[6].p, 32); memcpy(store->cursignedprekey.sig, fields[7].p, 64); store->prevsignedprekey.id = fields[8].v; memcpy(store->prevsignedprekey.kp.prv, fields[9].p, 32); memcpy(store->prevsignedprekey.kp.pub, fields[10].p, 32); memcpy(store->prevsignedprekey.sig, fields[11].p, 64); store->pkcounter = fields[12].v; const uint8_t *e = p + n; int i = 0; while (i < OMEMO_NUMPREKEYS && !ParseRepeatingField(p, e, &fields[13], 13) && fields[13].p) { struct ProtobufField innerfields[] = { [1] = {PB_REQUIRED | PB_UINT32}, [2] = {PB_REQUIRED | PB_LEN, 32}, [3] = {PB_REQUIRED | PB_LEN, 32}, }; if (ParseProtobuf(fields[13].p, fields[13].v, innerfields, 4)) return OMEMO_EPROTOBUF; store->prekeys[i].id = innerfields[1].v; memcpy(store->prekeys[i].kp.prv, innerfields[2].p, 32); memcpy(store->prekeys[i].kp.pub, innerfields[3].p, 32); i++; p = fields[13].p + fields[13].v; fields[13].v = 0, fields[13].p = NULL; } return 0; } size_t omemoGetSerializedSessionSize(const struct omemoSession *session) { if (!session) return 0; return 34 * 9 // Key + 1 * 6 + GetVarIntSize(session->state.ns) + GetVarIntSize(session->state.nr) + GetVarIntSize(session->state.pn) + GetVarIntSize(session->usedpk_id) + GetVarIntSize(session->usedspk_id) + GetVarIntSize(session->init); } void omemoSerializeSession(uint8_t *p, const struct omemoSession *session) { if (!p || !session) return; uint8_t *d = p; d = FormatKey(d, 1, session->remoteidentity); d = FormatKey(d, 2, session->state.dhs.prv); d = FormatKey(d, 3, session->state.dhs.pub); d = FormatKey(d, 4, session->state.dhr); d = FormatKey(d, 5, session->state.rk); d = FormatKey(d, 6, session->state.cks); d = FormatKey(d, 7, session->state.ckr); d = FormatVarInt(d, PB_UINT32, 8, session->state.ns); d = FormatVarInt(d, PB_UINT32, 9, session->state.nr); d = FormatVarInt(d, PB_UINT32, 10, session->state.pn); // TODO: don't have to include used* after first ratchet d = FormatKey(d, 11, session->usedek); d = FormatVarInt(d, PB_UINT32, 12, session->usedpk_id); d = FormatVarInt(d, PB_UINT32, 13, session->usedspk_id); d = FormatVarInt(d, PB_UINT32, 14, session->init); d = FormatKey(d, 15, session->identity); ASSERT(d - p == omemoGetSerializedSessionSize(session)); } int omemoDeserializeSession(const uint8_t *p, size_t n, struct omemoSession *session) { if (!p || !session) return OMEMO_EPARAM; struct ProtobufField fields[] = { [1] = {PB_REQUIRED | PB_LEN, 32}, [2] = {PB_REQUIRED | PB_LEN, 32}, [3] = {PB_REQUIRED | PB_LEN, 32}, [4] = {PB_REQUIRED | PB_LEN, 32}, [5] = {PB_REQUIRED | PB_LEN, 32}, [6] = {PB_REQUIRED | PB_LEN, 32}, [7] = {PB_REQUIRED | PB_LEN, 32}, [8] = {PB_REQUIRED | PB_UINT32}, [9] = {PB_REQUIRED | PB_UINT32}, [10] = {PB_REQUIRED | PB_UINT32}, [11] = {PB_REQUIRED | PB_LEN, 32}, [12] = {PB_REQUIRED | PB_UINT32}, [13] = {PB_REQUIRED | PB_UINT32}, [14] = {PB_REQUIRED | PB_UINT32}, [15] = {PB_REQUIRED | PB_LEN, 32}, }; if (ParseProtobuf(p, n, fields, 16)) return OMEMO_EPROTOBUF; memcpy(session->remoteidentity, fields[1].p, 32); memcpy(session->state.dhs.prv, fields[2].p, 32); memcpy(session->state.dhs.pub, fields[3].p, 32); memcpy(session->state.dhr, fields[4].p, 32); memcpy(session->state.rk, fields[5].p, 32); memcpy(session->state.cks, fields[6].p, 32); memcpy(session->state.ckr, fields[7].p, 32); session->state.ns = fields[8].v; session->state.nr = fields[9].v; session->state.pn = fields[10].v; memcpy(session->usedek, fields[11].p, 32); session->usedpk_id = fields[12].v; session->usedspk_id = fields[13].v; session->init = fields[14].v; memcpy(session->identity, fields[15].p, 32); return 0; } emacs-jabber-0.13.1/src/picomemo/omemo.h000066400000000000000000000241471523531702000200010ustar00rootroot00000000000000/** * Copyright 2024 mierenhoop * * Permission to use, copy, modify, and/or distribute this software for * any purpose with or without fee is hereby granted, provided that the * above copyright notice and this permission notice appear in all * copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL * WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED * WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE * AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER * TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR * PERFORMANCE OF THIS SOFTWARE. */ #ifndef OMEMO_H_ #define OMEMO_H_ #include #include #include #ifndef OMEMO_EXPORT #define OMEMO_EXPORT #endif #define OMEMO_NUMPREKEYS 100 #define OMEMO_EPROTOBUF (-1) #define OMEMO_ECRYPTO (-2) #define OMEMO_ECORRUPT (-3) #define OMEMO_EPARAM (-4) #define OMEMO_ESTATE (-5) #define OMEMO_EKEYGONE (-6) #define OMEMO_ESTORE (-7) #define OMEMO_EUSER (-8) #define OMEMO_ERANDOM (-9) #ifdef OMEMO2 #define OMEMO_KEYSIZE 48 #define OMEMO_INTERNAL_PAYLOAD_MAXPADDEDSIZE 64 #define OMEMO_INTERNAL_HEADER_MAXSIZE (2 * 6 + 34 + 2) #define OMEMO_INTERNAL_FULLMSG_MAXSIZE \ (OMEMO_INTERNAL_HEADER_MAXSIZE + OMEMO_INTERNAL_PAYLOAD_MAXPADDEDSIZE) #define OMEMO_INTERNAL_PREKEYHEADER_MAXSIZE (6 * 2 + 34 * 2 + 3) #define OMEMO_INTERNAL_ENCRYPTED_MAXSIZE \ (2 + 16 + 2 + OMEMO_INTERNAL_FULLMSG_MAXSIZE) #else #define OMEMO_KEYSIZE 32 #define OMEMO_INTERNAL_PAYLOAD_MAXPADDEDSIZE 48 #define OMEMO_INTERNAL_HEADER_MAXSIZE (1 + 35 + 2 * 6 + 2) #define OMEMO_INTERNAL_FULLMSG_MAXSIZE \ (OMEMO_INTERNAL_HEADER_MAXSIZE + OMEMO_INTERNAL_PAYLOAD_MAXPADDEDSIZE) #define OMEMO_INTERNAL_PREKEYHEADER_MAXSIZE (1 + 2 + 2 * 6 + 35 * 2 + 2) #define OMEMO_INTERNAL_ENCRYPTED_MAXSIZE \ (OMEMO_INTERNAL_FULLMSG_MAXSIZE + 8) #endif typedef uint8_t omemoKey[32]; #ifdef OMEMO2 typedef uint8_t omemoSerializedKey[32]; #else typedef uint8_t omemoSerializedKey[1 + 32]; #endif typedef uint8_t omemoCurveSignature[64]; struct omemoKeyPair { omemoKey prv; omemoKey pub; }; struct omemoPreKey { uint32_t id; struct omemoKeyPair kp; }; struct omemoSignedPreKey { uint32_t id; struct omemoKeyPair kp; omemoCurveSignature sig; }; struct omemoMessageKey { uint32_t nr; omemoKey dh; omemoKey mk; }; struct omemoState { struct omemoKeyPair dhs; omemoKey dhr; omemoKey rk, cks, ckr; uint32_t ns, nr, pn; }; struct omemoKeyMessage { uint8_t p[OMEMO_INTERNAL_PREKEYHEADER_MAXSIZE + OMEMO_INTERNAL_ENCRYPTED_MAXSIZE]; size_t n; bool isprekey; }; struct omemoStore { bool init; struct omemoKeyPair identity; struct omemoSignedPreKey cursignedprekey, prevsignedprekey; struct omemoPreKey prekeys[OMEMO_NUMPREKEYS]; uint32_t pkcounter; }; struct omemoSession { int init; omemoKey identity; omemoKey remoteidentity; struct omemoState state; omemoKey usedek; uint32_t usedpk_id, usedspk_id; }; typedef int (*omemoLoadMessageKeyCallback)(struct omemoSession *, struct omemoMessageKey *sk); typedef int (*omemoStoreMessageKeyCallback)( struct omemoSession *, const struct omemoMessageKey *, uint64_t n); typedef int (*omemoRandomCallback)(void *p, size_t n); int omemoLoadMessageKey(struct omemoSession *s, struct omemoMessageKey *sk); int omemoRemoveMessageKey(struct omemoSession *s, const struct omemoMessageKey *sk); int omemoStoreMessageKey(struct omemoSession *s, const struct omemoMessageKey *sk, uint64_t n); int omemoRandom(void *p, size_t n); /** * Set global callbacks for storing/loading skipped message keys and * random generation. */ OMEMO_EXPORT void omemoSetCallbacks(omemoLoadMessageKeyCallback, omemoStoreMessageKeyCallback, omemoRandomCallback); /** * Serialize a raw public key into the OMEMO public key format. */ OMEMO_EXPORT void omemoSerializeKey(omemoSerializedKey k, const omemoKey pub); /** * Generate a new store for an OMEMO device. * * @returns 0 or OMEMO_E* */ OMEMO_EXPORT int omemoSetupStore(struct omemoStore *store); /** * Refill all removed prekeys in store. * * @returns 0 or OMEMO_ECRYPTO */ OMEMO_EXPORT int omemoRefillPreKeys(struct omemoStore *store); /** * Rotate signed prekey in store. * * Retains the previous signed prekey for one rotation. * * @returns 0 or OMEMO_ECRYPTO */ OMEMO_EXPORT int omemoRotateSignedPreKey(struct omemoStore *store); /** * @returns size of buffer required for omemoSerializeStore */ OMEMO_EXPORT size_t omemoGetSerializedStoreSize(const struct omemoStore *store); /** * @param d buffer with capacity returned by * omemoGetSerializedStoreSize() */ OMEMO_EXPORT void omemoSerializeStore(uint8_t *d, const struct omemoStore *store); /** * @returns 0 or OMEMO_E* */ OMEMO_EXPORT int omemoDeserializeStore(const uint8_t *p, size_t n, struct omemoStore *store); /** * @returns size of buffer required for omemoSerializeSession */ OMEMO_EXPORT size_t omemoGetSerializedSessionSize(const struct omemoSession *session); /** * @param d buffer with capacity returned by * omemoGetSerializedSessionSize() */ OMEMO_EXPORT void omemoSerializeSession(uint8_t *d, const struct omemoSession *session); /** * @param session must be initialized with omemoSetupSession * @return 0 or OMEMO_EPROTOBUF */ OMEMO_EXPORT int omemoDeserializeSession(const uint8_t *p, size_t n, struct omemoSession *session); /** * Initiate OMEMO session with retrieved bundle. * * @returns 0 or OMEMO_E* */ OMEMO_EXPORT int omemoInitiateSession(struct omemoSession *session, const struct omemoStore *store, const omemoCurveSignature spks, const omemoSerializedKey spk, const omemoSerializedKey ik, const omemoSerializedKey pk, uint32_t spk_id, uint32_t pk_id); /** * Encrypt message encryption key payload for a specific recipient. * * @returns 0 or OMEMO_E* */ OMEMO_EXPORT int omemoEncryptKey(struct omemoSession *session, struct omemoKeyMessage *msg, const uint8_t *key, size_t keyn); /** * Decrypt message encryption key payload for a specific recipient. * * If a prekey is used, it will be stored in session->usedpk_id, which * should be removed from the store and bundle after catching up with * all other messages. Remove by iterating over store->prekeys and * zeroing the omemoPreKey structure where id == store->usedpk_id. * * If session->state.nr >= 53 you should send an empty message back to * advance the ratchet. * * @returns 0 or OMEMO_E* */ OMEMO_EXPORT int omemoDecryptKey(struct omemoSession *session, const struct omemoStore *store, uint8_t *key, size_t *keyn, bool isprekey, const uint8_t *msg, size_t msgn); /** * Create a heartbeat message if the ratchet counter is too high. * * This function can should be called after every omemoDecryptKey(). It * checks whether the counter is too high. When it is, it will fill * the omemoKeyMessage with a newly encrypted key which should be sent * afterwards. To check whether a heartbeat msg was made, check if * msg->n > 0. * * @returns 0 or OMEMO_E* */ OMEMO_EXPORT int omemoHeartbeat(struct omemoSession *session, const struct omemoStore *store, struct omemoKeyMessage *msg); #ifdef OMEMO2 #define omemoGetMessagePadSize(n) (16 - (n % 16)) /** * Encrypt message which will be stored in the element. * * @param key (out) will contain the encryption key * @param s is a mutable buffer containing the plaintext message with * `omemoGetMessagePadSize(n)` amount of bytes reserved at the end * @param d is the destination buffer that is the same size as s * @param n is the original message size * * @returns 0 or OMEMO_E* */ OMEMO_EXPORT int omemoEncryptMessage(uint8_t *d, uint8_t key[48], uint8_t *s, size_t n); #else /** * Encrypt message which will be stored in the element. * * @param key (out) will contain the encryption key * @param n is the size of the buffer in d and s * * @returns 0 or OMEMO_E* */ OMEMO_EXPORT int omemoEncryptMessage(uint8_t *d, uint8_t key[32], uint8_t iv[12], const uint8_t *s, size_t n); #endif #ifdef OMEMO2 /** * Decrypt message taken from the element. * * @param key is the decrypted key of the omemoKeyMessage * @param keyn is the size of key * @param n is the size of the buffer in d and s * * @returns 0 or OMEMO_E* */ OMEMO_EXPORT int omemoDecryptMessage(uint8_t *d, size_t *outn, const uint8_t *key, size_t keyn, const uint8_t *s, size_t n); #else /** * Decrypt message taken from the element. * * @param key is the decrypted key of the omemoKeyMessage * @param keyn is the size of key, some clients might make the tag * larger than 16 bytes * @param n is the size of the buffer in d and s * * @returns 0 or OMEMO_E* */ OMEMO_EXPORT int omemoDecryptMessage(uint8_t *d, const uint8_t *key, size_t keyn, const uint8_t iv[12], const uint8_t *s, size_t n); #endif #endif emacs-jabber-0.13.1/tests/000077500000000000000000000000001523531702000152475ustar00rootroot00000000000000emacs-jabber-0.13.1/tests/Makefile.am000066400000000000000000000006141523531702000173040ustar00rootroot00000000000000# 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-0.13.1/tests/caps-hash.el000066400000000000000000000026361523531702000174470ustar00rootroot00000000000000;;; caps-hash.el --- Test disco hash against examples in XEP-0115 -*- lexical-binding: t; -*- (require 'jabber-disco) (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-0.13.1/tests/jabber-test-activity.el000066400000000000000000000311271523531702000216310ustar00rootroot00000000000000;;; jabber-test-activity.el --- Tests for jabber-activity -*- lexical-binding: t; -*- ;;; Commentary: ;; Activity tracking and mode-line integration. ;;; Code: ;;; Code: (require 'ert) (require 'jabber-activity) ;; 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-buffer-connection) (defvar jabber-connections) (defvar jabber-roster-list) ;; 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-test-activity-common-prefix-basic () "Common prefix of strings with shared start." (should (= 3 (jabber-activity-common-prefix "abcdef" "abcxyz")))) (ert-deftest jabber-test-activity-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-test-activity-common-prefix-identical () "Common prefix of identical strings." (should (= 5 (jabber-activity-common-prefix "hello" "hello")))) (ert-deftest jabber-test-activity-common-prefix-no-match () "Common prefix of strings with no shared start." (should (= 0 (jabber-activity-common-prefix "abc" "xyz")))) (ert-deftest jabber-test-activity-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-test-activity-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-test-activity-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-test-activity-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-test-activity-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-test-activity-no-update-when-unchanged () "Do not call `force-mode-line-update' 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-test-activity-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-test-activity-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-test-activity-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-test-activity-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-list 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))))) ;;; Group 7: missing buffer recovery (ert-deftest jabber-test-activity-switch-to-recovers-missing-chat-buffer () "Missing 1:1 activity buffers are recreated through chat setup." (let ((jid "friend@example.org") (jc 'test-connection) (jabber-connections '(test-connection)) (jabber-buffer-connection nil) (jabber-activity-jids '("friend@example.org")) (jabber-activity-personal-jids nil) (created nil) (cleanup-called nil)) (with-temp-buffer (let ((target (generate-new-buffer " *jabber-test-chat*"))) (unwind-protect (cl-letf (((symbol-function 'jabber-activity-find-buffer-name) (lambda (_jid) nil)) ((symbol-function 'jabber-chat-with) (lambda (actual-jc actual-jid &optional _other-window) (setq created (list actual-jc actual-jid)) (switch-to-buffer target))) ((symbol-function 'fsm-get-state-data) (lambda (_jc) nil)) ((symbol-function 'jabber-muc-sender-p) (lambda (_jid) nil)) ((symbol-function 'jabber-muc-joined-p) (lambda (_jid &optional _jc) nil)) ((symbol-function 'jabber-activity-clean) (lambda () (setq cleanup-called t)))) (jabber-activity-switch-to jid) (should (equal created (list jc jid))) (should cleanup-called) (should (equal jabber-activity-jids (list jid)))) (when (buffer-live-p target) (kill-buffer target))))))) (ert-deftest jabber-test-activity-switch-to-recovers-missing-muc-buffer () "Missing active MUC activity buffers are recreated through MUC setup." (let ((jid "room@conference.example.org") (jabber-activity-jids '("room@conference.example.org")) (jabber-activity-personal-jids nil) (switched nil)) (with-temp-buffer (let ((target (generate-new-buffer " *jabber-test-muc*"))) (unwind-protect (cl-letf (((symbol-function 'jabber-activity-find-buffer-name) (lambda (_jid) nil)) ((symbol-function 'jabber-muc-sender-p) (lambda (_jid) nil)) ((symbol-function 'jabber-muc-joined-p) (lambda (_jid &optional _jc) t)) ((symbol-function 'jabber-muc-switch-to) (lambda (actual-jid) (setq switched actual-jid) (switch-to-buffer target))) ((symbol-function 'jabber-activity-clean) (lambda () nil))) (jabber-activity-switch-to jid) (should (string= switched jid)) (should (equal jabber-activity-jids (list jid)))) (when (buffer-live-p target) (kill-buffer target))))))) (ert-deftest jabber-test-activity-switch-to-missing-buffer-without-connection-falls-back () "Missing activity buffers still fall back when no connection can create one." (let ((jid "friend@example.org") (jabber-connections nil) (jabber-buffer-connection nil) (jabber-activity-jids '("friend@example.org")) (jabber-activity-personal-jids '("friend@example.org")) (message-text nil)) (cl-letf (((symbol-function 'jabber-activity-find-buffer-name) (lambda (_jid) nil)) ((symbol-function 'jabber-chat-with) (lambda (&rest _args) (ert-fail "jabber-chat-with should not be called"))) ((symbol-function 'jabber-muc-sender-p) (lambda (_jid) nil)) ((symbol-function 'jabber-muc-joined-p) (lambda (_jid &optional _jc) nil)) ((symbol-function 'jabber-activity-mode-line-update) (lambda () nil)) ((symbol-function 'jabber-activity-clean) (lambda () nil)) ((symbol-function 'message) (lambda (format-string &rest args) (setq message-text (apply #'format format-string args))))) (jabber-activity-switch-to jid) (should-not jabber-activity-jids) (should-not jabber-activity-personal-jids) (should (string= message-text "Buffer for friend@example.org no longer exists"))))) (provide 'jabber-test-activity) ;;; jabber-test-activity.el ends here emacs-jabber-0.13.1/tests/jabber-test-ahc.el000066400000000000000000000264041523531702000205320ustar00rootroot00000000000000;;; jabber-test-ahc.el --- Tests for Jabber ad-hoc commands -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0050 command discovery and form submission. ;;; Code: (require 'ert) (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-ahc) (ert-deftest jabber-test-ahc-get-list-uses-command-node () "Command discovery uses the XEP-0050 disco node and a focused callback." (let (arguments) (cl-letf (((symbol-function 'jabber-disco-get-items) (lambda (&rest args) (setq arguments args)))) (with-temp-buffer (jabber-ahc-get-list 'fake-jc "commands.example.org"))) (should (eq (nth 0 arguments) 'fake-jc)) (should (equal (nth 1 arguments) "commands.example.org")) (should (equal (nth 2 arguments) jabber-ahc-xmlns)) (should (eq (nth 3 arguments) #'jabber-ahc--command-list-result)) (should (bufferp (car (nth 4 arguments)))))) (ert-deftest jabber-test-ahc-command-list-executes-item-directly () "Choosing a discovered command passes its JID and node without prompts." (let ((jabber-connections '(fake-jc)) shown-map executed) (cl-letf (((symbol-function 'keymap-popup) (lambda (map) (setq shown-map map))) ((symbol-function 'pop-to-buffer) #'ignore) ((symbol-function 'jabber-connection-active-p) #'identity) ((symbol-function 'jabber-ahc-execute-command) (lambda (jc to node) (setq executed (list jc to node))))) (with-temp-buffer (jabber-ahc--command-list-result 'fake-jc (list (current-buffer) "commands.example.org") (list ["Restart service" "admin.example.org" "restart"])) (should (keymapp shown-map)) (call-interactively (keymap-lookup shown-map "1")))) (should (equal executed '(fake-jc "admin.example.org" "restart"))))) (ert-deftest jabber-test-ahc-command-list-keeps-item-specific-data () "Each discovered command keeps its own JID and node." (let ((jabber-connections '(fake-jc)) executed) (cl-letf (((symbol-function 'jabber-connection-active-p) #'identity) ((symbol-function 'jabber-ahc-execute-command) (lambda (jc to node) (push (list jc to node) executed)))) (let ((map (jabber-ahc--command-list-map 'fake-jc "commands.example.org" (list ["First" "one.example.org" "node-1"] ["Second" "two.example.org" "node-2"])))) (call-interactively (keymap-lookup map "1")) (call-interactively (keymap-lookup map "2")))) (should (equal (nreverse executed) '((fake-jc "one.example.org" "node-1") (fake-jc "two.example.org" "node-2")))))) (ert-deftest jabber-test-ahc-command-list-resolves-live-connection () "Command activation resolves a replacement for a stale connection." (let ((jabber-connections '(live-jc)) executed) (cl-letf (((symbol-function 'jabber-find-active-connection) (lambda (jc) (should (eq jc 'dead-jc)) 'live-jc)) ((symbol-function 'jabber-connection-active-p) (lambda (jc) (eq jc 'live-jc))) ((symbol-function 'jabber-ahc-execute-command) (lambda (jc _to _node) (setq executed jc)))) (let ((map (jabber-ahc--command-list-map 'dead-jc "commands.example.org" (list ["First" "one.example.org" "node-1"])))) (call-interactively (keymap-lookup map "1")))) (should (eq executed 'live-jc)))) (ert-deftest jabber-test-ahc-command-list-pages-four-at-a-time () "Discovered commands are divided into pages of at most four." (let ((items (cl-loop for number from 1 to 5 collect (vector (format "Command %d" number) "admin.example.org" (format "node-%d" number))))) (with-temp-buffer (jabber-ahc--command-list-map 'fake-jc "commands.example.org" items) (should (equal (jabber-ahc--command-description 0) "Command 1")) (should (jabber-ahc--command-has-next-page-p)) (jabber-ahc-command-next-page) (should (equal (jabber-ahc--command-description 0) "Command 5")) (should-not (jabber-ahc--command-at 1)) (should-not (jabber-ahc--command-has-next-page-p))))) (ert-deftest jabber-test-ahc-display-opens-data-form-with-server-actions () "An executing command uses the data-form menu and advertised actions." (let (shown-form shown-actions) (cl-letf (((symbol-function 'pop-to-buffer) #'ignore) ((symbol-function 'jabber-xdata-form-open) (lambda (form actions) (setq shown-form form shown-actions actions)))) (with-temp-buffer (jabber-ahc-display 'fake-jc '(iq ((from . "admin.example.org") (type . "result")) (command ((xmlns . "http://jabber.org/protocol/commands") (node . "restart") (sessionid . "session-1") (status . "executing")) (actions ((execute . "complete")) (prev nil) (complete nil)) (x ((xmlns . "jabber:x:data") (type . "form")) (field ((var . "confirm") (type . "boolean")) (value nil "1")))))))) (should (equal (plist-get (jabber-xdata-field shown-form "confirm") :values) '("1"))) (should (equal (mapcar (lambda (action) (list (plist-get action :key) (plist-get action :label))) shown-actions) '(("p" "Prev") ("RET" "Complete") ("q" "Cancel")))))) (ert-deftest jabber-test-ahc-overlapping-forms-keep-session-context () "Submitting an older form uses its original XEP-0050 session." (let (opened sent) (cl-letf (((symbol-function 'pop-to-buffer) #'ignore) ((symbol-function 'jabber-xdata-form-open) (lambda (_form actions) (setq opened (append opened (list actions))))) ((symbol-function 'jabber-connection-active-p) #'identity) ((symbol-function 'jabber-send-iq) (lambda (jc to _type query &rest _ignore) (setq sent (list jc to query))))) (with-temp-buffer (dolist (session '(("one.example.org" "node-1" "session-1") ("two.example.org" "node-2" "session-2"))) (jabber-ahc-display 'fake-jc `(iq ((from . ,(nth 0 session)) (type . "result")) (command ((xmlns . "http://jabber.org/protocol/commands") (node . ,(nth 1 session)) (sessionid . ,(nth 2 session)) (status . "executing")) (actions ((execute . "complete")) (complete nil)) (x ((xmlns . "jabber:x:data") (type . "form"))))))) (with-temp-buffer (setq-local jabber-xdata-form--form '(:fields nil)) (let ((jabber-connections '(fake-jc)) (complete (seq-find (lambda (action) (equal (plist-get action :label) "Complete")) (car opened)))) (call-interactively (plist-get complete :command)))))) (should (equal (nth 0 sent) 'fake-jc)) (should (equal (nth 1 sent) "one.example.org")) (let ((command (nth 2 sent))) (should (equal (jabber-xml-get-attribute command 'node) "node-1")) (should (equal (jabber-xml-get-attribute command 'sessionid) "session-1"))))) (ert-deftest jabber-test-ahc-result-does-not-enable-widget-ui () "A read-only command result renders without widget buffer machinery." (with-temp-buffer (jabber-ahc-display 'fake-jc '(iq ((from . "admin.example.org") (type . "result")) (command ((xmlns . "http://jabber.org/protocol/commands") (node . "status") (sessionid . "session-1") (status . "completed")) (x ((xmlns . "jabber:x:data") (type . "result")) (field ((var . "status") (label . "Status")) (value nil "Running")))))) (should-not (bound-and-true-p widget-minor-mode)) (should (string-match-p "Status:.*Running" (buffer-string))))) (ert-deftest jabber-test-ahc-submit-sends-form-only-for-forward-actions () "Complete submits the current form while cancel sends no form." (let (queries) (cl-letf (((symbol-function 'jabber-connection-active-p) #'identity) ((symbol-function 'jabber-send-iq) (lambda (_jc _to _type query &rest _ignore) (push query queries)))) (with-temp-buffer (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-ahc--submit-to "admin.example.org") (setq-local jabber-ahc-sessionid "session-1") (setq-local jabber-ahc-node "restart") (setq-local jabber-ahc--has-form t) (setq-local jabber-xdata-form--form (jabber-xdata-parse '(x ((xmlns . "jabber:x:data") (type . "form")) (field ((var . "FORM_TYPE") (type . "hidden")) (value nil "urn:test"))))) (let ((jabber-connections '(fake-jc))) (jabber-ahc-submit 'complete) (jabber-ahc-submit 'cancel)))) (should (jabber-xml-get-children (cadr queries) 'x)) (should-not (jabber-xml-get-children (car queries) 'x)))) (ert-deftest jabber-test-ahc-rejects-reconnecting-connection () "Command activation and submission reject a reconnecting FSM." (let ((reconnecting (make-symbol "reconnecting")) jabber-connections called) (setq jabber-connections (list reconnecting)) (put reconnecting :state :connecting) (cl-letf (((symbol-function 'jabber-ahc-execute-command) (lambda (&rest _ignore) (setq called t))) ((symbol-function 'jabber-send-iq) (lambda (&rest _ignore) (setq called t)))) (let ((map (jabber-ahc--command-list-map reconnecting "commands.example.org" (list ["First" "one.example.org" "node-1"])))) (should-error (call-interactively (keymap-lookup map "1")) :type 'user-error)) (with-temp-buffer (setq-local jabber-buffer-connection reconnecting) (setq-local jabber-ahc--submit-to "one.example.org") (setq-local jabber-ahc--has-form nil) (should-error (jabber-ahc-submit 'cancel) :type 'user-error))) (should-not called))) (ert-deftest jabber-test-ahc-actions-without-execute-have-no-default-key () "An actions element without execute does not advertise a default button." (let ((actions (jabber-ahc--menu-actions '(actions nil (next nil)) nil))) (should (equal (mapcar (lambda (action) (plist-get action :key)) actions) '("n" "q"))))) (provide 'jabber-test-ahc) ;;; jabber-test-ahc.el ends here emacs-jabber-0.13.1/tests/jabber-test-autoaway.el000066400000000000000000000043251523531702000216270ustar00rootroot00000000000000;;; jabber-test-autoaway.el --- Tests for jabber-autoaway -*- lexical-binding: t; -*- ;;; Commentary: ;; Autoaway presence selection. ;;; Code: (require 'ert) (require 'jabber-autoaway) (defvar jabber-current-priority) (defvar jabber-current-show) (defvar jabber-current-status) (defvar jabber-default-status) (defun jabber-test-autoaway--presence (xa show away-priority xa-priority) "Return presence sent for XA and SHOW using AWAY-PRIORITY and XA-PRIORITY." (let ((jabber-current-show show) (jabber-current-status "Available") (jabber-current-priority 1) (jabber-default-status "Available") (jabber-autoaway-status "Idle") (jabber-autoaway-xa-status "Extended away") (jabber-autoaway-priority away-priority) (jabber-autoaway-xa-priority xa-priority) sent) (cl-letf (((symbol-function 'jabber-send-presence) (lambda (&rest args) (setq sent args))) ((symbol-function 'jabber-autoaway-get-idle-time) (lambda () 600)) ((symbol-function 'run-with-timer) #'ignore)) (jabber-autoaway-set-idle xa)) sent)) (ert-deftest jabber-test-autoaway-uses-away-priority () "Away presence uses `jabber-autoaway-priority'." (should (equal '("away" "Idle" 5) (jabber-test-autoaway--presence nil nil 5 9)))) (ert-deftest jabber-test-autoaway-uses-xa-priority () "Extended-away presence uses `jabber-autoaway-xa-priority'." (should (equal '("xa" "Extended away" 9) (jabber-test-autoaway--presence t "away" 5 9)))) (ert-deftest jabber-test-autoaway-nil-priorities-preserve-current-priority () "Nil away and XA priorities preserve the current priority." (should (equal '("away" "Idle" 1) (jabber-test-autoaway--presence nil nil nil 9))) (should (equal '("xa" "Extended away" 1) (jabber-test-autoaway--presence t "away" 5 nil)))) (ert-deftest jabber-test-autoaway-preserves-dnd-and-xa () "Autoaway does not replace explicit DND or extended-away presence." (should-not (jabber-test-autoaway--presence nil "dnd" 5 9)) (should-not (jabber-test-autoaway--presence nil "xa" 5 9))) (provide 'jabber-test-autoaway) ;;; jabber-test-autoaway.el ends here emacs-jabber-0.13.1/tests/jabber-test-avatar.el000066400000000000000000000033211523531702000212460ustar00rootroot00000000000000;;; -*- lexical-binding: t; -*- (require 'ert) (require 'cl-lib) (require 'jabber-avatar) (require 'jabber-util) ;;; Avatar display bounds (ert-deftest jabber-test-avatar-image-uses-configured-bounds () (let ((avatar (make-jabber-avatar :base64-data (base64-encode-string "data" t) :mime-type "image/png")) (jabber-avatar-max-width 32) (jabber-avatar-max-height 48)) (cl-letf (((symbol-function 'jabber-image-create) (lambda (data mime-type max-width max-height) (list data mime-type max-width max-height)))) (should (equal (jabber-avatar-image avatar) '("data" "image/png" 32 48)))))) (ert-deftest jabber-test-avatar-set-cached-uses-configured-bounds () ;; Fresh obarray so the interned JID symbol carries no `avatar-hash' ;; from a prior run; otherwise the same-avatar optimization in ;; `jabber-avatar-set' skips the reload on a second in-process run. (let ((jabber-jid-obarray (make-vector 127 0)) (jabber-avatar-cache-directory temporary-file-directory) (jabber-avatar-max-width 40) (jabber-avatar-max-height 44) (calls nil)) (cl-letf (((symbol-function 'jabber-avatar-find-cached) (lambda (_hash) "/tmp/avatar.png")) ((symbol-function 'jabber-image-create-from-file) (lambda (file max-width max-height) (push (list file max-width max-height) calls) 'image))) (jabber-avatar-set "romeo@example.net" "hash") (should (equal calls '(("/tmp/avatar.png" 40 44)))) (should (eq (get (jabber-jid-symbol "romeo@example.net") 'avatar) 'image))))) (provide 'jabber-test-avatar) emacs-jabber-0.13.1/tests/jabber-test-blocking.el000066400000000000000000000060541523531702000215660ustar00rootroot00000000000000;;; jabber-test-blocking.el --- Tests for XEP-0191 blocking -*- lexical-binding: t; -*- ;;; Code: (require 'ert) (require 'cl-lib) (require 'jabber-blocking) (ert-deftest jabber-test-blocking-apply-block-push () "A block push adds its JIDs without duplicates." (let ((query `(block ((xmlns . ,jabber-blocking-xmlns)) (item ((jid . "a@example.org"))) (item ((jid . "b@example.org")))))) (should (equal (jabber-blocking--apply-push '("a@example.org" "old@example.org") query) '("a@example.org" "old@example.org" "b@example.org"))))) (ert-deftest jabber-test-blocking-apply-unblock-push () "An unblock push removes listed JIDs or clears the whole list." (let ((current '("a@example.org" "b@example.org"))) (should (equal (jabber-blocking--apply-push current `(unblock ((xmlns . ,jabber-blocking-xmlns)) (item ((jid . "a@example.org"))))) '("b@example.org"))) (should-not (jabber-blocking--apply-push current `(unblock ((xmlns . ,jabber-blocking-xmlns))))))) (ert-deftest jabber-test-blocking-processes-valid-push () "A valid server push updates state and receives an IQ result." (let* ((state-data (list :username "me" :server "example.org" :resource "emacs" :blocking-list '("old@example.org"))) (xml `(iq ((type . "set") (id . "push-1")) (block ((xmlns . ,jabber-blocking-xmlns)) (item ((jid . "new@example.org")))))) sent) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_jc) state-data)) ((symbol-function 'jabber-send-iq) (lambda (&rest args) (setq sent args)))) (jabber-blocking--process-push 'fake-jc xml)) (should (equal (plist-get state-data :blocking-list) '("old@example.org" "new@example.org"))) (should (equal (nth 2 sent) "result")) (should (equal (car (last sent)) "push-1")))) (ert-deftest jabber-test-blocking-rejects-foreign-push () "A foreign entity cannot change the local blocklist state." (let* ((state-data (list :username "me" :server "example.org" :resource "emacs" :blocking-list '("old@example.org"))) (xml `(iq ((type . "set") (id . "push-1") (from . "attacker@example.net")) (block ((xmlns . ,jabber-blocking-xmlns)) (item ((jid . "new@example.org")))))) sent) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_jc) state-data)) ((symbol-function 'jabber-send-iq) (lambda (&rest args) (setq sent args)))) (jabber-blocking--process-push 'fake-jc xml)) (should (equal (plist-get state-data :blocking-list) '("old@example.org"))) (should-not sent))) (provide 'jabber-test-blocking) ;;; jabber-test-blocking.el ends here emacs-jabber-0.13.1/tests/jabber-test-bookmarks.el000066400000000000000000001057541523531702000217750ustar00rootroot00000000000000;;; jabber-test-bookmarks.el --- Tests for jabber-bookmarks -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0048/XEP-0402 bookmark storage and retrieval. ;;; Code: (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-test-bookmarks-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-test-bookmarks-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-test-bookmarks-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-test-bookmarks-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)))) (ert-deftest jabber-test-bookmarks-parse-preserves-extensions () "Parse and keep the XEP-0402 element." (let* ((extensions '(extensions () (group ((xmlns . "xmpp:prosody.im/bookmarks") (name . "work"))))) (item `(item ((id . "room@conference.example.com")) (conference ((xmlns . "urn:xmpp:bookmarks:1")) ,extensions))) (result (jabber-bookmarks2--parse-item item))) (should (equal extensions (plist-get result :extensions))))) ;;; Group 2: Build conference XML (ert-deftest jabber-test-bookmarks-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-test-bookmarks-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-test-bookmarks-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-test-bookmarks-build-preserves-extensions () "Build native bookmark XML with the original element." (let* ((extensions '(extensions () (group ((xmlns . "xmpp:prosody.im/bookmarks") (name . "work"))))) (elem (jabber-bookmarks2--build-conference (list :jid "room@c.example.com" :extensions extensions)))) (should (equal extensions (car (jabber-xml-get-children elem 'extensions)))))) (ert-deftest jabber-test-bookmarks-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")))) (ert-deftest jabber-test-bookmarks-roundtrip-preserves-extensions () "Build then parse keeps unknown native bookmark extensions." (let* ((extensions '(extensions () (private ((xmlns . "urn:example:private") (value . "1"))))) (original (list :jid "room@c.example.com" :name "Room" :extensions extensions)) (elem (jabber-bookmarks2--build-conference original)) (item `(item ((id . "room@c.example.com")) ,elem)) (parsed (jabber-bookmarks2--parse-item item))) (should (equal extensions (plist-get parsed :extensions))))) ;;; 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-test-bookmarks-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-test-bookmarks-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-test-bookmarks-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-test-bookmarks-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-test-bookmarks-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 "user@example.com" 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-test-bookmarks-event-ignores-foreign-sender () "A foreign bare JID cannot inject bookmark changes." (let ((jabber-bookmarks (make-hash-table :test 'equal)) joined) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "user@example.com")) ((symbol-function 'jabber-muc-joined-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-join) (lambda (&rest args) (setq joined args)))) (jabber-bookmarks2--handle-event 'fake-jc "attacker@example.net" jabber-bookmarks2-xmlns `((item ((id . "room@c.example.com")) (conference ((xmlns . ,jabber-bookmarks2-xmlns) (autojoin . "true"))))))) (should-not joined) (should-not (gethash "user@example.com" jabber-bookmarks)))) (ert-deftest jabber-test-bookmarks-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 "user@example.com" nil `((item ((id . "room@c.example.com")) (conference ((xmlns . ,jabber-bookmarks2-xmlns))))))) (should (member "room@c.example.com" left)))) (ert-deftest jabber-test-bookmarks-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 "user@example.com" 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-test-bookmarks-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 "user@example.com" nil `((item ((id . "room@c.example.com")) (conference ((xmlns . ,jabber-bookmarks2-xmlns) (autojoin . "true"))))))) (should (= 0 join-count)))) (ert-deftest jabber-test-bookmarks-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 "user@example.com" 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-test-bookmarks-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-test-bookmarks-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-test-bookmarks-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-test-bookmarks-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))) ;;; Group 7: Bookmark editor UI (ert-deftest jabber-bookmarks-test-column-format-has-minimum-widths () "Bookmark editor columns stay usable in narrow windows." (cl-letf (((symbol-function 'window-width) (lambda (&rest _) 20))) (let ((format (jabber-bookmarks--column-format))) (should (= 5 (length format))) (should (equal "JID" (car (aref format 0)))) (should (= 20 (cadr (aref format 0)))) (should (equal "Name" (car (aref format 1)))) (should (= 12 (cadr (aref format 1)))) (should (equal "Autojoin" (car (aref format 2)))) (should (= 8 (cadr (aref format 2)))) (should (equal "Nick" (car (aref format 3)))) (should (= 12 (cadr (aref format 3)))) (should (equal "Password" (car (aref format 4)))) (should (= 8 (cadr (aref format 4))))))) (ert-deftest jabber-bookmarks-test-refresh-buffer-updates-column-format () "Refreshing the bookmark buffer recalculates column widths." (let ((buffer (get-buffer-create "*jabber-bookmarks*")) (width 80)) (unwind-protect (cl-letf (((symbol-function 'window-width) (lambda (&rest _) width)) ((symbol-function 'tabulated-list-print) #'ignore)) (with-current-buffer buffer (jabber-bookmarks-mode) (setq width 160) (jabber-bookmarks--refresh-buffer) (should (= 52 (cadr (aref tabulated-list-format 0)))))) (kill-buffer buffer)))) (provide 'jabber-test-bookmarks) ;;; jabber-test-bookmarks.el ends here emacs-jabber-0.13.1/tests/jabber-test-carbons.el000066400000000000000000000465161523531702000214340ustar00rootroot00000000000000;;; jabber-test-carbons.el --- Tests for jabber-carbons -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0280 Message Carbons processing. ;;; Code: ;; 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-test-carbons--make-carbon (type from inner-from inner-to &optional id body extra-elements) "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\". EXTRA-ELEMENTS are appended to the inner message." (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")) ,@extra-elements)))))) (defun jabber-test-carbons--make-carbon-with-namespaces (type wrapper-xmlns forwarded-xmlns) "Build a carbon-like stanza with explicit namespace values. TYPE is `sent' or `received'. WRAPPER-XMLNS is the namespace for the carbon wrapper. FORWARDED-XMLNS is the namespace for ." `(message ((from . "me@example.com") (type . "chat")) (,type ((xmlns . ,wrapper-xmlns)) (forwarded ((xmlns . ,forwarded-xmlns)) (message ((from . "me@example.com/phone") (to . "friend@example.com") (type . "chat")) (body nil "Hello")))))) (defun jabber-test-carbons--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-test-carbons--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-test-carbons--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-test-carbons--make-plain-message "friend@example.com" "me@example.com")) (result (jabber-chat--extract-carbon stanza))) (should-not result))) (ert-deftest jabber-chat-test-extract-carbon-rejects-wrapper-namespace () "Extract-carbon rejects sent/received elements outside carbons." (let ((stanza (jabber-test-carbons--make-carbon-with-namespaces 'sent "urn:example:not-carbons" "urn:xmpp:forward:0"))) (should-not (jabber-chat--extract-carbon stanza)))) (ert-deftest jabber-chat-test-extract-carbon-rejects-forwarded-namespace () "Extract-carbon rejects forwarded elements outside XEP-0297." (let ((stanza (jabber-test-carbons--make-carbon-with-namespaces 'sent "urn:xmpp:carbons:2" "urn:example:not-forward"))) (should-not (jabber-chat--extract-carbon stanza)))) ;;; 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-test-carbons--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 finds an existing buffer for a valid sent carbon." (let* ((stanza (jabber-test-carbons--make-carbon 'sent "me@example.com" "me@example.com/phone" "friend@example.com")) (test-buffer (generate-new-buffer " *test-carbon*"))) (with-current-buffer test-buffer (setq-local jabber-buffer-connection 'fake-jc)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-chat--find-buffer) (lambda (to) (should (equal to "friend@example.com")) test-buffer)) ((symbol-function 'jabber-chat-create-buffer) (lambda (&rest _) (ert-fail "Carbon unwrapping created a chat 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-sent-carbon-session-is-account-scoped () "A sent carbon adopts the session only in its account's chat buffer." (let ((account-a-buffer (generate-new-buffer " *carbon-account-a*")) (account-b-buffer (generate-new-buffer " *carbon-account-b*")) stored) (unwind-protect (progn (with-current-buffer account-a-buffer (setq-local jabber-buffer-connection 'account-a) (setq-local jabber-chatting-with "friend@example.com") (setq-local jabber-message-thread-session-id "session-a")) (with-current-buffer account-b-buffer (setq-local jabber-buffer-connection 'account-b) (setq-local jabber-chatting-with "friend@example.com") (setq-local jabber-message-thread-session-id "session-old-b")) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (jc) (pcase jc ('account-a "a@example.com") ('account-b "b@example.com")))) ((symbol-function 'jabber-chat--find-buffer) (lambda (_) account-a-buffer)) ((symbol-function 'jabber-chat-create-buffer) (lambda (jc peer) (should (eq jc 'account-b)) (should (equal peer "friend@example.com")) account-b-buffer)) ((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc stanza) stanza)) ((symbol-function 'jabber-message-thread-display-target) (lambda (&rest _) 'parent)) ((symbol-function 'jabber-chat--display-message) #'ignore) ((symbol-function 'jabber-chat--store-carbon) #'ignore) ((symbol-function 'jabber-db-set-chat-thread) (lambda (&rest args) (push args stored)))) (let ((jabber-chat-printers (list (lambda (&rest _) t)))) (jabber-process-chat 'account-b (jabber-test-carbons--make-carbon 'sent "b@example.com" "b@example.com/phone" "friend@example.com" "carbon-1" "hello" '((thread () "session-b")))))) (should (equal "session-a" (buffer-local-value 'jabber-message-thread-session-id account-a-buffer))) (should (equal "session-b" (buffer-local-value 'jabber-message-thread-session-id account-b-buffer))) (should (equal '(("b@example.com" "friend@example.com" "session-b")) stored))) (kill-buffer account-a-buffer) (kill-buffer account-b-buffer)))) (ert-deftest jabber-chat-test-bodyless-sent-carbon-does-not-create-buffer () "A bodyless sent carbon does not create a chat buffer." (let ((stanza '(message ((from . "me@example.com") (type . "chat")) (sent ((xmlns . "urn:xmpp:carbons:2")) (forwarded ((xmlns . "urn:xmpp:forward:0")) (message ((from . "me@example.com/phone") (to . "friend@example.com") (type . "chat")) (active ((xmlns . "http://jabber.org/protocol/chatstates")))))))) created) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-chat-create-buffer) (lambda (&rest _) (setq created t))) ((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc inner) inner)) ((symbol-function 'jabber-chat--store-carbon) #'ignore)) (let ((jabber-chat-printers nil)) (jabber-process-chat 'connection stanza)) (should-not created)))) (ert-deftest jabber-chat-test-unwrap-carbon-valid-received () "Unwrap-carbon returns inner message with no buffer for valid received carbon." (let* ((stanza (jabber-test-carbons--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-test-carbons-with-db (&rest body) "Run BODY with a fresh temp SQLite database." (declare (indent 0) (debug t)) `(let* ((jabber-test-carbons--dir (make-temp-file "jabber-carbons-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-test-carbons--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-test-carbons--dir) (delete-directory jabber-test-carbons--dir t))))) (ert-deftest jabber-chat-test-store-carbon-sent () "Sent carbon is stored with direction=out and peer=recipient." (jabber-test-carbons-with-db (let ((xml-data (jabber-test-carbons--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-test-carbons-with-db (let ((xml-data (jabber-test-carbons--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-test-carbons-with-db (let ((xml-data (jabber-test-carbons--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)))))))) (ert-deftest jabber-chat-test-sent-carbon-wire-session-stays-in-parent () "A first-seen sent-carbon wire session remains visible and stored." (jabber-test-carbons-with-db (let ((buffer (generate-new-buffer " *carbon-thread-root*")) (display-count 0) displayed-message displayed-buffer) (unwind-protect (let ((stanza (jabber-test-carbons--make-carbon 'sent "me@example.com" "me@example.com/phone" "friend@example.com" "root-1" "Thread root" '((thread () "thread-1"))))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-chat-create-buffer) (lambda (_jc jid) (should (equal jid "friend@example.com")) buffer)) ((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc inner) inner)) ((symbol-function 'jabber-chat--display-message) (lambda (_jc _xml target _local _from msg) (setq display-count (1+ display-count) displayed-buffer target displayed-message msg)))) (let ((jabber-chat-printers (list (lambda (&rest _) t)))) (jabber-process-chat 'connection stanza))) (should (= display-count 1)) (should (eq displayed-buffer buffer)) (should (equal "thread-1" (plist-get displayed-message :thread-id))) (should (equal '("thread-1") (car (sqlite-select jabber-db--connection "SELECT thread_id FROM message")))) (should-not (jabber-db-message-thread-summary "me@example.com" "friend@example.com" "chat" "thread-1")) (should (equal '((0)) (sqlite-select jabber-db--connection "SELECT dedicated FROM message_thread WHERE thread_id = 'thread-1'")))) (kill-buffer buffer))))) (ert-deftest jabber-chat-test-sent-correction-uses-recipient-buffer () "A sent-carbon correction redraws the recipient chat buffer." (let ((recipient-buffer (generate-new-buffer " *carbon-recipient*")) applied-buffer) (unwind-protect (let ((inner `(message ((from . "me@example.com/phone") (to . "friend@example.com") (type . "chat") (id . "correction-1")) (body () "corrected") (replace ((xmlns . ,jabber-message-correct-xmlns) (id . "original-1")))))) (cl-letf (((symbol-function 'jabber-muc-message-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-chat--unwrap-carbon) (lambda (&rest _) (cons inner recipient-buffer))) ((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc stanza) stanza)) ((symbol-function 'jabber-chat--store-carbon) #'ignore) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-message-correct--apply) (lambda (&rest args) (setq applied-buffer (car (funcall (nth 4 args) '(:row-id 7))))))) (jabber-process-chat 'fake-jc '(message ((from . "me@example.com/resource")))) (should (eq applied-buffer recipient-buffer)))) (kill-buffer recipient-buffer)))) (provide 'jabber-test-carbons) ;;; jabber-test-carbons.el ends here emacs-jabber-0.13.1/tests/jabber-test-chat.el000066400000000000000000002777271523531702000207360ustar00rootroot00000000000000;;; jabber-test-chat.el --- Tests for jabber-chat -*- lexical-binding: t; -*- ;;; Commentary: ;; One-to-one chat message parsing and display. ;;; Code: (require 'ert) (require 'jabber-chat) (require 'jabber-chat-commands) (defun jabber-test-chat--make-fake-jc (account) "Create a fake connection symbol for ACCOUNT." (let ((jc (gensym "jabber-test-chat-jc-")) (parts (split-string account "@"))) (put jc :state-data (list :username (nth 0 parts) :server (nth 1 parts))) jc)) (defmacro jabber-test-chat--with-db (&rest body) "Run BODY with a fresh temporary Jabber database." (declare (indent 0) (debug t)) `(let* ((dir (make-temp-file "jabber-chat-test" t)) (jabber-db-path (expand-file-name "test.sqlite" dir)) (jabber-db--connection nil)) (unwind-protect (progn (jabber-db-ensure-open) ,@body) (jabber-db-close) (when (file-directory-p dir) (delete-directory dir t))))) ;; 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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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)))) (ert-deftest jabber-test-chat-plist-from-stanza-server-id () "Valid stanza-id element sets :server-id." (let* ((stanza '(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (body () "Hello") (stanza-id ((xmlns . "urn:xmpp:sid:0") (id . "server-1") (by . "room@muc.example.com"))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (equal (plist-get plist :server-id) "server-1")))) (ert-deftest jabber-test-chat-plist-from-stanza-skips-origin-id () "Origin-id before stanza-id does not become :server-id." (let* ((stanza '(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (body () "Hello") (origin-id ((xmlns . "urn:xmpp:sid:0") (id . "origin-1"))) (stanza-id ((xmlns . "urn:xmpp:sid:0") (id . "server-1") (by . "room@muc.example.com"))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (equal (plist-get plist :server-id) "server-1")))) (ert-deftest jabber-test-chat-plist-from-stanza-rejects-stanza-id-without-by () "Stanza-id without by is not treated as a server id." (let* ((stanza '(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (body () "Hello") (stanza-id ((xmlns . "urn:xmpp:sid:0") (id . "server-1"))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should-not (plist-get plist :server-id)))) (ert-deftest jabber-test-chat-plist-groupchat-stanza-id-wrong-by-rejected () "Groupchat stanza-id with a by not matching the room is rejected." (let* ((stanza '(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (body () "Hello") (stanza-id ((xmlns . "urn:xmpp:sid:0") (id . "spoofed-1") (by . "attacker@evil.example"))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should-not (plist-get plist :server-id)))) (ert-deftest jabber-test-chat-plist-groupchat-stanza-id-skips-spoofed-by () "The room's stanza-id wins even when a spoofed one comes first." (let* ((stanza '(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (body () "Hello") (stanza-id ((xmlns . "urn:xmpp:sid:0") (id . "spoofed-1") (by . "attacker@evil.example"))) (stanza-id ((xmlns . "urn:xmpp:sid:0") (id . "server-1") (by . "room@muc.example.com"))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (equal (plist-get plist :server-id) "server-1")))) (ert-deftest jabber-test-chat-plist-chat-stanza-id-any-by-accepted () "1:1 chat messages keep accepting stanza-id from any archive." (let* ((stanza '(message ((from . "alice@example.com/phone") (type . "chat")) (body () "Hello") (stanza-id ((xmlns . "urn:xmpp:sid:0") (id . "archive-1") (by . "me@example.com"))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (equal (plist-get plist :server-id) "archive-1")))) (ert-deftest jabber-test-chat-plist-parses-origin-id () "Origin-id and stanza-id each land in their own plist key." (let* ((stanza '(message ((from . "alice@example.com/phone") (id . "client-1") (type . "chat")) (body () "Hello") (origin-id ((xmlns . "urn:xmpp:sid:0") (id . "origin-1"))) (stanza-id ((xmlns . "urn:xmpp:sid:0") (id . "archive-1") (by . "me@example.com"))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (equal "origin-1" (plist-get plist :origin-id))) (should (equal "archive-1" (plist-get plist :server-id))) (should (equal "client-1" (plist-get plist :id))))) (ert-deftest jabber-test-chat-plist-reply-fallback-range-parsed () "Reply fallback body offsets land in :fallback-range." (let* ((stanza '(message ((from . "alice@example.com/phone") (type . "chat")) (body () "> Alice:\n> Hello\nanswer") (reply ((xmlns . "urn:xmpp:reply:0") (to . "alice@example.com/phone") (id . "orig-1"))) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . "urn:xmpp:reply:0")) (body ((start . "0") (end . "17")))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (equal '(0 17) (plist-get plist :fallback-range))))) (ert-deftest jabber-test-chat-plist-reply-fallback-range-all () "Fallback without a body child covers the whole body." (let* ((stanza '(message ((from . "alice@example.com/phone") (type . "chat")) (body () "> Alice:\n> Hello") (reply ((xmlns . "urn:xmpp:reply:0") (to . "alice@example.com/phone") (id . "orig-1"))) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . "urn:xmpp:reply:0"))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (eq 'all (plist-get plist :fallback-range))))) (ert-deftest jabber-test-chat-plist-reply-fallback-range-bare-body-all () "A fallback without offsets covers the whole body." (let* ((stanza '(message ((from . "alice@example.com/phone") (type . "chat")) (body () "> Alice:\n> Hello") (reply ((xmlns . "urn:xmpp:reply:0") (to . "alice@example.com/phone") (id . "orig-1"))) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . "urn:xmpp:reply:0")) (body ())))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (eq 'all (plist-get plist :fallback-range))))) (ert-deftest jabber-test-chat-plist-reply-fallback-range-malformed-nil () "Malformed fallback offsets yield a nil :fallback-range." (let* ((stanza '(message ((from . "alice@example.com/phone") (type . "chat")) (body () "> Alice:\n> Hello\nanswer") (reply ((xmlns . "urn:xmpp:reply:0") (to . "alice@example.com/phone") (id . "orig-1"))) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . "urn:xmpp:reply:0")) (body ((start . "x") (end . "17")))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should-not (plist-get plist :fallback-range)))) (defmacro jabber-test-chat--with-reply-ewoc (&rest body) "Run BODY in a temp buffer with an original and a reply node. The original has id \"orig-1\"; the reply references it. Point starts on the reply node; `jabber-point-insert' marks the input area after both messages." (declare (indent 0) (debug t)) `(with-temp-buffer (let ((jabber-chat-ewoc (ewoc-create (lambda (data) (insert (plist-get (cadr data) :body) "\n")) nil nil 'nosep)) (jabber-chat--msg-nodes (make-hash-table :test 'equal))) (jabber-chat-ewoc-enter (list :foreign (list :id "orig-1" :from "alice@x.com" :body "the original" :timestamp (current-time)))) (let ((reply-node (jabber-chat-ewoc-enter (list :foreign (list :id "r-1" :from "alice@x.com" :body "the reply" :reply-to-id "orig-1" :timestamp (current-time)))))) (setq-local jabber-point-insert (point-max-marker)) (goto-char (ewoc-location reply-node)) ,@body)))) (ert-deftest jabber-test-chat-reply-target-at-point () "The reply target is found on the reply node and nowhere else." (jabber-test-chat--with-reply-ewoc (should (equal "orig-1" (jabber-chat--reply-target-at-point))) (goto-char (point-min)) (should-not (jabber-chat--reply-target-at-point)) (goto-char (point-max)) (should-not (jabber-chat--reply-target-at-point)))) (ert-deftest jabber-test-chat-goto-reply-target-jumps () "RET on a reply moves point to the original message." (jabber-test-chat--with-reply-ewoc (cl-letf (((symbol-function 'pulse-momentary-highlight-region) #'ignore)) (jabber-chat-goto-reply-target)) (should (= (point) (point-min))) (should (looking-at "the original")))) (ert-deftest jabber-test-chat-goto-reply-target-or-send-dispatch () "RET sends from the input area and jumps from a reply." (jabber-test-chat--with-reply-ewoc (let ((sent nil)) (cl-letf (((symbol-function 'jabber-chat-buffer-send) (lambda () (setq sent t))) ((symbol-function 'pulse-momentary-highlight-region) #'ignore)) (goto-char (point-max)) (jabber-chat-goto-reply-target-or-send) (should sent) (setq sent nil) (goto-char (point-min)) (ewoc-goto-next jabber-chat-ewoc 1) (jabber-chat-goto-reply-target-or-send) (should-not sent) (should (= (point) (point-min))))))) (ert-deftest jabber-test-chat-reply-context-synthesizes-quote () "A fallback-less reply quotes the original body from the database." (with-temp-buffer (setq-local jabber-chatting-with "alice@x.com") (setq-local jabber-buffer-connection 'fake-jc) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@x.com")) ((symbol-function 'jabber-muc-sender-p) (lambda (_jid) nil)) ((symbol-function 'jabber-db-reply-target-body) (lambda (_account _peer reply-id _muc-p) (and (equal reply-id "orig-1") "original text\nsecond line")))) (jabber-chat--insert-reply-context '(:reply-to-id "orig-1" :reply-to-jid "alice@x.com")) (should (string-match-p "reply to alice@x.com: original text" (buffer-string))) (should-not (string-match-p "second line" (buffer-string)))))) (ert-deftest jabber-test-chat-reply-context-label-without-db-hit () "A fallback-less reply falls back to the bare label when unresolved." (with-temp-buffer (setq-local jabber-chatting-with "alice@x.com") (setq-local jabber-buffer-connection 'fake-jc) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@x.com")) ((symbol-function 'jabber-muc-sender-p) (lambda (_jid) nil)) ((symbol-function 'jabber-db-reply-target-body) (lambda (&rest _) nil))) (jabber-chat--insert-reply-context '(:reply-to-id "orig-2" :reply-to-jid "alice@x.com")) (should (equal "reply to alice@x.com\n" (buffer-string)))))) (ert-deftest jabber-test-chat-outgoing-handler-stores-reply-metadata () "The DB outgoing handler reads reply elements off the final stanza." (require 'jabber-db) (with-temp-buffer (setq-local jabber-chatting-with "alice@x.com") (setq-local jabber-buffer-connection 'fake-jc) (let (stored-reply) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@x.com")) ((symbol-function 'jabber-muc-sender-p) (lambda (_jid) nil)) ((symbol-function 'jabber-db-store-message) (lambda (&rest args) (setq stored-reply (nth 12 args))))) (let ((stanza '(message ((to . "alice@x.com") (type . "chat") (id . "m-9")) (body () "> q\nanswer") (reply ((xmlns . "urn:xmpp:reply:0") (id . "orig-9"))))) (jabber-chat-send-hooks (list #'jabber-db--outgoing-handler))) (jabber-chat--run-send-hooks stanza "> q\nanswer" "m-9"))) (should (equal "orig-9" (plist-get stored-reply :reply-to-id)))))) (ert-deftest jabber-test-chat-outgoing-handler-skips-corrections () "The outgoing DB hook does not store a correction as a new message." (let ((jabber-chat--sending-correction t) (jabber-chatting-with "friend@example.com") (jabber-buffer-connection 'fake-jc) stored) (cl-letf (((symbol-function 'jabber-db-store-message) (lambda (&rest _) (setq stored t)))) (jabber-db--outgoing-handler "corrected" "correction-id")) (should-not stored))) (ert-deftest jabber-test-chat-send-hooks-stamp-origin-id () "The default send hooks stamp an XEP-0359 origin-id on outgoing stanzas." (with-temp-buffer (let ((stanza '(message ((to . "alice@example.com") (type . "chat") (id . "m-1")) (body () "hi")))) (jabber-chat--run-send-hooks stanza "hi" "m-1") (let ((el (seq-find (lambda (child) (and (consp child) (eq (car child) 'origin-id))) (jabber-xml-node-children stanza)))) (should el) (should (equal "m-1" (jabber-xml-get-attribute el 'id))) (should (equal "urn:xmpp:sid:0" (jabber-xml-get-xmlns el))))))) (ert-deftest jabber-test-chat-origin-id-round-trip () "A stanza stamped by the send hook parses back into :origin-id." (with-temp-buffer (let ((stanza '(message ((to . "alice@example.com") (type . "chat") (id . "m-2")) (body () "hi")))) (jabber-chat--run-send-hooks stanza "hi" "m-2") (should (equal "m-2" (plist-get (jabber-chat--msg-plist-from-stanza stanza) :origin-id)))))) (ert-deftest jabber-test-chat-plist-reply-fallback-not-masked () "A non-reply before the reply one must not mask it." (let* ((stanza '(message ((from . "alice@example.com/phone") (type . "chat")) (body () "> Alice:\n> Hello\nanswer") (reply ((xmlns . "urn:xmpp:reply:0") (to . "alice@example.com/phone") (id . "orig-1"))) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . "urn:xmpp:reactions:0"))) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . "urn:xmpp:reply:0")) (body ((start . "0") (end . "17")))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (equal '(0 17) (plist-get plist :fallback-range))))) ;;; Group 2: jabber-chat--oob-field (ert-deftest jabber-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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-test-chat-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: decrypt dedup cache (defun jabber-test-chat--encrypted-stanza (from id &optional origin-id ciphertext) "Build a fresh OMEMO-shaped encrypted stanza from FROM with ID. Optional ORIGIN-ID adds a XEP-0359 child. CIPHERTEXT defaults to ID." (append (list 'message (list (cons 'from from) (cons 'id id)) (list 'encrypted (list (cons 'xmlns "eu.siacs.conversations.axolotl")) (list 'payload nil (or ciphertext id)))) (and origin-id (list (list 'origin-id (list (cons 'xmlns "urn:xmpp:sid:0") (cons 'id origin-id))))))) (defun jabber-test-chat--body-text (xml-data) "Return the body text of XML-DATA, or nil." (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'body))))) (defmacro jabber-test-chat--with-decrypt-cache (&rest body) "Run BODY with fresh decrypt handler and dedup cache state. Stubs `jabber-connection-bare-jid' to a fixed account." (declare (indent 0) (debug t)) `(let ((jabber-chat-decrypt-handlers nil) (jabber-chat--sorted-decrypt-handlers-cache nil) (jabber-chat--crypto-loaded t) (jabber-chat--decrypt-cache (make-hash-table :test #'equal))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@x.com"))) ,@body))) (ert-deftest jabber-test-chat-decrypt-dedup-serves-repeat-from-cache () "A second delivery of the same encrypted stanza skips the handler." (jabber-test-chat--with-decrypt-cache (let ((runs 0)) (jabber-chat-register-decrypt-handler 'test-omemo :detect (lambda (xml) (jabber-xml-child-with-xmlns xml "eu.siacs.conversations.axolotl")) :decrypt (lambda (_jc xml _parsed) (cl-incf runs) (jabber-chat--set-body xml "secret text")) :priority 10 :error-label "OMEMO") (let ((first (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" "msg-1"))) (second (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" "msg-1")))) (should (= 1 runs)) (should (string= "secret text" (jabber-test-chat--body-text first))) (should (string= "secret text" (jabber-test-chat--body-text second))))))) (ert-deftest jabber-test-chat-decrypt-dedup-keeps-behavioral-message-id () "Different ciphertexts decrypt even when their origin-id matches." (jabber-test-chat--with-decrypt-cache (let ((runs 0)) (jabber-chat-register-decrypt-handler 'test-omemo :detect (lambda (xml) (jabber-xml-child-with-xmlns xml "eu.siacs.conversations.axolotl")) :decrypt (lambda (_jc xml _parsed) (cl-incf runs) (jabber-chat--set-body xml "secret text")) :priority 10 :error-label "OMEMO") (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" "id-a" "origin-1")) (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" "id-b" "origin-1")) (should (= 2 runs))))) (ert-deftest jabber-test-chat-decrypt-dedup-rejects-changed-message-id () "A changed raw id cannot run or reuse the same ciphertext." (jabber-test-chat--with-decrypt-cache (let ((runs 0)) (jabber-chat-register-decrypt-handler 'test-omemo :detect (lambda (xml) (jabber-xml-child-with-xmlns xml "eu.siacs.conversations.axolotl")) :decrypt (lambda (_jc xml _parsed) (cl-incf runs) (jabber-chat--set-body xml "secret text")) :priority 10 :error-label "OMEMO") (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" "id-a" nil "same-ciphertext")) (let ((second (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" "id-b" nil "same-ciphertext")))) (should (= 1 runs)) (should (string= "[OMEMO: could not decrypt]" (jabber-test-chat--body-text second))))))) (ert-deftest jabber-test-chat-decrypt-dedup-binds-replace-target () "Changed correction metadata cannot replay the same plaintext." (jabber-test-chat--with-decrypt-cache (let ((runs 0) second) (jabber-chat-register-decrypt-handler 'test-omemo :detect (lambda (xml) (jabber-xml-child-with-xmlns xml "eu.siacs.conversations.axolotl")) :decrypt (lambda (_jc xml _parsed) (cl-incf runs) (jabber-chat--set-body xml "corrected")) :priority 10 :error-label "OMEMO") (jabber-chat--decrypt-if-needed nil '(message ((from . "alice@x.com/phone") (id . "correction-1")) (body () "fallback") (encrypted ((xmlns . "eu.siacs.conversations.axolotl")) (payload () "same-ciphertext")) (replace ((xmlns . "urn:xmpp:message-correct:0") (id . "original-1"))))) (setq second (jabber-chat--decrypt-if-needed nil '(message ((from . "alice@x.com/phone") (id . "correction-1")) (body () "fallback") (encrypted ((xmlns . "eu.siacs.conversations.axolotl")) (payload () "same-ciphertext")) (replace ((xmlns . "urn:xmpp:message-correct:0") (id . "original-2")))))) (should (= 1 runs)) (should (string= "[OMEMO: could not decrypt]" (jabber-test-chat--body-text second)))))) (ert-deftest jabber-test-chat-decrypt-dedup-binds-inner-delay () "A changed delay wrapper cannot run the same ciphertext twice." (jabber-test-chat--with-decrypt-cache (let ((runs 0) (base '(message ((from . "room@conference.x/alice") (type . "groupchat") (id . "correction-1")) (body () "fallback") (encrypted ((xmlns . "eu.siacs.conversations.axolotl")) (payload () "same-ciphertext")) (replace ((xmlns . "urn:xmpp:message-correct:0") (id . "original-1")))))) (jabber-chat-register-decrypt-handler 'test-omemo :detect (lambda (xml) (jabber-xml-child-with-xmlns xml "eu.siacs.conversations.axolotl")) :decrypt (lambda (_jc xml _parsed) (cl-incf runs) (jabber-chat--set-body xml "corrected")) :priority 10 :error-label "OMEMO") (jabber-chat--decrypt-if-needed nil (copy-tree base)) (let ((second (jabber-chat--decrypt-if-needed nil (append (copy-tree base) '((delay ((xmlns . "urn:xmpp:delay") (stamp . "2026-07-26T10:00:00Z")))))))) (should (= 1 runs)) (should (string= "[OMEMO: could not decrypt]" (jabber-test-chat--body-text second))))))) (ert-deftest jabber-test-chat-decrypt-dedup-normalizes-muc-mam-item () "MUC live and MAM forms differing only in archive item metadata dedup." (jabber-test-chat--with-decrypt-cache (let ((runs 0) (live '(message ((from . "room@conference.x/alice") (to . "me@x.com/resource") (type . "groupchat") (id . "message-1")) (body () "fallback") (encrypted ((xmlns . "eu.siacs.conversations.axolotl")) (payload () "ciphertext")))) (archived '(message ((from . "room@conference.x/alice") (type . "groupchat") (id . "message-1")) (body () "fallback") (encrypted ((xmlns . "eu.siacs.conversations.axolotl")) (payload () "ciphertext")) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((jid . "alice@example.com"))))))) (jabber-chat-register-decrypt-handler 'test-omemo :detect (lambda (xml) (jabber-xml-child-with-xmlns xml "eu.siacs.conversations.axolotl")) :decrypt (lambda (_jc xml _parsed) (cl-incf runs) (jabber-chat--set-body xml "secret")) :priority 10 :error-label "OMEMO") (jabber-chat--decrypt-if-needed nil (copy-tree live)) (jabber-chat--decrypt-if-needed nil (copy-tree archived)) (should (= 1 runs))))) (ert-deftest jabber-test-chat-decrypt-dedup-retains-muc-invite () "Changed MUC invitation metadata rejects repeated ciphertext." (jabber-test-chat--with-decrypt-cache (let ((runs 0)) (jabber-chat-register-decrypt-handler 'test-omemo :detect (lambda (xml) (jabber-xml-child-with-xmlns xml "eu.siacs.conversations.axolotl")) :decrypt (lambda (_jc xml _parsed) (cl-incf runs) (jabber-chat--set-body xml "secret")) :priority 10 :error-label "OMEMO") (dolist (reason '("first" "second")) (jabber-chat--decrypt-if-needed nil `(message ((from . "room@conference.x") (type . "normal") (id . "invite-1")) (encrypted ((xmlns . "eu.siacs.conversations.axolotl")) (payload () "same-ciphertext")) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (invite ((from . "alice@example.com")) (reason () ,reason)))))) (should (= 1 runs))))) (ert-deftest jabber-test-chat-decrypt-dedup-normalizes-attribute-order () "Attribute order does not change ciphertext or wrapper identity." (jabber-test-chat--with-decrypt-cache (let ((runs 0)) (jabber-chat-register-decrypt-handler 'test-omemo :detect (lambda (xml) (jabber-xml-child-with-xmlns xml "eu.siacs.conversations.axolotl")) :decrypt (lambda (_jc xml _parsed) (cl-incf runs) (jabber-chat--set-body xml "secret")) :priority 10 :error-label "OMEMO") (jabber-chat--decrypt-if-needed nil '(message ((from . "alice@x.com/phone") (id . "one")) (encrypted ((xmlns . "eu.siacs.conversations.axolotl") (test . "yes")) (payload ((b . "2") (a . "1")) "cipher")))) (let ((second (jabber-chat--decrypt-if-needed nil '(message ((id . "one") (from . "alice@x.com/phone")) (encrypted ((test . "yes") (xmlns . "eu.siacs.conversations.axolotl")) (payload ((a . "1") (b . "2")) "cipher")))))) (should (= 1 runs)) (should (string= "secret" (jabber-test-chat--body-text second))))))) (ert-deftest jabber-test-chat-decrypt-dedup-no-cross-sender-collision () "Two senders using the same stanza id are decrypted independently." (jabber-test-chat--with-decrypt-cache (let ((runs 0)) (jabber-chat-register-decrypt-handler 'test-omemo :detect (lambda (xml) (jabber-xml-child-with-xmlns xml "eu.siacs.conversations.axolotl")) :decrypt (lambda (_jc xml _parsed) (cl-incf runs) (jabber-chat--set-body xml "secret text")) :priority 10 :error-label "OMEMO") (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" "1")) (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "bob@x.com/laptop" "1")) (should (= 2 runs))))) (ert-deftest jabber-test-chat-decrypt-dedup-caches-bodyless-outcome () "A successful decrypt with no body (heartbeat) is not re-decrypted." (jabber-test-chat--with-decrypt-cache (let ((runs 0)) (jabber-chat-register-decrypt-handler 'test-omemo :detect (lambda (xml) (jabber-xml-child-with-xmlns xml "eu.siacs.conversations.axolotl")) :decrypt (lambda (_jc xml _parsed) (cl-incf runs) xml) :priority 10 :error-label "OMEMO") (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" "hb-1")) (let ((second (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" "hb-1")))) (should (= 1 runs)) (should-not (jabber-test-chat--body-text second)))))) (ert-deftest jabber-test-chat-decrypt-dedup-does-not-cache-failures () "A failed decrypt stays retryable on the next delivery." (jabber-test-chat--with-decrypt-cache (let ((runs 0)) (jabber-chat-register-decrypt-handler 'test-omemo :detect (lambda (xml) (jabber-xml-child-with-xmlns xml "eu.siacs.conversations.axolotl")) :decrypt (lambda (_jc xml _parsed) (cl-incf runs) (if (= runs 1) (error "Ratchet failure") (jabber-chat--set-body xml "recovered text"))) :priority 10 :error-label "OMEMO") (let ((first (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" "msg-2"))) (second (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" "msg-2")))) (should (= 2 runs)) (should (string= "[OMEMO: could not decrypt]" (jabber-test-chat--body-text first))) (should (string= "recovered text" (jabber-test-chat--body-text second))))))) (ert-deftest jabber-test-chat-decrypt-dedup-caches-post-ratchet-failure () "A corrupt payload cannot send consumed ciphertext through the ratchet twice." (jabber-test-chat--with-decrypt-cache (let ((runs 0)) (jabber-chat-register-decrypt-handler 'test-omemo :detect (lambda (xml) (jabber-xml-child-with-xmlns xml "eu.siacs.conversations.axolotl")) :decrypt (lambda (_jc _xml _parsed) (cl-incf runs) (setq jabber-chat--decrypt-consumed-p t) (error "Payload authentication failed")) :priority 10 :error-label "OMEMO") (let ((first (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" "corrupt"))) (second (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" "corrupt")))) (should (= 1 runs)) (should (string= "[OMEMO: could not decrypt]" (jabber-test-chat--body-text first))) (should (string= "[OMEMO: could not decrypt]" (jabber-test-chat--body-text second))))))) (ert-deftest jabber-test-chat-decrypt-dedup-retains-old-ciphertext () "Old ciphertext remains blocked after many later messages." (jabber-test-chat--with-decrypt-cache (let ((runs 0)) (jabber-chat-register-decrypt-handler 'test-omemo :detect (lambda (xml) (jabber-xml-child-with-xmlns xml "eu.siacs.conversations.axolotl")) :decrypt (lambda (_jc xml _parsed) (cl-incf runs) (jabber-chat--set-body xml "secret text")) :priority 10 :error-label "OMEMO") (dotimes (i 513) (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" (format "e-%d" i)))) (jabber-chat--decrypt-if-needed nil (jabber-test-chat--encrypted-stanza "alice@x.com/phone" "e-0")) (should (= 513 runs))))) ;;; Group 8: jabber-chat-goto-address error handling (ert-deftest jabber-test-chat-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-test-chat-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-test-chat-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-test-chat-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))) ;;; Group 10: inline image resizing (defmacro jabber-test-chat-with-inline-image (&rest body) "Run BODY in a temp buffer containing one inline image URL." (declare (indent 0) (debug t)) `(with-temp-buffer (let* ((url "https://example.com/image.png") (image (list 'image :type 'png :max-width 300 :max-height 200))) (insert url) (cl-letf (((symbol-function 'jabber-chat--schedule-image-recenter) #'ignore)) (jabber-chat--apply-image-display image (point-min) (point-max) url) (put-text-property (point-min) (point-max) 'read-only t) (goto-char (point-min)) ,@body)))) (ert-deftest jabber-test-chat-image-range-at-point-finds-display () "Inline image range lookup returns URL, base image, and scale." (jabber-test-chat-with-inline-image (let ((range (jabber-chat--image-range-at-point))) (should (= (point-min) (plist-get range :beg))) (should (= (point-max) (plist-get range :end))) (should (equal url (plist-get range :url))) (should (eq image (plist-get range :image))) (should (= 1.0 (plist-get range :scale)))))) (ert-deftest jabber-test-chat-image-range-at-point-supports-loaded-image () "Inline image range lookup supports images rendered before reload." (jabber-test-chat-with-inline-image (let ((inhibit-read-only t)) (remove-text-properties (point-min) (point-max) '(jabber-chat-image-base nil jabber-chat-image-scale nil))) (let ((range (jabber-chat--image-range-at-point))) (should (equal url (plist-get range :url))) (should (eq (get-text-property (point) 'display) (plist-get range :image))) (should (= 1.0 (plist-get range :scale)))))) (ert-deftest jabber-test-chat-image-enlarge-shrink-and-reset () "Image resize commands update range-local scale." (jabber-test-chat-with-inline-image (cl-letf (((symbol-function 'message) #'ignore)) (jabber-chat-image-enlarge) (should (= jabber-chat--image-scale-step (get-text-property (point) 'jabber-chat-image-scale))) (jabber-chat-image-shrink) (should (= 1.0 (get-text-property (point) 'jabber-chat-image-scale))) (jabber-chat-image-shrink) (should (< (get-text-property (point) 'jabber-chat-image-scale) 1.0)) (jabber-chat-image-reset-size) (should (= 1.0 (get-text-property (point) 'jabber-chat-image-scale)))))) (ert-deftest jabber-test-chat-inline-image-keys-active-at-point () "Inline image resize keys are active through text properties." (jabber-test-chat-with-inline-image (should (eq (key-binding (kbd "+") nil nil (point)) #'jabber-chat-image-enlarge)) (should (eq (key-binding (kbd "=") nil nil (point)) #'jabber-chat-image-enlarge)) (should (eq (key-binding (kbd "-") nil nil (point)) #'jabber-chat-image-shrink)) (should (eq (key-binding (kbd "0") nil nil (point)) #'jabber-chat-image-reset-size)))) (defun jabber-test-chat--dispatch-key (key) "Dispatch KEY using the active keymaps at point." (let ((command (key-binding (kbd key) nil nil (point))) (last-command-event (string-to-char key))) (call-interactively command))) (ert-deftest jabber-test-chat-minus-key-shrinks-inline-image-via-command-loop () "Pressing - in `jabber-chat-mode' shrinks images via normal dispatch." (jabber-test-chat-with-inline-image (jabber-chat-mode) (cl-letf (((symbol-function 'message) #'ignore)) (jabber-test-chat--dispatch-key "-") (should (< (get-text-property (point) 'jabber-chat-image-scale) 1.0)) (should (string= url (buffer-substring-no-properties (point-min) (point-max))))))) (ert-deftest jabber-test-chat-mode-map-enlarge-and-zero-resize-inline-image () "The mode-map +, =, and 0 bindings dispatch to inline image resizing." (jabber-test-chat-with-inline-image (jabber-chat-mode) (cl-letf (((symbol-function 'message) #'ignore)) (jabber-test-chat--dispatch-key "+") (should (= jabber-chat--image-scale-step (get-text-property (point) 'jabber-chat-image-scale))) (jabber-test-chat--dispatch-key "0") (should (= 1.0 (get-text-property (point) 'jabber-chat-image-scale))) (jabber-test-chat--dispatch-key "=") (should (= jabber-chat--image-scale-step (get-text-property (point) 'jabber-chat-image-scale)))))) (ert-deftest jabber-test-chat-mode-map-resize-keys-self-insert-off-image () "The mode-map resize keys self-insert outside inline images." (with-temp-buffer (jabber-chat-mode) (dolist (key '("-" "+" "=" "0")) (jabber-test-chat--dispatch-key key)) (should (string= "-+=0" (buffer-string))) (let ((current-prefix-arg 3)) (jabber-test-chat--dispatch-key "-")) (should (string= "-+=0---" (buffer-string))))) (ert-deftest jabber-test-chat-scaled-image-does-not-mutate-base () "Scaling copies the image object instead of mutating the cached image." (let* ((image (list 'image :type 'png :max-width 300 :max-height 200)) (scaled (jabber-chat--scaled-image image 2.0))) (should (not (eq image scaled))) (should (= 300 (image-property image :max-width))) (should (= 200 (image-property image :max-height))) (should (= 600 (image-property scaled :max-width))) (should (= 400 (image-property scaled :max-height))))) ;;; Group: Backlog message identity (defmacro jabber-test-chat--with-backlog-ewoc (&rest body) "Run BODY with isolated backlog EWOC state." (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)) (jabber-print-rare-time nil) (jabber-group "room@conference.example.com")) (cl-letf (((symbol-function 'jabber-muc-our-nick-p) (lambda (&rest _) nil))) ,@body)))) (ert-deftest jabber-test-chat-backlog-scopes-colliding-muc-client-ids () "Backlog messages from different occupants may share a client id." (jabber-test-chat--with-backlog-ewoc (dolist (from '("room@conference.example.com/alice" "room@conference.example.com/bob")) (jabber-chat-insert-backlog-entry (list :id "same" :from from :direction "in" :msg-type "groupchat" :timestamp (current-time)))) (should (ewoc-nth jabber-chat-ewoc 1)) (should (gethash '(:muc "room@conference.example.com/alice" "same") jabber-chat--msg-nodes)) (should (gethash '(:muc "room@conference.example.com/bob" "same") jabber-chat--msg-nodes)))) (ert-deftest jabber-test-chat-backlog-then-live-dedups-server-id () "A live replay does not duplicate a backlog server identity." (jabber-test-chat--with-backlog-ewoc (let ((msg (list :id "client" :server-id "server" :from "room@conference.example.com/alice" :direction "in" :msg-type "groupchat" :timestamp (current-time)))) (jabber-chat-insert-backlog-entry msg) (should-not (jabber-chat-ewoc-enter (list :muc-foreign msg))) (should-not (ewoc-nth jabber-chat-ewoc 1))))) (ert-deftest jabber-test-chat-live-then-backlog-dedups-server-id () "A backlog replay does not duplicate a live server identity." (jabber-test-chat--with-backlog-ewoc (let ((msg (list :id "client" :server-id "server" :from "room@conference.example.com/alice" :direction "in" :msg-type "groupchat" :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :muc-foreign msg)) (jabber-chat-insert-backlog-entry msg) (should-not (ewoc-nth jabber-chat-ewoc 1))))) ;;; Group 11: jabber-chat-create-buffer (ert-deftest jabber-test-chat-create-buffer-does-not-start-mam () "Creating or reopening a chat buffer does not start MAM catch-up." (let* ((jc1 (jabber-test-chat--make-fake-jc "me@example.com")) (jc2 (jabber-test-chat--make-fake-jc "me@example.com")) (peer "emma@example.com/laptop") (jabber-chat-buffer-format " *jabber-test-chat-%j-%a*") (calls nil) buf) (cl-letf (((symbol-function 'jabber-db-backlog) (lambda (&rest _) nil)) ((symbol-function 'jabber-db-get-chat-encryption) (lambda (&rest _) nil)) ((symbol-function 'jabber-mam-chat-opened) (lambda (jc peer) (push (cons jc peer) calls)))) (unwind-protect (progn (setq buf (jabber-chat-create-buffer jc1 peer)) (should-not calls) (should (eq buf (jabber-chat-create-buffer jc2 peer))) (should-not calls) (with-current-buffer buf (should (eq jc2 jabber-buffer-connection)))) (when (buffer-live-p buf) (kill-buffer buf)))))) (ert-deftest jabber-test-chat-create-buffer-restores-parent-session () "Creating a parent chat restores its current logical session." (let* ((jc (jabber-test-chat--make-fake-jc "me@example.com")) (peer "emma@example.com/laptop") (jabber-chat-buffer-format " *jabber-test-session-%j-%a*") buffer) (cl-letf (((symbol-function 'jabber-db-backlog) (lambda (&rest _) nil)) ((symbol-function 'jabber-db-get-chat-encryption) (lambda (&rest _) nil)) ((symbol-function 'jabber-db-get-chat-thread) (lambda (account bare-peer) (should (equal account "me@example.com")) (should (equal bare-peer "emma@example.com")) "session-1"))) (unwind-protect (progn (setq buffer (jabber-chat-create-buffer jc peer)) (should (equal "session-1" (buffer-local-value 'jabber-message-thread-session-id buffer)))) (when (buffer-live-p buffer) (kill-buffer buffer)))))) (ert-deftest jabber-test-chat-capture-creates-parent-session () "The first parent send creates, persists, and captures a session ID." (with-temp-buffer (setq-local jabber-buffer-connection (jabber-test-chat--make-fake-jc "me@example.com")) (setq-local jabber-chatting-with "emma@example.com/laptop") (let (stored) (cl-letf (((symbol-function 'jabber-message-thread--generate-id) (lambda () "session-1")) ((symbol-function 'jabber-db-set-chat-thread) (lambda (&rest args) (setq stored args)))) (let ((context (jabber-chat--capture-send-context "hello" nil))) (should (equal '((thread nil "session-1")) (plist-get context :extra-elements))) (should (equal "session-1" jabber-message-thread-session-id)) (should (equal '("me@example.com" "emma@example.com" "session-1") stored))))))) (ert-deftest jabber-test-chat-parent-session-scope () "Only ordinary one-to-one parent buffers own chat sessions." (with-temp-buffer (setq-local jabber-chatting-with "emma@example.com/laptop") (should (jabber-chat--parent-session-buffer-p)) (setq-local jabber-group "room@example.com") (should-not (jabber-chat--parent-session-buffer-p)) (setq-local jabber-group nil) (setq-local jabber-muc-private-p t) (should-not (jabber-chat--parent-session-buffer-p)) (setq-local jabber-muc-private-p nil) (setq-local jabber-message-thread-id "dedicated-thread") (should-not (jabber-chat--parent-session-buffer-p)))) (ert-deftest jabber-test-chat-plaintext-reuses-parent-session () "Plaintext sends generate one session ID and keep using it." (with-temp-buffer (setq-local jabber-buffer-connection (jabber-test-chat--make-fake-jc "me@example.com")) (setq-local jabber-chatting-with "emma@example.com/laptop") (setq-local jabber-chat-encryption 'plaintext) (let ((jabber-chat-send-hooks '(jabber-chat--session-send-hook)) generated sent stored) (cl-letf (((symbol-function 'jabber-message-thread--generate-id) (lambda () (setq generated (1+ (or generated 0))) "session-1")) ((symbol-function 'jabber-db-set-chat-thread) (lambda (&rest args) (push args stored))) ((symbol-function 'jabber-chat--display-local-message) #'ignore) ((symbol-function 'jabber-send-sexp) (lambda (_jc stanza &rest _) (push stanza sent)))) (jabber-chat-send jabber-buffer-connection "first") (jabber-chat-send jabber-buffer-connection "second")) (should (= generated 1)) (should (equal '(("me@example.com" "emma@example.com" "session-1")) stored)) (dolist (stanza sent) (should (equal '(:thread-id "session-1" :thread-parent-id nil) (jabber-message-thread-protocol-fields stanza))))))) (ert-deftest jabber-test-chat-session-does-not-override-explicit-thread () "Explicit reply or dedicated metadata takes precedence over a session." (with-temp-buffer (setq-local jabber-message-thread-session-id "session-1") (should (equal '(:thread-id "thread-1" :thread-parent-id nil) (jabber-chat--captured-thread '(message () (thread () "thread-1")) nil))) (setq-local jabber-message-reply--thread '(:thread-id "reply-thread" :thread-parent-id nil)) (should (equal jabber-message-reply--thread (jabber-chat--captured-thread '(message ()) nil))) (setq-local jabber-message-reply--thread nil) (setq-local jabber-message-thread-id "dedicated-thread") (should (equal '(:thread-id "dedicated-thread" :thread-parent-id nil) (jabber-chat--captured-thread '(message ()) nil))))) (ert-deftest jabber-test-chat-live-message-adopts-parent-session () "A live parent message makes its thread the current chat session." (let ((buffer (generate-new-buffer " *jabber-test-live-session*")) stored) (unwind-protect (progn (with-current-buffer buffer (setq-local jabber-buffer-connection 'connection) (setq-local jabber-chatting-with "emma@example.com/laptop")) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.com")) ((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc stanza) stanza)) ((symbol-function 'jabber-chat--select-buffer) (lambda (&rest _) buffer)) ((symbol-function 'jabber-chat--display-message) #'ignore) ((symbol-function 'jabber-db-set-chat-thread) (lambda (&rest args) (setq stored args)))) (let ((jabber-chat-printers (list (lambda (&rest _) t)))) (jabber-process-chat 'connection '(message ((from . "emma@example.com/laptop") (to . "me@example.com") (type . "chat")) (body () "hello") (thread () "session-2"))))) (should (equal "session-2" (buffer-local-value 'jabber-message-thread-session-id buffer))) (should (equal '("me@example.com" "emma@example.com" "session-2") stored))) (kill-buffer buffer)))) (ert-deftest jabber-test-chat-child-thread-preserves-parent-session () "A live child thread cannot become the ordinary parent chat session." (jabber-test-chat--with-db (let* ((jc (jabber-test-chat--make-fake-jc "me@example.com")) (buffer (generate-new-buffer " *jabber-test-child-session*")) displayed) (unwind-protect (progn (with-current-buffer buffer (setq-local major-mode 'jabber-chat-mode) (setq-local jabber-buffer-connection jc) (setq-local jabber-chatting-with "friend@example.com/phone") (setq-local jabber-message-thread-session-id "session-S")) (jabber-db-set-chat-thread "me@example.com" "friend@example.com" "session-S") (cl-letf (((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc stanza) stanza)) ((symbol-function 'jabber-chat--select-buffer) (lambda (&rest _) buffer)) ((symbol-function 'jabber-chat--display-message) (lambda (_jc _xml target &rest _) (push target displayed)))) (let ((jabber-chat-printers (list (lambda (&rest _) t)))) (jabber-process-chat jc '(message ((from . "friend@example.com/phone") (to . "me@example.com") (type . "chat") (id . "child-1")) (body () "child root") (thread ((parent . "session-S")) "thread-T")))) (should (equal "session-S" (buffer-local-value 'jabber-message-thread-session-id buffer))) (should (equal "session-S" (jabber-db-get-chat-thread "me@example.com" "friend@example.com"))) (let ((jabber-db-message-thread-stored-functions nil)) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "child root" 1 "phone" "child-1" nil nil nil nil nil '(:thread-id "thread-T" :thread-parent-id "session-S"))) (should (jabber-db-message-thread-known-p "me@example.com" "friend@example.com" "chat" "thread-T")) (let ((jabber-chat-printers (list (lambda (&rest _) t)))) (jabber-process-chat jc '(message ((from . "friend@example.com/phone") (to . "me@example.com") (type . "chat") (id . "child-2")) (body () "later child") (thread ((parent . "session-S")) "thread-T")))) (should (equal "session-S" (buffer-local-value 'jabber-message-thread-session-id buffer))) (with-current-buffer buffer (let ((context (jabber-chat--capture-send-context "parent send" nil))) (should (equal '(:thread-id "session-S" :thread-parent-id nil) (jabber-message-thread-protocol-fields `(message () ,@(plist-get context :extra-elements))))) (should (eq buffer (jabber-chat--local-message-buffer jc '(:thread-id "session-S" :id "local-1")))))) (should (equal (list nil buffer) displayed)))) (kill-buffer buffer))))) (ert-deftest jabber-test-chat-live-unthreaded-message-starts-session () "A live unthreaded parent message starts a local logical session." (let ((buffer (generate-new-buffer " *jabber-test-new-session*")) stored) (unwind-protect (progn (with-current-buffer buffer (setq-local jabber-buffer-connection 'connection) (setq-local jabber-chatting-with "emma@example.com/laptop")) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.com")) ((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc stanza) stanza)) ((symbol-function 'jabber-chat--select-buffer) (lambda (&rest _) buffer)) ((symbol-function 'jabber-chat--display-message) #'ignore) ((symbol-function 'jabber-message-thread--generate-id) (lambda () "session-new")) ((symbol-function 'jabber-db-set-chat-thread) (lambda (&rest args) (setq stored args)))) (let ((jabber-chat-printers (list (lambda (&rest _) t)))) (jabber-process-chat 'connection '(message ((from . "emma@example.com/laptop") (to . "me@example.com") (type . "chat")) (body () "hello"))))) (should (equal "session-new" (buffer-local-value 'jabber-message-thread-session-id buffer))) (should (equal '("me@example.com" "emma@example.com" "session-new") stored))) (kill-buffer buffer)))) (ert-deftest jabber-test-chat-mam-does-not-change-parent-session () "MAM replay cannot replace a live parent session." (let ((buffer (generate-new-buffer " *jabber-test-mam-session*"))) (unwind-protect (progn (with-current-buffer buffer (setq-local jabber-buffer-connection 'connection) (setq-local jabber-chatting-with "emma@example.com/laptop") (setq-local jabber-message-thread-session-id "session-live")) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.com")) ((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc stanza) stanza)) ((symbol-function 'jabber-chat--find-buffer) (lambda (&rest _) buffer)) ((symbol-function 'jabber-chat--display-message) #'ignore) ((symbol-function 'jabber-db-set-chat-thread) (lambda (&rest _) (ert-fail "Persisted a MAM session")))) (let ((jabber-chat-printers (list (lambda (&rest _) t)))) (jabber-process-chat 'connection '(message ((from . "emma@example.com/laptop") (to . "me@example.com") (type . "chat") (jabber-mam--origin . "t")) (body () "archived") (thread () "session-old"))))) (should (equal "session-live" (buffer-local-value 'jabber-message-thread-session-id buffer)))) (kill-buffer buffer)))) (ert-deftest jabber-test-chat-with-starts-mam-after-buffer-creation () "Explicitly opening a chat starts MAM after creating its buffer." (let ((buffer (generate-new-buffer " *jabber-test-chat-with*")) events) (unwind-protect (cl-letf (((symbol-function 'jabber-chat-create-buffer) (lambda (jc jid) (push (list 'create jc jid) events) buffer)) ((symbol-function 'jabber-mam-chat-opened) (lambda (jc peer) (push (list 'mam jc peer) events))) ((symbol-function 'switch-to-buffer) (lambda (target &rest _) target))) (should (eq buffer (jabber-chat-with 'connection "emma@example.com/laptop"))) (should (equal (nreverse events) '((create connection "emma@example.com/laptop") (mam connection "emma@example.com"))))) (kill-buffer buffer)))) (ert-deftest jabber-test-chat-mam-replay-does-not-create-buffer () "A printable MAM replay does not create a chat buffer." (let ((stanza '(message ((from . "emma@example.com/laptop") (to . "me@example.com") (type . "chat") (jabber-mam--origin . "t")) (body () "archived"))) created displayed) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc message) message)) ((symbol-function 'jabber-chat--find-buffer) (lambda (&rest _) nil)) ((symbol-function 'jabber-chat-create-buffer) (lambda (&rest _) (setq created t))) ((symbol-function 'jabber-chat--display-message) (lambda (&rest _) (setq displayed t)))) (let ((jabber-chat-printers (list (lambda (&rest _) t)))) (jabber-process-chat 'connection stanza)) (should displayed) (should-not created)))) (ert-deftest jabber-test-chat-mam-replay-finds-buffer-by-account () "MAM replay uses the peer buffer belonging to its connection." (let ((account-a-buffer (generate-new-buffer " *mam-account-a*")) (account-b-buffer (generate-new-buffer " *mam-account-b*")) (account-b-thread (generate-new-buffer " *mam-account-b-thread*")) (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) displayed) (unwind-protect (progn (dolist (entry `((,account-b-buffer account-b) (,account-a-buffer account-a))) (with-current-buffer (car entry) (setq-local major-mode 'jabber-chat-mode) (setq-local jabber-buffer-connection (cadr entry)) (setq-local jabber-chatting-with "friend@example.com") (jabber-buffer-registry-register 'chat "friend@example.com"))) (with-current-buffer account-b-thread (setq-local major-mode 'jabber-chat-mode) (setq-local jabber-buffer-connection 'account-b) (setq-local jabber-chatting-with "friend@example.com") (setq-local jabber-message-thread-id "thread-1")) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (jc) (pcase jc ('account-a "a@example.com") ('account-b "b@example.com")))) ((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc stanza) stanza)) ((symbol-function 'buffer-list) (lambda (&rest _) (list account-b-thread account-b-buffer account-a-buffer))) ((symbol-function 'jabber-chat-create-buffer) (lambda (&rest _) (ert-fail "MAM replay created a chat buffer"))) ((symbol-function 'jabber-chat--display-message) (lambda (_jc _xml buffer &rest _) (setq displayed buffer)))) (let ((jabber-chat-printers (list (lambda (&rest _) t)))) (jabber-process-chat 'account-b '(message ((from . "friend@example.com/phone") (to . "b@example.com") (type . "chat") (jabber-mam--origin . "t")) (body () "archived"))))) (should (eq displayed account-b-buffer))) (kill-buffer account-a-buffer) (kill-buffer account-b-buffer) (kill-buffer account-b-thread)))) (ert-deftest jabber-test-chat-disabled-threads-load-original-backlog () "Load threaded messages into a newly created parent chat buffer." (let* ((jc (jabber-test-chat--make-fake-jc "me@example.com")) (peer "emma@example.com/laptop") (jabber-message-thread-use-buffers nil) (jabber-chat-buffer-format " *jabber-test-disabled-%j-%a*") backlog-args buffer) (cl-letf (((symbol-function 'jabber-db-backlog) (lambda (&rest args) (setq backlog-args args) nil)) ((symbol-function 'jabber-db-get-chat-encryption) (lambda (&rest _) nil)) ((symbol-function 'jabber-mam-chat-opened) #'ignore)) (unwind-protect (progn (setq buffer (jabber-chat-create-buffer jc peer)) (should (eq t (nth 6 backlog-args)))) (when (buffer-live-p buffer) (kill-buffer buffer)))))) ;;; Group: reaction rendering (ert-deftest jabber-test-chat-reaction-entry-string-carries-help-echo () "Rendered reaction text exposes who reacted via `help-echo'." (let* ((entry (jabber-reactions--display-entry "👍" '("alice@example.com" "bob@example.com") nil)) (text (jabber-chat--reaction-entry-string entry))) (should (string= text "2👍")) (should (equal (get-text-property 0 'help-echo text) "👍: alice@example.com, bob@example.com")))) ;;; Group 12: error stanza collapse (defun jabber-test-chat--error-buffer (jc peer) "Create a real chat buffer for PEER with DB and MAM stubbed out. JC is a fake connection from `jabber-test-chat--make-fake-jc'." (cl-letf (((symbol-function 'jabber-db-backlog) (lambda (&rest _) nil)) ((symbol-function 'jabber-db-get-chat-encryption) (lambda (&rest _) nil)) ((symbol-function 'jabber-mam-chat-opened) #'ignore)) (jabber-chat-create-buffer jc peer))) (defun jabber-test-chat--error-nodes (buffer) "Return the list of :error ewoc data entries in BUFFER." (with-current-buffer buffer (ewoc-collect jabber-chat-ewoc (lambda (data) (eq (car data) :error))))) (defun jabber-test-chat--make-error (peer text id) "Build an error message plist from PEER, TEXT and ID." (list :from peer :error-text text :id id :timestamp (current-time))) (ert-deftest jabber-test-chat-error-collapse-counts-repeats () "Repeated identical errors collapse into one counted node." (let* ((jc (jabber-test-chat--make-fake-jc "me@example.com")) (peer "bridge@example.com/x") (jabber-chat-buffer-format " *jabber-test-chat-%j-%a*") buf) (unwind-protect (progn (setq buf (jabber-test-chat--error-buffer jc peer)) (with-current-buffer buf (dolist (id '("e1" "e2" "e3")) (jabber-chat--enter-error-collapsed (jabber-test-chat--make-error peer "Recipient unavailable" id)))) (let ((nodes (jabber-test-chat--error-nodes buf))) (should (= 1 (length nodes))) (should (= 3 (plist-get (cadr (car nodes)) :count)))) (should (string-search "Error: Recipient unavailable (×3)" (with-current-buffer buf (buffer-string))))) (when (buffer-live-p buf) (kill-buffer buf))))) (ert-deftest jabber-test-chat-error-collapse-distinct-text-new-node () "A different error text after the first produces a second node." (let* ((jc (jabber-test-chat--make-fake-jc "me@example.com")) (peer "bridge@example.com/x") (jabber-chat-buffer-format " *jabber-test-chat-%j-%a*") buf) (unwind-protect (progn (setq buf (jabber-test-chat--error-buffer jc peer)) (with-current-buffer buf (jabber-chat--enter-error-collapsed (jabber-test-chat--make-error peer "Recipient unavailable" "e1")) (jabber-chat--enter-error-collapsed (jabber-test-chat--make-error peer "Service unavailable" "e2"))) (should (= 2 (length (jabber-test-chat--error-nodes buf))))) (when (buffer-live-p buf) (kill-buffer buf))))) (ert-deftest jabber-test-chat-find-buffer-nil-when-absent () "`jabber-chat--find-buffer' returns nil when no buffer exists." (cl-letf (((symbol-function 'jabber-muc-sender-p) #'ignore)) (should-not (jabber-chat--find-buffer "nobody@example.com/x")))) ;;; Group 13: aesgcm image policy (ert-deftest jabber-test-chat-aesgcm-image-size-cap-blocks-decrypt () "Oversized ciphertext is rejected before decryption runs." (let ((decrypted nil)) (cl-letf (((symbol-function 'jabber-omemo-aesgcm-decrypt) (lambda (&rest _) (setq decrypted t) "plain"))) (let ((jabber-image-max-bytes 4)) (should-not (jabber-chat--aesgcm-image-from-body "too big ciphertext" "key" "iv" nil)) (should-not decrypted))))) (ert-deftest jabber-test-chat-aesgcm-image-threads-allowed-types () (cl-letf (((symbol-function 'jabber-omemo-aesgcm-decrypt) (lambda (&rest _) "plaintext")) ((symbol-function 'jabber-image--result-from-data) (lambda (data types) (list :image (list data types))))) (let ((jabber-image-max-bytes nil)) (should (equal (jabber-chat--aesgcm-image-from-body "ct" "key" "iv" '(png)) '("plaintext" (png))))))) (ert-deftest jabber-test-chat-aesgcm-decode-failure-retains-plaintext () "An unsupported decrypted payload remains available for manual saving." (cl-letf (((symbol-function 'jabber-omemo-aesgcm-decrypt) (lambda (&rest _) "decrypted-heic")) ((symbol-function 'jabber-image--result-from-data) (lambda (data _types) (list :error 'decode :data data)))) (let ((result (jabber-chat--aesgcm-image-result-from-body "ciphertext" "key" "iv" nil))) (should (eq (plist-get result :error) 'decode)) (should (equal (plist-get result :data) "decrypted-heic"))))) (ert-deftest jabber-test-chat-aesgcm-image-nil-body-returns-nil () (should-not (jabber-chat--aesgcm-image-from-body nil "key" "iv" nil))) ;;; Group 14: image display policy (defun jabber-test-chat--make-jc-with-roster (&rest jids) "Create a fake connection whose roster contains JIDS." (let ((jc (gensym "jabber-test-chat-jc-"))) (put jc :state-data (list :roster (mapcar #'jabber-jid-symbol jids))) jc)) (defmacro jabber-test-chat--with-policy-buffer (peer &rest body) "Run BODY in a temp buffer chatting with PEER (nil for a MUC). The fake connection has alice@example.com on its roster." (declare (indent 1)) `(with-temp-buffer (setq-local jabber-buffer-connection (jabber-test-chat--make-jc-with-roster "alice@example.com")) (let ((peer ,peer)) (when peer (setq-local jabber-chatting-with peer))) ,@body)) (ert-deftest jabber-test-chat-auto-display-t-always () (jabber-test-chat--with-policy-buffer nil (let ((jabber-chat-display-images t)) (should (jabber-chat--auto-display-images-p))))) (ert-deftest jabber-test-chat-auto-display-legacy-non-nil-value () "Any non-nil value other than `roster' behaves like t." (jabber-test-chat--with-policy-buffer nil (let ((jabber-chat-display-images 'always)) (should (jabber-chat--auto-display-images-p))))) (ert-deftest jabber-test-chat-auto-display-nil-never () (jabber-test-chat--with-policy-buffer "alice@example.com" (let ((jabber-chat-display-images nil)) (should-not (jabber-chat--auto-display-images-p))))) (ert-deftest jabber-test-chat-auto-display-roster-contact () (jabber-test-chat--with-policy-buffer "alice@example.com" (let ((jabber-chat-display-images 'roster)) (should (jabber-chat--auto-display-images-p))))) (ert-deftest jabber-test-chat-auto-display-roster-full-jid () (jabber-test-chat--with-policy-buffer "alice@example.com/laptop" (let ((jabber-chat-display-images 'roster)) (should (jabber-chat--auto-display-images-p))))) (ert-deftest jabber-test-chat-auto-display-roster-stranger () (jabber-test-chat--with-policy-buffer "mallory@example.com" (let ((jabber-chat-display-images 'roster)) (should-not (jabber-chat--auto-display-images-p))))) (ert-deftest jabber-test-chat-auto-display-roster-muc () "MUC buffers have no `jabber-chatting-with' and never auto-display." (jabber-test-chat--with-policy-buffer nil (let ((jabber-chat-display-images 'roster)) (setq-local jabber-group "room@conf.example.com") (should-not (jabber-chat--auto-display-images-p))))) ;;; Group 15: image URL scan behavior (defconst jabber-test-chat--scan-url "https://example.com/pic.png") (defmacro jabber-test-chat--with-scan-buffer (&rest body) "Run BODY in a temp buffer containing one image URL. Bind `fetches' to the recorded `jabber-chat--start-image-fetch' calls and `url', `beg' and `end' to the URL and its bounds." `(with-temp-buffer (let ((fetches nil) (url jabber-test-chat--scan-url)) (insert url) (let ((beg (point-min)) (end (point-max))) (cl-letf (((symbol-function 'jabber-chat--start-image-fetch) (lambda (&rest args) (push args fetches)))) ,@body))))) (ert-deftest jabber-test-chat-scan-auto-fetches-with-allowlist () (jabber-test-chat--with-scan-buffer (jabber-chat--scan-image-url url beg end t) (should (equal fetches (list (list url beg end jabber-chat-image-auto-types)))))) (ert-deftest jabber-test-chat-scan-no-auto-still-clickable () "Without auto-display the URL is not fetched but stays actionable." (jabber-test-chat--with-scan-buffer (jabber-chat--scan-image-url url beg end nil) (should (null fetches)) (should (equal (get-text-property beg 'jabber-chat-image-url) url)) (should (eq (get-text-property beg 'keymap) jabber-chat-url-keymap)))) (ert-deftest jabber-test-chat-scan-skips-failed-fetch () (jabber-test-chat--with-scan-buffer (put-text-property beg end 'jabber-chat-image-fetching 'failed) (jabber-chat--scan-image-url url beg end t) (should (null fetches)))) (ert-deftest jabber-test-chat-scan-skips-in-flight-fetch () (jabber-test-chat--with-scan-buffer (put-text-property beg end 'jabber-chat-image-fetching url) (jabber-chat--scan-image-url url beg end t) (should (null fetches)))) (ert-deftest jabber-test-chat-scan-restores-cached-despite-policy () "A cached image is displayed even when auto-display is off." (jabber-test-chat--with-scan-buffer (unwind-protect (progn (jabber-chat--cache-image url '(image :type png)) (jabber-chat--scan-image-url url beg end nil) (should (null fetches)) (should (get-text-property beg 'display))) (remhash url jabber-chat--image-cache)))) (ert-deftest jabber-test-chat-failed-fetch-marks-url () "A nil image from the fetcher marks the URL range as failed." (with-temp-buffer (insert jabber-test-chat--scan-url) (let ((beg (copy-marker (point-min))) (end (copy-marker (point-max)))) (jabber-chat--replace-url-with-image nil jabber-test-chat--scan-url beg end (current-buffer)) (should (eq (jabber-chat--image-fetch-state (point-min)) 'failed))))) (ert-deftest jabber-test-chat-isolate-image-url-inserts-newline () (with-temp-buffer (insert "text https://example.com/pic.png") (let* ((end (point-max)) (bounds (jabber-chat--isolate-image-url 6 end))) (should (equal (cons 7 (1+ end)) bounds)) (should (eq (char-before (car bounds)) ?\n))))) (ert-deftest jabber-test-chat-isolate-image-url-already-alone () (with-temp-buffer (insert "https://example.com/pic.png") (should (equal (cons 1 (point-max)) (jabber-chat--isolate-image-url 1 (point-max)))))) ;;; Group 16: manual image load with RET (ert-deftest jabber-test-chat-image-url-bounds-at-point () (with-temp-buffer (insert "x") (insert (propertize jabber-test-chat--scan-url 'jabber-chat-image-url jabber-test-chat--scan-url)) (goto-char 3) (should (equal (jabber-chat--image-url-bounds) (list 2 (point-max) jabber-test-chat--scan-url))))) (ert-deftest jabber-test-chat-image-url-bounds-nil-without-property () (with-temp-buffer (insert "no url here") (goto-char (point-min)) (should-not (jabber-chat--image-url-bounds)))) (defmacro jabber-test-chat--with-manual-load-buffer (&rest body) "Run BODY in a temp buffer with point on an undisplayed image URL. Bind `fetches' to recorded `jabber-chat--start-image-fetch' calls and `url' to the URL; `display-graphic-p' is stubbed to t." `(with-temp-buffer (let ((fetches nil) (url jabber-test-chat--scan-url)) (insert (propertize url 'jabber-chat-image-url url)) (goto-char (point-min)) (cl-letf (((symbol-function 'jabber-chat--start-image-fetch) (lambda (&rest args) (push args fetches))) ((symbol-function 'display-graphic-p) (lambda (&optional _) t))) ,@body)))) (ert-deftest jabber-test-chat-manual-load-bypasses-allowlist () "Manual load passes nil ALLOWED-TYPES to the fetch." (jabber-test-chat--with-manual-load-buffer (jabber-chat--load-image-at-point) (should (equal fetches (list (list url 1 (point-max) nil t)))))) (ert-deftest jabber-test-chat-manual-load-blocked-while-in-flight () (jabber-test-chat--with-manual-load-buffer (put-text-property 1 (point-max) 'jabber-chat-image-fetching url) (jabber-chat--load-image-at-point) (should (null fetches)))) (ert-deftest jabber-test-chat-manual-load-retries-after-failure () (jabber-test-chat--with-manual-load-buffer (put-text-property 1 (point-max) 'jabber-chat-image-fetching 'failed) (jabber-chat--load-image-at-point) (should (= 1 (length fetches))))) (ert-deftest jabber-test-chat-manual-load-uses-cache () (jabber-test-chat--with-manual-load-buffer (unwind-protect (progn (jabber-chat--cache-image url '(image :type png)) (jabber-chat--load-image-at-point) (should (null fetches)) (should (get-text-property 1 'display))) (remhash url jabber-chat--image-cache)))) (ert-deftest jabber-test-chat-ret-loads-undisplayed-image () (jabber-test-chat--with-manual-load-buffer (cl-letf (((symbol-function 'jabber-chat-download-url) (lambda (_) (error "Should not download")))) (jabber-chat-url-action-at-point) (should (= 1 (length fetches)))))) (ert-deftest jabber-test-chat-ret-downloads-displayed-image () (jabber-test-chat--with-manual-load-buffer (let ((downloads nil)) (cl-letf (((symbol-function 'jabber-chat-download-url) (lambda (u) (push u downloads)))) (put-text-property 1 (point-max) 'display '(image :type png)) (jabber-chat-url-action-at-point) (should (equal downloads (list url))) (should (null fetches)))))) (ert-deftest jabber-test-chat-ret-prefix-downloads-undisplayed () (jabber-test-chat--with-manual-load-buffer (let ((downloads nil)) (cl-letf (((symbol-function 'jabber-chat-download-url) (lambda (u) (push u downloads)))) (jabber-chat-url-action-at-point '(4)) (should (equal downloads (list url))) (should (null fetches)))))) (ert-deftest jabber-test-chat-ret-prefers-file-url () (jabber-test-chat--with-manual-load-buffer (let ((downloads nil)) (cl-letf (((symbol-function 'jabber-chat-download-url) (lambda (u) (push u downloads)))) (put-text-property 1 (point-max) 'jabber-chat-file-url "https://example.com/doc.pdf") (jabber-chat-url-action-at-point) (should (equal downloads '("https://example.com/doc.pdf"))) (should (null fetches)))))) (ert-deftest jabber-test-chat-manual-load-tty-errors () "Batch Emacs is not graphical, so the tty branch errors." (with-temp-buffer (let ((url jabber-test-chat--scan-url)) (insert (propertize url 'jabber-chat-image-url url)) (goto-char (point-min)) (should-error (jabber-chat--load-image-at-point) :type 'user-error)))) (ert-deftest jabber-test-chat-ret-errors-without-url () (with-temp-buffer (insert "plain text") (goto-char (point-min)) (should-error (jabber-chat-url-action-at-point) :type 'user-error))) (ert-deftest jabber-test-chat-manual-decode-failure-offers-decrypted-save () "Manual aesgcm preview failure offers its decrypted bytes for saving." (with-temp-buffer (let* ((url (concat "aesgcm://example.org/photo.jpg#" (make-string 88 ?a))) (saved nil)) (insert (propertize url 'jabber-chat-image-url url)) (cl-letf (((symbol-function 'jabber-chat--offer-image-save) (lambda (save-url data) (setq saved (list save-url data))))) (jabber-chat--handle-image-result (list :error 'decode :data "decrypted-heic") url (copy-marker 1) (copy-marker (point-max)) (current-buffer) t) (should (equal saved (list url "decrypted-heic"))) (should (eq (get-text-property 1 'jabber-chat-image-fetching) 'failed)))))) (ert-deftest jabber-test-chat-aesgcm-save-fallback-writes-decrypted-bytes () "The aesgcm save fallback writes retained plaintext, not ciphertext." (let* ((url (concat "aesgcm://example.org/photo.jpg#" (make-string 88 ?a))) (plaintext (unibyte-string 0 1 2 255)) (dest (make-temp-file "jabber-save-fallback-"))) (unwind-protect (cl-letf (((symbol-function 'y-or-n-p) (lambda (&rest _) t)) ((symbol-function 'jabber-chat--download-destination) (lambda (_) dest))) (jabber-chat--offer-image-save url plaintext) (with-temp-buffer (set-buffer-multibyte nil) (insert-file-contents-literally dest) (should (equal (buffer-string) plaintext)))) (delete-file dest)))) (ert-deftest jabber-test-chat-automatic-decode-failure-does-not-offer-save () "Background image fetching must never open an interactive save prompt." (with-temp-buffer (let ((url "https://example.org/photo.jpg") (offered nil)) (insert (propertize url 'jabber-chat-image-url url)) (cl-letf (((symbol-function 'jabber-chat--offer-image-save) (lambda (&rest _) (setq offered t)))) (jabber-chat--handle-image-result (list :error 'decode :data "unsupported-image") url (copy-marker 1) (copy-marker (point-max)) (current-buffer) nil) (should-not offered) (should (eq (get-text-property 1 'jabber-chat-image-fetching) 'failed)))))) (provide 'jabber-test-chat) ;;; jabber-test-chat.el ends here emacs-jabber-0.13.1/tests/jabber-test-chatbuffer.el000066400000000000000000001603231523531702000221070ustar00rootroot00000000000000;;; jabber-test-chatbuffer.el --- Tests for jabber-chatbuffer -*- lexical-binding: t; -*- ;;; Commentary: ;; Shared chat buffer infrastructure (ewoc, message nodes). ;;; Code: (require 'ert) (require 'cl-lib) (require 'ewoc) (require 'jabber-chatbuffer) (require 'jabber-chat) (require 'jabber-chat-commands) (require 'jabber-db) (require 'jabber-httpupload) (require 'jabber-subscription) ;; jabber-chat requires this via jabber-muc (defvar jabber-muc-xmlns-user "http://jabber.org/protocol/muc#user") (defvar jabber-group nil) (defvar jabber-muc-participants nil) (defvar jabber-scrolltobottom-all nil) (declare-function jabber-chat-buffer-recenter-input "jabber-chatbuffer" ()) (declare-function jabber-chat-buffer--recenter-input-window "jabber-chatbuffer" (window)) ;;; Test helpers (defmacro jabber-test-chatbuffer-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-test-chatbuffer-ewoc-enter-registers-id () "Inserting a message with :id registers it in the hash table." (jabber-test-chatbuffer-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-test-chatbuffer-ewoc-enter-skips-nil-id () "Inserting a message without :id does not pollute the hash table." (jabber-test-chatbuffer-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-test-chatbuffer-ewoc-enter-notice-string () "Inserting a notice with string body does not error." (jabber-test-chatbuffer-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-test-chatbuffer-ewoc-enter-multiple-ids () "Multiple messages with distinct IDs are all registered." (jabber-test-chatbuffer-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)))) (ert-deftest jabber-test-chatbuffer-shift-undo-list-translates-positions () "Undo entries that contain buffer positions are shifted together." (with-temp-buffer (let ((marker (point-marker)) (buffer-undo-list (list 4 (cons 6 9) (cons "abc" 7) (cons "def" -8) ;; Freshly consed: `jabber-chat-buffer--shift-undo-list' ;; shifts this entry in place, so a quoted literal would ;; be mutated and corrupt a second run in the same process. (copy-tree '(nil face bold 10 . 12)) nil (cons t 0)))) (push (cons marker 3) buffer-undo-list) (jabber-chat-buffer--shift-undo-list 5) (should (equal buffer-undo-list (list (cons marker 3) 9 (cons 11 14) (cons "abc" 12) (cons "def" -13) '(nil face bold 15 . 17) nil (cons t 0))))))) (ert-deftest jabber-test-chatbuffer-ewoc-enter-shifts-input-undo () "Inserting chat output keeps typed input undo entries aligned." (with-temp-buffer (setq buffer-undo-list nil) (let ((jabber-chat-ewoc (ewoc-create (lambda (data) (insert (plist-get (cadr data) :body))) nil (concat (jabber-separator) "\n") 'nosep)) (jabber-chat--msg-nodes (make-hash-table :test 'equal))) (goto-char (point-max)) (setq-local jabber-point-insert (point-marker)) (insert "draft") (let ((undo-entry (copy-tree (car buffer-undo-list))) (prompt (marker-position jabber-point-insert))) (jabber-chat-ewoc-enter (list :local (list :id "shift-input" :body "hello"))) (let ((shift (- jabber-point-insert prompt))) (should (cl-plusp shift)) (should (equal (car buffer-undo-list) (cons (+ (car undo-entry) shift) (+ (cdr undo-entry) shift))))))))) ;;; Group 2: jabber-chat-ewoc-find-by-id (ert-deftest jabber-test-chatbuffer-find-by-id-returns-node () "Looking up a registered ID returns the correct ewoc node." (jabber-test-chatbuffer-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-test-chatbuffer-find-by-id-scans-and-backfills-server-id () "Looking up a stale missing :server-id scans EWOC and backfills it." (jabber-test-chatbuffer-with-ewoc (let* ((msg (list :id "local-id" :server-id "server-id" :body "test" :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :foreign msg)))) (remhash "server-id" jabber-chat--msg-nodes) (should (gethash "local-id" jabber-chat--msg-nodes)) (should-not (gethash "server-id" jabber-chat--msg-nodes)) (should (eq node (jabber-chat-ewoc-find-by-id "server-id"))) (should (eq node (gethash "local-id" jabber-chat--msg-nodes))) (should (eq node (gethash "server-id" jabber-chat--msg-nodes)))))) (ert-deftest jabber-test-chatbuffer-find-by-id-returns-nil-for-missing () "Looking up a nonexistent ID returns nil." (jabber-test-chatbuffer-with-ewoc (should-not (jabber-chat-ewoc-find-by-id "no-such-id")))) (ert-deftest jabber-test-chatbuffer-find-by-id-nil-safe () "Looking up nil returns nil without error." (jabber-test-chatbuffer-with-ewoc (should-not (jabber-chat-ewoc-find-by-id nil)))) ;;; Group 3: In-place status update (ert-deftest jabber-test-chatbuffer-status-update-in-place () "Mutating :status on the shared plist is visible through the ewoc node." (jabber-test-chatbuffer-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-test-chatbuffer-status-update-via-lookup () "Status update via find-by-id + plist-put works end-to-end." (jabber-test-chatbuffer-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-test-chatbuffer-hash-cleanup-on-clear () "Clearing the hash table via clrhash removes all entries." (jabber-test-chatbuffer-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-test-chatbuffer-hash-remhash-on-delete () "Removing an entry via remhash drops that ID from the table." (jabber-test-chatbuffer-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-test-chatbuffer-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-test-chatbuffer-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-test-chatbuffer-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-test-chatbuffer-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: Carbon display suppression (defun jabber-test-chatbuffer--sent-carbon (inner) "Wrap INNER in a sent carbon from the local account." `(message ((from . "me@example.com/resource") (type . "chat")) (sent ((xmlns . "urn:xmpp:carbons:2")) (forwarded ((xmlns . "urn:xmpp:forward:0")) ,inner)))) (defun jabber-test-chatbuffer--received-carbon (inner) "Wrap INNER in a received carbon from the local account." `(message ((from . "me@example.com/resource") (type . "chat")) (received ((xmlns . "urn:xmpp:carbons:2")) (forwarded ((xmlns . "urn:xmpp:forward:0")) ,inner)))) (defmacro jabber-test-chatbuffer-with-process-chat-spies (&rest body) "Run BODY with `jabber-process-chat' storage and display spies." (declare (indent 0) (debug t)) `(let ((stored nil) (displayed nil) (buffer (generate-new-buffer " *test-carbon-chat*")) (jabber-chat-printers (list (lambda (&rest _) t)))) (unwind-protect (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-muc-message-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-sender-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc xml-data) xml-data)) ((symbol-function 'jabber-message-correct--replace-id) (lambda (&rest _) nil)) ((symbol-function 'jabber-chat-create-buffer) (lambda (&rest _) buffer)) ((symbol-function 'jabber-chat--store-carbon) (lambda (_jc xml-data) (push xml-data stored))) ((symbol-function 'jabber-chat--display-message) (lambda (&rest args) (push args displayed)))) ,@body) (kill-buffer buffer)))) (ert-deftest jabber-test-chatbuffer-reaction-sent-carbon-not-stored-or-displayed () "Reaction fallback sent carbons are not stored or displayed as chat text." (jabber-test-chatbuffer-with-process-chat-spies (let* ((inner `(message ((from . "me@example.com/phone") (to . "friend@example.com") (type . "chat") (id . "reaction-carbon-1")) (body nil "> hello\n👍") (reactions ((xmlns . ,jabber-reactions-xmlns) (id . "target-1")) (reaction nil "👍")) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . ,jabber-reactions-xmlns))))) (carbon (jabber-test-chatbuffer--sent-carbon inner))) (jabber-process-chat 'fake-jc carbon) (should-not stored) (should-not displayed)))) (ert-deftest jabber-test-chatbuffer-reaction-received-carbon-not-stored-or-displayed () "Reaction fallback received carbons are not stored or displayed as chat text." (jabber-test-chatbuffer-with-process-chat-spies (let* ((inner `(message ((from . "friend@example.com/phone") (to . "me@example.com/resource") (type . "chat") (id . "reaction-carbon-2")) (body nil "> hello\n👍") (reactions ((xmlns . ,jabber-reactions-xmlns) (id . "target-1")) (reaction nil "👍")) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . ,jabber-reactions-xmlns))))) (carbon (jabber-test-chatbuffer--received-carbon inner))) (jabber-process-chat 'fake-jc carbon) (should-not stored) (should-not displayed)))) (ert-deftest jabber-test-chatbuffer-normal-sent-carbon-stores-and-displays () "Normal sent carbons still store and display as before." (jabber-test-chatbuffer-with-process-chat-spies (let* ((inner '(message ((from . "me@example.com/phone") (to . "friend@example.com") (type . "chat") (id . "normal-carbon-1")) (body nil "hello from phone"))) (carbon (jabber-test-chatbuffer--sent-carbon inner))) (jabber-process-chat 'fake-jc carbon) (should (= 1 (length stored))) (should (eq inner (car stored))) (should (= 1 (length displayed)))))) (ert-deftest jabber-test-chatbuffer-normal-received-carbon-stores-and-displays () "Normal received carbons still store and display as before." (jabber-test-chatbuffer-with-process-chat-spies (let* ((inner '(message ((from . "friend@example.com/phone") (to . "me@example.com/resource") (type . "chat") (id . "normal-carbon-2")) (body nil "hello from phone"))) (carbon (jabber-test-chatbuffer--received-carbon inner))) (jabber-process-chat 'fake-jc carbon) (should (= 1 (length stored))) (should (eq inner (car stored))) (should (= 1 (length displayed)))))) ;;; Group 8: OMEMO anonymous-room warning (require 'jabber-omemo) (ert-deftest jabber-test-chatbuffer-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-test-chatbuffer-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-test-chatbuffer-registry-chat-find () "Register a temp buffer as a chat buffer and find it." (let ((jabber-buffer-registry--buffers (make-hash-table :test #'equal))) (with-temp-buffer (jabber-buffer-registry-register 'chat "alice@example.com") (should (eq (current-buffer) (jabber-buffer-registry-find 'chat "alice@example.com")))))) (ert-deftest jabber-test-chatbuffer-registry-kill-removes-entry () "Killing the buffer removes its registry entry." (let ((jabber-buffer-registry--buffers (make-hash-table :test #'equal))) (let ((buf (generate-new-buffer " *test-chat-registry*"))) (with-current-buffer buf (jabber-buffer-registry-register 'chat "bob@example.com")) (should (eq buf (jabber-buffer-registry-find 'chat "bob@example.com"))) (kill-buffer buf) (should-not (jabber-buffer-registry-find 'chat "bob@example.com"))))) (ert-deftest jabber-test-chatbuffer-registry-no-collision () "MUC and chat buffers with the same bare JID do not collide." (let ((jabber-buffer-registry--buffers (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 (jabber-buffer-registry-register 'chat "room@conf.example.com")) (with-current-buffer muc-buf (jabber-buffer-registry-register 'muc "room@conf.example.com")) (should (eq chat-buf (jabber-buffer-registry-find 'chat "room@conf.example.com"))) (should (eq muc-buf (jabber-buffer-registry-find 'muc "room@conf.example.com")))) (kill-buffer chat-buf) (kill-buffer muc-buf))))) (ert-deftest jabber-test-chatbuffer-registry-muc-private () "MUC-private lookup by group+nick returns correct buffer." (let ((jabber-buffer-registry--buffers (make-hash-table :test #'equal))) (let ((buf (generate-new-buffer " *test-muc-private*"))) (unwind-protect (progn (with-current-buffer buf (jabber-buffer-registry-register 'muc-private "room@conf.example.com/alice")) (should (eq buf (jabber-buffer-registry-find 'muc-private "room@conf.example.com/alice")))) (kill-buffer buf))))) (ert-deftest jabber-test-chatbuffer-registry-replacement-survives-old-kill () "Killing a replaced buffer does not remove the current registration." (let ((jabber-buffer-registry--buffers (make-hash-table :test #'equal)) (old (generate-new-buffer " *test-chat-old*")) (new (generate-new-buffer " *test-chat-new*"))) (unwind-protect (progn (jabber-buffer-registry-register 'chat "carol@example.com" old) (jabber-buffer-registry-register 'chat "carol@example.com" new) (kill-buffer old) (should (eq new (jabber-buffer-registry-find 'chat "carol@example.com")))) (when (buffer-live-p old) (kill-buffer old)) (when (buffer-live-p new) (kill-buffer new))))) (ert-deftest jabber-test-subscription-removes-stale-prompts-from-chat () "Ordinary presence removes old subscription prompts for its sender." (let ((jabber-buffer-registry--buffers (make-hash-table :test #'equal))) (jabber-test-chatbuffer-with-ewoc (jabber-buffer-registry-register 'chat "alice@example.com") (jabber-chat-ewoc-enter '(:subscription-request "hello")) (jabber-chat-ewoc-enter '(:notice "keep me")) (jabber-subscription--remove-stale nil "alice@example.com/phone") (should (equal (ewoc-collect jabber-chat-ewoc #'identity) '((:notice "keep me"))))))) (ert-deftest jabber-test-subscription-request-enters-chat-buffer () "A subscription request is rendered in the sender's chat buffer." (with-temp-buffer (let ((buffer (current-buffer)) entered) (cl-letf (((symbol-function 'jabber-chat-create-buffer) (lambda (_jc _from) buffer)) ((symbol-function 'jabber-chat-ewoc-enter) (lambda (data) (setq entered data)))) (let ((jabber-presence-hooks nil) (jabber-alert-presence-hooks nil)) (jabber-process-subscription-request 'fake-jc "alice@example.com" "please"))) (should (equal (plist-get entered :subscription-request) "please")) (should (plist-get entered :time))))) ;;; Group 9: OMEMO immediate display status transitions (defvar jabber-muc-printers) (defmacro jabber-test-chatbuffer-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-muc-printers nil) (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: "))) ((symbol-function 'jabber-chat-print-prompt) (lambda (_msg _ts _delayed _/me-p) (insert "them: "))) ((symbol-function 'jabber-muc-print-prompt) (lambda (_msg _local-p _/me-p) (insert "room: ")))) ,@body)))) (ert-deftest jabber-test-chatbuffer-sending-status-renders-warning-dot () "A message with :sending status renders a warning-face dot." (jabber-test-chatbuffer-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-test-chatbuffer-reply-inline-quote-renders-1to1 () "A 1:1 reply renders the fallback quote inline and shows no id label." (jabber-test-chatbuffer-with-rendering-ewoc (let* ((msg (list :id "reply-1" :body "> phone:\n> original\nanswer" :from "alice@example.com/phone" :reply-to-id "orig-1" :reply-to-jid "alice@example.com/phone" :fallback-range '(0 20) :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :foreign msg)))) (should node) (let ((text (buffer-string))) (should (string-match-p "> phone:\n> original\nanswer" text)) (should-not (string-match-p "reply to " text)))))) (ert-deftest jabber-test-chatbuffer-reply-inline-quote-renders-muc () "A MUC reply renders the fallback quote inline and shows no id label." (jabber-test-chatbuffer-with-rendering-ewoc (let* ((msg (list :id "reply-2" :body "> alice:\n> original\nanswer" :from "room@conf.example.com/bob" :reply-to-id "server-orig-1" :reply-to-jid "room@conf.example.com/alice" :fallback-range '(0 20) :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :muc-foreign msg)))) (should node) (let ((text (buffer-string))) (should (string-match-p "> alice:\n> original\nanswer" text)) (should-not (string-match-p "reply to " text)))))) (ert-deftest jabber-test-chatbuffer-reply-without-fallback-shows-label () "A reply carrying no fallback quote renders a compact context label." (jabber-test-chatbuffer-with-rendering-ewoc (let* ((msg (list :id "reply-3" :body "answer" :from "alice@example.com/phone" :reply-to-id "orig-1" :reply-to-jid "alice@example.com/phone" :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :foreign msg)))) (should node) (should (string-match-p "reply to alice@example.com" (buffer-string)))))) (ert-deftest jabber-test-chatbuffer-reply-without-fallback-muc-label-uses-nick () "The MUC context label shows the occupant nick, not the room." (jabber-test-chatbuffer-with-rendering-ewoc (cl-letf (((symbol-function 'jabber-muc-sender-p) (lambda (_jid) t))) (let* ((msg (list :id "reply-4" :body "answer" :from "room@conf.example.com/bob" :reply-to-id "server-orig-1" :reply-to-jid "room@conf.example.com/alice" :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :muc-foreign msg)))) (should node) (should (string-match-p "reply to alice\n" (buffer-string))))))) (ert-deftest jabber-test-chatbuffer-reply-without-jid-shows-bare-label () "A reply with no author JID still gets a bare context label." (jabber-test-chatbuffer-with-rendering-ewoc (let* ((msg (list :id "reply-5" :body "answer" :from "alice@example.com/phone" :reply-to-id "orig-1" :timestamp (current-time))) (node (jabber-chat-ewoc-enter (list :foreign msg)))) (should node) (let ((text (buffer-string))) (should (string-match-p "reply\n" text)) (should-not (string-match-p "reply to " text)))))) (ert-deftest jabber-test-chatbuffer-status-sending-to-sent () "Status :sending -> :sent updates the indicator face." (jabber-test-chatbuffer-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-test-chatbuffer-status-sending-to-undelivered () "Status :sending -> :undelivered shows error-face X." (jabber-test-chatbuffer-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-test-chatbuffer-send-failed-restores-body () "jabber-omemo--send-failed restores body text to buffer input area." (require 'jabber-omemo) (jabber-test-chatbuffer-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-test-chatbuffer-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-test-chatbuffer-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-test-chatbuffer-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)))))) ;;; Group 11: Refresh completion (ert-deftest jabber-test-chatbuffer-refresh-recenters-after-chunked-insert () "Refresh recenters only from the chunked insertion completion callback." (jabber-test-chatbuffer-with-ewoc (let ((events nil) (callback nil) (insert-generation nil) (jabber-buffer-connection 'fake-jc) (jabber-chatting-with "friend@example.com") (jabber-group nil) (jabber-chat-buffer-msg-count nil) (jabber-backlog-number 10) (jabber-chat-earliest-backlog nil) (entries (list (list :timestamp (current-time) :body "hello")))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-backlog) (lambda (&rest _) entries)) ((symbol-function 'jabber-muc-sender-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-chat--insert-backlog-chunked) (lambda (_buffer _entries cb &optional generation) (setq events (append events '(insert-start)) callback cb insert-generation generation))) ((symbol-function 'jabber-chat-display-buffer-images) (lambda () (setq events (append events '(images))))) ((symbol-function 'jabber-chat-buffer--restore-view) (lambda (_anchors) (setq events (append events '(restore)))))) (jabber-chat-buffer-refresh) (should (equal '(insert-start) events)) (should callback) (should (= insert-generation jabber-chat--backlog-generation)) (funcall callback) (should (equal '(insert-start images restore) events)))))) (ert-deftest jabber-test-chatbuffer-disabled-threads-refresh-as-plain-chat () "Include threaded messages in the original parent refresh path." (jabber-test-chatbuffer-with-ewoc (let ((jabber-message-thread-use-buffers nil) (jabber-buffer-connection 'fake-jc) (jabber-chatting-with "friend@example.com") (jabber-group nil) (jabber-chat-buffer-msg-count nil) backlog-args) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-backlog) (lambda (&rest args) (setq backlog-args args) nil)) ((symbol-function 'jabber-muc-sender-p) (lambda (&rest _) nil))) (jabber-chat-buffer-refresh) (should (eq t (nth 6 backlog-args))))))) (ert-deftest jabber-test-chatbuffer-refresh-empty-skips-completion-callbacks () "Empty refresh preserves behavior by skipping insert completion callbacks." (jabber-test-chatbuffer-with-ewoc (let ((events nil) (jabber-buffer-connection 'fake-jc) (jabber-chatting-with "friend@example.com") (jabber-group nil) (jabber-chat-buffer-msg-count nil) (jabber-backlog-number 10) (jabber-chat-earliest-backlog nil)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-backlog) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-sender-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-chat--insert-backlog-chunked) (lambda (&rest _) (setq events (append events '(insert-start))))) ((symbol-function 'jabber-chat-display-buffer-images) (lambda () (setq events (append events '(images))))) ((symbol-function 'jabber-chat-buffer-recenter-input) (lambda () (setq events (append events '(recenter)))))) (jabber-chat-buffer-refresh) (should-not events))))) ;;; Group 11b: view preservation across refresh (ert-deftest jabber-test-chatbuffer-node-stanza-id-prefers-id () "A message node's anchor id is :id when present." (jabber-test-chatbuffer-with-ewoc (let ((node (jabber-chat-ewoc-enter (list :foreign (list :id "a" :server-id "b" :body "x"))))) (should (equal "a" (jabber-chat-buffer--node-stanza-id node)))))) (ert-deftest jabber-test-chatbuffer-node-stanza-id-falls-back-to-server-id () "A message node with only :server-id anchors on the server id." (jabber-test-chatbuffer-with-ewoc (let ((node (jabber-chat-ewoc-enter (list :foreign (list :server-id "only-server" :body "x"))))) (should (equal "only-server" (jabber-chat-buffer--node-stanza-id node)))))) (ert-deftest jabber-test-chatbuffer-node-stanza-id-nil-for-notice () "Notice nodes carry no anchor id." (jabber-test-chatbuffer-with-ewoc (let ((node (jabber-chat-ewoc-enter (list :notice "joined")))) (should-not (jabber-chat-buffer--node-stanza-id node))))) (ert-deftest jabber-test-chatbuffer-anchor-id-survives-refresh-rebuild () "A captured anchor id still resolves after a full clear and rebuild. This is the invariant the refresh view-restore depends on: a reader scrolled up to a server-id-only message must be findable again once the ewoc is rebuilt from the database." (jabber-test-chatbuffer-with-ewoc (let ((entries (list (list :foreign (list :id "m1" :body "one")) (list :foreign (list :server-id "s2" :body "two")) (list :local (list :id "m3" :body "three"))))) (dolist (e entries) (jabber-chat-ewoc-enter e)) (let ((anchor-id (jabber-chat-buffer--node-stanza-id (jabber-chat-ewoc-find-by-id "s2")))) (should (equal "s2" anchor-id)) ;; Mimic jabber-chat-buffer-refresh: drop every node, then rebuild. (let ((n (ewoc-nth jabber-chat-ewoc 0))) (while n (let ((next (ewoc-next jabber-chat-ewoc n))) (ewoc-delete jabber-chat-ewoc n) (setq n next)))) (clrhash jabber-chat--msg-nodes) (dolist (e entries) (jabber-chat-ewoc-enter e)) (let ((restored (jabber-chat-ewoc-find-by-id anchor-id))) (should restored) (should (equal "two" (plist-get (cadr (ewoc-data restored)) :body)))))))) (ert-deftest jabber-test-chatbuffer-restore-view-dispatch () "A following window is recentered without moving point; a history window is scrolled back to its anchored message; a vanished anchor is forced to the bottom (the only path that overwrites point)." (jabber-test-chatbuffer-with-ewoc (let ((recentered nil) (forced nil) (started nil)) (cl-letf (((symbol-function 'window-live-p) (lambda (_w) t)) ((symbol-function 'jabber-chat-buffer--recenter-input-window) (lambda (w) (push w recentered))) ((symbol-function 'jabber-chat-buffer--restore-bottom) (lambda (w) (push w forced))) ((symbol-function 'jabber-chat-ewoc-find-by-id) (lambda (id) (when (equal id "present") 'fake-node))) ((symbol-function 'ewoc-location) (lambda (_n) 42)) ((symbol-function 'set-window-start) (lambda (w pos) (push (list w pos) started))) ((symbol-function 'set-window-point) (lambda (_w _pos) nil))) (jabber-chat-buffer--restore-view '((win-bottom . bottom) (win-present msg . "present") (win-missing msg . "gone"))) ;; Following window recentered, point preserved (not forced). (should (equal '(win-bottom) recentered)) ;; Only the vanished-anchor window is forced to the bottom. (should (equal '(win-missing) forced)) ;; The live-anchor window is scrolled to its message. (should (equal '((win-present 42)) started)))))) ;;; Group 12: scroll-to-bottom window policy (ert-deftest jabber-test-chatbuffer-recenter-input-default-uses-one-window () "Default scroll-to-bottom behavior recenters only one visible window." (with-temp-buffer (let ((jabber-scrolltobottom-all nil) (seen-buffers nil) (checked nil) (recentered nil)) (cl-letf (((symbol-function 'get-buffer-window) (lambda (buffer &optional _all-frames) (push buffer seen-buffers) 'win-a)) ((symbol-function 'get-buffer-window-list) (lambda (&rest _) (error "get-buffer-window-list should not be called"))) ((symbol-function 'jabber-chat-buffer--recenter-input-p) (lambda (window) (push window checked) t)) ((symbol-function 'window-live-p) (lambda (_window) t)) ((symbol-function 'jabber-chat-buffer--recenter-input-window) (lambda (window) (push window recentered)))) (jabber-chat-buffer-recenter-input) (should (equal (list (current-buffer)) seen-buffers)) (should (equal '(win-a) checked)) (should (equal '(win-a) recentered)))))) (ert-deftest jabber-test-chatbuffer-recenter-input-all-uses-visible-windows () "All-window scroll-to-bottom checks every visible chat buffer window." (with-temp-buffer (let ((jabber-scrolltobottom-all t) (seen-buffers nil) (checked nil) (recentered nil)) (cl-letf (((symbol-function 'get-buffer-window) (lambda (&rest _) (error "get-buffer-window should not be called"))) ((symbol-function 'get-buffer-window-list) (lambda (buffer &optional _minibuf _all-frames) (push buffer seen-buffers) '(win-a win-b win-c))) ((symbol-function 'jabber-chat-buffer--recenter-input-p) (lambda (window) (push window checked) (memq window '(win-a win-c)))) ((symbol-function 'jabber-chat-buffer--recenter-input-window) (lambda (window) (push window recentered)))) (jabber-chat-buffer-recenter-input) (should (equal (list (current-buffer)) seen-buffers)) (should (equal '(win-c win-b win-a) checked)) (should (equal '(win-c win-a) recentered)))))) (ert-deftest jabber-test-chatbuffer-with-scrolltobottom-is-no-op-wrapper () "Scroll-to-bottom compatibility wrapper evaluates BODY only." (let ((events nil)) (cl-letf (((symbol-function 'jabber-chat-buffer-recenter-input) (lambda () (push 'recenter events))) ((symbol-function 'jabber-chat-buffer--recenter-input-window) (lambda (_window) (push 'recenter-window events)))) (should (eq 'body-result (jabber-chat-buffer-with-scrolltobottom (push 'body events) 'body-result))) (should (equal '(body) events))))) (ert-deftest jabber-test-chatbuffer-with-scrolltobottom-is-callable () "Scroll-to-bottom wrapper also works as an ordinary function." (should (eq 'body-result (funcall #'jabber-chat-buffer-with-scrolltobottom 'ignored 'body-result)))) (ert-deftest jabber-test-chatbuffer-recenter-input-window-preserves-point () "Recentering moves temporarily to the input marker and restores point." (let ((buffer (generate-new-buffer " *test-chat-recenter*")) (previous-buffer (window-buffer (selected-window))) (recenter-point nil) typed-point) (unwind-protect (progn (switch-to-buffer buffer) (insert "history\n") (setq-local jabber-point-insert (point-marker)) (insert "typed input") (setq typed-point (point)) (cl-letf (((symbol-function 'recenter) (lambda (&rest _) (setq recenter-point (point))))) (jabber-chat-buffer--recenter-input-window (selected-window))) (should (= recenter-point jabber-point-insert)) (should (= (point) typed-point))) (set-window-buffer (selected-window) previous-buffer) (kill-buffer buffer)))) ;;; Group 13: HTTP Upload callback (ert-deftest jabber-test-chatbuffer-attach-file-inserts-url-when-buffer-live () "Upload completion inserts the URL into the original live buffer." (with-temp-buffer (let ((jabber-buffer-connection 'jc) (callback nil) (messages nil)) (cl-letf (((symbol-function 'jabber-httpupload--upload) (lambda (_jc _filepath cb) (setq callback cb))) ((symbol-function 'message) (lambda (format-string &rest args) (push (apply #'format format-string args) messages)))) (jabber-chat-attach-file "/tmp/file.txt") (funcall callback "https://upload.example.net/file.txt") (should (string= (buffer-string) "https://upload.example.net/file.txt")) (should (string= jabber-httpupload--pending-url "https://upload.example.net/file.txt")) (should (equal messages '("Uploaded: https://upload.example.net/file.txt (send with RET)"))))))) (ert-deftest jabber-test-chatbuffer-attach-file-skips-dead-buffer () "Upload completion skips insertion when the original buffer was killed." (let ((buffer (generate-new-buffer " *jabber-upload-dead*")) (callback nil)) (with-current-buffer buffer (setq-local jabber-buffer-connection 'jc) (cl-letf (((symbol-function 'jabber-httpupload--upload) (lambda (_jc _filepath cb) (setq callback cb)))) (jabber-chat-attach-file "/tmp/file.txt"))) (kill-buffer buffer) (should-not (buffer-live-p buffer)) (should-not (funcall callback "https://upload.example.net/file.txt")))) ;;; Group: help-at-point display (ert-deftest jabber-test-chatbuffer-help-at-point-enabled () "Enabling the option scopes help-at-pt to the chat buffer." (let ((jabber-chat-display-help-at-point t)) (unwind-protect (with-temp-buffer (jabber-chat-mode) (should (local-variable-p 'help-at-pt-display-when-idle)) (should (equal help-at-pt-display-when-idle '(help-echo)))) (help-at-pt-cancel-timer)))) (ert-deftest jabber-test-chatbuffer-help-at-point-disabled () "Disabling the option leaves help-at-pt untouched in the buffer." (let ((jabber-chat-display-help-at-point nil)) (with-temp-buffer (jabber-chat-mode) (should-not (local-variable-p 'help-at-pt-display-when-idle))))) ;;; Group 14: shared input sending (ert-deftest jabber-test-input-send-extracts-body () "Send and remove input below the prompt marker." (with-temp-buffer (insert "Prompt: hello") (let ((jabber-connections '(connection)) (sent nil)) (setq-local jabber-buffer-connection 'connection) (setq-local jabber-point-insert (copy-marker 9)) (setq-local jabber-send-function (lambda (jc body) (setq sent (cons jc body)))) (jabber-chat-buffer-send) (should (equal sent '(connection . "hello"))) (should (string= (buffer-string) "Prompt: "))))) (ert-deftest jabber-test-input-send-passes-extra-elements () "Pass optional stanza elements through the shared input sender." (with-temp-buffer (insert "Prompt: hello") (let ((jabber-connections '(connection)) sent) (setq-local jabber-buffer-connection 'connection) (setq-local jabber-point-insert (copy-marker 9)) (setq-local jabber-send-function (lambda (jc body &optional extra-elements) (setq sent (list jc body extra-elements)))) (jabber-chat-buffer-send '((thread () "thread-1"))) (should (equal sent '(connection "hello" ((thread () "thread-1"))))) (should (string= (buffer-string) "Prompt: "))))) (ert-deftest jabber-test-input-send-reuses-active-connection () "Replace a stale connection before sending input." (with-temp-buffer (insert "hello") (let ((jabber-connections '(new)) (sent nil)) (setq-local jabber-buffer-connection 'old) (setq-local jabber-point-insert (copy-marker (point-min))) (setq-local jabber-send-function (lambda (jc body) (setq sent (cons jc body)))) (cl-letf (((symbol-function 'jabber-find-active-connection) (lambda (_jc) 'new)) ((symbol-function 'jabber-read-account) (lambda (&rest _) (ert-fail "Prompted for an account")))) (jabber-chat-buffer-send)) (should (equal sent '(new . "hello"))) (should (eq jabber-buffer-connection 'new))))) ;;; Group 15: MUC message identity (ert-deftest jabber-test-chatbuffer-muc-client-id-is-sender-scoped () "Two MUC occupants using one client ID both remain addressable." (with-temp-buffer (let ((jabber-group "room@conference.example.com") (jabber-chat-ewoc (ewoc-create #'ignore nil nil 'nosep)) (jabber-chat--msg-nodes (make-hash-table :test #'equal))) (let ((alice (jabber-chat-ewoc-enter (list :muc-foreign (list :id "same-id" :server-id "server-a" :from "room@conference.example.com/alice" :body "alice")))) (bob (jabber-chat-ewoc-enter (list :muc-foreign (list :id "same-id" :server-id "server-b" :from "room@conference.example.com/bob" :body "bob"))))) (should alice) (should bob) (should (eq alice (jabber-chat-ewoc-find-by-id-and-sender "same-id" "room@conference.example.com/alice"))) (should (eq bob (jabber-chat-ewoc-find-by-id-and-sender "same-id" "room@conference.example.com/bob"))) (should (eq alice (jabber-chat-ewoc-find-by-id "server-a"))) (should (eq bob (jabber-chat-ewoc-find-by-id "server-b"))))))) (ert-deftest jabber-test-chatbuffer-unregister-removes-composite-keys () "Removing a MUC node drops its client and server index keys." (with-temp-buffer (let ((jabber-group "room@conference.example.com") (jabber-chat-ewoc (ewoc-create #'ignore nil nil 'nosep)) (jabber-chat--msg-nodes (make-hash-table :test #'equal))) (let ((node (jabber-chat-ewoc-enter (list :muc-foreign (list :id "client-id" :server-id "server-id" :from "room@conference.example.com/alice" :body "hello"))))) (jabber-chat-ewoc-unregister-node node) (should-not (gethash "server-id" jabber-chat--msg-nodes)) (should-not (gethash '(:muc "room@conference.example.com/alice" "client-id") jabber-chat--msg-nodes)))))) (ert-deftest jabber-test-chatbuffer-mam-refresh-is-account-scoped () "A MAM completion refreshes only the account that produced it." (let ((first (generate-new-buffer " *jabber-mam-first*")) (second (generate-new-buffer " *jabber-mam-second*")) refreshed) (unwind-protect (progn (dolist (entry `((,first account-a) (,second account-b))) (with-current-buffer (car entry) (setq-local major-mode 'jabber-chat-mode) (setq-local jabber-buffer-connection (cadr entry)) (setq-local jabber-chatting-with "friend@example.com"))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (jc) (if (eq jc 'account-a) "me-a@example.com" "me-b@example.com"))) ((symbol-function 'jabber-chat-buffer-refresh) (lambda () (push (current-buffer) refreshed)))) (jabber-chat--handle-mam-sync-complete '(("me-a@example.com" "friend@example.com" "chat")))) (should (equal (list first) refreshed))) (kill-buffer first) (kill-buffer second)))) (provide 'jabber-test-chatbuffer) ;;; jabber-test-chatbuffer.el ends here emacs-jabber-0.13.1/tests/jabber-test-chatstates.el000066400000000000000000002022211523531702000221330ustar00rootroot00000000000000;;; jabber-test-chatstates.el --- Tests for jabber-chatstates -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0085 Chat State Notifications. ;;; Code: (require 'ert) (require 'jabber-chatstates) (require 'jabber-reactions) (defun jabber-test-chatstates--message (from type state) "Return a message sexp from FROM with TYPE and chat STATE." `(message ((from . ,from) (type . ,type)) (,state ((xmlns . ,jabber-chatstates-xmlns))))) (defun jabber-test-chatstates--plain-message (from type) "Return a message sexp from FROM with TYPE, body, and no chat state." `(message ((from . ,from) (type . ,type)) (body nil "hello"))) (defun jabber-test-chatstates--thread-message (from type state thread-id) "Return a threaded message from FROM with TYPE and chat STATE." `(message ((from . ,from) (type . ,type)) (thread () ,thread-id) (,state ((xmlns . ,jabber-chatstates-xmlns))))) (defun jabber-test-chatstates--thread-body-message (from type thread-id) "Return a threaded body message from FROM with TYPE." `(message ((from . ,from) (type . ,type)) (thread () ,thread-id) (body nil "hello"))) (defun jabber-test-chatstates--reaction-message (from type) "Return a bodyless reaction message sexp from FROM with TYPE." `(message ((from . ,from) (type . ,type)) (reactions ((xmlns . "urn:xmpp:reactions:0") (id . "target-1")) (reaction nil "👍")))) (defun jabber-test-chatstates--reaction-fallback-message (from type) "Return a reaction message from FROM with TYPE and fallback text." `(message ((from . ,from) (type . ,type)) (body nil "> quoted\n👍") (reactions ((xmlns . "urn:xmpp:reactions:0") (id . "target-1")) (reaction nil "👍")) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . "urn:xmpp:reactions:0")) (body ((start . "0") (end . "10")))))) (defun jabber-test-chatstates--ewoc-data () "Return the current EWOC data in display order." (let (data) (ewoc-map (lambda (item) (push item data)) jabber-chat-ewoc) (nreverse data))) (defun jabber-test-chatstates--create-thread-buffer (parent type) "Create a test thread with PARENT and message TYPE." (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.org")) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) nil)) ((symbol-function 'jabber-chat-mode-setup) #'ignore) ((symbol-function 'jabber-buffer-registry-register) #'ignore) ((symbol-function 'jabber-db-thread-backlog) #'ignore)) (jabber-message-thread-create-buffer 'fake-jc (if (equal type "groupchat") "room@conference.example" "alice@example.org") type "thread-1" nil parent))) ;;; Group 1: Composing notification fix (ert-deftest jabber-test-chatstates-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-test-chatstates-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-test-chatstates-no-composing-when-not-requested () "Composing notification is not sent after negotiation opt-out." (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-chatstates-requested 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-test-chatstates-direct-thread-composing-keeps-thread () "A direct thread composing notification includes its ThreadID." (let (sent) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc stanza) (setq sent stanza))) ((symbol-function 'jabber-chatstates-kick-timer) #'ignore)) (with-temp-buffer (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatstates-requested t) (setq-local jabber-chatting-with "them@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-thread-parent-id "parent-1") (setq-local jabber-point-insert (point-min)) (setq-local jabber-chatstates-composing-sent nil) (insert "draft") (jabber-chatstates-after-change))) (should (equal sent `(message ((to . "them@example.com") (type . "chat")) (thread ((parent . "parent-1")) "thread-1") (composing ((xmlns . ,jabber-chatstates-xmlns)))))))) (ert-deftest jabber-test-chatstates-muc-thread-composing-keeps-thread () "A MUC thread composing notification targets the room and ThreadID." (let (sent) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc stanza) (setq sent stanza))) ((symbol-function 'jabber-chatstates-kick-timer) #'ignore)) (with-temp-buffer (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatstates-requested t) (setq-local jabber-group "room@conference.example") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-thread-parent-id nil) (setq-local jabber-point-insert (point-min)) (setq-local jabber-chatstates-composing-sent nil) (insert "draft") (jabber-chatstates-after-change))) (should (equal sent `(message ((to . "room@conference.example") (type . "groupchat")) (thread () "thread-1") (composing ((xmlns . ,jabber-chatstates-xmlns)))))))) (ert-deftest jabber-test-chatstates-new-direct-thread-inherits-hooks () "A new direct thread inherits negotiated chat-state sending." (let ((parent (generate-new-buffer " *jabber-direct-thread-parent*")) thread) (unwind-protect (progn (with-current-buffer parent (setq-local jabber-chatstates-requested t) (add-hook 'post-command-hook #'jabber-chatstates-after-change nil t)) (setq thread (jabber-test-chatstates--create-thread-buffer parent "chat")) (with-current-buffer thread (should (memq #'jabber-chatstates-after-change post-command-hook)) (should (memq #'jabber-chatstates-send-gone kill-buffer-hook)))) (when (buffer-live-p thread) (with-current-buffer thread (remove-hook 'kill-buffer-hook #'jabber-chatstates-send-gone t)) (kill-buffer thread)) (kill-buffer parent)))) (ert-deftest jabber-test-chatstates-new-direct-thread-inherits-opt-out () "A new direct thread inherits its parent's negotiated opt-out." (let ((parent (generate-new-buffer " *jabber-opt-out-parent*")) thread sent) (unwind-protect (progn (with-current-buffer parent (setq-local jabber-chatstates-requested nil)) (setq thread (jabber-test-chatstates--create-thread-buffer parent "chat")) (with-current-buffer thread (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-point-insert (point-min)) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (&rest _) (setq sent t)))) (should-not jabber-chatstates-requested) (should-not (jabber-chatstates-when-sending "message" "message-1")) (insert "draft") (jabber-chatstates-after-change) (jabber-chatstates-send-gone) (should-not sent)) (should-not (memq #'jabber-chatstates-after-change post-command-hook)) (should-not (memq #'jabber-chatstates-send-gone kill-buffer-hook)))) (when (buffer-live-p thread) (kill-buffer thread)) (kill-buffer parent)))) (ert-deftest jabber-test-chatstates-new-muc-thread-enables-sending () "A new MUC thread enables chat states without a gone hook." (let ((parent (generate-new-buffer " *jabber-muc-thread-parent*")) thread) (unwind-protect (progn (setq thread (jabber-test-chatstates--create-thread-buffer parent "groupchat")) (with-current-buffer thread (should (memq #'jabber-chatstates-after-change post-command-hook)) (should-not (memq #'jabber-chatstates-send-gone kill-buffer-hook)))) (when (buffer-live-p thread) (kill-buffer thread)) (kill-buffer parent)))) (ert-deftest jabber-test-chatstates-muc-thread-kill-cancels-timers () "Killing a MUC thread cancels state timers without sending gone." (let ((parent (generate-new-buffer " *jabber-muc-timer-parent*")) thread timer sent) (unwind-protect (progn (setq thread (jabber-test-chatstates--create-thread-buffer parent "groupchat")) (with-current-buffer thread (setq timer (run-with-timer 3600 nil #'ignore)) (setq-local jabber-chatstates-paused-timer timer)) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (&rest _) (setq sent t)))) (kill-buffer thread)) (should-not sent) (should-not (memq timer timer-list))) (when (and timer (memq timer timer-list)) (cancel-timer timer)) (when (buffer-live-p thread) (kill-buffer thread)) (kill-buffer parent)))) (ert-deftest jabber-test-chatstates-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-test-chatstates-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)))) (ert-deftest jabber-test-chatstates-send-hook-nil-when-not-requested () "Send hook returns nil after chat state negotiation is disabled." (with-temp-buffer (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatstates-requested 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-test-chatstates-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-test-chatstates-timer-keeps-originating-thread () "A paused timer sends from the thread buffer that started it." (let ((origin (generate-new-buffer " *jabber-chatstate-origin*")) callback callback-args sent) (unwind-protect (cl-letf (((symbol-function 'run-with-timer) (lambda (_seconds _repeat function &rest args) (setq callback function callback-args args) 'fake-timer)) ((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc stanza) (setq sent stanza)))) (with-current-buffer origin (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatstates-requested t) (setq-local jabber-chatting-with "them@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-thread-parent-id nil) (setq-local jabber-chatstates-paused-timer nil) (setq-local jabber-chatstates-inactive-timer nil) (jabber-chatstates-kick-timer)) (with-temp-buffer (apply callback callback-args)) (should (equal sent `(message ((to . "them@example.com") (type . "chat")) (thread () "thread-1") (paused ((xmlns . ,jabber-chatstates-xmlns))))))) (kill-buffer origin)))) (ert-deftest jabber-test-chatstates-paused-not-sent-when-not-requested () "send-paused is a no-op after negotiation opt-out." (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-chatstates-requested nil) (setq-local jabber-chatting-with "them@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chatstates-inactive-timer nil) (jabber-chatstates-send-paused) (should-not sent) (should-not jabber-chatstates-inactive-timer))))) (ert-deftest jabber-test-chatstates-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-test-chatstates-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-test-chatstates-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-test-chatstates-send-gone-not-sent-when-not-requested () "send-gone is a no-op after negotiation opt-out." (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-chatstates-requested nil) (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-not sent))))) (ert-deftest jabber-test-chatstates-direct-thread-gone-keeps-thread () "A direct thread gone notification includes its ThreadID." (let (sent) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc stanza) (setq sent stanza)))) (with-temp-buffer (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatstates-requested t) (setq-local jabber-chatting-with "them@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-thread-parent-id nil) (setq-local jabber-chatstates-paused-timer nil) (setq-local jabber-chatstates-inactive-timer nil) (jabber-chatstates-send-gone))) (should (equal sent `(message ((to . "them@example.com") (type . "chat")) (thread () "thread-1") (gone ((xmlns . ,jabber-chatstates-xmlns)))))))) (ert-deftest jabber-test-chatstates-muc-thread-does-not-send-gone () "Closing a MUC thread does not send a gone notification." (let (sent) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc stanza) (setq sent stanza)))) (with-temp-buffer (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatstates-requested t) (setq-local jabber-group "room@conference.example") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-chatstates-paused-timer nil) (setq-local jabber-chatstates-inactive-timer nil) (jabber-chatstates-send-gone))) (should-not sent))) (ert-deftest jabber-test-chatstates-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))))) ;;; Group 3: MUC typing helpers (ert-deftest jabber-test-chatstates-format-no-muc-composers () (should-not (jabber-chatstates--format-muc-composers nil))) (ert-deftest jabber-test-chatstates-format-one-muc-composer () (should (string= (jabber-chatstates--format-muc-composers '("alice")) "alice is typing..."))) (ert-deftest jabber-test-chatstates-format-multiple-muc-composers () (should (string= (jabber-chatstates--format-muc-composers '("alice" "bob")) "alice, bob are typing..."))) (ert-deftest jabber-test-chatstates-muc-composers-adds-on-composing () (should (equal (jabber-chatstates--muc-composers-for-state '("alice") "bob" 'composing) '("alice" "bob")))) (ert-deftest jabber-test-chatstates-muc-composers-does-not-duplicate () (should (equal (jabber-chatstates--muc-composers-for-state '("alice" "bob") "alice" 'composing) '("alice" "bob")))) (ert-deftest jabber-test-chatstates-muc-composers-removes-on-non-composing () (should (equal (jabber-chatstates--muc-composers-for-state '("alice" "bob" "carol") "bob" 'paused) '("alice" "carol")))) (ert-deftest jabber-test-chatstates-muc-composers-removal-is-idempotent () (should (equal (jabber-chatstates--muc-composers-for-state '("alice" "bob") "carol" 'active) '("alice" "bob")))) (ert-deftest jabber-test-chatstates-direct-send-clears-typing-node () "Local direct-chat send clears the peer typing node." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (node (ewoc-enter-last jabber-chat-ewoc '(:typing "alice is typing...")))) (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatstates--ewoc-node node) (jabber-chatstates-when-sending "hello" "id-1") (should-not jabber-chatstates--ewoc-node) (should-not (jabber-test-chatstates--ewoc-data))))) (ert-deftest jabber-test-chatstates-muc-send-preserves-remote-composers () "Local MUC send preserves remote composers and their typing node." (let ((deleted nil)) (with-temp-buffer (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatstates--muc-composers '("alice")) (setq-local jabber-chatstates--ewoc-node 'node) (cl-letf (((symbol-function 'jabber-chat-ewoc-delete) (lambda (node) (setq deleted node)))) (jabber-chatstates-when-sending "hello" "id-1") (should-not deleted) (should (equal jabber-chatstates--muc-composers '("alice"))) (should (eq jabber-chatstates--ewoc-node 'node)))))) (ert-deftest jabber-test-chatstates-clear-typing-forgets-stale-node () "Clearing a stale typing node forgets it without deleting again." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (node (ewoc-enter-last jabber-chat-ewoc '(:typing "alice is typing...")))) (ewoc-delete jabber-chat-ewoc node) (setq-local jabber-chatstates--ewoc-node node) (should-not (jabber-chatstates--live-ewoc-node-p node)) (jabber-chatstates--clear-typing) (should-not jabber-chatstates--ewoc-node)))) (ert-deftest jabber-test-chatstates-live-node-error-is-reported () "EWOC lookup errors are reported and treated as stale nodes." (let (logged) (cl-letf (((symbol-function 'ewoc-location) (lambda (_node) (error "bad node"))) ((symbol-function 'message) (lambda (format-string &rest args) (setq logged (apply #'format format-string args))))) (should-not (jabber-chatstates--live-ewoc-node-p 'bad-node))) (should (string-match-p "stale chat state ewoc node: bad node" logged)))) (ert-deftest jabber-test-chatstates-direct-send-forgets-stale-typing-node () "Local direct-chat send ignores stale typing nodes." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (node (ewoc-enter-last jabber-chat-ewoc '(:typing "alice is typing...")))) (ewoc-delete jabber-chat-ewoc node) (setq-local jabber-chatstates-confirm t) (setq-local jabber-chatstates--ewoc-node node) (jabber-chatstates-when-sending "hello" "id-1") (should-not jabber-chatstates--ewoc-node)))) (ert-deftest jabber-test-chatstates-muc-reinsert-after-stale-node () "A stale MUC typing node does not block bottom reinsertion." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (node (ewoc-enter-last jabber-chat-ewoc '(:typing "alice is typing...")))) (ewoc-delete jabber-chat-ewoc node) (ewoc-enter-last jabber-chat-ewoc '(:muc-message "alice: hello")) (setq-local jabber-chatstates--muc-composers '("bob")) (setq-local jabber-chatstates--ewoc-node node) (jabber-chatstates--update-muc-ewoc) (should (equal (jabber-test-chatstates--ewoc-data) '((:muc-message "alice: hello") (:typing "bob is typing...")))) (should-not (eq jabber-chatstates--ewoc-node node))))) (ert-deftest jabber-test-chatstates-muc-ewoc-update-reinserts-node () "Updating existing MUC typing text reinserts the node at bottom." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (first (ewoc-enter-last jabber-chat-ewoc '(:muc-notice "joined"))) (old-node (ewoc-enter-last jabber-chat-ewoc '(:typing "alice is typing...")))) (setq-local jabber-chatstates--muc-composers '("alice" "bob")) (setq-local jabber-chatstates--ewoc-node old-node) (jabber-chatstates--update-muc-ewoc) (should (equal (ewoc-data first) '(:muc-notice "joined"))) (should-not (eq jabber-chatstates--ewoc-node old-node)) (should (equal (jabber-test-chatstates--ewoc-data) '((:muc-notice "joined") (:typing "alice, bob are typing..."))))))) (ert-deftest jabber-test-chatstates-muc-clear-nick-deletes-typing-node () "Clearing the last MUC composer deletes the typing node." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (node (ewoc-enter-last jabber-chat-ewoc '(:typing "alice is typing...")))) (setq-local jabber-chatstates--muc-composers '("alice")) (setq-local jabber-chatstates--ewoc-node node) (jabber-chatstates--muc-clear-nick "alice") (should-not jabber-chatstates--muc-composers) (should-not jabber-chatstates--ewoc-node) (should-not (jabber-test-chatstates--ewoc-data))))) (ert-deftest jabber-test-chatstates-muc-clear-nick-reinserts-typing-node () "Clearing one MUC composer reinserts the node for remaining composers." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (old-node (ewoc-enter-last jabber-chat-ewoc '(:typing "alice, bob are typing...")))) (setq-local jabber-chatstates--muc-composers '("alice" "bob")) (setq-local jabber-chatstates--ewoc-node old-node) (jabber-chatstates--muc-clear-nick "alice") (should (equal jabber-chatstates--muc-composers '("bob"))) (should-not (eq jabber-chatstates--ewoc-node old-node)) (should (equal (jabber-test-chatstates--ewoc-data) '((:typing "bob is typing..."))))))) (ert-deftest jabber-test-chatstates-groupchat-message-keeps-typing-at-bottom () "Plain groupchat message cleanup moves remaining typing below the message." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (old-node (ewoc-enter-last jabber-chat-ewoc '(:typing "alice, bob are typing...")))) (setq-local jabber-chatstates--muc-composers '("alice" "bob")) (setq-local jabber-chatstates--ewoc-node old-node) (ewoc-enter-last jabber-chat-ewoc '(:muc-message "alice: hello")) (let ((muc-buffer (current-buffer))) (cl-letf (((symbol-function 'jabber-buffer-registry-find) (lambda (_kind _group) muc-buffer)) ((symbol-function 'jabber-muc-nickname) #'ignore)) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--plain-message "room@conference.example/alice" "groupchat")))) (should (equal jabber-chatstates--muc-composers '("bob"))) (should (equal (jabber-test-chatstates--ewoc-data) '((:muc-message "alice: hello") (:typing "bob is typing..."))))))) (ert-deftest jabber-test-chatstates-muc-leave-cleanup-keeps-typing-at-bottom () "Leave cleanup can remove, print notice, and reinsert typing at bottom." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (old-node (ewoc-enter-last jabber-chat-ewoc '(:typing "alice, bob are typing...")))) (setq-local jabber-chatstates--muc-composers '("alice" "bob")) (setq-local jabber-chatstates--ewoc-node old-node) (jabber-chatstates--muc-remove-nick "alice") (jabber-chatstates--delete-typing-node) (ewoc-enter-last jabber-chat-ewoc '(:muc-notice "alice has left")) (jabber-chatstates--muc-reinsert-typing) (should (equal jabber-chatstates--muc-composers '("bob"))) (should (equal (jabber-test-chatstates--ewoc-data) '((:muc-notice "alice has left") (:typing "bob is typing..."))))))) ;;; Group 4: Incoming MUC routing (ert-deftest jabber-test-chatstates-direct-thread-routes-exclusively () "A direct threaded state updates and enables only its thread buffer." (let ((parent (generate-new-buffer " *jabber-chatstate-parent*")) (thread (generate-new-buffer " *jabber-chatstate-thread*"))) (unwind-protect (progn (with-current-buffer parent (setq-local jabber-chatting-with "alice@example.org") (setq-local jabber-message-thread-session-id "thread-1") (setq-local jabber-chat-ewoc (ewoc-create #'ignore))) (with-current-buffer thread (setq-local jabber-chatting-with "alice@example.org") (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-chat-ewoc (ewoc-create #'ignore))) (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (_from _jc) (buffer-name parent))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.org")) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (_account _peer _type _thread-id) thread))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--thread-message "alice@example.org/resource" "chat" 'composing "thread-1"))) (with-current-buffer parent (should-not (jabber-test-chatstates--ewoc-data)) (should-not (memq #'jabber-chatstates-after-change post-command-hook))) (with-current-buffer thread (should (eq jabber-chatstates-last-state 'composing)) (should (equal (jabber-test-chatstates--ewoc-data) '((:typing "alice@example.org is typing...")))) (should (memq #'jabber-chatstates-after-change post-command-hook)) (should (memq #'jabber-chatstates-send-gone kill-buffer-hook)))) (dolist (buffer (list parent thread)) (when (buffer-live-p buffer) (with-current-buffer buffer (remove-hook 'kill-buffer-hook #'jabber-chatstates-send-gone t)) (kill-buffer buffer)))))) (ert-deftest jabber-test-chatstates-parent-gone-retires-session-thread () "Incoming gone forces the parent chat to use a new session thread." (with-temp-buffer (rename-buffer " *jabber-parent-gone-chatstate*" t) (let ((parent (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore)) stored) (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chatting-with "alice@example.org") (setq-local jabber-message-thread-session-id "session-old") (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (_from _jc) (buffer-name parent))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.org")) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) nil)) ((symbol-function 'jabber-message-thread--generate-id) (lambda () "session-new")) ((symbol-function 'jabber-db-set-chat-thread) (lambda (&rest args) (push args stored)))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--thread-message "alice@example.org/resource" "chat" 'gone "session-old")) (should-not jabber-message-thread-session-id) (should (equal (jabber-chat--session-send-hook "reply" "message-1") '((thread nil "session-new"))))) (should (equal (reverse stored) '(("me@example.org" "alice@example.org" nil) ("me@example.org" "alice@example.org" "session-new")))) (remove-hook 'kill-buffer-hook #'jabber-chatstates-send-gone t)))) (ert-deftest jabber-test-chatstates-disabled-thread-routes-to-parent () "A state-only threaded stanza uses the parent when buffers are disabled." (let ((parent (generate-new-buffer " *jabber-disabled-state-parent*")) (stale-thread (generate-new-buffer " *jabber-disabled-state-thread*")) (jabber-message-thread-use-buffers nil)) (unwind-protect (progn (with-current-buffer parent (setq-local jabber-chatting-with "alice@example.org") (setq-local jabber-chat-ewoc (ewoc-create #'ignore))) (with-current-buffer stale-thread (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-chat-ewoc (ewoc-create #'ignore))) (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (&rest _) (buffer-name parent))) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) (ert-fail "Looked up a stale thread buffer")))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--thread-message "alice@example.org/resource" "chat" 'composing "thread-1"))) (with-current-buffer parent (should (eq jabber-chatstates-last-state 'composing)) (should (equal (jabber-test-chatstates--ewoc-data) '((:typing "alice@example.org is typing..."))))) (with-current-buffer stale-thread (should-not jabber-chatstates-last-state) (should-not (jabber-test-chatstates--ewoc-data)))) (dolist (buffer (list parent stale-thread)) (when (buffer-live-p buffer) (with-current-buffer buffer (remove-hook 'kill-buffer-hook #'jabber-chatstates-send-gone t)) (kill-buffer buffer)))))) (ert-deftest jabber-test-chatstates-direct-thread-gone-renews-thread-id () "Incoming gone retires the direct thread ID before further typing." (let ((parent (generate-new-buffer " *jabber-gone-parent*")) (thread (generate-new-buffer " *jabber-gone-thread*")) (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) content-elements sent) (unwind-protect (progn (with-current-buffer parent (setq-local jabber-chatting-with "alice@example.org")) (with-current-buffer thread (setq-local jabber-chatting-with "alice@example.org") (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-thread-type "chat") (setq-local jabber-message-thread-peer "alice@example.org") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chat-ewoc (ewoc-create #'ignore)) (setq-local jabber-point-insert (point-min)) (jabber-buffer-registry-register 'thread '("me@example.org" "alice@example.org" "chat" "thread-1"))) (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (_from _jc) (buffer-name parent))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.org")) ((symbol-function 'jabber-message-thread--generate-id) (lambda () "thread-2")) ((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc stanza) (setq sent stanza)))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--thread-message "alice@example.org/resource" "chat" 'gone "thread-1")) (with-current-buffer thread (should (equal jabber-message-thread-id "thread-2")) (should (equal jabber-message-thread-parent-id "thread-1")) (goto-char (point-max)) (insert "reply") (jabber-chatstates-after-change) (setq content-elements (append (jabber-message-thread--send-hook "reply" "message-1") (jabber-chatstates-when-sending "reply" "message-1"))))) (should (equal sent `(message ((to . "alice@example.org") (type . "chat")) (thread ((parent . "thread-1")) "thread-2") (composing ((xmlns . ,jabber-chatstates-xmlns)))))) (should (equal content-elements `((thread ((parent . "thread-1")) "thread-2") (active ((xmlns . ,jabber-chatstates-xmlns)))))) (should-not (jabber-message-thread-find-buffer "me@example.org" "alice@example.org" "chat" "thread-1")) (should (eq (jabber-message-thread-find-buffer "me@example.org" "alice@example.org" "chat" "thread-2") thread))) (when (buffer-live-p thread) (with-current-buffer thread (remove-hook 'kill-buffer-hook #'jabber-chatstates-send-gone t))) (dolist (buffer (list parent thread)) (when (buffer-live-p buffer) (kill-buffer buffer)))))) (ert-deftest jabber-test-chatstates-direct-state-without-type-still-routes () "A direct state without a type attribute keeps legacy routing." (with-temp-buffer (let ((parent (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore))) (setq-local jabber-chatting-with "alice@example.org") (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (_from _jc) (buffer-name parent)))) (jabber-handle-incoming-message-chatstates 'fake-jc `(message ((from . "alice@example.org/resource")) (composing ((xmlns . ,jabber-chatstates-xmlns)))))) (should (eq jabber-chatstates-last-state 'composing)) (should (memq #'jabber-chatstates-after-change post-command-hook)) (remove-hook 'kill-buffer-hook #'jabber-chatstates-send-gone t)))) (ert-deftest jabber-test-chatstates-threaded-error-disables-owner-only () "A threaded error disables its chat or groupchat owner, not its parent." (dolist (owner-type '("chat" "groupchat")) (let ((parent (generate-new-buffer " *jabber-error-parent*")) (thread (generate-new-buffer " *jabber-error-thread*"))) (unwind-protect (progn (dolist (buffer (list parent thread)) (with-current-buffer buffer (setq-local 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))) (with-current-buffer thread (setq-local jabber-message-thread-id "thread-1")) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.org")) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (_account _peer type _thread-id) (and (equal type owner-type) thread)))) (jabber-handle-incoming-message-chatstates 'fake-jc `(message ((from . "peer@example.org/resource") (type . "error")) (thread () "thread-1") (error ((type . "cancel")))))) (with-current-buffer parent (should jabber-chatstates-requested) (should (memq #'jabber-chatstates-after-change post-command-hook))) (with-current-buffer thread (should-not jabber-chatstates-requested) (should-not (memq #'jabber-chatstates-after-change post-command-hook)) (should-not (memq #'jabber-chatstates-send-gone kill-buffer-hook)))) (dolist (buffer (list parent thread)) (when (buffer-live-p buffer) (with-current-buffer buffer (remove-hook 'kill-buffer-hook #'jabber-chatstates-send-gone t)) (kill-buffer buffer))))))) (ert-deftest jabber-test-chatstates-muc-thread-routes-exclusively () "A MUC threaded state updates and enables only its thread buffer." (let ((parent (generate-new-buffer " *jabber-muc-chatstate-parent*")) (thread (generate-new-buffer " *jabber-muc-chatstate-thread*"))) (unwind-protect (progn (with-current-buffer parent (setq-local jabber-group "room@conference.example") (setq-local jabber-chat-ewoc (ewoc-create #'ignore))) (with-current-buffer thread (setq-local jabber-group "room@conference.example") (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-chat-ewoc (ewoc-create #'ignore))) (cl-letf (((symbol-function 'jabber-buffer-registry-find) (lambda (_kind _key) parent)) ((symbol-function 'jabber-muc-find-buffer) (lambda (_group _jc) parent)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.org")) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (_account _peer _type _thread-id) thread)) ((symbol-function 'jabber-muc-nickname) #'ignore)) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--thread-message "room@conference.example/alice" "groupchat" 'composing "thread-1"))) (with-current-buffer parent (should-not jabber-chatstates--muc-composers) (should-not (jabber-test-chatstates--ewoc-data))) (with-current-buffer thread (should (equal jabber-chatstates--muc-composers '("alice"))) (should (equal (jabber-test-chatstates--ewoc-data) '((:typing "alice is typing...")))) (should (memq #'jabber-chatstates-after-change post-command-hook)) (should-not (memq #'jabber-chatstates-send-gone kill-buffer-hook)))) (dolist (buffer (list parent thread)) (when (buffer-live-p buffer) (kill-buffer buffer)))))) (ert-deftest jabber-test-chatstates-muc-thread-ignores-gone () "A MUC gone state does not change thread composer or send state." (with-temp-buffer (let ((thread (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore))) (setq-local jabber-group "room@conference.example") (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-chatstates--muc-composers '("alice")) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.org")) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) thread)) ((symbol-function 'jabber-muc-nickname) #'ignore)) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--thread-message "room@conference.example/alice" "groupchat" 'gone "thread-1"))) (should (equal jabber-chatstates--muc-composers '("alice"))) (should-not (memq #'jabber-chatstates-after-change post-command-hook))))) (ert-deftest jabber-test-chatstates-muc-ignores-state-without-nick () "A MUC state from the bare room JID does not add a composer." (with-temp-buffer (let ((muc-buffer (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore))) (setq-local jabber-group "room@conference.example") (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (_group _jc) muc-buffer)) ((symbol-function 'jabber-muc-nickname) #'ignore)) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--message "room@conference.example" "groupchat" 'composing))) (should-not jabber-chatstates--muc-composers) (should-not (jabber-test-chatstates--ewoc-data))))) (ert-deftest jabber-test-chatstates-session-thread-state-routes-to-parent () "A state for the direct chat session updates its parent buffer." (with-temp-buffer (rename-buffer " *jabber-session-thread-chatstate*" t) (let ((parent (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore))) (setq-local jabber-chatting-with "alice@example.org") (setq-local jabber-message-thread-session-id "session-42") (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (_from _jc) (buffer-name parent))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.org")) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) nil))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--thread-message "alice@example.org/resource" "chat" 'composing "session-42"))) (should (eq jabber-chatstates-last-state 'composing)) (should (equal (jabber-test-chatstates--ewoc-data) '((:typing "alice@example.org is typing..."))))))) (ert-deftest jabber-test-chatstates-unknown-thread-state-stays-out-of-parent () "A state-only unknown thread does not update the parent buffer." (with-temp-buffer (rename-buffer " *jabber-unknown-thread-chatstate*" t) (let ((parent (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore))) (setq-local jabber-chatting-with "alice@example.org") (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (_from _jc) (buffer-name parent))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.org")) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) nil))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--thread-message "alice@example.org/resource" "chat" 'composing "unknown"))) (should-not jabber-chatstates-last-state) (should-not (jabber-test-chatstates--ewoc-data))))) (ert-deftest jabber-test-chatstates-thread-body-clears-thread-state () "A threaded body message clears composing in its displayed thread." (let ((parent (generate-new-buffer " *jabber-body-parent*")) (thread (generate-new-buffer " *jabber-body-thread*"))) (unwind-protect (progn (with-current-buffer thread (setq-local jabber-chatting-with "alice@example.org") (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-chatstates-last-state 'composing) (setq-local jabber-chat-ewoc (ewoc-create #'ignore)) (setq-local jabber-chatstates--ewoc-node (ewoc-enter-last jabber-chat-ewoc '(:typing "alice@example.org is typing...")))) (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (_from _jc) (buffer-name parent))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.org")) ((symbol-function 'jabber-message-thread-display-target) (lambda (&rest _) thread))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--thread-body-message "alice@example.org/resource" "chat" "thread-1"))) (with-current-buffer thread (should-not jabber-chatstates-last-state) (should-not jabber-chatstates--ewoc-node) (should-not (jabber-test-chatstates--ewoc-data)))) (kill-buffer parent) (kill-buffer thread)))) (ert-deftest jabber-test-chatstates-groupchat-composing-routes-to-muc-buffer () "Incoming groupchat composing updates the room buffer by bare JID." (let ((entered nil) (seen-context nil)) (with-temp-buffer (let ((muc-buffer (current-buffer))) (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (group jc) (setq seen-context (list group jc)) muc-buffer)) ((symbol-function 'jabber-muc-nickname) #'ignore) ((symbol-function 'jabber-chat-ewoc-enter) (lambda (data) (setq entered data) 'node))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--message "room@conference.example/alice" "groupchat" 'composing)) (should (equal seen-context '("room@conference.example" fake-jc))) (should (equal jabber-chatstates--muc-composers '("alice"))) (should (equal entered '(:typing "alice is typing...")))))))) (ert-deftest jabber-test-chatstates-groupchat-active-removes-from-muc-buffer () "Incoming groupchat active removes the occupant from the room buffer." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (node (ewoc-enter-last jabber-chat-ewoc '(:typing "alice is typing...")))) (setq-local jabber-chatstates--muc-composers '("alice")) (setq-local jabber-chatstates--ewoc-node node) (let ((muc-buffer (current-buffer))) (cl-letf (((symbol-function 'jabber-buffer-registry-find) (lambda (_kind _group) muc-buffer)) ((symbol-function 'jabber-muc-nickname) #'ignore)) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--message "room@conference.example/alice" "groupchat" 'active)) (should-not jabber-chatstates--muc-composers) (should-not jabber-chatstates--ewoc-node) (should-not (jabber-test-chatstates--ewoc-data))))))) (ert-deftest jabber-test-chatstates-groupchat-message-clears-composing () "Incoming groupchat message without chatstate clears occupant typing." (with-temp-buffer (let ((muc-buffer (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore))) (cl-letf (((symbol-function 'jabber-buffer-registry-find) (lambda (_kind _group) muc-buffer)) ((symbol-function 'jabber-muc-nickname) #'ignore)) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--message "room@conference.example/alice" "groupchat" 'composing)) (should (equal jabber-chatstates--muc-composers '("alice"))) (should (equal (jabber-test-chatstates--ewoc-data) '((:typing "alice is typing...")))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--plain-message "room@conference.example/alice" "groupchat")) (should-not jabber-chatstates--muc-composers) (should-not jabber-chatstates--ewoc-node) (should-not (jabber-test-chatstates--ewoc-data)))))) (ert-deftest jabber-test-chatstates-groupchat-reaction-preserves-composing () "Incoming groupchat reaction-only stanza does not clear occupant typing." (with-temp-buffer (let ((muc-buffer (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore))) (cl-letf (((symbol-function 'jabber-buffer-registry-find) (lambda (_kind _group) muc-buffer)) ((symbol-function 'jabber-muc-nickname) #'ignore)) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--message "room@conference.example/alice" "groupchat" 'composing)) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--reaction-message "room@conference.example/alice" "groupchat")) (should (equal jabber-chatstates--muc-composers '("alice"))) (should (equal (jabber-test-chatstates--ewoc-data) '((:typing "alice is typing...")))))))) (ert-deftest jabber-test-chatstates-groupchat-reaction-fallback-preserves-composing () "Incoming groupchat reaction fallback body does not clear occupant typing." (with-temp-buffer (let ((muc-buffer (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore))) (cl-letf (((symbol-function 'jabber-buffer-registry-find) (lambda (_kind _group) muc-buffer)) ((symbol-function 'jabber-muc-nickname) #'ignore)) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--message "room@conference.example/alice" "groupchat" 'composing)) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--reaction-fallback-message "room@conference.example/alice" "groupchat")) (should (equal jabber-chatstates--muc-composers '("alice"))) (should (equal (jabber-test-chatstates--ewoc-data) '((:typing "alice is typing...")))))))) (ert-deftest jabber-test-chatstates-groupchat-self-nick-is-ignored () "Incoming groupchat state from our nick refreshes without mutating composers." (let ((find-called nil) (entered nil)) (with-temp-buffer (cl-letf (((symbol-function 'jabber-buffer-registry-find) (lambda (_kind _group) (setq find-called t) (current-buffer))) ((symbol-function 'jabber-muc-nickname) (lambda (_group _jc) "alice")) ((symbol-function 'jabber-chat-ewoc-enter) (lambda (data) (setq entered data) 'node))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--message "room@conference.example/alice" "groupchat" 'composing)) (should find-called) (should-not jabber-chatstates--muc-composers) (should-not entered))))) (ert-deftest jabber-test-chatstates-self-groupchat-message-keeps-typing-at-bottom () "Self groupchat echo refreshes remote typing below the echoed message." (with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create #'ignore)) (old-node (ewoc-enter-last jabber-chat-ewoc '(:typing "bob is typing...")))) (setq-local jabber-chatstates--muc-composers '("bob")) (setq-local jabber-chatstates--ewoc-node old-node) (ewoc-enter-last jabber-chat-ewoc '(:muc-message "alice: hello")) (let ((muc-buffer (current-buffer))) (cl-letf (((symbol-function 'jabber-buffer-registry-find) (lambda (_kind _group) muc-buffer)) ((symbol-function 'jabber-muc-nickname) (lambda (_group _jc) "alice"))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--plain-message "room@conference.example/alice" "groupchat")))) (should (equal jabber-chatstates--muc-composers '("bob"))) (should-not (eq jabber-chatstates--ewoc-node old-node)) (should (equal (jabber-test-chatstates--ewoc-data) '((:muc-message "alice: hello") (:typing "bob is typing..."))))))) (ert-deftest jabber-test-chatstates-direct-chat-keeps-direct-routing () "Incoming direct chat states keep using the direct chat buffer lookup." (let ((direct-called nil) (muc-called nil) (entered nil)) (with-temp-buffer (rename-buffer " *jabber-direct-chatstates-test*" t) (setq-local jabber-chatting-with "alice@example.org/resource") (let ((chat-buffer (current-buffer))) (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (from jc) (setq direct-called (list from jc)) (buffer-name chat-buffer))) ((symbol-function 'jabber-buffer-registry-find) (lambda (_kind _group) (setq muc-called t) nil)) ((symbol-function 'jabber-chat-ewoc-enter) (lambda (data) (setq entered data) 'node))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--message "alice@example.org/resource" "chat" 'composing)) (should (equal direct-called '("alice@example.org/resource" fake-jc))) (should-not muc-called) (should (eq jabber-chatstates-last-state 'composing)) (should (equal entered '(:typing "alice@example.org is typing...")))))))) (ert-deftest jabber-test-chatstates-direct-reaction-fallback-preserves-composing () "Incoming direct reaction fallback body does not clear peer typing." (with-temp-buffer (rename-buffer " *jabber-direct-chatstates-reaction-fallback-test*" t) (let ((chat-buffer (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore))) (setq-local jabber-chatting-with "alice@example.org/resource") (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (_from _jc) (buffer-name chat-buffer)))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--message "alice@example.org/resource" "chat" 'composing)) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--reaction-fallback-message "alice@example.org/resource" "chat")) (should (eq jabber-chatstates-last-state 'composing)) (should (equal (jabber-test-chatstates--ewoc-data) '((:typing "alice@example.org is typing...")))))))) (ert-deftest jabber-test-chatstates-direct-message-clears-composing () "Incoming direct message without chatstate clears peer typing." (with-temp-buffer (rename-buffer " *jabber-direct-chatstates-message-clears-test*" t) (let ((chat-buffer (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore))) (setq-local jabber-chatting-with "alice@example.org/resource") (setq-local jabber-chatstates-requested t) (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (_from _jc) (buffer-name chat-buffer)))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--message "alice@example.org/resource" "chat" 'composing)) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--plain-message "alice@example.org/resource" "chat")) (should-not jabber-chatstates-last-state) (should-not jabber-chatstates-requested) (should-not jabber-chatstates--ewoc-node) (should-not (jabber-test-chatstates--ewoc-data)))))) (ert-deftest jabber-test-chatstates-direct-message-removes-send-hooks () "A direct body reply without chatstate removes local send hooks." (with-temp-buffer (rename-buffer " *jabber-direct-chatstates-hook-opt-out-test*" t) (let ((chat-buffer (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore))) (setq-local 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) (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (_from _jc) (buffer-name chat-buffer)))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--plain-message "alice@example.org/resource" "chat")) (should-not jabber-chatstates-requested) (should-not (memq #'jabber-chatstates-after-change post-command-hook)) (should-not (memq #'jabber-chatstates-send-gone kill-buffer-hook)))))) (ert-deftest jabber-test-chatstates-direct-active-forgets-stale-node () "Incoming direct active clears a stale typing node without error." (with-temp-buffer (rename-buffer " *jabber-direct-chatstates-active-stale-test*" t) (let* ((chat-buffer (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore)) (node (ewoc-enter-last jabber-chat-ewoc '(:typing "alice is typing...")))) (ewoc-delete jabber-chat-ewoc node) (setq-local jabber-chatstates--ewoc-node node) (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (_from _jc) (buffer-name chat-buffer)))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--message "alice@example.org/resource" "chat" 'active)) (should-not jabber-chatstates--ewoc-node) (should-not (jabber-test-chatstates--ewoc-data)))))) (ert-deftest jabber-test-chatstates-direct-composing-replaces-stale-node () "Incoming direct composing inserts a fresh node after stale node cleanup." (with-temp-buffer (rename-buffer " *jabber-direct-chatstates-composing-stale-test*" t) (let* ((chat-buffer (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore)) (node (ewoc-enter-last jabber-chat-ewoc '(:typing "alice is typing...")))) (ewoc-delete jabber-chat-ewoc node) (setq-local jabber-chatting-with "alice@example.org/resource") (setq-local jabber-chatstates--ewoc-node node) (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (_from _jc) (buffer-name chat-buffer)))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--message "alice@example.org/resource" "chat" 'composing)) (should jabber-chatstates--ewoc-node) (should-not (eq jabber-chatstates--ewoc-node node)) (should (equal (jabber-test-chatstates--ewoc-data) '((:typing "alice@example.org is typing...")))))))) (ert-deftest jabber-test-chatstates-direct-composing-keeps-live-node () "Repeated incoming direct composing preserves the live typing node." (with-temp-buffer (rename-buffer " *jabber-direct-chatstates-composing-live-test*" t) (let ((chat-buffer (current-buffer)) (jabber-chat-ewoc (ewoc-create #'ignore))) (setq-local jabber-chatting-with "alice@example.org/resource") (cl-letf (((symbol-function 'jabber-chat-get-buffer) (lambda (_from _jc) (buffer-name chat-buffer)))) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--message "alice@example.org/resource" "chat" 'composing)) (let ((node jabber-chatstates--ewoc-node)) (jabber-handle-incoming-message-chatstates 'fake-jc (jabber-test-chatstates--message "alice@example.org/resource" "chat" 'composing)) (should (eq jabber-chatstates--ewoc-node node)) (should (equal (jabber-test-chatstates--ewoc-data) '((:typing "alice@example.org is typing..."))))))))) (provide 'jabber-test-chatstates) ;;; jabber-test-chatstates.el ends here emacs-jabber-0.13.1/tests/jabber-test-conn.el000066400000000000000000000566061523531702000207430ustar00rootroot00000000000000;;; jabber-test-conn.el --- Tests for jabber-conn -*- lexical-binding: t; -*- ;;; Commentary: ;; Network transport helpers. ;;; Code: (require 'ert) (require 'jabber-conn) (require 'jabber-core) (defvar jabber-account-list) (defvar jabber-default-resource) (defvar jabber-process-buffer) (defvar jabber-debug-keep-process-buffers) ;;; Proxy configuration (ert-deftest jabber-conn-test-normalize-socks5-proxy () "A complete SOCKS5 proxy plist is accepted unchanged." (let ((proxy '(:type socks5 :host "127.0.0.1" :port 9050))) (should (equal (jabber-conn--normalize-proxy proxy) proxy)))) (ert-deftest jabber-conn-test-rejects-invalid-socks5-proxy () "Invalid or unsupported proxy settings are rejected." (dolist (proxy '((:type socks4 :host "127.0.0.1" :port 9050) (:type socks5 :port 9050) (:type socks5 :host "" :port 9050) (:type socks5 :host "127.0.0.1" :port 0) (:type socks5 :host "127.0.0.1" :port 65536))) (should-error (jabber-conn--normalize-proxy proxy)))) (ert-deftest jabber-conn-test-connect-all-passes-account-proxy () "Connecting configured accounts passes their proxy setting through." (let* ((proxy '(:type socks5 :host "127.0.0.1" :port 9050)) (jabber-account-list `(("romeo@example.com" (:password . "secret") (:proxy . ,proxy)))) (jabber-default-resource "emacs") (jabber-connections nil) connect-args) (cl-letf (((symbol-function 'jabber-connect) (lambda (&rest args) (setq connect-args args)))) (jabber-connect-all) (should (equal (car (last connect-args)) proxy))))) (ert-deftest jabber-conn-test-start-constructor-keeps-old-arity () "The generated FSM constructor accepts its original arguments." (cl-letf (((symbol-function 'jabber-network-connect) #'ignore)) (let ((fsm (start-jabber-connection "romeo" "example.com" "emacs" nil "secret" nil nil 'starttls))) (should-not (plist-get (fsm-get-state-data fsm) :proxy))))) ;;; SOCKS5 protocol (ert-deftest jabber-conn-test-socks5-request-uses-domain-name () "The SOCKS5 CONNECT request sends the target hostname to the proxy." (should (equal (string-to-list (jabber-conn--socks5-request "xmpp.example" 5222)) '(5 1 0 3 12 120 109 112 112 46 101 120 97 109 112 108 101 20 102)))) (ert-deftest jabber-conn-test-socks5-request-rejects-long-hostname () "A SOCKS5 CONNECT request rejects hostnames longer than one byte." (should-error (jabber-conn--socks5-request (make-string 256 ?a) 5222))) (ert-deftest jabber-conn-test-socks5-method-parser-waits-for-full-frame () "The SOCKS5 method parser leaves a partial frame incomplete." (should (equal (jabber-conn--socks5-parse-method (unibyte-string 5)) '(:status incomplete)))) (ert-deftest jabber-conn-test-socks5-method-parser-returns-remainder () "The SOCKS5 method parser accepts no-auth and returns trailing bytes." (should (equal (jabber-conn--socks5-parse-method (concat (unibyte-string 5 0) (unibyte-string 1 2))) `(:status ok :rest ,(unibyte-string 1 2))))) (ert-deftest jabber-conn-test-socks5-method-parser-rejects-authentication () "The SOCKS5 method parser rejects methods requiring authentication." (let ((result (jabber-conn--socks5-parse-method (unibyte-string 5 2)))) (should (eq (plist-get result :status) 'error)) (should (string-match-p "authentication" (plist-get result :message))))) (ert-deftest jabber-conn-test-socks5-method-parser-rejects-version () "The SOCKS5 method parser rejects a non-SOCKS5 response." (let ((result (jabber-conn--socks5-parse-method (unibyte-string 4 0)))) (should (eq (plist-get result :status) 'error)) (should (string-match-p "version" (plist-get result :message))))) (ert-deftest jabber-conn-test-socks5-reply-parser-waits-for-full-frame () "The SOCKS5 reply parser waits for the complete variable-length frame." (dolist (bytes (list (unibyte-string 5 0 0) (unibyte-string 5 0 0 3) (concat (unibyte-string 5 0 0 3 3) "fo"))) (should (equal (jabber-conn--socks5-parse-reply bytes) '(:status incomplete))))) (ert-deftest jabber-conn-test-socks5-reply-parser-accepts-domain-frame () "The SOCKS5 reply parser accepts a domain response and returns its remainder." (let ((frame (concat (unibyte-string 5 0 0 3 3) "foo" (unibyte-string 0 80 9)))) (should (equal (jabber-conn--socks5-parse-reply frame) `(:status ok :rest ,(unibyte-string 9)))))) (ert-deftest jabber-conn-test-socks5-reply-parser-reports-standard-failures () "Every assigned SOCKS5 CONNECT failure has an explanatory error." (dolist (reply (number-sequence 1 8)) (let ((result (jabber-conn--socks5-parse-reply (unibyte-string 5 reply 0 1 127 0 0 1 0 0)))) (should (eq (plist-get result :status) 'error)) (should (> (length (plist-get result :message)) 0))))) (ert-deftest jabber-conn-test-socks5-reply-parser-rejects-malformed-header () "Malformed SOCKS5 CONNECT response headers are rejected." (dolist (bytes (list (unibyte-string 4 0 0 1 127 0 0 1 0 0) (unibyte-string 5 0 1 1 127 0 0 1 0 0) (unibyte-string 5 0 0 2 0 0))) (should (eq (plist-get (jabber-conn--socks5-parse-reply bytes) :status) 'error)))) ;;; Proxy transport (ert-deftest jabber-conn-test-network-connect-reads-proxy-from-fsm () "The network connector preserves its API and reads proxy state from FSM." (let ((proxy '(:type socks5 :host "127.0.0.1" :port 9050)) async-args) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_fsm) (list :proxy proxy))) ((symbol-function 'jabber-network-connect-async) (lambda (&rest args) (setq async-args args)))) (jabber-network-connect 'fake-fsm "example.com" nil nil) (should (equal async-args (list 'fake-fsm "example.com" nil nil proxy)))))) (ert-deftest jabber-conn-test-proxy-process-connects-in-binary () "A proxied process connects to the proxy endpoint using binary coding." (let ((proxy '(:type socks5 :host "127.0.0.1" :port 9050)) process-args) (cl-letf (((symbol-function 'make-network-process) (lambda (&rest args) (setq process-args args) 'fake-process))) (should (eq (jabber-conn--make-process "xmpp.example" 5222 nil nil "example.com" proxy) 'fake-process)) (should (equal (plist-get process-args :host) "127.0.0.1")) (should (= (plist-get process-args :service) 9050)) (should (eq (plist-get process-args :coding) 'binary)) (should-not (plist-member process-args :tls-parameters))))) (ert-deftest jabber-conn-test-direct-process-remains-unchanged () "A direct process still connects to its target using UTF-8." (let (process-args) (cl-letf (((symbol-function 'make-network-process) (lambda (&rest args) (setq process-args args) 'fake-process))) (jabber-conn--make-process "xmpp.example" 5222 nil nil "example.com" nil) (should (equal (plist-get process-args :host) "xmpp.example")) (should (= (plist-get process-args :service) 5222)) (should (eq (plist-get process-args :coding) 'utf-8)) (should-not (plist-member process-args :tls-parameters))))) (ert-deftest jabber-conn-test-proxy-negotiates-before-connected () "The FSM receives :connected only after fragmented SOCKS5 negotiation." (let ((proxy '(:type socks5 :host "127.0.0.1" :port 9050)) (jabber-process-buffer " *jabber-test-process*") (jabber-connection-timeout nil) proc sentinel filter sent fsm-event coding) (cl-letf (((symbol-function 'jabber-conn--make-process) (lambda (_host _port buffer &rest _) (setq proc (make-pipe-process :name "jabber-test-process" :buffer buffer)))) ((symbol-function 'set-process-sentinel) (lambda (_proc fn) (setq sentinel fn))) ((symbol-function 'set-process-filter) (lambda (_proc fn) (setq filter fn))) ((symbol-function 'set-process-coding-system) (lambda (_proc read write) (setq coding (list read write)))) ((symbol-function 'process-send-string) (lambda (_proc bytes) (push bytes sent))) ((symbol-function 'fsm-send) (lambda (_fsm event) (setq fsm-event event))) ((symbol-function 'fsm-send-sync) (lambda (_fsm event) (setq fsm-event event)))) (unwind-protect (progn (jabber-network-connect-async 'fake-fsm "xmpp.example" nil nil proxy) (funcall sentinel proc "open\n") (should-not fsm-event) (should (equal (car sent) (unibyte-string 5 1 0))) (funcall filter proc (unibyte-string 5)) (should-not fsm-event) (funcall filter proc (unibyte-string 0)) (should (equal (car sent) (jabber-conn--socks5-request "xmpp.example" 5222))) (funcall filter proc (unibyte-string 5 0 0 1 127)) (should-not fsm-event) (funcall filter proc (unibyte-string 0 0 1 0 0)) (should (equal fsm-event (list :connected proc nil))) (should (equal coding '(utf-8 utf-8)))) (when (process-live-p proc) (delete-process proc)) (when (buffer-live-p (process-buffer proc)) (kill-buffer (process-buffer proc))))))) (ert-deftest jabber-conn-test-proxy-timeout-cleans-negotiation () "The connection timeout remains active during SOCKS5 negotiation." (let ((proxy '(:type socks5 :host "127.0.0.1" :port 9050)) (jabber-process-buffer " *jabber-test-process*") (jabber-debug-keep-process-buffers nil) (jabber-connection-timeout 10) proc sentinel timeout-callback fsm-event) (cl-letf (((symbol-function 'jabber-conn--make-process) (lambda (_host _port buffer &rest _) (setq proc (make-pipe-process :name "jabber-test-process" :buffer buffer)))) ((symbol-function 'set-process-sentinel) (lambda (_proc fn) (setq sentinel fn))) ((symbol-function 'run-at-time) (lambda (_seconds _repeat fn) (setq timeout-callback fn) 'fake-timer)) ((symbol-function 'cancel-timer) #'ignore) ((symbol-function 'process-send-string) #'ignore) ((symbol-function 'fsm-send) (lambda (_fsm event) (setq fsm-event event)))) (jabber-network-connect-async 'fake-fsm "xmpp.example" nil nil proxy) (funcall sentinel proc "open\n") (funcall timeout-callback) (should-not (process-live-p proc)) (should-not (buffer-live-p (process-buffer proc))) (should (equal fsm-event '(:connection-failed ("Couldn't connect to xmpp.example:5222: connection timed out"))))))) (ert-deftest jabber-conn-test-proxy-attempts-have-independent-state () "A partial SOCKS5 reply from one attempt cannot affect another." (let (filters sent successes) (cl-letf (((symbol-function 'set-process-filter) (lambda (proc fn) (push (cons proc fn) filters))) ((symbol-function 'process-send-string) (lambda (proc bytes) (push (cons proc bytes) sent))) ((symbol-function 'set-process-coding-system) #'ignore)) (jabber-conn--start-socks5 'first "first.example" 5222 (lambda (proc) (push proc successes)) #'ignore) (jabber-conn--start-socks5 'second "second.example" 5222 (lambda (proc) (push proc successes)) #'ignore) (funcall (cdr (assq 'first filters)) 'first (unibyte-string 5)) (funcall (cdr (assq 'second filters)) 'second (unibyte-string 5 0)) (funcall (cdr (assq 'second filters)) 'second (unibyte-string 5 0 0 1 127 0 0 1 0 0)) (should (equal successes '(second))) (should (equal (cdr (assq 'second sent)) (jabber-conn--socks5-request "second.example" 5222)))))) (ert-deftest jabber-conn-test-proxy-filter-converts-errors-to-failure () "A negotiation error reaches the connection failure boundary." (let (filter failure) (cl-letf (((symbol-function 'set-process-filter) (lambda (_proc fn) (setq filter fn))) ((symbol-function 'set-process-coding-system) #'ignore) ((symbol-function 'process-send-string) #'ignore)) (jabber-conn--start-socks5 'fake-process (make-string 256 ?a) 5222 #'ignore (lambda (_proc message) (setq failure message))) (funcall filter 'fake-process (unibyte-string 5 0)) (should (string-match-p "longer than 255 bytes" failure))))) (ert-deftest jabber-conn-test-proxy-filter-ignores-stale-process () "A callback for another process cannot settle the current attempt." (let (filter success) (cl-letf (((symbol-function 'set-process-filter) (lambda (_proc fn) (setq filter fn))) ((symbol-function 'set-process-coding-system) #'ignore) ((symbol-function 'process-send-string) #'ignore)) (jabber-conn--start-socks5 'current "example.com" 5222 (lambda (proc) (setq success proc)) #'ignore) (funcall filter 'stale (unibyte-string 5 0)) (funcall filter 'stale (unibyte-string 5 0 0 1 127 0 0 1 0 0)) (should-not success)))) (ert-deftest jabber-conn-test-proxy-handoff-preserves-immediate-close () "A close after SOCKS success reaches the FSM sentinel." (let ((proxy '(:type socks5 :host "127.0.0.1" :port 9050)) (jabber-process-buffer " *jabber-test-process*") (jabber-connection-timeout nil) proc sentinel filter events) (cl-letf (((symbol-function 'jabber-conn--make-process) (lambda (_host _port buffer &rest _) (setq proc (make-pipe-process :name "jabber-test-process" :buffer buffer)))) ((symbol-function 'set-process-sentinel) (lambda (_proc fn) (setq sentinel fn))) ((symbol-function 'set-process-filter) (lambda (_proc fn) (setq filter fn))) ((symbol-function 'set-process-coding-system) #'ignore) ((symbol-function 'process-send-string) #'ignore) ((symbol-function 'fsm-send) (lambda (_fsm event) (push event events))) ((symbol-function 'fsm-send-sync) (lambda (_fsm event) (push event events) (setq sentinel (lambda (process status) (push (list :sentinel process status) events)))))) (unwind-protect (progn (jabber-network-connect-async 'fake-fsm "xmpp.example" nil nil proxy) (funcall sentinel proc "open\n") (funcall filter proc (unibyte-string 5 0)) (funcall filter proc (unibyte-string 5 0 0 1 127 0 0 1 0 0)) (funcall sentinel proc "closed\n") (should (equal (nreverse events) `((:connected ,proc nil) (:sentinel ,proc "closed\n"))))) (when (process-live-p proc) (delete-process proc)) (when (buffer-live-p (process-buffer proc)) (kill-buffer (process-buffer proc))))))) ;;; Connection state (defun jabber-test-conn--state-handler (state) "Return the `jabber-connection' handler for STATE." (gethash state (get 'jabber-connection :fsm-event))) (ert-deftest jabber-conn-test-ordinary-reconnect-clears-encryption () "An ordinary TCP reconnect clears encryption state from the old socket." (let* ((connection 'new-connection) (result (funcall (jabber-test-conn--state-handler :connecting) 'fake-fsm '(:encrypted t) (list :connected connection nil) #'ignore)) (state-data (cadr result))) (should (eq (car result) :connected)) (should (eq (plist-get state-data :connection) connection)) (should-not (plist-get state-data :encrypted)))) (ert-deftest jabber-conn-test-direct-tls-sets-encryption () "A direct TLS connection records that its socket is encrypted." (let* ((connection 'new-connection) (result (funcall (jabber-test-conn--state-handler :connecting) 'fake-fsm '(:encrypted nil) (list :connected connection t) #'ignore)) (state-data (cadr result))) (should (eq (car result) :connected)) (should (eq (plist-get state-data :connection) connection)) (should (eq (plist-get state-data :encrypted) t)))) (ert-deftest jabber-conn-test-reconnect-selects-starttls () "An ordinary reconnect negotiates advertised STARTTLS." (let* ((connect-result (funcall (jabber-test-conn--state-handler :connecting) 'fake-fsm '(:connection-type starttls :encrypted t) '(:connected new-connection nil) #'ignore)) (features `(features nil (starttls ((xmlns . ,jabber-tls-xmlns))))) (result (funcall (jabber-test-conn--state-handler :connected) 'fake-fsm (cadr connect-result) (list :stanza features) #'ignore))) (should (eq (car result) :starttls)))) (ert-deftest jabber-conn-test-configured-proxy-reconnects-to-starttls () "A configured proxy survives an FSM reconnect and reaches STARTTLS." (let* ((proxy '(:type socks5 :host "127.0.0.1" :port 9050)) (jabber-account-list `(("romeo@example.com" (:password . "secret") (:connection-type . starttls) (:proxy . ,proxy)))) (jabber-default-resource "emacs") (jabber-connections nil) (jabber-lost-connection-hooks nil) (jabber-process-buffer " *jabber-test-process*") (jabber-connection-timeout nil) (real-async (symbol-function 'jabber-network-connect-async)) connector-proxies proc starttls-called) (cl-letf (((symbol-function 'jabber-network-connect-async) (lambda (_fsm _server _network-server _port proxy) (push proxy connector-proxies))) ((symbol-function 'jabber-lifecycle-dispatch-session-reset) #'ignore) ((symbol-function 'jabber-lifecycle-dispatch-connection-list-changed) #'ignore) ((symbol-function 'jabber-send-stream-header) #'ignore) ((symbol-function 'jabber-starttls-initiate) (lambda (_fsm) (setq starttls-called t))) ((symbol-function 'jabber-conn--make-process) (lambda (_host _port buffer &rest _) (setq proc (make-pipe-process :name "jabber-test-process" :buffer buffer)))) ((symbol-function 'process-send-string) #'ignore)) (unwind-protect (progn (jabber-connect-all) (let ((fsm (car jabber-connections))) (should (equal (plist-get (fsm-get-state-data fsm) :proxy) proxy)) (fsm-send-sync fsm '(:connection-failed ("first attempt"))) (fsm-send-sync fsm :timeout) (should (equal connector-proxies (list proxy proxy))) (funcall real-async fsm "example.com" nil nil proxy) (funcall (process-sentinel proc) proc "open\n") (funcall (process-filter proc) proc (unibyte-string 5 0)) (funcall (process-filter proc) proc (unibyte-string 5 0 0 1 127 0 0 1 0 0)) (fsm-send-sync fsm `(:stanza (features nil (starttls ((xmlns . ,jabber-tls-xmlns)))))) (should (eq (get fsm :state) :starttls)) (should starttls-called))) (when (process-live-p proc) (delete-process proc)) (when (and proc (buffer-live-p (process-buffer proc))) (kill-buffer (process-buffer proc))))))) ;;; Failed async connection cleanup (ert-deftest jabber-conn-test-failed-target-kills-process-buffer () "A failed async connection target cleans up its process buffer." (let ((jabber-process-buffer " *jabber-test-process*") (jabber-debug-keep-process-buffers nil) (jabber-connection-timeout nil) proc sentinel fsm-event) (cl-letf (((symbol-function 'jabber-srv-targets) (lambda (&rest _) '(("example.com" 5222 nil)))) ((symbol-function 'jabber-conn--make-process) (lambda (_host _port buffer _directtls-p _server &optional _proxy) (setq proc (make-pipe-process :name "jabber-test-process" :buffer buffer)) proc)) ((symbol-function 'set-process-sentinel) (lambda (_proc fn) (setq sentinel fn))) ((symbol-function 'fsm-send) (lambda (_fsm event) (setq fsm-event event)))) (jabber-network-connect-async 'fake-fsm "example.com" nil nil) (funcall sentinel proc "failed with code 1\n") (should-not (process-live-p proc)) (should-not (buffer-live-p (process-buffer proc))) (should (equal '(:connection-failed ("Couldn't connect to example.com:5222: failed with code 1")) fsm-event))))) (ert-deftest jabber-conn-test-setup-error-kills-generated-buffer () "A setup error after buffer creation kills the generated buffer." (let ((jabber-process-buffer " *jabber-test-process*") (jabber-debug-keep-process-buffers nil) (jabber-connection-timeout nil) generated-buffer fsm-event) (cl-letf (((symbol-function 'jabber-srv-targets) (lambda (&rest _) '(("example.com" 5222 nil)))) ((symbol-function 'generate-new-buffer) (lambda (name) (setq generated-buffer (get-buffer-create name)) generated-buffer)) ((symbol-function 'jabber-conn--make-process) (lambda (&rest _) (error "setup failed"))) ((symbol-function 'fsm-send) (lambda (_fsm event) (setq fsm-event event)))) (jabber-network-connect-async 'fake-fsm "example.com" nil nil) (should-not (buffer-live-p generated-buffer)) (should (equal '(:connection-failed ("Couldn't connect to example.com:5222: setup failed")) fsm-event))))) (ert-deftest jabber-conn-test-keeps-failed-buffer-when-debugging () "Debug buffer retention preserves failed process buffers." (let ((jabber-debug-keep-process-buffers t) (buffer (generate-new-buffer " *jabber-test-process*")) proc) (unwind-protect (progn (setq proc (make-pipe-process :name "jabber-test-process" :buffer buffer)) (jabber-conn--delete-failed-process proc buffer) (should-not (process-live-p proc)) (should (buffer-live-p buffer))) (when (process-live-p proc) (delete-process proc)) (when (buffer-live-p buffer) (kill-buffer buffer))))) (provide 'jabber-test-conn) ;;; jabber-test-conn.el ends here emacs-jabber-0.13.1/tests/jabber-test-csi.el000066400000000000000000000157621523531702000205620ustar00rootroot00000000000000;;; jabber-test-csi.el --- Tests for jabber-csi -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0352 Client State Indication. ;;; Code: (require 'cl-lib) (require 'ert) (require 'jabber-csi) ;;; Test data (defconst jabber-test-csi--supported-features `(features nil (csi ((xmlns . ,jabber-csi-xmlns)))) "Stream features with CSI support.") (defconst jabber-test-csi--unsupported-features '(features nil (sm ((xmlns . "urn:xmpp:sm:3")))) "Stream features without CSI support.") (defun jabber-test-csi--state-data (features) "Return FSM state data containing FEATURES." (list :stream-features features)) (defun jabber-test-csi--last-state-table (&rest entries) "Return a CSI last-state hash table initialized with ENTRIES. ENTRIES is a flat list of connection/state pairs." (let ((table (make-hash-table :test #'eq))) (while entries (puthash (pop entries) (pop entries) table)) table)) ;;; Group 1: State detection (ert-deftest jabber-test-csi-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-test-csi-send-active-when-focused-and-supported () "Sends active element when focused and stream features advertise CSI." (let ((sent nil) (jabber-csi-enable t) (jabber-csi--last-state (jabber-test-csi--last-state-table)) (jabber-connections '(fake-jc))) (cl-letf (((symbol-function 'jabber-csi--focused-p) (lambda () t)) ((symbol-function 'fsm-get-state-data) (lambda (_jc) (jabber-test-csi--state-data jabber-test-csi--supported-features))) ((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 (gethash 'fake-jc jabber-csi--last-state) 'active))))) (ert-deftest jabber-test-csi-send-inactive-when-unfocused-and-supported () "Sends inactive element when unfocused and stream features advertise CSI." (let ((sent nil) (jabber-csi-enable t) (jabber-csi--last-state (jabber-test-csi--last-state-table)) (jabber-connections '(fake-jc))) (cl-letf (((symbol-function 'jabber-csi--focused-p) (lambda () nil)) ((symbol-function 'fsm-get-state-data) (lambda (_jc) (jabber-test-csi--state-data jabber-test-csi--supported-features))) ((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 (gethash 'fake-jc jabber-csi--last-state) 'inactive))))) (ert-deftest jabber-test-csi-send-nothing-when-unsupported () "Does not send CSI when stream features omit CSI support." (let ((sent nil) (jabber-csi-enable t) (jabber-csi--last-state (jabber-test-csi--last-state-table)) (jabber-connections '(fake-jc))) (cl-letf (((symbol-function 'jabber-csi--focused-p) (lambda () t)) ((symbol-function 'fsm-get-state-data) (lambda (_jc) (jabber-test-csi--state-data jabber-test-csi--unsupported-features))) ((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc sexp) (setq sent sexp)))) (jabber-csi--send-state) (should-not sent) (should-not (gethash 'fake-jc jabber-csi--last-state))))) (ert-deftest jabber-test-csi-no-duplicate-send-per-connection () "Does not let one connection suppress sends for another." (let ((sent nil) (jabber-csi-enable t) (jabber-csi--last-state (jabber-test-csi--last-state-table 'jc-a 'active)) (jabber-connections '(jc-a jc-b))) (cl-letf (((symbol-function 'jabber-csi--focused-p) (lambda () t)) ((symbol-function 'fsm-get-state-data) (lambda (_jc) (jabber-test-csi--state-data jabber-test-csi--supported-features))) ((symbol-function 'jabber-send-sexp-if-connected) (lambda (jc sexp) (push (cons jc sexp) sent)))) (jabber-csi--send-state) (should (= (length sent) 1)) (should (eq (caar sent) 'jc-b)) (should (eq (gethash 'jc-a jabber-csi--last-state) 'active)) (should (eq (gethash 'jc-b jabber-csi--last-state) 'active))))) (ert-deftest jabber-test-csi-disabled-sends-nothing () "Sends nothing when jabber-csi-enable is nil." (let ((sent nil) (jabber-csi-enable nil) (jabber-csi--last-state (jabber-test-csi--last-state-table)) (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-test-csi-on-connect-resets-state-for-connection () "On-connect resets last-state for the affected connection and sends current state." (let ((jabber-csi-enable t) (jabber-csi--last-state (jabber-test-csi--last-state-table 'fake-jc 'active 'other-jc 'inactive)) (jabber-csi--timer nil)) (cl-letf (((symbol-function 'jabber-csi--focused-p) (lambda () t)) ((symbol-function 'fsm-get-state-data) (lambda (_jc) (jabber-test-csi--state-data jabber-test-csi--supported-features))) ((symbol-function 'jabber-send-sexp-if-connected) #'ignore)) (jabber-csi--on-connect 'fake-jc) (should (eq (gethash 'fake-jc jabber-csi--last-state) 'active)) (should (eq (gethash 'other-jc jabber-csi--last-state) 'inactive))))) ;;; Group 3: Debounce (ert-deftest jabber-test-csi-debounce-coalesces () "Rapid focus-changed calls produce only one pending timer." (let ((jabber-csi--timer nil)) (cl-letf (((symbol-function 'jabber-csi--focused-p) (lambda () t)) ((symbol-function 'jabber-send-sexp-if-connected) #'ignore)) (jabber-csi--focus-changed) (jabber-csi--focus-changed) (jabber-csi--focus-changed) (should (timerp jabber-csi--timer)) (jabber-csi--stop-timer)))) (ert-deftest jabber-test-csi-disconnect-cleanup () "On-disconnect cancels pending timer and resets state for the connection." (let ((jabber-csi--timer (run-with-timer 10 nil #'ignore)) (jabber-csi--last-state (jabber-test-csi--last-state-table 'fake-jc 'active 'other-jc 'inactive))) (jabber-csi--on-disconnect 'fake-jc) (should-not jabber-csi--timer) (should-not (gethash 'fake-jc jabber-csi--last-state)) (should (eq (gethash 'other-jc jabber-csi--last-state) 'inactive)))) (provide 'jabber-test-csi) ;;; jabber-test-csi.el ends here emacs-jabber-0.13.1/tests/jabber-test-db.el000066400000000000000000004461651523531702000203760ustar00rootroot00000000000000;;; jabber-test-db.el --- Tests for jabber-db -*- lexical-binding: t; -*- ;;; Commentary: ;; SQLite message storage, schema, and queries. ;;; Code: (require 'ert) (require 'jabber-chat) (require 'jabber-chat-commands) (require 'jabber-db) (require 'jabber-reactions) (declare-function jabber-db-replace-reactions "jabber-db" (account peer type target-id sender reactions &optional updated-at)) ;;; Test infrastructure (defmacro jabber-test-db-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-test-db--dir (make-temp-file "jabber-db-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-test-db--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-test-db--dir) (delete-directory jabber-test-db--dir t))))) ;;; Group 1: Schema and lifecycle (ert-deftest jabber-test-db-ensure-open-creates-db () "Opening the database creates the file and returns a connection." (jabber-test-db-with-db (should (sqlitep jabber-db--connection)) (should (file-exists-p jabber-db-path)))) (ert-deftest jabber-test-db-ensure-open-idempotent () "Calling ensure-open twice returns the same connection." (jabber-test-db-with-db (let ((db1 jabber-db--connection) (db2 (jabber-db-ensure-open))) (should (eq db1 db2))))) (ert-deftest jabber-test-db-ensure-open-migrates-live-connection () "Ensure-open migrates an existing connection after a code reload." (jabber-test-db-with-db (sqlite-execute jabber-db--connection "DROP TABLE message_thread") (sqlite-execute jabber-db--connection "DROP INDEX idx_msg_thread") (sqlite-execute jabber-db--connection "ALTER TABLE message DROP COLUMN thread_parent_id") (sqlite-execute jabber-db--connection "ALTER TABLE message DROP COLUMN thread_id") (sqlite-execute jabber-db--connection "PRAGMA user_version=7") (let ((db jabber-db--connection)) (should (eq db (jabber-db-ensure-open))) (should (= jabber-db--schema-version (caar (sqlite-select db "PRAGMA user_version")))) (should (member "thread_id" (mapcar #'car (sqlite-select db "SELECT name FROM pragma_table_info('message')")))) (should (jabber-db--table-exists-p db "message_thread"))))) (ert-deftest jabber-test-db-close-and-reopen () "Closing and reopening the database works." (jabber-test-db-with-db (jabber-db-close) (should (null jabber-db--connection)) (let ((db (jabber-db-ensure-open))) (should (sqlitep db))))) (ert-deftest jabber-test-db-schema-version () "The user_version pragma matches `jabber-db--schema-version'." (jabber-test-db-with-db (should (= jabber-db--schema-version (caar (sqlite-select jabber-db--connection "PRAGMA user_version")))))) (ert-deftest jabber-test-db-wal-mode () "WAL journal mode is active." (jabber-test-db-with-db (should (string= "wal" (caar (sqlite-select jabber-db--connection "PRAGMA journal_mode")))))) (ert-deftest jabber-test-db-tables-exist () "All expected tables and indexes exist." (jabber-test-db-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 "message_thread" tables)) (should (member "chat_settings" tables))))) (ert-deftest jabber-test-db-thread-schema-has-dedicated-state () "Fresh databases distinguish dedicated threads from wire sessions." (jabber-test-db-with-db (should (member "dedicated" (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM pragma_table_info('message_thread')")))))) (ert-deftest jabber-test-db-thread-schema-has-local-title () "Fresh databases can store a local title for each thread." (jabber-test-db-with-db (should (member "title" (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM pragma_table_info('message_thread')")))))) ;;; Group 2: Store and retrieve (ert-deftest jabber-test-db-store-and-query () "Storing a message and querying it back returns matching fields." (jabber-test-db-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-test-db-store-with-stanza-id () "Storing a message with stanza-id and server-id preserves them." (jabber-test-db-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-test-db-store-unicode-body () "Unicode text in message body is preserved." (jabber-test-db-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-test-db-store-nil-body () "Storing a message with nil body succeeds." (jabber-test-db-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-test-db-store-multiline-body () "Newlines in message body are preserved." (jabber-test-db-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-test-db-backlog-plist-format () "Backlog entries are plists with :from, :body, :timestamp, :delayed, :direction, :msg-type." (jabber-test-db-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-test-db-backlog-chat-no-resource () "Chat backlog sender is bare JID when no resource is stored." (jabber-test-db-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-test-db-backlog-outgoing-format () "Outgoing backlog entries have account JID as :from." (jabber-test-db-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-test-db-backlog-ordering () "Backlog returns messages in reverse chronological order." (jabber-test-db-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-test-db-backlog-respects-count () "Backlog returns at most COUNT messages." (jabber-test-db-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-test-db-backlog-time-filter () "Backlog respects the start-time parameter." (jabber-test-db-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-test-db-backlog-msg-type-filter () "Backlog with msg-type filters by message type." (jabber-test-db-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-test-db-fts-search () "Full-text search finds messages by keyword." (jabber-test-db-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-test-db-fts-search-with-peer () "FTS search scoped to a specific peer." (jabber-test-db-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-test-db-fts-search-no-match () "FTS search returns nil when no messages match." (jabber-test-db-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-test-db-dedup-stanza-id () "Duplicate stanza_id keeps one row with body preserved and timestamp updated." (jabber-test-db-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-test-db-dedup-scoped-by-account () "Same stanza_id from different accounts are stored as separate messages." (jabber-test-db-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-test-db-no-dedup-without-stanza-id () "Messages without stanza_id are never deduped." (jabber-test-db-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-test-db-last-timestamp () "last-timestamp returns the latest timestamp for a peer." (jabber-test-db-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-test-db-account-isolation () "Messages from different accounts are isolated." (jabber-test-db-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-test-db-peer-isolation () "Messages to different peers are isolated." (jabber-test-db-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-test-db-empty-backlog () "Backlog returns nil on an empty database." (jabber-test-db-with-db (should (null (jabber-db-backlog "me@example.com" "friend@example.com"))))) (ert-deftest jabber-test-db-empty-search () "Search returns nil on an empty database." (jabber-test-db-with-db (should (null (jabber-db-search "me@example.com" "anything"))))) (ert-deftest jabber-test-db-empty-last-timestamp () "last-timestamp returns nil when no messages exist." (jabber-test-db-with-db (should (null (jabber-db-last-timestamp "me@example.com" "friend@example.com"))))) ;;; Group 8: Query pagination (ert-deftest jabber-test-db-query-pagination () "Query with limit and offset returns correct page." (jabber-test-db-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-test-db-query-time-range () "Query with start-time and end-time filters correctly." (jabber-test-db-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-test-db-persistence () "Data survives close and reopen." (jabber-test-db-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-test-db-muc-backlog-sender-has-nickname () "MUC backlog sender includes room JID and nickname as resource." (jabber-test-db-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-test-db-muc-backlog-multiple-senders () "MUC backlog preserves distinct nicknames for different senders." (jabber-test-db-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-test-db-muc-backlog-persistence () "MUC messages survive close/reopen and retain nicknames." (jabber-test-db-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-test-db-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-test-db-import-history () "Importing from flat-file history populates the database." (jabber-test-db-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-test-db-import-history-strips-resource () "Imported messages with resource JIDs are stored under the bare JID." (jabber-test-db-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-test-db-import-global-history () "Importing from a global history file works." (jabber-test-db-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-test-db-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-test-db-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-test-db-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-test-db-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-test-db-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-test-db-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-test-db-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-test-db-chat-settings-table-exists () "The chat_settings table is created by the schema." (jabber-test-db-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-test-db-chat-settings-has-thread-id () "The chat_settings table stores the current parent chat session." (jabber-test-db-with-db (should (member "thread_id" (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM pragma_table_info('chat_settings')")))))) (ert-deftest jabber-test-db-set-and-get-encryption-omemo () "Storing OMEMO encryption and reading it back returns the symbol." (jabber-test-db-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-test-db-set-and-get-encryption-plaintext () "Storing plaintext encryption and reading it back returns the symbol." (jabber-test-db-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-test-db-get-encryption-default-returns-nil () "Storing `default' encryption returns nil from get." (jabber-test-db-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-test-db-get-encryption-missing-returns-nil () "Querying encryption for an unknown peer returns nil." (jabber-test-db-with-db (should (null (jabber-db-get-chat-encryption "me@example.com" "nobody@example.com"))))) (ert-deftest jabber-test-db-set-encryption-overwrites () "Setting encryption twice overwrites the previous value." (jabber-test-db-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-test-db-chat-thread-round-trip-preserves-encryption () "Thread and encryption settings update independently." (jabber-test-db-with-db (jabber-db-set-chat-encryption "me@example.com" "alice@example.com" 'omemo) (jabber-db-set-chat-thread "me@example.com" "alice@example.com" "session-1") (should (equal "session-1" (jabber-db-get-chat-thread "me@example.com" "alice@example.com"))) (should (eq 'omemo (jabber-db-get-chat-encryption "me@example.com" "alice@example.com"))) (jabber-db-set-chat-encryption "me@example.com" "alice@example.com" 'plaintext) (should (equal "session-1" (jabber-db-get-chat-thread "me@example.com" "alice@example.com"))))) (ert-deftest jabber-test-db-chat-settings-account-isolation () "Encryption settings are isolated per account." (jabber-test-db-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-test-db-chat-settings-peer-isolation () "Encryption settings are isolated per peer." (jabber-test-db-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-test-db-chat-settings-persist-across-reopen () "Encryption settings survive close and reopen." (jabber-test-db-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-test-db-chat-settings-muc-peer () "Encryption settings work with MUC room JIDs." (jabber-test-db-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-test-db-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-test-db--make-fake-jc (account) "Create a fake connection symbol for ACCOUNT (user@server)." (let ((jc (gensym "jabber-test-db-jc-")) (parts (split-string account "@"))) (put jc :state-data (list :username (nth 0 parts) :server (nth 1 parts))) jc)) (defmacro jabber-test-db-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-test-db-with-db (let* ((jc (jabber-test-db--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-test-db-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-test-db-with-db (let* ((jc (jabber-test-db--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-test-db-chat-buffer-loads-encryption-from-db () "1:1 chat buffer loads saved encryption from DB on setup." (jabber-test-db-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-test-db-chat-buffer-falls-back-to-default () "1:1 chat buffer uses default when no DB setting exists." (jabber-test-db-with-chat-buffer "me@example.com" "bob@example.com" (should (eq 'omemo jabber-chat-encryption)))) (ert-deftest jabber-test-db-chat-buffer-default-plaintext () "1:1 chat buffer respects jabber-chat-default-encryption when set to plaintext." (jabber-test-db-with-db (let* ((jc (jabber-test-db--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-test-db-chat-buffer-db-overrides-default () "DB setting overrides jabber-chat-default-encryption." (jabber-test-db-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-test-db-muc-buffer-loads-encryption-from-db () "MUC buffer loads saved encryption from DB on setup." (jabber-test-db-with-db (let* ((jc (jabber-test-db--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-test-db-muc-buffer-falls-back-to-plaintext () "MUC buffer defaults to plaintext when no DB setting exists." (jabber-test-db-with-muc-buffer "me@example.com" "room@conference.example.com" (should (eq 'plaintext jabber-chat-encryption)))) (ert-deftest jabber-test-db-chat-buffer-without-peer-falls-back () "Buffer without jabber-chatting-with or jabber-group falls back to default." (jabber-test-db-with-db (let* ((jc (jabber-test-db--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-test-db-toggle-save-roundtrip () "Toggling encryption saves to DB and reloading a fresh buffer picks it up." (jabber-test-db-with-db (let* ((jc (jabber-test-db--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-test-db-redisplay-reloads-encryption () "jabber-chat-redisplay reloads encryption from DB." (jabber-test-db-with-db (let* ((jc (jabber-test-db--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-test-db-receipt-columns () "Message table has delivered_at and displayed_at columns." (jabber-test-db-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-test-db-update-receipt-delivered () "Update delivered_at for an outgoing message by stanza_id." (jabber-test-db-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-test-db-update-receipt-displayed () "Update displayed_at for an outgoing message by stanza_id." (jabber-test-db-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-test-db-update-receipt-no-overwrite () "Duplicate receipt does not overwrite earlier timestamp." (jabber-test-db-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-test-db-update-receipt-nil-stanza-id () "Update with nil stanza_id is a no-op." (jabber-test-db-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-test-db-update-receipt-scoped-by-peer () "Receipt update only affects matching account+peer, not other conversations." (jabber-test-db-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-test-db-update-receipt-only-outgoing () "Receipt update only affects outgoing messages, not incoming." (jabber-test-db-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-test-db-delete-peer-messages () "Deleting peer messages removes all rows for that account+peer." (jabber-test-db-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-test-db-delete-peer-messages-empty () "Deleting from a nonexistent peer is a no-op." (jabber-test-db-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-test-db-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-test-db-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-test-db-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-test-db-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)))))) (ert-deftest jabber-test-db-retract-message-in-peer-is-scoped () "Scoped retraction only updates when account, peer, and server-id match." (let ((jabber-backlog-days 3.0) (jabber-backlog-number 10) (now (floor (float-time)))) (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "room1@x.com" "in" "groupchat" "one" now nil "client-room1" "srv-room1") (jabber-db-store-message "me@x.com" "room2@x.com" "in" "groupchat" "two" now nil nil "srv-room2") (jabber-db-retract-message-in-peer "me@x.com" "room2@x.com" "srv-room1" "room2@x.com/mod" "spam") (should-not (plist-get (car (jabber-db-backlog "me@x.com" "room1@x.com")) :retracted)) (jabber-db-retract-message-in-peer "me@x.com" "room1@x.com" "client-room1" "room1@x.com/mod" "spam") (should-not (plist-get (car (jabber-db-backlog "me@x.com" "room1@x.com")) :retracted)) (jabber-db-retract-message-in-peer "me@x.com" "room1@x.com" "srv-room1" "room1@x.com/mod" "spam") (let ((room1 (car (jabber-db-backlog "me@x.com" "room1@x.com"))) (room2 (car (jabber-db-backlog "me@x.com" "room2@x.com")))) (should (plist-get room1 :retracted)) (should (equal "room1@x.com/mod" (plist-get room1 :retracted-by))) (should-not (plist-get room2 :retracted)))))) (ert-deftest jabber-test-db-retract-shared-server-id-is-room-scoped () "Retraction changes one room when two rooms share a server id." (jabber-test-db-with-db (dolist (room '("one@conference.x" "two@conference.x")) (jabber-db-store-message "me@x.com" room "in" "groupchat" room 1700000000 "alice" nil "shared-server-id")) (jabber-db-retract-message-in-peer "me@x.com" "one@conference.x" "shared-server-id" "one@conference.x/mod") (should (equal '(("one@conference.x" "one@conference.x/mod") ("two@conference.x" nil)) (sqlite-select jabber-db--connection "SELECT peer, retracted_by FROM message ORDER BY peer"))))) ;;; Group: Failed-decrypt replacement (ert-deftest jabber-test-db-store-replaces-failed-decrypt-by-stanza-id () "Re-storing a message with real text replaces a decrypt-failure placeholder." (jabber-test-db-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-test-db-store-replaces-failed-decrypt-by-server-id () "Re-storing by server-id replaces a decrypt-failure placeholder." (jabber-test-db-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-test-db-server-id-is-scoped-to-room () "Two rooms may store the same server-assigned stanza id." (jabber-test-db-with-db (dolist (room '("one@conference.x" "two@conference.x")) (jabber-db-store-message "me@x.com" room "in" "groupchat" room 1700000000 "alice" nil "shared-server-id")) (should (equal '(("one@conference.x" "one@conference.x") ("two@conference.x" "two@conference.x")) (sqlite-select jabber-db--connection "SELECT peer, body FROM message ORDER BY peer"))))) (ert-deftest jabber-test-db-server-id-placeholder-update-is-room-scoped () "A server-id retry updates only the matching room's placeholder." (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "one@conference.x" "in" "groupchat" "[OMEMO: could not decrypt]" 1700000000 "alice" nil "shared-server-id") (jabber-db-store-message "me@x.com" "two@conference.x" "in" "groupchat" "room two" 1700000000 "alice" nil "shared-server-id") (jabber-db-store-message "me@x.com" "one@conference.x" "in" "groupchat" "room one" 1700000000 "alice" nil "shared-server-id" nil nil t) (should (equal '(("one@conference.x" "room one") ("two@conference.x" "room two")) (sqlite-select jabber-db--connection "SELECT peer, body FROM message ORDER BY peer"))))) (ert-deftest jabber-test-db-store-no-replace-when-still-undecryptable () "Re-storing with another failed-decrypt body does not update." (jabber-test-db-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-test-db-store-no-replace-placeholder-across-labels () "A placeholder with a different label does not replace an existing one." (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "[OMEMO: could not decrypt]" 1700000000 "res" "stanza-7" "srv-7") (jabber-db-store-message "me@x.com" "friend@x.com" "in" "chat" "[OpenPGP: could not decrypt]" 1700000000 "res" "stanza-7" "srv-7") (let ((rows (sqlite-select (jabber-db-ensure-open) "SELECT body FROM message WHERE stanza_id = ?" '("stanza-7")))) (should (= 1 (length rows))) (should (string= "[OMEMO: could not decrypt]" (caar rows)))))) (ert-deftest jabber-test-db-store-no-replace-when-already-decrypted () "Re-storing does not overwrite an already-decrypted message." (jabber-test-db-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-test-db-store-normalizes-timestamp-on-dedup () "Re-storing a duplicate updates the timestamp to the server's value." (jabber-test-db-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-test-db-store-normalizes-timestamp-and-replaces-decrypt () "Failed-decrypt replacement also normalizes the timestamp." (jabber-test-db-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-test-db--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" "CREATE TABLE IF NOT EXISTS omemo_store ( account TEXT PRIMARY KEY, store_blob BLOB NOT NULL)") "V1 schema DDL for migration tests.") (defmacro jabber-test-db-with-v1-db (&rest body) "Run BODY with a v1 database (has raw_xml, no occupant_id)." (declare (indent 0) (debug t)) `(let* ((jabber-test-db--dir (make-temp-file "jabber-db-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-test-db--dir)) (jabber-db--connection nil)) (unwind-protect (let ((db (sqlite-open jabber-db-path))) (dolist (ddl jabber-test-db--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-test-db--dir) (delete-directory jabber-test-db--dir t))))) (defmacro jabber-test-db-with-migration-fixture (version ddl &rest body) "Create a database at VERSION from DDL, migrate it, then run BODY." (declare (indent 2) (debug t)) `(let* ((jabber-test-db--dir (make-temp-file "jabber-db-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-test-db--dir)) (jabber-db--connection nil)) (unwind-protect (progn (let ((db (sqlite-open jabber-db-path))) (dolist (statement ,ddl) (sqlite-execute db statement)) (sqlite-execute db (format "PRAGMA user_version=%d" ,version)) (sqlite-close db)) (jabber-db-ensure-open) ,@body) (jabber-db-close) (when (file-directory-p jabber-test-db--dir) (delete-directory jabber-test-db--dir t))))) (defconst jabber-test-db--v3-ddl '("CREATE TABLE message (id INTEGER PRIMARY KEY)" "CREATE TABLE omemo_store ( account TEXT PRIMARY KEY, store_blob BLOB NOT NULL)") "Minimal valid tables needed to migrate a v3 database.") (defconst jabber-test-db--v4-ddl (append jabber-test-db--v3-ddl '("CREATE TABLE caps_cache ( hash TEXT NOT NULL, ver TEXT NOT NULL, identities TEXT NOT NULL, features TEXT NOT NULL, PRIMARY KEY (hash, ver))")) "Minimal valid tables needed to migrate a v4 database.") (defconst jabber-test-db--v7-reaction-ddl '("CREATE TABLE message (id INTEGER PRIMARY KEY)" "CREATE TABLE message_reaction ( message_id INTEGER NOT NULL REFERENCES message(id) ON DELETE CASCADE, sender TEXT NOT NULL, reaction TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender, reaction))" "INSERT INTO message (id) VALUES (1)" "INSERT INTO message_reaction (message_id, sender, reaction, updated_at) VALUES (1, 'friend@example.com', '👍', 100)") "Minimal v7 reaction data used to exercise actor repair.") (ert-deftest jabber-test-db-v1-to-v2-migration () "Migrating from v1 adds occupant_id, drops raw_xml, and runs through v3." (skip-unless (fboundp 'sqlite-open)) (jabber-test-db-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-test-db-v1-migration-preserves-data () "Migrating from v1 preserves existing message data." (skip-unless (fboundp 'sqlite-open)) (jabber-test-db-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-test-db-migration-from-v3 () "A v3 database applies caps, reaction, OMEMO, and reply migrations." (jabber-test-db-with-migration-fixture 3 jabber-test-db--v3-ddl (should (= jabber-db--schema-version (caar (sqlite-select jabber-db--connection "PRAGMA user_version")))) (let ((tables (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM sqlite_master WHERE type='table'")))) (should (member "caps_cache" tables)) (should (member "message_reaction" tables)) (should (member "message_reaction_actor" tables))))) (ert-deftest jabber-test-db-migration-from-v4 () "A v4 database applies reaction, OMEMO, and reply migrations." (jabber-test-db-with-migration-fixture 4 jabber-test-db--v4-ddl (should (= jabber-db--schema-version (caar (sqlite-select jabber-db--connection "PRAGMA user_version")))) (let ((tables (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM sqlite_master WHERE type='table'")))) (should (member "message_reaction" tables)) (should (member "message_reaction_actor" tables))))) (ert-deftest jabber-test-db-v7-repairs-missing-reaction-actors () "Opening a v7 database creates and backfills missing actor metadata." (jabber-test-db-with-migration-fixture 7 jabber-test-db--v7-reaction-ddl (should (equal '("friend@example.com" 100) (car (sqlite-select jabber-db--connection "SELECT sender, updated_at FROM message_reaction_actor")))))) (ert-deftest jabber-test-db-v7-repairs-stale-reaction-actors-idempotently () "Opening a v7 database updates stale actor metadata only once." (jabber-test-db-with-migration-fixture 7 (append jabber-test-db--v7-reaction-ddl '("CREATE TABLE message_reaction_actor ( message_id INTEGER NOT NULL REFERENCES message(id) ON DELETE CASCADE, sender TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender))" "INSERT INTO message_reaction_actor (message_id, sender, updated_at) VALUES (1, 'friend@example.com', 50)")) (should (equal '(100) (car (sqlite-select jabber-db--connection "SELECT updated_at FROM message_reaction_actor")))) (jabber-db-close) (jabber-db-ensure-open) (should (equal '(1 100) (car (sqlite-select jabber-db--connection "SELECT count(*), MAX(updated_at) FROM message_reaction_actor")))))) (ert-deftest jabber-test-db-check-direction-on-fresh-db () "CHECK constraint rejects invalid direction on fresh databases." (skip-unless (fboundp 'sqlite-open)) (jabber-test-db-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-test-db-check-type-on-fresh-db () "CHECK constraint rejects invalid message type on fresh databases." (skip-unless (fboundp 'sqlite-open)) (jabber-test-db-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-test-db-occupant-id-round-trip () "Storing and retrieving occupant_id works end-to-end." (skip-unless (fboundp 'sqlite-open)) (jabber-test-db-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-test-db-occupant-id-nil-when-absent () "occupant_id is nil when not provided." (skip-unless (fboundp 'sqlite-open)) (jabber-test-db-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-test-db-server-ids-by-occupant-id () "Returns correct server-ids for an occupant-id." (jabber-test-db-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-test-db-server-ids-by-occupant-id-excludes-retracted () "Already-retracted messages are excluded." (jabber-test-db-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-test-db-server-ids-by-occupant-id-excludes-nil-server-id () "Messages without server-id are excluded." (jabber-test-db-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-test-db-server-ids-by-occupant-id-unknown () "Returns nil for an unknown occupant-id." (jabber-test-db-with-db (should (null (jabber-db-server-ids-by-occupant-id "me@x.com" "room@x.com" "nonexistent"))))) (ert-deftest jabber-test-db-occupant-id-by-server-id () "Returns occupant-id for a known server-id." (jabber-test-db-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-test-db-occupant-id-by-server-id-nil () "Returns nil for unknown server-id." (jabber-test-db-with-db (should (null (jabber-db-occupant-id-by-server-id "nonexistent"))))) (ert-deftest jabber-test-db-occupant-id-by-server-id-is-peer-scoped () "The same server id resolves to each room's own occupant." (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "one@conference.x" "in" "groupchat" "one" 1700000000 "nick" nil "shared" "occ-one") (jabber-db-store-message "me@x.com" "two@conference.x" "in" "groupchat" "two" 1700000000 "nick" nil "shared" "occ-two") (should-not (jabber-db-occupant-id-by-server-id "shared")) (should (equal "occ-one" (jabber-db-occupant-id-by-server-id-in-peer "me@x.com" "one@conference.x" "shared"))) (should (equal "occ-two" (jabber-db-occupant-id-by-server-id-in-peer "me@x.com" "two@conference.x" "shared"))))) (ert-deftest jabber-test-db-occupant-id-by-stanza-id () "Returns occupant-id for a known stanza-id." (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "hello" (floor (float-time)) "nick" "stanza-occ-1" nil "occ-stanza") (should (string= "occ-stanza" (jabber-db-occupant-id-by-stanza-id "stanza-occ-1"))))) (ert-deftest jabber-test-db-store-preserves-retraction-on-dedup () "Re-storing a retracted message does not clear retracted_by." (jabber-test-db-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-test-db-oob-table-exists () "The message_oob table and index exist in fresh databases." (jabber-test-db-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-test-db-store-single-oob () "Storing a message with one OOB entry creates a child row." (jabber-test-db-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-test-db-store-multiple-oob () "Storing a message with multiple OOB entries creates multiple child rows." (jabber-test-db-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-test-db-store-nil-oob () "Storing a message with nil OOB creates no child rows." (jabber-test-db-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-test-db-backlog-oob-entries () "Backlog returns :oob-entries with correct data." (jabber-test-db-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-test-db-backlog-oob-compat () "Backlog sets :oob-url and :oob-desc from first entry for compat." (jabber-test-db-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-test-db-backlog-no-oob () "Backlog returns nil :oob-entries for messages without OOB." (jabber-test-db-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-test-db-oob-cascade-delete () "Deleting a message cascades to message_oob rows." (jabber-test-db-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-test-db-migration-v2-to-v4 () "Migration v2->v4 applies the full chain: OOB child table, caps cache." (let* ((jabber-test-db--dir (make-temp-file "jabber-db-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-test-db--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 "\ CREATE TABLE omemo_store ( account TEXT PRIMARY KEY, store_blob BLOB NOT NULL)") (sqlite-execute db "PRAGMA user_version=2") (sqlite-close db)) ;; Open with migration. (jabber-db-ensure-open) ;; Check version is current (full chain: v2 through latest). (should (= jabber-db--schema-version (caar (sqlite-select jabber-db--connection "PRAGMA user_version")))) (let ((tables (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM sqlite_master WHERE type='table'")))) (should (member "message_reaction" tables)) (should (member "message_reaction_actor" tables))) ;; 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-test-db--dir) (delete-directory jabber-test-db--dir t))))) (ert-deftest jabber-test-db-migration-v5-to-v6 () "Migration v5->v6 adds spk_rotated_at and preserves store blobs." (let* ((jabber-test-db--dir (make-temp-file "jabber-db-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-test-db--dir)) (jabber-db--connection nil)) (unwind-protect (progn ;; Create a minimal v5 database with a store row. The ;; reaction tables satisfy the post-migration repair step; ;; the message table is needed by the v6->v7 migration. (let ((db (sqlite-open jabber-db-path))) (sqlite-execute db "\ CREATE TABLE message ( id INTEGER PRIMARY KEY, account TEXT NOT NULL, peer TEXT NOT NULL, direction TEXT NOT NULL, type TEXT, body TEXT, timestamp INTEGER NOT NULL, stanza_id TEXT)") (sqlite-execute db "\ CREATE TABLE omemo_store ( account TEXT PRIMARY KEY, store_blob BLOB NOT NULL)") (sqlite-execute db "\ INSERT INTO omemo_store (account, store_blob) VALUES ('me@x.com', x'0102')") (sqlite-execute db "\ CREATE TABLE message_reaction ( message_id INTEGER NOT NULL, sender TEXT NOT NULL, reaction TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender, reaction))") (sqlite-execute db "\ CREATE TABLE message_reaction_actor ( message_id INTEGER NOT NULL, sender TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender))") (sqlite-execute db "PRAGMA user_version=5") (sqlite-close db)) (jabber-db-ensure-open) (should (= jabber-db--schema-version (caar (sqlite-select jabber-db--connection "PRAGMA user_version")))) (let ((cols (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM pragma_table_info('omemo_store')")))) (should (member "spk_rotated_at" cols))) (should (equal "\x01\x02" (caar (sqlite-select jabber-db--connection "SELECT store_blob FROM omemo_store WHERE account = 'me@x.com'"))))) (jabber-db-close) (when (file-directory-p jabber-test-db--dir) (delete-directory jabber-test-db--dir t))))) (ert-deftest jabber-test-db-migration-v6-to-v7 () "Migration v6->v7 adds the reply metadata columns." (let* ((jabber-test-db--dir (make-temp-file "jabber-db-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-test-db--dir)) (jabber-db--connection nil)) (unwind-protect (progn (let ((db (sqlite-open jabber-db-path))) (sqlite-execute db "\ CREATE TABLE message ( id INTEGER PRIMARY KEY, account TEXT NOT NULL, peer TEXT NOT NULL, direction TEXT NOT NULL, type TEXT, body TEXT, timestamp INTEGER NOT NULL, stanza_id TEXT)") (sqlite-execute db "\ CREATE TABLE message_reaction ( message_id INTEGER NOT NULL, sender TEXT NOT NULL, reaction TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender, reaction))") (sqlite-execute db "\ CREATE TABLE message_reaction_actor ( message_id INTEGER NOT NULL, sender TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender))") (sqlite-execute db "\ CREATE TABLE omemo_store ( account TEXT PRIMARY KEY, store_blob BLOB NOT NULL, spk_rotated_at INTEGER)") (sqlite-execute db "PRAGMA user_version=6") (sqlite-close db)) (jabber-db-ensure-open) (should (= jabber-db--schema-version (caar (sqlite-select jabber-db--connection "PRAGMA user_version")))) (let ((cols (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM pragma_table_info('message')")))) (dolist (col '("reply_to_id" "reply_to_jid" "fallback_start" "fallback_end")) (should (member col cols))))) (jabber-db-close) (when (file-directory-p jabber-test-db--dir) (delete-directory jabber-test-db--dir t))))) ;; Group: Thread metadata persistence (ert-deftest jabber-test-db-migration-v7-to-v8 () "Migration v7->v8 adds thread storage without losing messages." (let* ((jabber-test-db--dir (make-temp-file "jabber-db-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-test-db--dir)) (jabber-db--connection nil)) (unwind-protect (progn (let ((db (sqlite-open jabber-db-path))) (sqlite-execute db "\ CREATE TABLE message ( id INTEGER PRIMARY KEY, account TEXT NOT NULL, peer TEXT NOT NULL, direction TEXT NOT NULL, type TEXT, body TEXT, timestamp INTEGER NOT NULL, stanza_id TEXT, server_id TEXT, reply_to_id TEXT, reply_to_jid TEXT, fallback_start INTEGER, fallback_end INTEGER)") (sqlite-execute db "\ INSERT INTO message (account, peer, direction, type, body, timestamp, stanza_id) VALUES ('me@x.com', 'alice@x.com', 'in', 'chat', 'kept', 1, 'root-1')") (sqlite-execute db "\ CREATE TABLE message_reaction ( message_id INTEGER NOT NULL, sender TEXT NOT NULL, reaction TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender, reaction))") (sqlite-execute db "\ CREATE TABLE message_reaction_actor ( message_id INTEGER NOT NULL, sender TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender))") (sqlite-execute db "PRAGMA user_version=7") (sqlite-close db)) (jabber-db-ensure-open) (should (= jabber-db--schema-version (caar (sqlite-select jabber-db--connection "PRAGMA user_version")))) (let ((cols (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM pragma_table_info('message')")))) (should (member "thread_id" cols)) (should (member "thread_parent_id" cols))) (should (jabber-db--table-exists-p jabber-db--connection "message_thread")) (should (member "read_message_id" (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM pragma_table_info('message_thread')")))) (should (member "root_message_id" (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM pragma_table_info('message_thread')")))) (should (equal "kept" (caar (sqlite-select jabber-db--connection "SELECT body FROM message"))))) (jabber-db-close) (when (file-directory-p jabber-test-db--dir) (delete-directory jabber-test-db--dir t))))) (ert-deftest jabber-test-db-migration-v7-to-v8-retries-after-failure () "A failed v8 migration rolls back and can be retried safely." (let* ((dir (make-temp-file "jabber-db-v8-retry" t)) (path (expand-file-name "test.sqlite" dir)) (db (sqlite-open path))) (unwind-protect (progn (sqlite-execute db "\ CREATE TABLE message ( id INTEGER PRIMARY KEY, account TEXT NOT NULL, peer TEXT NOT NULL, direction TEXT NOT NULL, type TEXT, body TEXT, timestamp INTEGER NOT NULL, stanza_id TEXT, server_id TEXT, reply_to_id TEXT, reply_to_jid TEXT, fallback_start INTEGER, fallback_end INTEGER)") (sqlite-execute db "\ INSERT INTO message (account, peer, direction, type, body, timestamp, stanza_id) VALUES ('me@x.com', 'alice@x.com', 'in', 'chat', 'kept', 1, 'root-1')") (sqlite-execute db "\ CREATE TABLE message_reaction ( message_id INTEGER NOT NULL, sender TEXT NOT NULL, reaction TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender, reaction))") (sqlite-execute db "\ CREATE TABLE message_reaction_actor ( message_id INTEGER NOT NULL, sender TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender))") (sqlite-execute db "PRAGMA user_version=7") (let ((sqlite-execute-real (symbol-function 'sqlite-execute)) failed) (cl-letf (((symbol-function 'sqlite-execute) (lambda (&rest args) (if (and (not failed) (string-match-p "ADD COLUMN thread_parent_id" (nth 1 args))) (progn (setq failed t) (error "Forced migration failure")) (apply sqlite-execute-real args))))) (should-error (jabber-db--migrate db)))) (should (= 7 (caar (sqlite-select db "PRAGMA user_version")))) (should-not (member "thread_id" (mapcar #'car (sqlite-select db "SELECT name FROM pragma_table_info('message')")))) (should (equal "kept" (caar (sqlite-select db "SELECT body FROM message")))) (jabber-db--migrate db) (should (= jabber-db--schema-version (caar (sqlite-select db "PRAGMA user_version")))) (dolist (column '("thread_id" "thread_parent_id")) (should (member column (mapcar #'car (sqlite-select db "SELECT name FROM pragma_table_info('message')"))))) (should (equal "kept" (caar (sqlite-select db "SELECT body FROM message"))))) (when (sqlitep db) (sqlite-close db)) (when (file-directory-p dir) (delete-directory dir t))))) (ert-deftest jabber-test-db-migration-v8-to-v9-classifies-dedicated-threads () "Migration v8->v9 preserves sessions and identifies dedicated threads." (let* ((dir (make-temp-file "jabber-db-v9" t)) (path (expand-file-name "test.sqlite" dir)) (db (sqlite-open path))) (unwind-protect (progn (sqlite-execute db "\ CREATE TABLE message ( id INTEGER PRIMARY KEY, account TEXT NOT NULL, peer TEXT NOT NULL, direction TEXT NOT NULL, type TEXT, timestamp INTEGER NOT NULL, thread_id TEXT, reply_to_id TEXT)") (sqlite-execute db "\ CREATE TABLE message_thread ( account TEXT NOT NULL, peer TEXT NOT NULL, type TEXT NOT NULL, thread_id TEXT NOT NULL, parent_thread_id TEXT, root_message_id INTEGER, root_stanza_id TEXT, root_server_id TEXT, created_at INTEGER NOT NULL, read_message_id INTEGER, PRIMARY KEY (account, peer, type, thread_id))") (sqlite-execute db "\ INSERT INTO message_thread (account, peer, type, thread_id, parent_thread_id, created_at, read_message_id) VALUES ('me@x.com', 'alice@x.com', 'chat', 'session', NULL, 1, NULL), ('me@x.com', 'alice@x.com', 'chat', 'participated', NULL, 2, NULL), ('me@x.com', 'alice@x.com', 'chat', 'child', 'parent', 3, NULL), ('me@x.com', 'alice@x.com', 'chat', 'opened', NULL, 4, 7), ('me@x.com', 'alice@x.com', 'chat', 'replied', NULL, 5, NULL), ('me@x.com', 'room@x.com', 'groupchat', 'muc', NULL, 6, NULL)") (sqlite-execute db "\ INSERT INTO message (account, peer, direction, type, timestamp, thread_id, reply_to_id) VALUES ('me@x.com', 'alice@x.com', 'out', 'chat', 2, 'participated', NULL), ('me@x.com', 'alice@x.com', 'in', 'chat', 5, 'replied', 'root-1')") (sqlite-execute db "\ CREATE TABLE message_reaction ( message_id INTEGER NOT NULL, sender TEXT NOT NULL, reaction TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender, reaction))") (sqlite-execute db "\ CREATE TABLE message_reaction_actor ( message_id INTEGER NOT NULL, sender TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender))") (sqlite-execute db "PRAGMA user_version=8") (jabber-db--migrate-v8-to-v9 db) (should (= 9 (caar (sqlite-select db "PRAGMA user_version")))) (should (equal '(("child" 1) ("muc" 1) ("opened" 1) ("participated" 1) ("replied" 0) ("session" 0)) (sqlite-select db "SELECT thread_id, dedicated FROM message_thread ORDER BY thread_id")))) (when (sqlitep db) (sqlite-close db)) (when (file-directory-p dir) (delete-directory dir t))))) (ert-deftest jabber-test-db-migration-v9-to-v10-adds-local-thread-state () "Migration v9->v10 preserves rows and adds local thread state." (let* ((dir (make-temp-file "jabber-db-v10" t)) (path (expand-file-name "test.sqlite" dir)) (db (sqlite-open path))) (unwind-protect (progn (sqlite-execute db "\ CREATE TABLE message_thread ( account TEXT NOT NULL, peer TEXT NOT NULL, type TEXT NOT NULL, thread_id TEXT NOT NULL, parent_thread_id TEXT, root_message_id INTEGER, root_stanza_id TEXT, root_server_id TEXT, created_at INTEGER NOT NULL, read_message_id INTEGER, dedicated INTEGER NOT NULL DEFAULT 0, PRIMARY KEY (account, peer, type, thread_id))") (sqlite-execute db "\ INSERT INTO message_thread (account, peer, type, thread_id, created_at, dedicated) VALUES ('me@x.com', 'alice@x.com', 'chat', 'thread-1', 1, 1)") (sqlite-execute db "\ CREATE TABLE chat_settings ( account TEXT NOT NULL, peer TEXT NOT NULL, encryption TEXT DEFAULT 'default', PRIMARY KEY (account, peer))") (sqlite-execute db "\ INSERT INTO chat_settings (account, peer, encryption) VALUES ('me@x.com', 'alice@x.com', 'omemo')") (sqlite-execute db "PRAGMA user_version=9") (jabber-db--migrate-v9-to-v10 db) (should (= 10 (caar (sqlite-select db "PRAGMA user_version")))) (should (equal '(("thread-1" nil)) (sqlite-select db "SELECT thread_id, title FROM message_thread"))) (should (equal '(("omemo" nil)) (sqlite-select db "SELECT encryption, thread_id FROM chat_settings")))) (when (sqlitep db) (sqlite-close db)) (when (file-directory-p dir) (delete-directory dir t))))) (ert-deftest jabber-test-db-migration-v9-to-v10-retries-after-failure () "Migration v9->v10 rolls back a partial change and can retry." (let* ((dir (make-temp-file "jabber-db-v10-retry" t)) (path (expand-file-name "test.sqlite" dir)) (db (sqlite-open path))) (unwind-protect (progn (sqlite-execute db "\ CREATE TABLE message_thread ( account TEXT NOT NULL, peer TEXT NOT NULL, type TEXT NOT NULL, thread_id TEXT NOT NULL, parent_thread_id TEXT, root_message_id INTEGER, root_stanza_id TEXT, root_server_id TEXT, created_at INTEGER NOT NULL, read_message_id INTEGER, dedicated INTEGER NOT NULL DEFAULT 0, PRIMARY KEY (account, peer, type, thread_id))") (sqlite-execute db "\ CREATE TABLE chat_settings ( account TEXT NOT NULL, peer TEXT NOT NULL, encryption TEXT DEFAULT 'default', PRIMARY KEY (account, peer))") (sqlite-execute db "PRAGMA user_version=9") (let ((sqlite-execute-real (symbol-function 'sqlite-execute))) (cl-letf (((symbol-function 'sqlite-execute) (lambda (connection sql &optional values) (if (equal sql "PRAGMA user_version=10") (error "Forced migration failure") (funcall sqlite-execute-real connection sql values))))) (should-error (jabber-db--migrate-v9-to-v10 db)))) (should (= 9 (caar (sqlite-select db "PRAGMA user_version")))) (should-not (member "title" (mapcar #'car (sqlite-select db "SELECT name FROM pragma_table_info('message_thread')")))) (should-not (member "thread_id" (mapcar #'car (sqlite-select db "SELECT name FROM pragma_table_info('chat_settings')")))) (jabber-db--migrate-v9-to-v10 db) (should (= 10 (caar (sqlite-select db "PRAGMA user_version")))) (should (member "title" (mapcar #'car (sqlite-select db "SELECT name FROM pragma_table_info('message_thread')")))) (should (member "thread_id" (mapcar #'car (sqlite-select db "SELECT name FROM pragma_table_info('chat_settings')"))))) (when (sqlitep db) (sqlite-close db)) (when (file-directory-p dir) (delete-directory dir t))))) (ert-deftest jabber-test-db-thread-metadata-round-trip () "Thread metadata stored with a message comes back in the backlog." (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "reply" 2 "phone" "reply-1" nil nil nil nil nil '(:thread-id "thread-1" :thread-parent-id "parent-1")) (let ((msg (car (jabber-db-thread-backlog "me@x.com" "alice@x.com" "chat" "thread-1" t)))) (should (equal "thread-1" (plist-get msg :thread-id))) (should (equal "parent-1" (plist-get msg :thread-parent-id)))))) (ert-deftest jabber-test-db-thread-backfill-uses-exact-muc-row () "Thread backfill does not touch a MUC row with a recycled client ID." (jabber-test-db-with-db (let ((now (floor (float-time)))) (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "first" now "Alice" "same-id" "server-a") (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "second" (1+ now) "Bob" "same-id" "server-b") (jabber-db-store-message "me@x.com" "room@x.com" "in" "groupchat" "second" (1+ now) "Bob" "same-id" "server-b" nil nil nil nil '(:thread-id "thread-b"))) (should (equal '(("server-a" nil) ("server-b" "thread-b")) (sqlite-select jabber-db--connection "SELECT server_id, thread_id FROM message ORDER BY server_id"))) (should (member "first" (mapcar (lambda (msg) (plist-get msg :body)) (jabber-db-backlog "me@x.com" "room@x.com" nil nil nil "groupchat")))))) (ert-deftest jabber-test-db-opened-thread-first-observed-message-is-root () "An opened remote thread keeps its first observed message as local root." (jabber-test-db-with-db (let ((now (floor (float-time)))) (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "root" now "phone" "root-1") (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "reply" (1+ now) "phone" "reply-1" nil nil nil nil '(:reply-to-id "root-1") '(:thread-id "thread-1")) (jabber-db-register-message-thread "me@x.com" "alice@x.com" "chat" "thread-1" nil "reply-1" nil (1+ now)) (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "later reply" (+ now 2) "phone" "reply-2" nil nil nil nil nil '(:thread-id "thread-1")) (should (jabber-db-message-thread-known-p "me@x.com" "alice@x.com" "chat" "thread-1")) (should (jabber-db-message-thread-root-p "me@x.com" "alice@x.com" "chat" "thread-1" "reply-1" nil (plist-get (jabber-db-message-thread-summary "me@x.com" "alice@x.com" "chat" "thread-1") :root-message-id))) (should (equal '(:thread-id "thread-1" :root t) (jabber-db-message-thread-location "me@x.com" "alice@x.com" "chat" "reply-1" nil))) (should-not (jabber-db-message-thread-root-p "me@x.com" "alice@x.com" "chat" "thread-1" "root-1" nil)) (should-not (jabber-db-message-thread-for-message "me@x.com" "alice@x.com" "chat" "reply-1" nil)) (should (equal "thread-1" (jabber-db-message-thread-for-message "me@x.com" "alice@x.com" "chat" "reply-2" nil))) (should (equal '(:thread-id "thread-1" :root nil) (jabber-db-message-thread-location "me@x.com" "alice@x.com" "chat" "reply-2" nil))) (should-not (jabber-db-message-thread-for-message "me@x.com" "alice@x.com" "chat" "root-1" nil))))) (ert-deftest jabber-test-db-wire-session-stays-in-parent-chat () "A wire ThreadID alone does not create a dedicated UI thread." (jabber-test-db-with-db (let ((now (floor (float-time)))) (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "first" now "phone" "session-1" nil nil nil nil nil '(:thread-id "wire-session")) (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "second" (1+ now) "phone" "session-2" nil nil nil nil nil '(:thread-id "wire-session"))) (let ((parent (jabber-db-backlog "me@x.com" "alice@x.com"))) (should (equal '("second" "first") (mapcar (lambda (msg) (plist-get msg :body)) parent))) (should-not (seq-some (lambda (msg) (plist-get msg :thread-summary)) parent))) (should-not (jabber-db-message-thread-known-p "me@x.com" "alice@x.com" "chat" "wire-session")) (should-not (jabber-db-message-thread-location "me@x.com" "alice@x.com" "chat" "session-2" nil)) (should (equal '((0)) (sqlite-select jabber-db--connection "SELECT dedicated FROM message_thread WHERE thread_id = ?" '("wire-session")))))) (ert-deftest jabber-test-db-wire-session-replies-stay-in-parent-chat () "Replies do not turn XEP-0201 sessions into dedicated UI threads." (jabber-test-db-with-db (let ((now (floor (float-time)))) (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "same root" now nil "same-root" nil nil nil nil nil '(:thread-id "same-session")) (jabber-db-store-message "me@x.com" "alice@x.com" "out" "chat" "same reply" (1+ now) nil "same-reply" nil nil nil nil '(:reply-to-id "same-root") '(:thread-id "same-session")) (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "plain root" (+ now 2) nil "plain-root") (jabber-db-store-message "me@x.com" "alice@x.com" "out" "chat" "plain reply" (+ now 3) nil "plain-reply" nil nil nil nil '(:reply-to-id "plain-root") '(:thread-id "new-session"))) (should (equal '(("new-session" 0) ("same-session" 0)) (sqlite-select jabber-db--connection "SELECT thread_id, dedicated FROM message_thread ORDER BY thread_id"))) (let ((jc (jabber-test-db--make-fake-jc "me@x.com"))) (dolist (thread-id '("same-session" "new-session")) (should (eq 'parent (jabber-message-thread-display-target jc "alice@x.com" "chat" (list :thread-id thread-id :id "following")))))))) (ert-deftest jabber-test-db-message-threads-limits-dedicated-results () "List only the 50 most recently active dedicated threads." (jabber-test-db-with-db (dotimes (index 55) (let ((thread-id (format "thread-%02d" index)) (root-id (format "root-%02d" index))) (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" root-id index "phone" root-id) (jabber-db-register-message-thread "me@x.com" "alice@x.com" "chat" thread-id nil root-id nil index))) (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "session" 100 "phone" "session-root" nil nil nil nil nil '(:thread-id "wire-session")) (let ((threads (jabber-db-message-threads "me@x.com" "alice@x.com" "chat"))) (should (= 50 (length threads))) (should (equal "thread-54" (plist-get (car threads) :thread-id))) (should (equal "thread-05" (plist-get (car (last threads)) :thread-id)))))) (ert-deftest jabber-test-db-thread-title-round-trip () "Store normalized local titles on dedicated threads only." (jabber-test-db-with-db (jabber-db-register-message-thread "me@x.com" "alice@x.com" "chat" "thread-1" nil nil nil 1) (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "session" 2 "phone" "session-1" nil nil nil nil nil '(:thread-id "wire-session")) (jabber-db-set-message-thread-title "me@x.com" "alice@x.com" "chat" "thread-1" " Roadmap\n\t2026 ") (should-error (jabber-db-set-message-thread-title "me@x.com" "alice@x.com" "chat" "wire-session" "Hidden") :type 'user-error) (should (equal "Roadmap 2026" (plist-get (jabber-db-message-thread-summary "me@x.com" "alice@x.com" "chat" "thread-1") :title))) (should (equal "Roadmap 2026" (plist-get (car (jabber-db-message-threads "me@x.com" "alice@x.com" "chat")) :title))) (should (equal '((nil)) (sqlite-select jabber-db--connection "SELECT title FROM message_thread WHERE thread_id = ?" '("wire-session")))) (jabber-db-set-message-thread-title "me@x.com" "alice@x.com" "chat" "thread-1" " ") (should-not (plist-get (jabber-db-message-thread-summary "me@x.com" "alice@x.com" "chat" "thread-1") :title)))) (ert-deftest jabber-test-db-thread-backlog-and-summary () "Parent backlog hides replies and exposes reply count and unread state." (jabber-test-db-with-db (let ((now (floor (float-time)))) (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "root" now "phone" "root-1") (jabber-db-register-message-thread "me@x.com" "alice@x.com" "chat" "thread-1" nil "root-1" nil now) (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "first reply" (1+ now) "phone" "reply-1" nil nil nil nil nil '(:thread-id "thread-1")) (jabber-db-store-message "me@x.com" "alice@x.com" "out" "chat" "second reply" (+ now 2) nil "reply-2" nil nil nil nil nil '(:thread-id "thread-1")) (let* ((parent (jabber-db-backlog "me@x.com" "alice@x.com")) (unthreaded-view (jabber-db-backlog "me@x.com" "alice@x.com" nil nil nil nil t)) (thread (jabber-db-thread-backlog "me@x.com" "alice@x.com" "chat" "thread-1" t)) (summary (plist-get (car parent) :thread-summary))) (should (equal '("root") (mapcar (lambda (msg) (plist-get msg :body)) parent))) (should (equal '("second reply" "first reply" "root") (mapcar (lambda (msg) (plist-get msg :body)) unthreaded-view))) (should (equal '("second reply" "first reply" "root") (mapcar (lambda (msg) (plist-get msg :body)) thread))) (should (= 2 (plist-get summary :reply-count))) (should (plist-get summary :unread))) (jabber-db-mark-message-thread-read "me@x.com" "alice@x.com" "chat" "thread-1") (should-not (plist-get (plist-get (car (jabber-db-backlog "me@x.com" "alice@x.com")) :thread-summary) :unread)) (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "same-second reply" (+ now 2) "phone" "reply-3" nil nil nil nil nil '(:thread-id "thread-1")) (should (plist-get (plist-get (car (jabber-db-backlog "me@x.com" "alice@x.com")) :thread-summary) :unread))))) (ert-deftest jabber-test-db-message-threads-orders-by-latest-activity () "List one chat's threads by activity with root and summary data." (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "Older root" 10 "phone" "root-old") (jabber-db-register-message-thread "me@x.com" "alice@x.com" "chat" "thread-old" nil "root-old" nil 10) (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "Recent root" 20 "phone" "root-recent") (jabber-db-register-message-thread "me@x.com" "alice@x.com" "chat" "thread-recent" nil "root-recent" nil 20) (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "Late reply" 30 "tablet" "reply-old" nil nil nil nil nil '(:thread-id "thread-old")) (jabber-db-store-message "me@x.com" "alice@x.com" "out" "chat" "Latest reply" 31 nil "reply-latest" nil nil nil nil nil '(:thread-id "thread-old")) (jabber-db-store-message "me@x.com" "other@x.com" "in" "chat" "Other chat" 40 nil "root-other" nil nil nil nil nil '(:thread-id "thread-other")) (let* ((threads (jabber-db-message-threads "me@x.com" "alice@x.com" "chat")) (active (car threads)) (recent (cadr threads))) (should (equal '("thread-old" "thread-recent") (mapcar (lambda (thread) (plist-get thread :thread-id)) threads))) (should (= 10 (floor (float-time (plist-get active :created-at))))) (should (= 31 (floor (float-time (plist-get active :latest-at))))) (should (= 2 (plist-get active :reply-count))) (should (= 1 (plist-get active :local-reply-count))) (should (plist-get active :unread)) (should (equal "Older root" (plist-get (plist-get active :root-message) :body))) (should (equal "alice@x.com/phone" (plist-get (plist-get active :root-message) :from))) (should (= 20 (floor (float-time (plist-get recent :latest-at)))))))) (ert-deftest jabber-test-db-message-threads-preserves-muc-root-identity () "List a MUC thread without confusing a recycled client stanza ID." (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "room@conference.x.com" "in" "groupchat" "Alice root" 10 "Alice" "same-id" "root-server" nil nil nil nil '(:thread-id "thread-1")) (jabber-db-store-message "me@x.com" "room@conference.x.com" "in" "groupchat" "Alice reply" 20 "Alice" "same-id" "reply-server" nil nil nil nil '(:thread-id "thread-1")) (let* ((threads (jabber-db-message-threads "me@x.com" "room@conference.x.com" "groupchat")) (thread (car threads)) (root (plist-get thread :root-message))) (should (= 1 (length threads))) (should (= 1 (plist-get thread :reply-count))) (should (equal "Alice root" (plist-get root :body))) (should (equal "root-server" (plist-get root :server-id))) (should (equal "room@conference.x.com/Alice" (plist-get root :from)))))) (ert-deftest jabber-test-db-message-threads-root-is-not-unread () "Do not treat an incoming thread root as an unread reply." (jabber-test-db-with-db (dolist (type '("chat" "groupchat")) (let ((peer (if (equal type "chat") "alice@x.com" "room@conference.x.com"))) (jabber-db-store-message "me@x.com" peer "in" type "Root only" 10 "Alice" "root-id" "root-server" nil nil nil nil '(:thread-id "thread-1")) (jabber-db-register-message-thread "me@x.com" peer type "thread-1" nil "root-id" "root-server" 10) (sqlite-execute jabber-db--connection "UPDATE message_thread SET root_message_id = NULL WHERE account = ? AND peer = ? AND type = ? AND thread_id = ?" (list "me@x.com" peer type "thread-1")) (let ((thread (car (jabber-db-message-threads "me@x.com" peer type)))) (should (= 0 (plist-get thread :reply-count))) (should-not (plist-get thread :unread))))))) (ert-deftest jabber-test-db-message-threads-carries-retraction-state () "Expose root retraction state without discarding stored metadata." (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "Sensitive root" 10 "phone" "root-id" "root-server") (jabber-db-register-message-thread "me@x.com" "alice@x.com" "chat" "thread-1" nil "root-id" nil 10) (jabber-db-retract-message-in-peer "me@x.com" "alice@x.com" "root-server" "moderator@x.com") (let ((root (plist-get (car (jabber-db-message-threads "me@x.com" "alice@x.com" "chat")) :root-message))) (should (plist-get root :retracted)) (should (equal "Sensitive root" (plist-get root :body)))))) (ert-deftest jabber-test-db-thread-summaries-only-aggregate-visible-roots () "Backlog attachment aggregates only threads visible in the page." (jabber-test-db-with-db (dolist (thread '(("thread-1" "root-1") ("thread-2" "root-2"))) (jabber-db-register-message-thread "me@x.com" "alice@x.com" "chat" (car thread) nil (cadr thread) nil 1)) (let ((real-summary (symbol-function 'jabber-db--thread-summary)) (calls 0) (root '(:id "root-1" :msg-type "chat"))) (cl-letf (((symbol-function 'jabber-db--thread-summary) (lambda (&rest args) (setq calls (1+ calls)) (apply real-summary args)))) (jabber-db--attach-thread-summaries jabber-db--connection "me@x.com" "alice@x.com" (list root))) (should (= calls 1)) (should (equal "thread-1" (plist-get (plist-get root :thread-summary) :thread-id)))))) (ert-deftest jabber-test-db-thread-location-disambiguates-muc-client-id () "Exact row identity disambiguates recycled MUC client stanza IDs." (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "room@conference.x.com" "in" "groupchat" "Alice root" 1 "Alice" "same-id" nil nil nil nil nil '(:thread-id "thread-a")) (jabber-db-store-message "me@x.com" "room@conference.x.com" "in" "groupchat" "Bob root" 2 "Bob" "same-id" nil nil nil nil nil '(:thread-id "thread-b")) (let* ((candidates (jabber-db-message-correction-candidates "me@x.com" "room@conference.x.com" "same-id")) (alice (seq-find (lambda (candidate) (equal "room@conference.x.com/Alice" (plist-get candidate :from))) candidates)) (bob (seq-find (lambda (candidate) (equal "room@conference.x.com/Bob" (plist-get candidate :from))) candidates))) (should (equal '(:thread-id "thread-a" :root t) (jabber-db-message-thread-location-by-row "me@x.com" "room@conference.x.com" "groupchat" (plist-get alice :row-id)))) (should (equal '(:thread-id "thread-b" :root t) (jabber-db-message-thread-location-by-row "me@x.com" "room@conference.x.com" "groupchat" (plist-get bob :row-id)))) (should (equal '("Alice root") (mapcar (lambda (msg) (plist-get msg :body)) (jabber-db-thread-backlog "me@x.com" "room@conference.x.com" "groupchat" "thread-a" t))))))) (ert-deftest jabber-test-db-thread-muc-root-prefers-row-and-server-id () "A recycled MUC client ID does not turn a reply into the root." (jabber-test-db-with-db (let ((now (floor (float-time)))) (jabber-db-store-message "me@x.com" "room@conference.x.com" "in" "groupchat" "root" now "Alice" "same-id" "root-server" nil nil nil nil '(:thread-id "thread-a")) (jabber-db-store-message "me@x.com" "room@conference.x.com" "in" "groupchat" "reply" (1+ now) "Alice" "same-id" "reply-server" nil nil nil nil '(:thread-id "thread-a")) (let* ((parent (jabber-db-backlog "me@x.com" "room@conference.x.com" nil nil nil "groupchat")) (summary (plist-get (car parent) :thread-summary))) (should (equal '("root") (mapcar (lambda (msg) (plist-get msg :body)) parent))) (should (= 1 (plist-get summary :reply-count))) (should (equal '(:thread-id "thread-a" :root nil) (jabber-db-message-thread-location "me@x.com" "room@conference.x.com" "groupchat" "reply-server" t))))))) (ert-deftest jabber-test-db-thread-muc-root-row-beats-client-id () "A stored root row takes precedence over a recycled MUC client ID." (jabber-test-db-with-db (let ((now (floor (float-time)))) (jabber-db-store-message "me@x.com" "room@conference.x.com" "in" "groupchat" "root" now "Alice" "same-id" nil nil nil nil nil '(:thread-id "thread-a")) (jabber-db-store-message "me@x.com" "room@conference.x.com" "in" "groupchat" "reply" (1+ now) "Alice" "same-id" nil nil nil nil nil '(:thread-id "thread-a")) (jabber-db-store-message "me@x.com" "room@conference.x.com" "in" "groupchat" "unrelated" (+ now 2) "Bob" "same-id") (let* ((summary (jabber-db-message-thread-summary "me@x.com" "room@conference.x.com" "groupchat" "thread-a")) (messages (jabber-db-thread-backlog "me@x.com" "room@conference.x.com" "groupchat" "thread-a" t)) (root (seq-find (lambda (msg) (equal "root" (plist-get msg :body))) messages)) (reply (seq-find (lambda (msg) (equal "reply" (plist-get msg :body))) messages))) (should (equal '("reply" "root") (mapcar (lambda (msg) (plist-get msg :body)) messages))) (should (jabber-db-message-thread-root-p "me@x.com" "room@conference.x.com" "groupchat" "thread-a" "same-id" nil (plist-get root :db-id))) (should-not (jabber-db-message-thread-root-p "me@x.com" "room@conference.x.com" "groupchat" "thread-a" "same-id" nil (plist-get reply :db-id))) (should-not (jabber-db-message-thread-root-p "me@x.com" "room@conference.x.com" "groupchat" "thread-a" "same-id" nil)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@x.com")) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) nil))) (should (eq 'parent (jabber-message-thread-display-target 'jc "room@conference.x.com" "groupchat" (list :thread-id "thread-a" :id "same-id" :db-id (plist-get root :db-id))))) (should-not (jabber-message-thread-display-target 'jc "room@conference.x.com" "groupchat" (list :thread-id "thread-a" :id "same-id" :db-id (plist-get reply :db-id)))) (should-not (jabber-message-thread-display-target 'jc "room@conference.x.com" "groupchat" '(:thread-id "thread-a" :id "same-id")))) (should (= (plist-get root :db-id) (plist-get summary :root-message-id))))))) ;;; Group: Reply metadata persistence (ert-deftest jabber-test-db-reply-metadata-round-trip () "Reply metadata stored with a message comes back in the backlog." (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "> quote\nanswer" (floor (float-time)) "phone" "msg-1" nil nil nil nil '(:reply-to-id "orig-1" :reply-to-jid "alice@x.com" :fallback-range (0 8))) (let ((msg (car (jabber-db-backlog "me@x.com" "alice@x.com")))) (should (equal "orig-1" (plist-get msg :reply-to-id))) (should (equal "alice@x.com" (plist-get msg :reply-to-jid))) (should (equal '(0 8) (plist-get msg :fallback-range)))))) (ert-deftest jabber-test-db-reply-metadata-all-range () "A whole-body fallback range survives the -1 encoding." (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "> just a quote" (floor (float-time)) "phone" "msg-2" nil nil nil nil '(:reply-to-id "orig-2" :fallback-range all)) (let ((msg (car (jabber-db-backlog "me@x.com" "alice@x.com")))) (should (eq 'all (plist-get msg :fallback-range)))))) (ert-deftest jabber-test-db-reply-metadata-absent () "A message without reply metadata reads back nil fields." (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "alice@x.com" "in" "chat" "plain" (floor (float-time)) "phone" "msg-3") (let ((msg (car (jabber-db-backlog "me@x.com" "alice@x.com")))) (should-not (plist-get msg :reply-to-id)) (should-not (plist-get msg :fallback-range))))) (ert-deftest jabber-test-db-reply-metadata-backfill-on-dedup () "A duplicate store with reply metadata backfills NULL reply columns." (jabber-test-db-with-db (let ((ts (floor (float-time)))) ;; First store without reply metadata (OMEMO pending echo shape). (jabber-db-store-message "me@x.com" "alice@x.com" "out" "chat" "answer" ts nil "msg-4") ;; Same stanza-id again, now with reply metadata. (jabber-db-store-message "me@x.com" "alice@x.com" "out" "chat" "answer" ts nil "msg-4" nil nil nil nil '(:reply-to-id "orig-4" :fallback-range all)) (let ((msg (car (jabber-db-backlog "me@x.com" "alice@x.com")))) (should (equal "orig-4" (plist-get msg :reply-to-id))) (should (eq 'all (plist-get msg :fallback-range))))))) (ert-deftest jabber-test-db-reply-target-body-lookup () "Reply target lookup matches server_id in MUC, stanza_id in 1:1." (jabber-test-db-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@x.com" "room@conf.x.com" "in" "groupchat" "the original" ts "alice" "short-1" "room-uuid-1") (jabber-db-store-message "me@x.com" "bob@x.com" "in" "chat" "direct original" ts "phone" "origin-7")) (should (equal "the original" (jabber-db-reply-target-body "me@x.com" "room@conf.x.com" "room-uuid-1" t))) (should-not (jabber-db-reply-target-body "me@x.com" "room@conf.x.com" "short-1" t)) (should (equal "direct original" (jabber-db-reply-target-body "me@x.com" "bob@x.com" "origin-7" nil))) (should-not (jabber-db-reply-target-body "me@x.com" "bob@x.com" "missing" nil)))) (ert-deftest jabber-test-db-reply-target-body-skips-retracted () "A retracted reply target is not quoted." (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "bob@x.com" "in" "chat" "soon gone" (floor (float-time)) "phone" "orig-8" "srv-8") (jabber-db-retract-message "srv-8" "bob@x.com/phone" nil) (should-not (jabber-db-reply-target-body "me@x.com" "bob@x.com" "orig-8" nil)))) (ert-deftest jabber-test-db-extract-reply-fields () "Reply extraction matches the chat-side parser's shape." (let ((stanza '(message ((from . "alice@x.com") (type . "chat")) (body () "> q\nanswer") (reply ((xmlns . "urn:xmpp:reply:0") (to . "alice@x.com") (id . "orig-5"))) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . "urn:xmpp:reply:0")) (body ((start . "0") (end . "4"))))))) (should (equal '(:reply-to-id "orig-5" :reply-to-jid "alice@x.com" :fallback-range (0 4)) (jabber-db--extract-reply-fields stanza)))) (should-not (jabber-db--extract-reply-fields '(message ((from . "a@x.com")) (body () "plain"))))) (ert-deftest jabber-test-db-oob-dedup-replacement () "Failed-decrypt replacement updates OOB entries." (jabber-test-db-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)))))))) ;;; Group: message_reaction child table (ert-deftest jabber-test-db-reaction-table-exists () "The reaction row and actor metadata tables exist in fresh databases." (jabber-test-db-with-db (let ((tables (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM sqlite_master WHERE type='table'")))) (should (member "message_reaction" tables)) (should (member "message_reaction_actor" tables))) (let ((indexes (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM sqlite_master WHERE type='index'")))) (should (member "idx_reaction_message_id" indexes))))) (ert-deftest jabber-test-db-v5-repairs-missing-reaction-actor-table () "A v5 DB missing message_reaction_actor is repaired without data loss." (skip-unless (fboundp 'sqlite-open)) (let* ((jabber-test-db--dir (make-temp-file "jabber-db-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-test-db--dir)) (jabber-db--connection nil)) (unwind-protect (progn (let ((db (sqlite-open jabber-db-path))) (sqlite-execute db "\ CREATE TABLE message ( id INTEGER PRIMARY KEY, account TEXT NOT NULL, peer TEXT NOT NULL, direction TEXT NOT NULL, type TEXT, body TEXT, timestamp INTEGER NOT NULL, stanza_id TEXT)") (sqlite-execute db "\ CREATE TABLE message_reaction ( message_id INTEGER NOT NULL REFERENCES message(id) ON DELETE CASCADE, sender TEXT NOT NULL, reaction TEXT NOT NULL, updated_at INTEGER NOT NULL, PRIMARY KEY (message_id, sender, reaction))") (sqlite-execute db "\ INSERT INTO message (id, account, peer, direction, type, body, timestamp, stanza_id) VALUES (1, 'me@example.com', 'friend@example.com', 'in', 'chat', 'hello', 1000, 'target-1')") (sqlite-execute db "\ INSERT INTO message_reaction (message_id, sender, reaction, updated_at) VALUES (1, 'friend@example.com', '👍', 1001)") (sqlite-execute db "\ CREATE TABLE omemo_store ( account TEXT PRIMARY KEY, store_blob BLOB NOT NULL)") (sqlite-execute db "PRAGMA user_version=5") (sqlite-close db)) (jabber-db-ensure-open) (let ((tables (mapcar #'car (sqlite-select jabber-db--connection "SELECT name FROM sqlite_master WHERE type='table'")))) (should (member "message_reaction_actor" tables))) (should (= 1 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message_reaction")))) (should (equal '("friend@example.com" 1001) (car (sqlite-select jabber-db--connection "SELECT sender, updated_at FROM message_reaction_actor")))) (should-not (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "target-1" "friend@example.com" '("🎉") 1000)) (should (equal '("👍" 1001) (car (sqlite-select jabber-db--connection "SELECT reaction, updated_at FROM message_reaction")))) (should (string= "hello" (caar (sqlite-select jabber-db--connection "SELECT body FROM message WHERE id = 1")))) (jabber-db-close) (jabber-db-ensure-open) (should (= 1 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message_reaction_actor")))) (should (equal '("friend@example.com" 1001) (car (sqlite-select jabber-db--connection "SELECT sender, updated_at FROM message_reaction_actor")))) (should (equal '("👍" 1001) (car (sqlite-select jabber-db--connection "SELECT reaction, updated_at FROM message_reaction")))) (should (string= "hello" (caar (sqlite-select jabber-db--connection "SELECT body FROM message WHERE id = 1"))))) (jabber-db-close) (when (file-directory-p jabber-test-db--dir) (delete-directory jabber-test-db--dir t))))) (ert-deftest jabber-test-db-reaction-fallback-body-not-stored () "Reaction fallback body is not stored as a normal message body." (jabber-test-db-with-db (let ((xml `(message ((from . "friend@example.com/laptop") (type . "chat") (id . "reaction-1")) (body nil "> quoted\n👍") (reactions ((xmlns . ,jabber-reactions-xmlns) (id . "target-1")) (reaction nil "👍")) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . ,jabber-reactions-xmlns)) (body ((start . "0") (end . "10"))))))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (jabber-db--message-handler 'fake-jc xml)) (should (null (jabber-db-query "me@example.com" "friend@example.com")))))) (ert-deftest jabber-test-db-muc-self-message-stored-outgoing () "A live MUC echo from our nickname is not counted as incoming." (jabber-test-db-with-db (let ((jabber-muc--rooms (make-hash-table :test #'equal)) (xml '(message ((from . "room@example.com/me") (type . "groupchat") (id . "message-1")) (body nil "mine")))) (jabber-muc-join-set "room@example.com" 'fake-jc "me") (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (jabber-db--message-handler 'fake-jc xml)) (should (equal "out" (plist-get (car (jabber-db-query "me@example.com" "room@example.com")) :direction)))))) (ert-deftest jabber-test-db-replace-reactions-chat-by-stanza-id () "Direct-chat reactions are stored against the target stanza id." (jabber-test-db-with-db (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "hello" 1000 nil "stanza-1") (should (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "friend@example.com" '("👍" "👍" "🎉"))) (let ((rows (sqlite-select jabber-db--connection "SELECT sender, reaction FROM message_reaction"))) (should (= 2 (length rows))) (should (member '("friend@example.com" "👍") rows)) (should (member '("friend@example.com" "🎉") rows))))) (ert-deftest jabber-test-db-replace-reactions-groupchat-by-server-id () "MUC reactions are stored against the target server id." (jabber-test-db-with-db (jabber-db-store-message "me@example.com" "room@example.com" "in" "groupchat" "hello" 1000 "alice" nil "server-1") (should (jabber-db-replace-reactions "me@example.com" "room@example.com" "groupchat" "server-1" "room@example.com/bob" '("❤️"))) (let ((row (car (sqlite-select jabber-db--connection "SELECT sender, reaction FROM message_reaction")))) (should (equal row '("room@example.com/bob" "❤️")))))) (ert-deftest jabber-test-db-replace-reactions-stores-source-timestamp () "Reaction replacement stores the supplied source timestamp." (jabber-test-db-with-db (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "hello" 1000 nil "stanza-1") (should (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("👍") 1234)) (should (= 1234 (caar (sqlite-select jabber-db--connection "SELECT updated_at FROM message_reaction")))) (should (= 1234 (caar (sqlite-select jabber-db--connection "SELECT updated_at FROM message_reaction_actor")))))) (ert-deftest jabber-test-db-replace-reactions-newer-overwrites () "A newer reaction replacement overwrites existing sender state." (jabber-test-db-with-db (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "hello" 1000 nil "stanza-1") (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("👍") 1000) (should (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("🎉") 1001)) (should (equal (sqlite-select jabber-db--connection "SELECT reaction, updated_at FROM message_reaction") '(("🎉" 1001)))))) (ert-deftest jabber-test-db-replace-reactions-stale-ignored () "An older or equal reaction replacement does not overwrite sender state." (jabber-test-db-with-db (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "hello" 1000 nil "stanza-1") (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("👍") 1000) (should-not (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("🎉") 999)) (should-not (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("❤️") 1000)) (should (equal (sqlite-select jabber-db--connection "SELECT reaction, updated_at FROM message_reaction") '(("👍" 1000)))))) (ert-deftest jabber-test-db-replace-reactions-old-call-remains-compatible () "Reaction replacement still works when callers omit UPDATED-AT." (jabber-test-db-with-db (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "hello" 1000 nil "stanza-1") (should (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("👍"))) (should (equal (caar (sqlite-select jabber-db--connection "SELECT reaction FROM message_reaction")) "👍")))) (ert-deftest jabber-test-db-replace-reactions-empty-removes-sender () "An empty replacement removes only that sender's reactions." (jabber-test-db-with-db (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "hello" 1000 nil "stanza-1") (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("👍")) (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "bob" '("🎉")) (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" nil) (let ((rows (sqlite-select jabber-db--connection "SELECT sender, reaction FROM message_reaction"))) (should (equal rows '(("bob" "🎉"))))))) (ert-deftest jabber-test-db-replace-reactions-empty-preserves-actor-timestamp () "Empty replacement records actor timestamp and blocks older replays." (jabber-test-db-with-db (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "hello" 1000 nil "stanza-1") (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("👍") 1000) (should (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" nil 1001)) (should-not (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("🎉") 1000)) (should (= 1001 (caar (sqlite-select jabber-db--connection "SELECT updated_at FROM message_reaction_actor")))) (should (= 0 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message_reaction")))))) (ert-deftest jabber-test-db-replace-reactions-local-same-second-updates () "Local replacements without UPDATED-AT are accepted even in the same second." (jabber-test-db-with-db (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "hello" 1000 nil "stanza-1") (cl-letf (((symbol-function 'float-time) (lambda (&optional _time) 1234.9))) (should (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("👍"))) (should (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("🎉")))) (should (equal (sqlite-select jabber-db--connection "SELECT reaction, updated_at FROM message_reaction") '(("🎉" 1234)))))) (ert-deftest jabber-test-db-replace-reactions-explicit-equal-rejected () "Source-ordered replacement with equal timestamp is ignored." (jabber-test-db-with-db (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "hello" 1000 nil "stanza-1") (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("👍") 1000) (should-not (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("🎉") 1000)) (should (equal (sqlite-select jabber-db--connection "SELECT reaction, updated_at FROM message_reaction") '(("👍" 1000)))))) (ert-deftest jabber-test-db-backlog-empty-reactions-after-removal () "Empty replacement leaves no reactions in backlog." (jabber-test-db-with-db (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "hello" 1000 nil "stanza-1") (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("👍") 1000) (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" nil 1001) (let ((entry (car (jabber-db-backlog "me@example.com" "friend@example.com")))) (should-not (plist-get entry :reactions))))) (ert-deftest jabber-test-db-backlog-attaches-reactions () "Backlog entries include persisted reaction state." (jabber-test-db-with-db (let ((ts (floor (float-time)))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "hello" ts nil "stanza-1")) (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("👍" "🎉")) (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "bob" '("👍")) (let* ((entry (car (jabber-db-backlog "me@example.com" "friend@example.com"))) (reactions (plist-get entry :reactions))) (should (equal (alist-get "alice" reactions nil nil #'equal) '("👍" "🎉"))) (should (equal (alist-get "bob" reactions nil nil #'equal) '("👍")))))) (ert-deftest jabber-test-db-reaction-cascade-delete () "Deleting a message cascades to reaction rows and actor metadata." (jabber-test-db-with-db (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "hello" 1000 nil "stanza-1") (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "stanza-1" "alice" '("👍")) (jabber-db-delete-peer-messages "me@example.com" "friend@example.com") (should (= 0 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message_reaction")))) (should (= 0 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message_reaction_actor")))))) ;;; Group: stanza-id extraction for storage (ert-deftest jabber-test-db-stanza-id-element-validates-by () "Only a stanza-id (not origin-id) with the expected by is returned." (let ((stanza '(message ((from . "room@conf.example.com/alice") (type . "groupchat")) (body () "hi") (origin-id ((xmlns . "urn:xmpp:sid:0") (id . "origin-1"))) (stanza-id ((xmlns . "urn:xmpp:sid:0") (id . "spoofed-1") (by . "attacker@evil.example"))) (stanza-id ((xmlns . "urn:xmpp:sid:0") (id . "server-1") (by . "room@conf.example.com")))))) (let ((el (jabber-db--stanza-id-element stanza "room@conf.example.com"))) (should (equal "server-1" (jabber-xml-get-attribute el 'id)))) (should-not (jabber-db--stanza-id-element stanza "me@example.com")))) (ert-deftest jabber-test-db-stanza-id-element-skips-origin-id () "An origin-id preceding the stanza-id does not mask it." (let ((stanza '(message ((from . "alice@example.com/phone") (type . "chat")) (body () "hi") (origin-id ((xmlns . "urn:xmpp:sid:0") (id . "origin-1"))) (stanza-id ((xmlns . "urn:xmpp:sid:0") (id . "archive-1") (by . "me@example.com")))))) (let ((el (jabber-db--stanza-id-element stanza "me@example.com"))) (should (equal "archive-1" (jabber-xml-get-attribute el 'id)))))) (provide 'jabber-test-db) ;;; jabber-test-db.el ends here emacs-jabber-0.13.1/tests/jabber-test-disco.el000066400000000000000000000217401523531702000210760ustar00rootroot00000000000000;;; jabber-test-disco.el --- Tests for jabber-disco -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0030 Service Discovery and XEP-0115 Entity Caps. ;;; Code: (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-test-disco-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-test-disco-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-test-disco-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-test-disco-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-test-disco-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-test-disco-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-test-disco-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-test-disco-parse-info-preserves-xdata-forms () "Disco info parsing preserves XEP-0128 data forms." (let* ((form `(x ((xmlns . ,jabber-xdata-xmlns) (type . "result")) (field ((var . "FORM_TYPE") (type . "hidden")) (value () "urn:xmpp:http:upload:0")) (field ((var . "max-file-size")) (value () "5242880")))) (result (jabber-disco-parse-info `(iq ((from . "upload.example.net") (type . "result")) (query ((xmlns . ,jabber-disco-xmlns-info)) (identity ((category . "store") (type . "file") (name . "HTTP File Upload"))) (feature ((var . "urn:xmpp:http:upload:0"))) ,form))))) (should (equal (nth 1 result) '("urn:xmpp:http:upload:0"))) (should (equal (nth 2 result) (list form))))) (ert-deftest jabber-test-disco-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-test-disco-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)))) (ert-deftest jabber-test-disco-advertise-feature-runs-change-hook-once () "Advertising a new connected feature runs the change hook once." (let ((jabber-advertised-features nil) (jabber-caps-current-hash "old") (jabber-disco-features-changed-hook nil) (recalculations 0) (changes 0)) (add-hook 'jabber-disco-features-changed-hook (lambda () (cl-incf changes))) (cl-letf (((symbol-function 'jabber-caps-recalculate-hash) (lambda () (cl-incf recalculations)))) (jabber-disco-advertise-feature "urn:test:feature") (jabber-disco-advertise-feature "urn:test:feature")) (should (= recalculations 1)) (should (= changes 1)))) (provide 'jabber-test-disco) ;;; jabber-test-disco.el ends here emacs-jabber-0.13.1/tests/jabber-test-httpupload.el000066400000000000000000000316521523531702000221640ustar00rootroot00000000000000;;; jabber-test-httpupload.el --- Tests for jabber-httpupload -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0363 HTTP File Upload. ;;; Code: (require 'ert) (require 'cl-lib) (require 'jabber-httpupload) ;;; Slot parsing (ert-deftest jabber-test-httpupload-parse-slot-answer () (let* ((slot `(iq () (slot ((xmlns . ,jabber-httpupload-xmlns)) (put ((xmlns . ,jabber-httpupload-xmlns) (url . "https://upload.example.net/file")) (header ((name . "Authorization")) "Bearer token")) (get ((xmlns . ,jabber-httpupload-xmlns) (url . "https://download.example.net/file")))))) (result (jabber-httpupload-parse-slot-answer slot))) (should (equal result '(("https://upload.example.net/file" ("Authorization" . "Bearer token")) "https://download.example.net/file"))))) (ert-deftest jabber-test-httpupload-parse-slot-answer-inherited-namespace () (let* ((slot `(iq () (slot ((xmlns . ,jabber-httpupload-xmlns)) (get ((url . "https://download.example.net/file"))) (put ((url . "https://upload.example.net/file")) (header ((name . "Authorization")) "Bearer token"))))) (result (jabber-httpupload-parse-slot-answer slot))) (should (equal result '(("https://upload.example.net/file" ("Authorization" . "Bearer token")) "https://download.example.net/file"))))) (ert-deftest jabber-test-httpupload-parse-slot-rejects-wrong-namespace () (let ((slot '(iq () (slot ((xmlns . "urn:xmpp:other")) (put ((xmlns . "urn:xmpp:other") (url . "https://upload.example.net/file"))) (get ((xmlns . "urn:xmpp:other") (url . "https://download.example.net/file"))))))) (should-error (jabber-httpupload-parse-slot-answer slot) :type 'error))) ;;; Service metadata (defun jabber-test-httpupload--max-size-form (size) "Return an HTTP Upload disco form advertising SIZE." `(x ((xmlns . ,jabber-xdata-xmlns) (type . "result")) (field ((var . "FORM_TYPE") (type . "hidden")) (value () ,jabber-httpupload-xmlns)) (field ((var . "max-file-size")) (value () ,size)))) (ert-deftest jabber-test-httpupload-records-max-file-size () (let ((jabber-httpupload-support nil) (jabber-httpupload-max-file-size nil) (result (list nil (list jabber-httpupload-xmlns) (list (jabber-test-httpupload--max-size-form "512"))))) (jabber-httpupload--record-support 'jc "upload.example.net" result) (should (equal jabber-httpupload-support '((jc . "upload.example.net")))) (should (equal jabber-httpupload-max-file-size '((jc . 512)))))) (ert-deftest jabber-test-httpupload-rejects-oversized-file-before-slot-request () (let ((jabber-httpupload-support '((jc . "upload.example.net"))) (jabber-httpupload-max-file-size '((jc . 3))) (slot-requested nil) (file (make-temp-file "jabber-httpupload-test"))) (unwind-protect (progn (with-temp-file file (insert "1234")) (cl-letf (((symbol-function 'jabber-send-iq) (lambda (&rest _args) (setq slot-requested t)))) (should-error (jabber-httpupload--upload 'jc file #'ignore) :type 'user-error) (should-not slot-requested))) (delete-file file)))) ;;; Slot errors (ert-deftest jabber-test-httpupload-slot-error-file-too-large () (let ((xml `(iq ((type . "error")) (error ((type . "modify")) (file-too-large ((xmlns . ,jabber-httpupload-xmlns)) (max-file-size () "20000")))))) (should (string= (jabber-httpupload--slot-error-message "file.jpg" xml) "File file.jpg is too large for HTTP Upload (maximum 20000 bytes)")))) (ert-deftest jabber-test-httpupload-slot-error-retry () (let ((xml `(iq ((type . "error")) (error ((type . "wait")) (retry ((xmlns . ,jabber-httpupload-xmlns) (stamp . "2017-12-03T23:42:05Z"))))))) (should (string= (jabber-httpupload--slot-error-message "file.jpg" xml) "HTTP Upload temporarily unavailable for file.jpg; retry after 2017-12-03T23:42:05Z")))) (ert-deftest jabber-test-httpupload-slot-error-generic-stanza-error () (let ((xml `(iq ((type . "error")) (error ((type . "auth")) (forbidden ((xmlns . ,jabber-stanzas-xmlns))))))) (should (string= (jabber-httpupload--slot-error-message "file.jpg" xml) "HTTP Upload slot rejected for file.jpg: Forbidden")))) ;;; Curl upload (ert-deftest jabber-test-httpupload-curl-sentinel-calls-callback-on-zero-exit () "Curl sentinel calls its callback when curl exits successfully." (let ((buffer (generate-new-buffer " *jabber-curl-test*")) (called nil)) (unwind-protect (cl-letf (((symbol-function 'process-buffer) (lambda (_process) buffer)) ((symbol-function 'process-status) (lambda (_process) 'exit)) ((symbol-function 'process-exit-status) (lambda (_process) 0))) (jabber-httpupload--curl-sentinel 'process "finished\n" (lambda (arg) (setq called arg)) 'done) (should (eq called 'done)) (with-current-buffer buffer (should (string-match-p "Sentinel: \"finished" (buffer-string))))) (kill-buffer buffer)))) (ert-deftest jabber-test-httpupload-curl-sentinel-reports-nonzero-exit () "Curl sentinel reports nonzero exit without calling its callback." (let ((buffer (generate-new-buffer " *jabber-curl-test*")) (called nil) (messages nil)) (unwind-protect (progn (with-current-buffer buffer (insert "curl: (22) upload rejected\nAuthorization: Bearer secret\n")) (cl-letf (((symbol-function 'process-buffer) (lambda (_process) buffer)) ((symbol-function 'process-status) (lambda (_process) 'exit)) ((symbol-function 'process-exit-status) (lambda (_process) 22)) ((symbol-function 'process-get) (lambda (_process prop) (and (eq prop :jabber-httpupload-filename) "file.jpg"))) ((symbol-function 'message) (lambda (format-string &rest args) (push (apply #'format format-string args) messages)))) (jabber-httpupload--curl-sentinel 'process "exited abnormally with code 22\n" (lambda (_arg) (setq called t)) 'done) (should-not called) (should (equal messages '("HTTP Upload failed for file.jpg: exit status 22; event: exited abnormally with code 22; curl output: curl: (22) upload rejected Authorization: "))))) (kill-buffer buffer)))) (ert-deftest jabber-test-httpupload-curl-sentinel-reports-signal () "Curl sentinel reports signal status without calling its callback." (let ((called nil) (messages nil)) (cl-letf (((symbol-function 'process-buffer) (lambda (_process) nil)) ((symbol-function 'process-status) (lambda (_process) 'signal)) ((symbol-function 'process-exit-status) (lambda (_process) 15)) ((symbol-function 'process-get) (lambda (_process prop) (and (eq prop :jabber-httpupload-filename) "file.jpg"))) ((symbol-function 'message) (lambda (format-string &rest args) (push (apply #'format format-string args) messages)))) (jabber-httpupload--curl-sentinel 'process "killed\n" (lambda (_arg) (setq called t)) 'done) (should-not called) (should (equal messages '("HTTP Upload failed for file.jpg: signal status 15; event: killed")))))) (ert-deftest jabber-test-httpupload-curl-log-redacts-header-values () "Curl process log omits request header values." (let ((buffer (generate-new-buffer " *jabber-curl-test*")) command) (unwind-protect (cl-letf (((symbol-function 'executable-find) (lambda (_program) "/bin/curl")) ((symbol-function 'get-buffer-create) (lambda (_name) buffer)) ((symbol-function 'make-process) (lambda (&rest args) (setq command (plist-get args :command)) 'process)) ((symbol-function 'process-put) (lambda (&rest _args) nil))) (should (jabber-httpupload-put-file-curl "/tmp/file.jpg" '(("Authorization" . "Bearer secret") ("Cookie" . "sid=secret") ("content-type" . "image/jpeg")) "https://upload.example.net/file.jpg" #'ignore 'done)) (should (member "Authorization: Bearer secret" command)) (with-current-buffer buffer (let ((log (buffer-string))) (should (string-match-p "Authorization: " log)) (should (string-match-p "Cookie: " log)) (should-not (string-match-p "Bearer secret" log)) (should-not (string-match-p "sid=secret" log)) (should-not (string-match-p "image/jpeg" log))))) (kill-buffer buffer)))) ;;; Discovery (ert-deftest jabber-test-httpupload-discover-errors-with-no-items () (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_jc) '(:server "example.net"))) ((symbol-function 'jabber-disco-get-items) (lambda (jc _jid _node callback closure) (funcall callback jc closure nil))) ((symbol-function 'message) #'ignore)) (should-error (jabber-httpupload--discover-and-upload 'jc "/tmp/file.txt" #'ignore) :type 'user-error))) (ert-deftest jabber-test-httpupload-discover-errors-without-feature () (let ((items (list ["Archive" "archive.example.net" nil] ["Proxy" "proxy.example.net" nil]))) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_jc) '(:server "example.net"))) ((symbol-function 'jabber-disco-get-items) (lambda (jc _jid _node callback closure) (funcall callback jc closure items))) ((symbol-function 'jabber-disco-get-info) (lambda (jc jid _node callback closure) (funcall callback jc closure (list nil (list (format "feature:%s" jid)))))) ((symbol-function 'message) #'ignore)) (should-error (jabber-httpupload--discover-and-upload 'jc "/tmp/file.txt" #'ignore) :type 'user-error)))) (ert-deftest jabber-test-httpupload-discover-uploads-with-feature () (let ((items (list ["Upload" "upload.example.net" nil])) (jabber-httpupload-support nil) (jabber-httpupload-max-file-size nil) (uploaded nil)) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_jc) '(:server "example.net"))) ((symbol-function 'jabber-disco-get-items) (lambda (jc _jid _node callback closure) (funcall callback jc closure items))) ((symbol-function 'jabber-disco-get-info) (lambda (jc _jid _node callback closure) (funcall callback jc closure (list nil (list jabber-httpupload-xmlns) (list (jabber-test-httpupload--max-size-form "4096")))))) ((symbol-function 'jabber-httpupload--upload) (lambda (jc filepath callback) (setq uploaded (list jc filepath callback)))) ((symbol-function 'message) #'ignore)) (jabber-httpupload--discover-and-upload 'jc "/tmp/file.txt" #'ignore) (should (equal jabber-httpupload-support '((jc . "upload.example.net")))) (should (equal jabber-httpupload-max-file-size '((jc . 4096)))) (should (equal uploaded (list 'jc "/tmp/file.txt" #'ignore)))))) (provide 'jabber-test-httpupload) ;;; jabber-test-httpupload.el ends here emacs-jabber-0.13.1/tests/jabber-test-image.el000066400000000000000000000104431523531702000210550ustar00rootroot00000000000000;;; jabber-test-image.el --- Tests for jabber-image -*- lexical-binding: t; -*- ;;; Commentary: ;; Image size cap and detected-type policy checks. ;;; Code: (require 'ert) (require 'cl-lib) (require 'jabber-image) (defconst jabber-test-image--png-bytes (unibyte-string #x89 ?P ?N ?G #x0d #x0a #x1a #x0a 0 0 0 13 ?I ?H ?D ?R) "Enough PNG magic bytes for `image-type-from-data'.") (defconst jabber-test-image--gif-bytes (concat "GIF89a" (unibyte-string 1 0 1 0 0 0 0)) "Enough GIF magic bytes for `image-type-from-data'.") ;;; Size cap (ert-deftest jabber-test-image-size-ok-p-nil-limit-allows-any () (let ((jabber-image-max-bytes nil)) (should (jabber-image--size-ok-p (make-string 100000 ?x))))) (ert-deftest jabber-test-image-size-ok-p-enforces-limit () (let ((jabber-image-max-bytes 10)) (should (jabber-image--size-ok-p "123456789")) (should (jabber-image--size-ok-p "1234567890")) (should-not (jabber-image--size-ok-p "12345678901")))) ;;; Type allowlist (ert-deftest jabber-test-image-type-ok-p-detects-png () (should (jabber-image--type-ok-p jabber-test-image--png-bytes '(png))) (should-not (jabber-image--type-ok-p jabber-test-image--png-bytes '(jpeg)))) (ert-deftest jabber-test-image-type-ok-p-detects-gif () (should (jabber-image--type-ok-p jabber-test-image--gif-bytes '(gif png))) (should-not (jabber-image--type-ok-p jabber-test-image--gif-bytes '(png)))) (ert-deftest jabber-test-image-type-ok-p-nil-allows-any () (should (jabber-image--type-ok-p jabber-test-image--png-bytes nil)) (should (jabber-image--type-ok-p "not an image at all" nil))) ;;; jabber-image-from-data (defmacro jabber-test-image--with-fake-create (&rest body) "Run BODY with `jabber-image-create' stubbed to a recorder. Binds `calls' to the list of DATA arguments received." `(let ((calls nil)) (cl-letf (((symbol-function 'jabber-image-create) (lambda (data &rest _) (push data calls) (list 'image :type 'png)))) ,@body))) (ert-deftest jabber-test-image-from-data-respects-size-cap () (jabber-test-image--with-fake-create (let ((jabber-image-max-bytes 4)) (should-not (jabber-image-from-data jabber-test-image--png-bytes)) (should (null calls))))) (ert-deftest jabber-test-image-from-data-respects-allowlist () (jabber-test-image--with-fake-create (let ((jabber-image-max-bytes nil)) (should-not (jabber-image-from-data jabber-test-image--png-bytes '(jpeg))) (should (null calls))))) (ert-deftest jabber-test-image-from-data-nil-allowlist-decodes () (jabber-test-image--with-fake-create (let ((jabber-image-max-bytes nil)) (should (equal (jabber-image-from-data jabber-test-image--png-bytes) '(image :type png))) (should (equal calls (list jabber-test-image--png-bytes)))))) (ert-deftest jabber-test-image-from-data-nil-data-returns-nil () (jabber-test-image--with-fake-create (should-not (jabber-image-from-data nil)) (should (null calls)))) (ert-deftest jabber-test-image-from-data-decode-error-returns-nil () (cl-letf (((symbol-function 'jabber-image-create) (lambda (&rest _) (error "boom")))) (let ((jabber-image-max-bytes nil)) (should-not (jabber-image-from-data jabber-test-image--png-bytes))))) (ert-deftest jabber-test-image-result-retains-data-on-decode-error () "A decode failure keeps bytes available for a manual save fallback." (cl-letf (((symbol-function 'jabber-image-create) (lambda (&rest _) (error "Invalid image type ‘heic’")))) (let* ((jabber-image-max-bytes nil) (data "unsupported-image-bytes") (result (jabber-image--result-from-data data nil))) (should (eq (plist-get result :error) 'decode)) (should (equal (plist-get result :data) data)) (should-not (plist-get result :image))))) ;;; Response body extraction (ert-deftest jabber-test-image-response-body-extracts-bytes () (with-temp-buffer (insert "HTTP/1.1 200 OK\r\nContent-Type: image/png\r\n\r\nBODY") (should (equal (jabber-image--response-body) "BODY")))) (ert-deftest jabber-test-image-response-body-nil-without-separator () (with-temp-buffer (insert "HTTP/1.1 200 OK") (should-not (jabber-image--response-body)))) (provide 'jabber-test-image) ;;; jabber-test-image.el ends here emacs-jabber-0.13.1/tests/jabber-test-keepalive.el000066400000000000000000000162271523531702000217460ustar00rootroot00000000000000;;; jabber-test-keepalive.el --- Tests for jabber-keepalive -*- lexical-binding: t; -*- ;;; Commentary: ;; Keepalive timer lifecycle. ;;; Code: (require 'cl-lib) (require 'ert) (require 'jabber-keepalive) (defun jabber-test-keepalive--mock-timer-p (object) "Return non-nil when OBJECT is a mock keepalive timer." (and (consp object) (eq (car object) 'mock-timer))) (ert-deftest jabber-test-keepalive-do-replaces-timeout-timer () "Rearming keepalive cancels the previous timeout timer." (let ((jabber-connections '(first second)) (jabber-keepalive-timeout-timer nil) (jabber-keepalive-pending nil) (live-timers nil) (cancelled-timers nil) (next-timer-id 0)) (cl-letf (((symbol-function 'run-with-timer) (lambda (&rest _args) (let ((timer (list 'mock-timer (cl-incf next-timer-id)))) (push timer live-timers) timer))) ((symbol-function 'cancel-timer) (lambda (timer) (setq live-timers (delq timer live-timers)) (push timer cancelled-timers))) ((symbol-function 'timerp) #'jabber-test-keepalive--mock-timer-p) ((symbol-function 'jabber-ping-send) #'ignore)) (jabber-keepalive-do) (let ((first-timer jabber-keepalive-timeout-timer)) (jabber-keepalive-do) (should (equal cancelled-timers (list first-timer))) (should (= (length live-timers) 1)) (should (eq (car live-timers) jabber-keepalive-timeout-timer)) (should-not (eq first-timer jabber-keepalive-timeout-timer)))))) (ert-deftest jabber-test-keepalive-start-clears-previous-round () "Restarting keepalive clears timers and pending state from the old round." (let* ((recurring-timer (list 'mock-timer 'recurring)) (timeout-timer (list 'mock-timer 'timeout)) (replacement-timer (list 'mock-timer 'replacement)) (jabber-keepalive-timer recurring-timer) (jabber-keepalive-timeout-timer timeout-timer) (jabber-keepalive-pending '(stale)) (jabber-post-disconnect-hook nil) (cancelled-timers nil)) (cl-letf (((symbol-function 'run-with-timer) (lambda (&rest _args) replacement-timer)) ((symbol-function 'cancel-timer) (lambda (timer) (push timer cancelled-timers))) ((symbol-function 'timerp) #'jabber-test-keepalive--mock-timer-p)) (jabber-keepalive-start) (should (eq jabber-keepalive-timer replacement-timer)) (should (null jabber-keepalive-timeout-timer)) (should (null jabber-keepalive-pending)) (should (equal cancelled-timers (list timeout-timer recurring-timer)))))) (ert-deftest jabber-test-keepalive-start-clears-timeout-without-recurring-timer () "Restarting keepalive clears a stale round without a recurring timer." (let* ((timeout-timer (list 'mock-timer 'timeout)) (replacement-timer (list 'mock-timer 'replacement)) (jabber-keepalive-timer nil) (jabber-keepalive-timeout-timer timeout-timer) (jabber-keepalive-pending '(stale)) (jabber-post-disconnect-hook nil) (cancelled-timers nil)) (cl-letf (((symbol-function 'run-with-timer) (lambda (&rest _args) replacement-timer)) ((symbol-function 'cancel-timer) (lambda (timer) (push timer cancelled-timers))) ((symbol-function 'timerp) #'jabber-test-keepalive--mock-timer-p)) (jabber-keepalive-start) (should (eq jabber-keepalive-timer replacement-timer)) (should (null jabber-keepalive-timeout-timer)) (should (null jabber-keepalive-pending)) (should (equal cancelled-timers (list timeout-timer)))))) (ert-deftest jabber-test-keepalive-timeout-preserves-survivor-monitoring () "Timing out one connection keeps monitoring the surviving connection." (let* ((survivor 'survivor) (lost 'lost) (recurring-timer (list 'mock-timer 'recurring)) (jabber-connections (list survivor lost)) (jabber-keepalive-timer recurring-timer) (jabber-keepalive-timeout-timer nil) (jabber-keepalive-pending nil) (live-timers (list recurring-timer)) (cancelled-timers nil) (disconnected nil) (pings nil) (next-timer-id 0)) (cl-letf (((symbol-function 'run-with-timer) (lambda (&rest _args) (let ((timer (list 'mock-timer (cl-incf next-timer-id)))) (push timer live-timers) timer))) ((symbol-function 'cancel-timer) (lambda (timer) (setq live-timers (delq timer live-timers)) (push timer cancelled-timers))) ((symbol-function 'timerp) #'jabber-test-keepalive--mock-timer-p) ((symbol-function 'jabber-ping-send) (lambda (jc &rest _args) (push jc pings))) ((symbol-function 'fsm-get-state-data) (lambda (jc) (list :server (symbol-name jc)))) ((symbol-function 'run-hook-with-args) #'ignore) ((symbol-function 'jabber-disconnect-one) (lambda (jc &rest _args) (push jc disconnected) (setq jabber-connections (delq jc jabber-connections))))) (jabber-keepalive-do) (jabber-keepalive-got-response survivor) (setq pings nil) (jabber-keepalive-timeout) (should (eq jabber-keepalive-timer recurring-timer)) (should (memq recurring-timer live-timers)) (should-not (memq recurring-timer cancelled-timers)) (should (null jabber-keepalive-timeout-timer)) (should (null jabber-keepalive-pending)) (should (equal disconnected (list lost))) (should (equal jabber-connections (list survivor))) (jabber-keepalive-do) (should (equal pings (list survivor)))))) (ert-deftest jabber-test-keepalive-timeout-stops-without-connections () "Timing out the final connection stops the recurring timer." (let* ((lost 'lost) (recurring-timer (list 'mock-timer 'recurring)) (jabber-connections (list lost)) (jabber-keepalive-timer recurring-timer) (jabber-keepalive-timeout-timer (list 'mock-timer 'timeout)) (jabber-keepalive-pending (list lost)) (cancelled-timers nil)) (cl-letf (((symbol-function 'cancel-timer) (lambda (timer) (push timer cancelled-timers))) ((symbol-function 'fsm-get-state-data) (lambda (_jc) (list :server "lost"))) ((symbol-function 'run-hook-with-args) #'ignore) ((symbol-function 'jabber-disconnect-one) (lambda (jc &rest _args) (setq jabber-connections (delq jc jabber-connections))))) (jabber-keepalive-timeout) (should (null jabber-connections)) (should (null jabber-keepalive-timer)) (should (null jabber-keepalive-timeout-timer)) (should (null jabber-keepalive-pending)) (should (equal cancelled-timers (list recurring-timer)))))) (provide 'jabber-test-keepalive) ;;; jabber-test-keepalive.el ends here emacs-jabber-0.13.1/tests/jabber-test-mam.el000066400000000000000000001766631523531702000205660ustar00rootroot00000000000000;;; jabber-test-mam.el --- Tests for jabber-mam -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0313 Message Archive Management. ;;; Code: (require 'ert) (require 'jabber-db) (require 'jabber-disco) (require 'jabber-chat) (require 'jabber-muc) (require 'jabber-mam) (require 'jabber-core) (require 'jabber-message-correct) (require 'jabber-omemo-store) ;;; Test infrastructure (defmacro jabber-test-mam-with-db (&rest body) "Run BODY with a fresh temp SQLite database." (declare (indent 0) (debug t)) `(let* ((jabber-test-mam--dir (make-temp-file "jabber-mam-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-test-mam--dir)) (jabber-db--connection nil)) (unwind-protect (progn (jabber-db-ensure-open) ,@body) (jabber-db-close) (when (file-directory-p jabber-test-mam--dir) (delete-directory jabber-test-mam--dir t))))) (defvar jabber-test-mam-queryid "test-query" "Default query ID used in test MAM stanzas.") (defun jabber-test-mam--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-test-mam-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-test-mam--without-delay (stanza) "Return a copy of MAM result STANZA without its delay element." (let* ((copy (copy-tree stanza)) (result (jabber-xml-child-with-xmlns copy jabber-mam-xmlns)) (forwarded (car (jabber-xml-get-children result 'forwarded)))) (setcdr (cdr forwarded) (cl-remove-if (lambda (child) (eq (jabber-xml-node-name child) 'delay)) (jabber-xml-node-children forwarded))) copy)) (defun jabber-test-mam--make-correction-message (archive-id stanza-id replace-id from body) "Build a fake MAM correction stanza. ARCHIVE-ID and STANZA-ID identify the archived correction. REPLACE-ID is the original message id. FROM is the correction sender." `(message ((from . "me@example.com")) (result ((xmlns . ,jabber-mam-xmlns) (queryid . ,jabber-test-mam-queryid) (id . ,archive-id)) (forwarded ((xmlns . ,jabber-mam-forward-xmlns)) (delay ((xmlns . ,jabber-mam-delay-xmlns) (stamp . "2025-01-01T00:00:00Z"))) (message ((from . ,from) (to . "me@example.com") (id . ,stanza-id)) (body () ,body) (replace ((id . ,replace-id) (xmlns . ,jabber-message-correct-xmlns)))))))) (defun jabber-test-mam--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-test-mam--make-fake-jc (account) "Create a fake connection symbol for ACCOUNT." (let ((jc (gensym "jabber-test-mam-jc-")) (parts (split-string account "@"))) (put jc :state-data (list :username (nth 0 parts) :server (nth 1 parts))) jc)) ;;; Group 0: Hook defaults (ert-deftest jabber-test-mam-post-connect-hook-default () "MAM catch-up is enabled for fresh connections by default." (should (memq 'jabber-mam-maybe-catchup jabber-post-connect-hooks)) (should (memq 'jabber-mam-maybe-catchup (get 'jabber-post-connect-hooks 'custom-options))) (should (memq 'jabber-mam-maybe-catchup jabber-post-resume-hooks)) (should (memq 'jabber-mam-maybe-catchup (get 'jabber-post-resume-hooks 'custom-options)))) (ert-deftest jabber-test-mam-chat-opened-coalesces-peer-sync () "Repeated chat opens share one peer MAM catch-up." (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (peer "friend@example.com") (jabber-mam-enable t) (jabber-mam--peer-syncing nil) (jabber-mam--completion-callbacks nil) disco-requests query-requests) (cl-letf (((symbol-function 'jabber-disco-get-info) (lambda (_jc _jid _node callback closure &optional _force) (push (cons callback closure) disco-requests))) ((symbol-function 'jabber-mam--query) (lambda (&rest args) (push args query-requests)))) (jabber-mam-chat-opened jc peer) (jabber-mam-chat-opened jc peer) (should (= 1 (length disco-requests))) (pcase-let ((`(,callback . ,closure) (car disco-requests))) (funcall callback jc closure (list nil (list jabber-mam-xmlns)))) (should (= 1 (length query-requests))) (jabber-mam-chat-opened jc peer) (should (= 1 (length disco-requests))) (funcall (cdar jabber-mam--completion-callbacks)) (jabber-mam-chat-opened jc peer) (should (= 2 (length disco-requests)))))) (ert-deftest jabber-test-mam-stale-disco-callback-does-not-start-query () "A disco callback from an abandoned peer sync cannot start a query." (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (peer "friend@example.com") (jabber-mam-enable t) (jabber-mam--peer-syncing nil) (jabber-mam--syncing nil) (jabber-mam--completion-callbacks nil) disco-requests query-requests) (cl-letf (((symbol-function 'jabber-disco-get-info) (lambda (_jc _jid _node callback closure &optional _force) (push (cons callback closure) disco-requests))) ((symbol-function 'jabber-mam--query) (lambda (&rest args) (push args query-requests)))) (jabber-mam-chat-opened jc peer) (let ((old-request (car disco-requests))) (jabber-mam--cleanup-connection jc) (jabber-mam-chat-opened jc peer) (pcase-let ((`(,callback . ,closure) old-request)) (funcall callback jc closure (list nil (list jabber-mam-xmlns)))) (should-not query-requests) (pcase-let ((`(,callback . ,closure) (car disco-requests))) (funcall callback jc closure (list nil (list jabber-mam-xmlns))))) (should (= 1 (length query-requests)))))) (ert-deftest jabber-test-mam-query-send-failure-runs-completion () "A synchronous query send failure runs and removes its callback." (let* ((callback-fired nil) (jabber-mam--syncing nil) (jabber-mam--query-targets nil) (jabber-mam--completion-callbacks (list (cons "failing-query" (lambda () (setq callback-fired t))))) (jabber-mam--tx-depth 0)) (cl-letf (((symbol-function 'jabber-mam--tx-begin) #'ignore) ((symbol-function 'jabber-mam--tx-end) #'ignore) ((symbol-function 'jabber-send-iq) (lambda (&rest _) (error "send failed")))) (jabber-mam--query 'jc nil "failing-query")) (should callback-fired) (should-not jabber-mam--completion-callbacks))) ;;; Group 1: Large sync (ert-deftest jabber-test-mam-large-sync () "3650 messages (10 years, 1/day) are stored and deduped correctly." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (count 3650) (jabber-mam--syncing (list (cons jc jabber-test-mam-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-test-mam--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-test-mam-dedup-resync () "Running 3650 messages twice yields exactly 3650 rows." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (count 3650) (jabber-mam--syncing (list (cons jc jabber-test-mam-queryid))) (jabber-muc-participants nil)) ;; First pass (jabber-db-with-transaction (dotimes (i count) (jabber-mam--process-message jc (jabber-test-mam--make-message i)))) ;; Second pass (re-sync) (jabber-db-with-transaction (dotimes (i count) (jabber-mam--process-message jc (jabber-test-mam--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))))))) (ert-deftest jabber-test-mam-replay-without-delay-preserves-timestamp () "A replay without a delay stamp does not make an old message new." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-test-mam-queryid))) (jabber-muc-participants nil) (stanza (jabber-test-mam--make-message 1)) (replay (jabber-test-mam--without-delay stanza)) (ids (make-hash-table :test #'equal))) (jabber-mam--process-message jc stanza) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "newer local message" 1800000000 nil nil "newer-server-id") (let ((jabber-mam--sync-received (list (cons jabber-test-mam-queryid (list :ids ids :min-ts nil :max-ts nil :account "me@example.com" :peer "friend@example.com"))))) (cl-letf (((symbol-function 'current-time) (lambda () (seconds-to-time 1800000000)))) (jabber-mam--process-message jc replay)) (should (equal '((1700086400)) (sqlite-select jabber-db--connection "SELECT timestamp FROM message WHERE server_id = ?" '("archive-000001")))) (let ((sync-data (cdr (car jabber-mam--sync-received)))) (should-not (plist-get sync-data :min-ts)) (should-not (plist-get sync-data :max-ts))) (jabber-mam--reconcile-sync jabber-test-mam-queryid) (should (sqlite-select jabber-db--connection "SELECT 1 FROM message WHERE server_id = ?" '("newer-server-id"))))))) (ert-deftest jabber-test-mam-preserves-archived-thread-fields () "A MAM result stores XEP-0201 metadata from the forwarded stanza." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-test-mam-queryid))) (jabber-muc-participants nil) (stanza (jabber-test-mam--make-message 1)) (result (jabber-xml-child-with-xmlns stanza jabber-mam-xmlns)) (forwarded (car (jabber-xml-get-children result 'forwarded))) (inner (car (jabber-xml-get-children forwarded 'message)))) (nconc inner '((thread ((parent . "parent-1")) "thread-1"))) (jabber-mam--process-message jc stanza) (let ((stored (car (jabber-db-thread-backlog "me@example.com" "friend@example.com" "chat" "thread-1" t)))) (should (equal "thread-1" (plist-get stored :thread-id))) (should (equal "parent-1" (plist-get stored :thread-parent-id))))))) ;;; Group 3: Transaction batching performance (ert-deftest jabber-test-mam-transaction-batching () "Batched inserts inside a transaction are faster than unbatched." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (batch-count 500) (jabber-mam--syncing (list (cons jc jabber-test-mam-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-test-mam--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))))))) (ert-deftest jabber-test-mam-encrypted-session-save-in-transaction () "An encrypted MAM message can migrate its session inside the MAM transaction." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-test-mam-queryid))) (jabber-muc-participants nil) (stanza (jabber-test-mam--make-message 1)) (inner (nth 2 (jabber-mam--parse-result stanza))) (envelope (unibyte-string ?J ?O ?M ?E ?M ?O 0 1 0)) (body (car (jabber-xml-get-children inner 'body)))) (setcdr (last inner) '((encrypted ((xmlns . "eu.siacs.conversations.axolotl"))))) (sqlite-execute jabber-db--connection "\ INSERT INTO omemo_skipped_keys (account, jid, device_id, dh_key, message_number, message_key, created_at) VALUES ('me@example.com', 'friend@example.com', 7, 'dh', 3, 'mk', 0)") (sqlite-execute jabber-db--connection "BEGIN") (cl-letf (((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc message) (jabber-omemo-store-save-session-and-clear-legacy-keys "me@example.com" "friend@example.com" 7 envelope) (setcdr (cdr body) '("decrypted")) message))) (jabber-mam--process-message jc stanza)) (sqlite-execute jabber-db--connection "COMMIT") (should (equal envelope (jabber-omemo-store-load-session "me@example.com" "friend@example.com" 7))) (should-not (jabber-omemo-store-all-skipped-keys "me@example.com" "friend@example.com" 7)) (should (equal "decrypted" (caar (sqlite-select jabber-db--connection "\ SELECT body FROM message WHERE stanza_id = 'stanza-000001'"))))))) (ert-deftest jabber-test-mam-decrypts-without-message-noise () "Archived decryption does not write per-message diagnostics." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-test-mam-queryid))) (jabber-muc-participants nil) (stanza (jabber-test-mam--make-message 1)) message-settings) (cl-letf (((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc message) (setq message-settings (list inhibit-message message-log-max)) message))) (jabber-mam--process-message jc stanza)) (should (equal '(t nil) message-settings))))) ;;; Group 4: Parse helpers (ert-deftest jabber-test-mam-parse-result () "jabber-mam--parse-result extracts archive-id, stamp, and inner message." (let* ((xml (jabber-test-mam--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-test-mam-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-test-mam-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-test-mam-valid-sender-accepts-query-room () "MUC MAM results are valid only from the room targeted by QUERYID." (let ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--query-targets '(("muc-query" . "room-a@muc")))) (should (jabber-mam--valid-sender-p jc "room-a@muc/nick" "muc-query")))) (ert-deftest jabber-test-mam-valid-sender-accepts-one-shot-query-room () "A one-shot marker does not hide the MUC query target." (let ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--query-targets '(("muc-query" . one-shot) ("muc-query" . "room-a@muc")))) (should (jabber-mam--valid-sender-p jc "room-a@muc/nick" "muc-query")))) (ert-deftest jabber-test-mam-valid-sender-rejects-other-joined-room () "MUC MAM results from another joined room do not match QUERYID." (let ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--query-targets '(("muc-query" . "room-a@muc"))) (jabber-muc--rooms (make-hash-table :test #'equal))) (puthash "room-b@muc" (list (cons jc "nick")) jabber-muc--rooms) (should-not (jabber-mam--valid-sender-p jc "room-b@muc/nick" "muc-query")))) (ert-deftest jabber-test-mam-valid-sender-accepts-own-archive () "User archive MAM results are valid from the account bare JID." (let ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--query-targets nil)) (should (jabber-mam--valid-sender-p jc "me@example.com" "user-query")))) (ert-deftest jabber-test-mam-parse-fin-incomplete () "jabber-mam--parse-fin returns :complete nil when not complete." (let* ((xml (jabber-test-mam--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-test-mam-parse-fin-complete () "jabber-mam--parse-fin returns :complete t when archive is exhausted." (let* ((xml (jabber-test-mam--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-test-mam-tx-depth-single-query () "Single query cycle: depth goes 0 -> 1 -> 0, transaction commits." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--tx-depth 0) (jabber-mam--syncing (list (cons jc jabber-test-mam-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-test-mam--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-test-mam-tx-depth-concurrent-queries () "Concurrent queries share one transaction: depth 0 -> 1 -> 2 -> 1 -> 0." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--tx-depth 0) (jabber-mam--syncing (list (cons jc jabber-test-mam-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-test-mam--make-message 0)) (jabber-mam--process-message jc (jabber-test-mam--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-test-mam-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-test-mam--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-test-mam-muc-message-storage () "MUC messages from MAM are stored with correct peer and type." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--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-test-mam--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-test-mam-muc-direction-detection () "MUC MAM detects outgoing messages by matching our nickname." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--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-test-mam--make-muc-message 0 room "mynick")) ; from us (idx%3=0) (jabber-mam--process-message jc (jabber-test-mam--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-test-mam-mark-dirty-dedup () "jabber-mam--mark-dirty does not add the same peer twice." (let ((jabber-mam--dirty-peers nil)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (jc) (symbol-name jc)))) (jabber-mam--mark-dirty 'account-a "peer@example.com" "chat") (jabber-mam--mark-dirty 'account-a "peer@example.com" "chat") (jabber-mam--mark-dirty 'account-b "peer@example.com" "chat") (should (= 2 (length jabber-mam--dirty-peers))) (should (member '("account-a" "peer@example.com" "chat") jabber-mam--dirty-peers)) (should (member '("account-b" "peer@example.com" "chat") jabber-mam--dirty-peers))))) (ert-deftest jabber-test-mam-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-test-mam-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-test-mam-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-test-mam-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-test-mam-reconcile-deletes-orphan-messages () "Reconciliation deletes local messages whose IDs are not in the remote set." (jabber-test-mam-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-test-mam-reconcile-keeps-messages-without-ids () "Reconciliation keeps local messages that have no stanza_id or server_id." (jabber-test-mam-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-test-mam-reconcile-prunes-empty-thread () "Reconciliation removes thread metadata after its last message is deleted." (jabber-test-mam-with-db (let ((account "me@example.com") (peer "friend@example.com")) (jabber-db-store-message account peer "in" "chat" "root" 1700000100 "phone" "root-1" "server-root" nil nil nil nil '(:thread-id "thread-1")) (jabber-db-register-message-thread account peer "chat" "thread-1" nil "root-1" "server-root" 1700000100) (jabber-db-store-message account peer "in" "chat" "reply" 1700000100 "phone" "reply-1" "server-reply" nil nil nil nil '(:thread-id "thread-1")) (jabber-db-store-message account peer "in" "chat" "kept" 1700000100 "phone" "kept-1" "server-kept") (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 "server-kept" t ids) (jabber-mam--reconcile-sync "test-q") (should-not (jabber-db-message-thread-known-p account peer "chat" "thread-1")))))) (ert-deftest jabber-test-mam-reconcile-keeps-rootless-thread-with-reply () "Reconciliation retains thread metadata while a reply survives." (jabber-test-mam-with-db (let ((account "me@example.com") (peer "friend@example.com")) (jabber-db-store-message account peer "in" "chat" "root" 1700000100 "phone" "root-1" "server-root" nil nil nil nil '(:thread-id "thread-1")) (jabber-db-register-message-thread account peer "chat" "thread-1" nil "root-1" "server-root" 1700000100) (jabber-db-store-message account peer "in" "chat" "reply" 1700000100 "phone" "reply-1" "server-reply" nil nil nil nil '(:thread-id "thread-1")) (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 "server-reply" t ids) (jabber-mam--reconcile-sync "test-q") (should (jabber-db-message-thread-known-p account peer "chat" "thread-1")) (should (= 1 (plist-get (jabber-db-message-thread-summary account peer "chat" "thread-1") :reply-count))))))) (ert-deftest jabber-test-mam-reconcile-noop-when-empty () "Reconciliation is a no-op when no messages were received." (jabber-test-mam-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-test-mam-reconcile-uses-stanza-id-too () "Reconciliation matches on stanza_id when server_id is absent." (jabber-test-mam-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-test-mam-process-message-tracks-ids () "process-message accumulates IDs and timestamps for sync tracking." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (ids (make-hash-table :test #'equal)) (jabber-mam--sync-received (list (cons jabber-test-mam-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-test-mam-queryid))) (jabber-mam--tx-depth 1) (jabber-muc-participants nil)) ;; Process two messages (jabber-mam--process-message jc (jabber-test-mam--make-message 0)) (jabber-mam--process-message jc (jabber-test-mam--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-test-mam-correction-from-original-sender-updates-db () "Archived XEP-0308 correction from the original sender updates storage." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-test-mam-queryid))) (jabber-mam--tx-depth 1) (jabber-muc-participants nil)) (jabber-mam--process-message jc (jabber-test-mam--make-message 1)) (jabber-mam--process-message jc (jabber-test-mam--make-correction-message "archive-correction-1" "correction-1" "stanza-000001" "friend@example.com/other-resource" "Corrected body")) (let ((row (car (sqlite-select (jabber-db-ensure-open) "SELECT body, edited FROM message \ WHERE stanza_id = 'stanza-000001'")))) (should (equal '("Corrected body" 1) row)))))) (ert-deftest jabber-test-mam-correction-from-wrong-sender-rejected () "Archived XEP-0308 correction from another sender does not update storage." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-test-mam-queryid))) (jabber-mam--tx-depth 1) (jabber-muc-participants nil)) (jabber-mam--process-message jc (jabber-test-mam--make-message 1)) (jabber-mam--process-message jc (jabber-test-mam--make-correction-message "archive-correction-2" "correction-2" "stanza-000001" "mallory@example.com/resource" "Forged body")) (let ((row (car (sqlite-select (jabber-db-ensure-open) "SELECT body, edited FROM message \ WHERE stanza_id = 'stanza-000001'")))) (should (equal '("Message 1" 0) row)))))) (ert-deftest jabber-test-mam-undecryptable-correction-preserves-plaintext () "An archived correction decrypt failure never replaces stored plaintext." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-test-mam-queryid))) (jabber-mam--tx-depth 1) (jabber-muc-participants nil) (correction (jabber-test-mam--make-correction-message "archive-correction-failed" "correction-failed" "stanza-000001" "friend@example.com/phone" "OMEMO encrypted message")) messages) (jabber-mam--process-message jc (jabber-test-mam--make-message 1)) (cl-letf (((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc inner) (jabber-chat--set-body inner "[OMEMO: could not decrypt]"))) ((symbol-function 'message) (lambda (format-string &rest args) (push (apply #'format format-string args) messages)))) (jabber-mam--process-message jc correction)) (should-not (cl-find-if (lambda (text) (string-prefix-p "XEP-0308:" text)) messages)) (should (equal '(("Message 1" 0)) (sqlite-select (jabber-db-ensure-open) "SELECT body, edited FROM message \ WHERE stanza_id = 'stanza-000001'")))))) (ert-deftest jabber-test-mam-cleanup-all-commits-transaction () "cleanup-all commits open transaction and resets state." (jabber-test-mam-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--peer-syncing '(((jc1 "one@example.com") . token-1) ((jc2 "two@example.com") . token-2))) (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) (should-not jabber-mam--peer-syncing) ;; 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-test-mam-cleanup-connection-scoped () "cleanup-connection only removes entries for the given connection." (jabber-test-mam-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--peer-syncing '(((jc1 "one@example.com") . token-1) ((jc2 "two@example.com") . token-2))) (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) (should (equal '(((jc2 "two@example.com") . token-2)) jabber-mam--peer-syncing))))) (ert-deftest jabber-test-mam-cleanup-triggers-redisplay () "cleanup-all redraws dirty buffers." (jabber-test-mam-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-test-mam-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-test-mam-body-stanza-stripped () "Body-bearing MAM result has children stripped after processing." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-test-mam-queryid))) (jabber-mam--tx-depth 1) (jabber-chat--crypto-loaded t) (stanza (jabber-test-mam--make-message 1))) (jabber-mam--process-message jc stanza) (should-not (cddr stanza))))) (ert-deftest jabber-test-mam-reaction-reply-fallback-not-stored () "Conversations reaction fallback from MAM is not stored as chat text." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-test-mam-queryid))) (jabber-mam--tx-depth 1) (jabber-chat--crypto-loaded t) (quote "Δύο άτομα δίνουν πόνο έξω") (body (concat "> " quote "\n👍")) (stanza `(message ((from . "me@example.com")) (result ((xmlns . ,jabber-mam-xmlns) (queryid . ,jabber-test-mam-queryid) (id . "archive-reaction-1")) (forwarded ((xmlns . ,jabber-mam-forward-xmlns)) (delay ((xmlns . ,jabber-mam-delay-xmlns) (stamp . "2026-06-07T06:25:31Z"))) (message ((from . "me@example.com/Conversations") (to . "som@yax.im") (type . "chat")) (reactions ((xmlns . ,jabber-reactions-xmlns) (id . "target-1")) (reaction nil "👍")) (store ((xmlns . "urn:xmpp:hints"))) (reply ((xmlns . "urn:xmpp:reply:0") (to . "som@yax.im/Conversations") (id . "target-1"))) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . "urn:xmpp:reply:0")) (body ((start . "0") (end . "30")))) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . ,jabber-reactions-xmlns)) (body nil)) (body nil ,body))))))) (jabber-mam--process-message jc stanza) (should-not (sqlite-select (jabber-db-ensure-open) "SELECT body FROM message WHERE server_id = ?" '("archive-reaction-1"))) (should (jabber-xml-get-attribute stanza 'jabber-mam--origin)) (should (car (jabber-xml-get-children stanza 'reactions)))))) (ert-deftest jabber-test-mam-bodyless-stanza-unwrapped () "Bodyless MAM result is unwrapped with original sender and MAM marker." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-test-mam-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-test-mam-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)) ;; Archive id is needed by downstream tombstone handlers. (should (equal "archive-001" (jabber-xml-get-attribute stanza 'jabber-mam--archive-id))) ;; The receipt element should be a child (should (car (jabber-xml-get-children stanza 'received)))))) ;;; Group 9: query ID validation (ert-deftest jabber-test-mam-unknown-queryid-rejected () "MAM result with unknown queryid is not processed." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--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-test-mam-known-queryid-accepted () "MAM result with known queryid is processed normally." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--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-test-mam-error-callback-transferred () "item-not-found fallback transfers callback to new query." (jabber-test-mam-with-db (sqlite-execute (jabber-db-ensure-open) "BEGIN") (let* ((jc (jabber-test-mam--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-test-mam-rejects-foreign-sender () "MAM result from a server other than ours is rejected." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-test-mam-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-test-mam-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-test-mam-accepts-own-jid-sender () "MAM result from our own bare JID is accepted." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--syncing (list (cons jc jabber-test-mam-queryid))) (jabber-mam--tx-depth 1) (jabber-chat--crypto-loaded t) ;; Normal 1:1 MAM result with from=our bare JID (stanza (jabber-test-mam--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-test-mam-accepts-joined-muc-sender () "MAM result from a joined MUC room is accepted." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (room "room@conference.example.com") (jabber-mam--syncing (list (cons jc "muc-query"))) (jabber-mam--query-targets (list (cons "muc-query" room))) (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-test-mam-cancel-muc-query () "Cancelling a MUC MAM query removes it from active state." (jabber-test-mam-with-db (sqlite-execute (jabber-db-ensure-open) "BEGIN") (let* ((jc (jabber-test-mam--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-test-mam-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-test-mam) ;;; jabber-test-mam.el ends here emacs-jabber-0.13.1/tests/jabber-test-menu.el000066400000000000000000000071131523531702000207370ustar00rootroot00000000000000;;; jabber-test-menu.el --- Tests for jabber-menu -*- lexical-binding: t; -*- ;;; Commentary: ;; Keymap popup menu structure. ;;; Code: (require 'ert) (require 'jabber-bookmarks) (require 'jabber-chat-commands) (require 'jabber-disco-menu) (require 'jabber-keymap) (require 'jabber-muc-menu) (require 'jabber-omemo-trust) (require 'jabber-roster-menu) ;;; Helpers (defun jabber-test-menu--extract-popup-commands (keymap) "Extract jabber command symbols bound in KEYMAP. Only returns symbols with a `jabber-' prefix, skipping inherited bindings from parent mode keymaps." (let (commands) (map-keymap (lambda (_key binding) (when (and (symbolp binding) (string-prefix-p "jabber-" (symbol-name binding))) (push binding commands))) keymap) commands)) ;;; Tests (ert-deftest jabber-test-menu-popup-commands-defined () "Every command in a jabber popup keymap must be fboundp." (let ((maps (list jabber-common-keymap jabber-global-keymap jabber-chat-operations-menu-map jabber-chat-encryption-menu-map jabber-roster-popup-map jabber-roster-presence-map jabber-roster-discovery-map jabber-roster-contact-action-map jabber-info-menu-map jabber-muc-menu-map jabber-service-menu-map jabber-bookmarks-mode-map jabber-bookmarks-edit-map jabber-omemo-trust-mode-map)) (missing nil)) (dolist (map maps) (dolist (cmd (jabber-test-menu--extract-popup-commands map)) (unless (fboundp cmd) (push (format "%s" cmd) missing)))) (should (null missing)))) (ert-deftest jabber-test-menu-global-bindings () "Expose every global Jabber command through its prefix map." (dolist (binding '(("C-c" . jabber-connect-all) ("C-d" . jabber-disconnect) ("C-r" . jabber-roster-popup) ("C-j" . jabber-chat-with) ("C-l" . jabber-activity-switch-to) ("C-a" . jabber-send-away-presence) ("C-o" . jabber-send-default-presence) ("C-x" . jabber-send-xa-presence) ("C-p" . jabber-send-presence) ("C-b" . jabber-chat-buffer-switch) ("C-m" . jabber-muc-join))) (should (eq (keymap-lookup jabber-global-keymap (car binding)) (cdr binding)))) (should-not (keymap-lookup jabber-global-keymap "C-g"))) (ert-deftest jabber-test-menu-thread-commands () "Expose thread roots in the menu and keep normal thread sending on RET." (should (eq (keymap-lookup jabber-chat-operations-menu-map "t") 'jabber-message-thread-open)) (should (eq (keymap-lookup jabber-chat-operations-menu-map "T") 'jabber-message-thread-start)) (should (eq (keymap-lookup jabber-chat-operations-menu-map "l") 'jabber-message-thread-browse)) (let ((jabber-message-thread-id nil)) (should-not (keymap-lookup jabber-chat-operations-menu-map "L"))) (let ((jabber-message-thread-id "thread-id")) (should (eq (keymap-lookup jabber-chat-operations-menu-map "L") 'jabber-message-thread-set-title))) (should (eq (keymap-lookup jabber-chat-mode-map "C-c C-t") 'jabber-message-thread-open)) (should (eq (keymap-lookup jabber-chat-mode-map "RET") 'jabber-chat-goto-reply-target-or-send))) (provide 'jabber-test-menu) ;;; jabber-test-menu.el ends here emacs-jabber-0.13.1/tests/jabber-test-message-correct.el000066400000000000000000001624551523531702000230710ustar00rootroot00000000000000;;; jabber-test-message-correct.el --- Tests for jabber-message-correct -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0308 Last Message Correction. ;;; Code: (require 'ert) (require 'ewoc) (require 'jabber-xml) (require 'jabber-db) (require 'jabber-chatbuffer) (require 'jabber-message-correct) ;; 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-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-replace-id-missing-id () "Correction element without id is ignored." (let ((stanza `(message ((from . "alice@example.com") (id . "msg-2")) (body () "hello corrected") (replace ((xmlns . ,jabber-message-correct-xmlns)))))) (should-not (jabber-message-correct--replace-id stanza)))) (ert-deftest jabber-test-message-correct-replace-id-self-reference () "Correction element that references its own stanza id is ignored." (let ((stanza `(message ((from . "alice@example.com") (id . "msg-2")) (body () "hello corrected") (replace ((id . "msg-2") (xmlns . ,jabber-message-correct-xmlns)))))) (should-not (jabber-message-correct--replace-id stanza)))) (ert-deftest jabber-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-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))) (ert-deftest jabber-test-message-correct-valid-sender-muc-same-occupant-id () "MUC: same occupant-id allows correction even if resource changed." (should (jabber-message-correct--valid-sender-p "room@muc.example.com/alice" "room@muc.example.com/alice2" t "occ-1" "occ-1"))) (ert-deftest jabber-test-message-correct-valid-sender-muc-different-occupant-id () "MUC: different occupant-id rejects correction even if resource matches." (should-not (jabber-message-correct--valid-sender-p "room@muc.example.com/alice" "room@muc.example.com/alice" t "occ-1" "occ-2"))) ;;; Group 3: DB integration (ert-deftest jabber-test-message-correct-db-correct-message () "jabber-db-correct-message updates body and sets edited=1." (jabber-test-message-correct-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-test-message-correct-db-row-to-plist-edited () "jabber-db--row-to-plist returns :edited t for edited messages." (jabber-test-message-correct-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-test-message-correct-db-correct-unknown-id () "jabber-db-correct-message is a no-op for unknown stanza-id." (jabber-test-message-correct-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-test-message-correct-db-unedited-returns-nil () "Unedited message returns :edited nil via jabber-db--row-to-plist." (jabber-test-message-correct-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)))))) (ert-deftest jabber-test-message-correct-db-candidates-are-conversation-scoped () "Correction candidates never cross account or peer boundaries." (jabber-test-message-correct-with-db (dolist (row '(("me-a@example.com" "friend@example.com" "one") ("me-b@example.com" "friend@example.com" "two") ("me-a@example.com" "other@example.com" "three"))) (jabber-db-store-message (nth 0 row) (nth 1 row) "in" "chat" (nth 2 row) (floor (float-time)) nil "shared-id")) (let ((candidates (jabber-db-message-correction-candidates "me-a@example.com" "friend@example.com" "shared-id"))) (should (= 1 (length candidates))) (should (equal "friend@example.com" (plist-get (car candidates) :from)))))) (ert-deftest jabber-test-message-correct-db-outgoing-muc-candidate-keeps-nick () "An outgoing MUC candidate uses its full room JID as sender." (jabber-test-message-correct-with-db (jabber-db-store-message "me@example.com" "room@conference.example.com" "out" "groupchat" "Hello" (floor (float-time)) "my-nick" "muc-message-1") (let ((candidates (jabber-db-message-correction-candidates "me@example.com" "room@conference.example.com" "muc-message-1"))) (should (= 1 (length candidates))) (should (equal "room@conference.example.com/my-nick" (plist-get (car candidates) :from)))))) (ert-deftest jabber-test-message-correct-db-outgoing-chat-candidate-keeps-account () "An outgoing direct-chat candidate uses its account JID as sender." (jabber-test-message-correct-with-db (jabber-db-store-message "me@example.com" "friend@example.com" "out" "chat" "Hello" (floor (float-time)) nil "chat-message-1") (let ((candidates (jabber-db-message-correction-candidates "me@example.com" "friend@example.com" "chat-message-1"))) (should (= 1 (length candidates))) (should (equal "me@example.com" (plist-get (car candidates) :from)))))) (ert-deftest jabber-test-message-correct-db-update-targets-one-row () "Correction updates the selected primary row only." (jabber-test-message-correct-with-db (dotimes (i 2) (jabber-db-store-message "me@example.com" "room@conference.example.com" "in" "groupchat" (format "body-%d" i) (+ (floor (float-time)) i) (if (zerop i) "alice" "bob") "shared-id")) (let* ((rows (jabber-db-message-correction-candidates "me@example.com" "room@conference.example.com" "shared-id")) (alice (seq-find (lambda (row) (equal (plist-get row :from) "room@conference.example.com/alice")) rows))) (jabber-db-correct-message-row (plist-get alice :row-id) "fixed") (should (equal '(("fixed" 1) ("body-1" 0)) (sqlite-select jabber-db--connection "SELECT body, edited FROM message ORDER BY id")))))) (ert-deftest jabber-test-message-correct-db-unscoped-update-rejects-collision () "The compatibility update refuses an ambiguous global stanza ID." (jabber-test-message-correct-with-db (dolist (account '("me-a@example.com" "me-b@example.com")) (jabber-db-store-message account "friend@example.com" "in" "chat" account (floor (float-time)) nil "shared-id")) (jabber-db-correct-message "shared-id" "unsafe") (should (equal '(("me-a@example.com" 0) ("me-b@example.com" 0)) (sqlite-select jabber-db--connection "SELECT body, edited FROM message ORDER BY account"))))) ;;; Group 4: ewoc apply correction (ert-deftest jabber-test-message-correct-apply-updates-ewoc () "jabber-message-correct--apply updates body and edited in the ewoc node, and writes DB." (jabber-test-message-correct-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-test-message-correct-apply-drops-undecryptable-body () "A correction whose body failed to decrypt is dropped entirely (issue #134)." (jabber-test-message-correct-with-ewoc (let ((msg (list :id "orig-dec-1" :from "alice@example.com/phone" :body "original plaintext" :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)))) (should-not (jabber-message-correct--apply "orig-dec-1" "[OMEMO: could not decrypt]" "alice@example.com/phone" nil (current-buffer)))) (should-not db-called) (let* ((node (jabber-chat-ewoc-find-by-id "orig-dec-1")) (msg (cadr (ewoc-data node)))) (should (equal "original plaintext" (plist-get msg :body))) (should-not (plist-get msg :edited)))))) (ert-deftest jabber-test-message-correct-apply-rejects-wrong-sender () "jabber-message-correct--apply rejects correction from wrong sender." (jabber-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-apply-muc-same-occupant-id () "MUC: correction with matching occupant-id 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-occupant-id-by-stanza-id) (lambda (_id) "occ-1")) ((symbol-function 'jabber-db-correct-message) (lambda (_id _body) (setq db-called t)))) (jabber-message-correct--apply "muc-orig-3" "corrected" "room@muc.example.com/alice2" t nil "occ-1")) (should db-called))) (ert-deftest jabber-test-message-correct-apply-muc-different-occupant-id () "MUC: correction with different occupant-id 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-occupant-id-by-stanza-id) (lambda (_id) "occ-1")) ((symbol-function 'jabber-db-correct-message) (lambda (_id _body) (setq db-called t)))) (jabber-message-correct--apply "muc-orig-4" "evil" "room@muc.example.com/alice" t nil "occ-2")) (should-not db-called))) (ert-deftest jabber-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-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 (_group &optional _jc) 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-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-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))) ;; jabber-correct-last-message runs the full send-hook chain; ;; disable storage so the DB outgoing handler cannot touch the ;; user's real database. (let ((jabber-db-path nil) (jabber-db--connection nil) 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-test-message-correct-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-test-message-correct-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-test-message-correct-nil-body-ewoc-update () "Correction with nil body updates ewoc :body to nil without error." (jabber-test-message-correct-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-test-message-correct-empty-body-accepted () "Correction with empty string body is accepted and written." (jabber-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-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-test-message-correct-edited-indicator-foreign () "jabber-chat-pp--foreign inserts \" (edited)\" when :edited is t." (jabber-test-message-correct-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-test-message-correct-no-edited-indicator-when-unedited () "jabber-chat-pp--foreign does not insert \" (edited)\" when :edited is nil." (jabber-test-message-correct-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-test-message-correct-edited-indicator-local () "jabber-chat-pp--local inserts \" (edited)\" when :edited is t." (jabber-test-message-correct-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-test-message-correct-edited-indicator-muc-foreign () "jabber-chat-pp--muc-foreign inserts \" (edited)\" when :edited is t." (jabber-test-message-correct-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-test-message-correct-edited-indicator-muc-local () "jabber-chat-pp--muc-local inserts \" (edited)\" when :edited is t." (jabber-test-message-correct-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-test-message-correct-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-test-message-correct-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)))))) ;;; Group 10: reply re-attachment on correction (ert-deftest jabber-test-message-correct-find-last-sent-returns-msg () "find-last-sent returns the msg plist as fourth element." (jabber-test-message-correct-with-ewoc (let ((msg (list :id "m-1" :body "hello" :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :local msg)) (pcase-let ((`(,_node ,id ,body ,found) (jabber-message-correct--find-last-sent jabber-chat-ewoc))) (should (equal "m-1" id)) (should (equal "hello" body)) (should (eq msg found)))))) (ert-deftest jabber-test-message-correct-reattaches-reply () "Correcting a reply re-attaches the reply and fallback elements." (jabber-test-message-correct-with-ewoc (setq-local jabber-group nil) (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-buffer-connection 'fake-jc) (let ((msg (list :id "r-1" :from "me@example.com" :body "> alice:\n> hi\nanswer" :reply-to-id "orig-1" :reply-to-jid "alice@example.com/phone" :fallback-range '(0 14) :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :local msg))) (let ((jabber-db-path nil) sent) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (_jc stanza) (setq sent stanza))) ((symbol-function 'read-string) (lambda (&rest _) "> alice:\n> hi\nbetter answer")) ((symbol-function 'jabber-db-correct-message) #'ignore)) (jabber-correct-last-message)) (should (jabber-xml-child-with-xmlns sent "urn:xmpp:message-correct:0")) (let ((reply-el (jabber-xml-child-with-xmlns sent "urn:xmpp:reply:0"))) (should reply-el) (should (equal "orig-1" (jabber-xml-get-attribute reply-el 'id))) (should (equal "alice@example.com/phone" (jabber-xml-get-attribute reply-el 'to)))) (let ((fb-el (jabber-xml-child-with-xmlns sent "urn:xmpp:fallback:0"))) (should fb-el) (should (equal "14" (jabber-xml-get-attribute (car (jabber-xml-get-children fb-el 'body)) 'end))))))) (ert-deftest jabber-test-message-correct-threaded-root-keeps-thread () "Direct and MUC root corrections retain one XEP-0201 element." (dolist (kind '(chat groupchat)) (jabber-test-message-correct-with-ewoc (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chat-encryption 'plaintext) (if (eq kind 'groupchat) (setq-local jabber-group "room@example.com") (setq-local jabber-chatting-with "alice@example.com")) (jabber-chat-ewoc-enter (list (if (eq kind 'groupchat) :muc-local :local) (list :id "root-1" :from (if (eq kind 'groupchat) "room@example.com/me" "me@example.com") :body "root" :thread-id "thread-1" :thread-parent-id "parent-1" :timestamp (current-time)))) (let ((jabber-db-path nil) sent) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.com")) ((symbol-function 'read-string) (lambda (&rest _) "corrected root")) ((symbol-function 'jabber-send-sexp) (lambda (_jc stanza &rest _) (setq sent stanza)))) (jabber-correct-last-message)) (let ((threads (jabber-xml-get-children sent 'thread))) (should (= 1 (length threads))) (should (equal "thread-1" (car (jabber-xml-node-children (car threads))))) (should (equal "parent-1" (jabber-xml-get-attribute (car threads) 'parent)))))))) (ert-deftest jabber-test-message-correct-drops-stale-fallback () "Editing the quote away keeps the reply element but drops the range." (jabber-test-message-correct-with-ewoc (setq-local jabber-group nil) (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-buffer-connection 'fake-jc) (let ((msg (list :id "r-2" :from "me@example.com" :body "> alice:\n> hi\nanswer" :reply-to-id "orig-1" :reply-to-jid "alice@example.com/phone" :fallback-range '(0 14) :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :local msg))) (let ((jabber-db-path nil) sent) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (_jc stanza) (setq sent stanza))) ((symbol-function 'read-string) (lambda (&rest _) "answer without quote")) ((symbol-function 'jabber-db-correct-message) #'ignore)) (jabber-correct-last-message)) (should (jabber-xml-child-with-xmlns sent "urn:xmpp:reply:0")) (should-not (jabber-xml-child-with-xmlns sent "urn:xmpp:fallback:0")) (let* ((node (jabber-chat-ewoc-find-by-id "r-2")) (msg (cadr (ewoc-data node)))) (should-not (plist-get msg :fallback-range)))))) (ert-deftest jabber-test-message-correct-non-reply-adds-no-reply-element () "Correcting a plain message adds no reply or fallback elements." (jabber-test-message-correct-with-ewoc (setq-local jabber-group nil) (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-buffer-connection 'fake-jc) (let ((msg (list :id "p-1" :from "me@example.com" :body "plain" :timestamp (current-time)))) (jabber-chat-ewoc-enter (list :local msg))) (let ((jabber-db-path nil) sent) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (_jc stanza) (setq sent stanza))) ((symbol-function 'read-string) (lambda (&rest _) "plain fixed")) ((symbol-function 'jabber-db-correct-message) #'ignore)) (jabber-correct-last-message)) (should (jabber-xml-child-with-xmlns sent "urn:xmpp:message-correct:0")) (should-not (jabber-xml-child-with-xmlns sent "urn:xmpp:reply:0")) (should-not (jabber-xml-child-with-xmlns sent "urn:xmpp:fallback:0"))))) (ert-deftest jabber-test-message-correct-omemo-failure-preserves-local-state () "An asynchronous OMEMO pre-send failure leaves local history unchanged." (jabber-test-message-correct-with-ewoc (setq-local jabber-group nil) (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chat-encryption 'omemo) (let ((msg (list :id "original-1" :from "me@example.com" :body "original" :timestamp (current-time))) db-updated) (jabber-chat-ewoc-enter (list :local msg)) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "proposed correction")) ((symbol-function 'jabber-chat-send) (lambda (_jc _body _extra _success failure) (funcall failure "no recipient sessions"))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-correction-candidates) (lambda (&rest _) (list (list :row-id 1 :from "me@example.com")))) ((symbol-function 'jabber-db-correct-message-row) (lambda (&rest _) (setq db-updated t)))) (jabber-correct-last-message)) (should (equal "original" (plist-get msg :body))) (should-not (plist-get msg :edited)) (should-not db-updated)))) (ert-deftest jabber-test-message-correct-omemo-success-commits-once () "An OMEMO correction commits only from its transport-success callback." (jabber-test-message-correct-with-ewoc (setq-local jabber-group nil) (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chat-encryption 'omemo) (let ((msg (list :id "original-1" :from "me@example.com" :body "original" :timestamp (current-time))) (updates 0)) (jabber-chat-ewoc-enter (list :local msg)) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "corrected")) ((symbol-function 'jabber-chat-send) (lambda (_jc _body _extra success _failure) (funcall success))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-correction-candidates) (lambda (&rest _) (list (list :row-id 1 :from "me@example.com")))) ((symbol-function 'jabber-db-correct-message-row) (lambda (_row-id _body) (cl-incf updates)))) (jabber-correct-last-message)) (should (equal "corrected" (plist-get msg :body))) (should (plist-get msg :edited)) (should (= 1 updates))))) (ert-deftest jabber-test-message-correct-own-muc-echo-matches-stored-sender () "A locally sent MUC echo is corrected using its full stored sender." (jabber-test-message-correct-with-ewoc (setq-local jabber-group "room@conference.example.com") (setq-local jabber-chatting-with nil) (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chat-encryption 'omemo) (let ((msg (list :id "original-1" :from "room@conference.example.com/me" :body "original" :timestamp (current-time))) queried updates) (jabber-chat-ewoc-enter (list :muc-local msg)) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "corrected")) ((symbol-function 'jabber-muc-send) (lambda (_jc _body _extra success _failure) (funcall success))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-correction-candidates) (lambda (account peer id) (setq queried (list account peer id)) (list (list :row-id 7 :from "room@conference.example.com/me")))) ((symbol-function 'jabber-db-correct-message-row) (lambda (row-id body) (setq updates (list row-id body))))) (jabber-correct-last-message)) (should (equal '("me@example.com" "room@conference.example.com" "original-1") queried)) (should (equal '(7 "corrected") updates)) (should (equal "corrected" (plist-get msg :body)))))) (ert-deftest jabber-test-message-correct-omemo-late-success-after-failure-is-inert () "A stale success callback cannot commit after the send has failed." (jabber-test-message-correct-with-ewoc (setq-local jabber-group nil) (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chat-encryption 'omemo) (let ((msg (list :id "original-1" :from "me@example.com" :body "original" :timestamp (current-time))) (updates 0) success failure) (jabber-chat-ewoc-enter (list :local msg)) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "corrected")) ((symbol-function 'jabber-chat-send) (lambda (_jc _body _extra on-success on-failure) (setq success on-success failure on-failure))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-correction-candidates) (lambda (&rest _) (list (list :row-id 1 :from "me@example.com")))) ((symbol-function 'jabber-db-correct-message-row) (lambda (&rest _) (cl-incf updates)))) (jabber-correct-last-message) (funcall failure "connection reset") (funcall success)) (should (equal "original" (plist-get msg :body))) (should-not (plist-get msg :edited)) (should (= 0 updates))))) (ert-deftest jabber-test-message-correct-omemo-synchronous-error-clears-pending () "A synchronous OMEMO send error clears pending correction state." (jabber-test-message-correct-with-ewoc (setq-local jabber-group nil) (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chat-encryption 'omemo) (let ((msg (list :id "original-1" :from "me@example.com" :body "original" :timestamp (current-time))) (updates 0)) (jabber-chat-ewoc-enter (list :local msg)) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "corrected")) ((symbol-function 'jabber-chat-send) (lambda (&rest _) (error "send failed"))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-correction-candidates) (lambda (&rest _) (list (list :row-id 1 :from "me@example.com")))) ((symbol-function 'jabber-db-correct-message-row) (lambda (&rest _) (cl-incf updates)))) (should-error (jabber-correct-last-message))) (should-not jabber-message-correct--pending-outgoing) (should (equal "original" (plist-get msg :body))) (should-not (plist-get msg :edited)) (should (= 0 updates))))) (ert-deftest jabber-test-message-correct-omemo-success-after-buffer-kill-is-inert () "An OMEMO success callback cannot commit after its buffer is killed." (jabber-test-message-correct-with-ewoc (setq-local jabber-group nil) (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chat-encryption 'omemo) (let ((buffer (current-buffer)) (msg (list :id "original-1" :from "me@example.com" :body "original" :timestamp (current-time))) (updates 0) success) (jabber-chat-ewoc-enter (list :local msg)) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "corrected")) ((symbol-function 'jabber-chat-send) (lambda (_jc _body _extra on-success _on-failure) (setq success on-success))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-correction-candidates) (lambda (&rest _) (list (list :row-id 1 :from "me@example.com")))) ((symbol-function 'jabber-db-correct-message-row) (lambda (&rest _) (cl-incf updates)))) (jabber-correct-last-message) (kill-buffer buffer) (funcall success)) (should (equal "original" (plist-get msg :body))) (should-not (plist-get msg :edited)) (should (= 0 updates))))) (ert-deftest jabber-test-message-correct-omemo-duplicate-success-is-inert () "A duplicate OMEMO success callback commits only once." (jabber-test-message-correct-with-ewoc (setq-local jabber-group nil) (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chat-encryption 'omemo) (let ((msg (list :id "original-1" :from "me@example.com" :body "original" :timestamp (current-time))) (updates 0) success) (jabber-chat-ewoc-enter (list :local msg)) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "corrected")) ((symbol-function 'jabber-chat-send) (lambda (_jc _body _extra on-success _on-failure) (setq success on-success))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-correction-candidates) (lambda (&rest _) (list (list :row-id 1 :from "me@example.com")))) ((symbol-function 'jabber-db-correct-message-row) (lambda (&rest _) (cl-incf updates)))) (jabber-correct-last-message) (funcall success) (funcall success)) (should (equal "corrected" (plist-get msg :body))) (should (plist-get msg :edited)) (should-not jabber-message-correct--pending-outgoing) (should (= 1 updates))))) (ert-deftest jabber-test-message-correct-omemo-failure-after-success-is-inert () "A stale OMEMO failure callback cannot undo a committed correction." (jabber-test-message-correct-with-ewoc (setq-local jabber-group nil) (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chat-encryption 'omemo) (let ((msg (list :id "original-1" :from "me@example.com" :body "original" :timestamp (current-time))) (updates 0) success failure) (jabber-chat-ewoc-enter (list :local msg)) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "corrected")) ((symbol-function 'jabber-chat-send) (lambda (_jc _body _extra on-success on-failure) (setq success on-success failure on-failure))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-correction-candidates) (lambda (&rest _) (list (list :row-id 1 :from "me@example.com")))) ((symbol-function 'jabber-db-correct-message-row) (lambda (&rest _) (cl-incf updates)))) (jabber-correct-last-message) (funcall success) (funcall failure "late failure")) (should (equal "corrected" (plist-get msg :body))) (should (plist-get msg :edited)) (should-not jabber-message-correct--pending-outgoing) (should (= 1 updates))))) (ert-deftest jabber-test-message-correct-blocks-overlapping-omemo-edits () "A second edit cannot race an OMEMO correction awaiting transport." (jabber-test-message-correct-with-ewoc (setq-local jabber-message-correct--pending-outgoing '(pending)) (let ((prompted nil)) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) (setq prompted t)))) (should-error (jabber-correct-last-message) :type 'user-error)) (should-not prompted)))) (ert-deftest jabber-test-message-correct-muc-continuity-rejects-rejoin () "Legacy MUC correction continuity is reset across occupant presence lifetimes." (let ((jabber-message-correct--muc-presence-sessions (make-hash-table :test #'equal)) (jabber-message-correct--muc-last-message-ids (make-hash-table :test #'equal)) (from "room@conference.example.com/alice")) (jabber-message-correct--muc-presence-enter 'jc-a from) (jabber-message-correct--record-muc-original 'jc-a from "original-1") (should (jabber-message-correct--muc-current-target-p 'jc-a from "original-1")) (jabber-message-correct--muc-presence-leave 'jc-a from) (jabber-message-correct--muc-presence-enter 'jc-a from) (should-not (jabber-message-correct--muc-current-target-p 'jc-a from "original-1")))) (ert-deftest jabber-test-message-correct-muc-continuity-is-connection-scoped () "Two accounts in one room cannot authorize each other's correction target." (let ((jabber-message-correct--muc-presence-sessions (make-hash-table :test #'equal)) (jabber-message-correct--muc-last-message-ids (make-hash-table :test #'equal)) (from "room@conference.example.com/alice")) (jabber-message-correct--muc-presence-enter 'jc-a from) (jabber-message-correct--muc-presence-enter 'jc-b from) (jabber-message-correct--record-muc-original 'jc-a from "account-a-id") (should (jabber-message-correct--muc-current-target-p 'jc-a from "account-a-id")) (should-not (jabber-message-correct--muc-current-target-p 'jc-b from "account-a-id")))) (provide 'jabber-test-message-correct) ;;; jabber-test-message-correct.el ends here emacs-jabber-0.13.1/tests/jabber-test-message-reply.el000066400000000000000000000700311523531702000225470ustar00rootroot00000000000000;;; jabber-test-message-reply.el --- Tests for jabber-message-reply -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0461 Message Replies with XEP-0428 Fallback. ;;; Code: (require 'ert) (require 'ewoc) (require 'jabber-xml) (require 'jabber-chat) (require 'jabber-chatbuffer) (require 'jabber-muc) (require 'jabber-message-reply) ;;; Group 1: jabber-message-reply--build-fallback-text (ert-deftest jabber-test-message-reply-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-test-message-reply-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-test-message-reply-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-test-message-reply-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 1b: jabber-message-reply--strip-fallback (ert-deftest jabber-test-message-reply-strip-fallback-range () "A (START END) range is excised from the body." (should (equal "answer" (jabber-message-reply--strip-fallback "> alice:\n> hi\nanswer" '(0 14))))) (ert-deftest jabber-test-message-reply-strip-fallback-all () "A whole-body fallback strips to the empty string." (should (equal "" (jabber-message-reply--strip-fallback "> alice:\n> hi" 'all)))) (ert-deftest jabber-test-message-reply-strip-fallback-nil () "A nil range leaves the body unchanged." (should (equal "hello" (jabber-message-reply--strip-fallback "hello" nil)))) (ert-deftest jabber-test-message-reply-strip-fallback-malformed () "Out-of-bounds or malformed ranges leave the body unchanged." (should (equal "short" (jabber-message-reply--strip-fallback "short" '(0 99)))) (should (equal "short" (jabber-message-reply--strip-fallback "short" '(3 1)))) (should (equal "short" (jabber-message-reply--strip-fallback "short" "junk")))) ;;; Group 2: jabber-message-reply--select-id (ert-deftest jabber-test-message-reply-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-test-message-reply-select-id-prefers-origin-id () "In 1:1 chat, prefer :origin-id over :id." (let ((msg (list :id "client-id-1" :origin-id "origin-id-1"))) (should (equal "origin-id-1" (jabber-message-reply--select-id msg nil))) ;; MUC keeps requiring the server-assigned stanza-id. (should-not (jabber-message-reply--select-id msg t)))) (ert-deftest jabber-test-message-reply-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-test-message-reply-select-id-muc-requires-server-id () "In MUC without :server-id, do not use the stanza id." (let ((msg (list :id "client-id-3" :server-id nil))) (should-not (jabber-message-reply--select-id msg t)))) (ert-deftest jabber-test-message-reply-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 2b: jabber-message-reply--author-name (ert-deftest jabber-test-message-reply-author-name-muc-pm-uses-nick () "MUC private messages quote the occupant nick, not the room name." (with-temp-buffer (cl-letf (((symbol-function 'jabber-muc-sender-p) (lambda (_jid) t))) (should (equal "alice" (jabber-message-reply--author-name "room@conf.example.com/alice")))))) (ert-deftest jabber-test-message-reply-author-name-1to1-uses-username () "1:1 chats quote the username part of the JID." (with-temp-buffer (cl-letf (((symbol-function 'jabber-muc-sender-p) (lambda (_jid) nil))) (should (equal "alice" (jabber-message-reply--author-name "alice@example.com/phone")))))) ;;; Group 3: jabber-message-reply--send-hook (ert-deftest jabber-test-message-reply-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-text "> Alice:\n> Hello\n") (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-text)))) (ert-deftest jabber-test-message-reply-send-hook-preserves-thread () "An ordinary reply reuses the target message's thread context." (with-temp-buffer (setq-local jabber-message-reply--id "orig-id") (setq-local jabber-message-reply--thread '(:thread-id "thread-1" :thread-parent-id "parent-1")) (let* ((jabber-chat--send-hook-stanza '(message ((type . "chat")) (body () "reply"))) (elements (jabber-message-reply--send-hook "reply" "new-id"))) (should (equal '((thread ((parent . "parent-1")) "thread-1")) (cl-remove-if-not (lambda (element) (eq (car element) 'thread)) elements))) (should-not jabber-message-reply--thread)))) (ert-deftest jabber-test-message-reply-send-hook-does-not-duplicate-thread () "An explicit outgoing thread element wins over pending reply context." (with-temp-buffer (setq-local jabber-message-reply--id "orig-id") (setq-local jabber-message-reply--thread '(:thread-id "thread-1" :thread-parent-id nil)) (let* ((jabber-chat--send-hook-stanza '(message ((type . "chat")) (body () "reply") (thread () "thread-1"))) (elements (jabber-message-reply--send-hook "reply" "new-id"))) (should-not (cl-find 'thread elements :key #'car))))) (ert-deftest jabber-test-message-reply-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-test-message-reply-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-text "> Bob:\n> Hey\n") (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-test-message-reply-send-hook-no-fallback-when-no-quote () "No fallback element when no quote text was inserted." (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-text nil) (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))))) (ert-deftest jabber-test-message-reply-send-hook-skips-fallback-when-edited () "An edited quote suppresses the fallback range but keeps the reply." (with-temp-buffer (setq-local jabber-message-reply--id "target-msg") (setq-local jabber-message-reply--jid "alice@example.com") (setq-local jabber-message-reply--fallback-text "> Alice:\n> Hello\n") (let ((elements (jabber-message-reply--send-hook "> Alice: Hello (edited)\nmy reply" "new-msg"))) (should (cl-some (lambda (el) (eq (car el) 'reply)) elements)) (should-not (cl-some (lambda (el) (eq (car el) 'fallback)) elements))))) (ert-deftest jabber-test-message-reply-send-hook-fallback-range-matches-text () "Fallback end offset equals the quote's code point count." (with-temp-buffer (let ((fb "> Alice:\n> Hëllo\n")) (setq-local jabber-message-reply--id "target-msg") (setq-local jabber-message-reply--jid "alice@example.com") (setq-local jabber-message-reply--fallback-text fb) (let* ((elements (jabber-message-reply--send-hook (concat fb "my reply") "new-msg")) (fb-el (cl-find 'fallback elements :key #'car)) (body-el (car (jabber-xml-get-children fb-el 'body)))) (should body-el) (should (equal "0" (jabber-xml-get-attribute body-el 'start))) (should (equal (number-to-string (length fb)) (jabber-xml-get-attribute body-el 'end))))))) (ert-deftest jabber-test-message-reply-send-hook-omits-empty-to () "Replying to our own message (no author JID) omits the `to' attribute. A `to=\"\"' is an invalid JID and makes strict parsers drop the reply." (with-temp-buffer (setq-local jabber-message-reply--id "orig-id") (setq-local jabber-message-reply--jid "") (setq-local jabber-message-reply--fallback-text nil) (let* ((elements (jabber-message-reply--send-hook "Just a reply" "new-msg")) (reply-el (cl-find 'reply elements :key #'car)) (attrs (cadr reply-el))) (should reply-el) (should (equal "orig-id" (cdr (assq 'id attrs)))) (should-not (assq 'to attrs))))) (ert-deftest jabber-test-message-reply-outgoing-body-keeps-fallback () "The outgoing reply stanza body retains the quoted fallback text. The send hook adds / elements but must never strip the quoted prefix from the body that is actually sent." (with-temp-buffer (let* ((fallback (jabber-message-reply--build-fallback-text "alice" "Hello")) (body (concat fallback "my reply")) (jabber-chat-send-hooks (list #'jabber-message-reply--send-hook))) (setq-local jabber-message-reply--id "orig-1") (setq-local jabber-message-reply--jid "alice@example.com") (setq-local jabber-message-reply--fallback-text fallback) (let ((stanza `(message ((to . "room@conf.example.com") (type . "groupchat") (id . "m1")) (body () ,body)))) (jabber-chat--run-send-hooks stanza body "m1") (let ((sent-body (car (jabber-xml-node-children (car (jabber-xml-get-children stanza 'body)))))) (should (string-prefix-p "> alice:\n> Hello\n" sent-body)) (should (string-suffix-p "my reply" sent-body))) (should (jabber-xml-child-with-xmlns stanza "urn:xmpp:reply:0")) (should (jabber-xml-child-with-xmlns stanza "urn:xmpp:fallback:0")))))) (ert-deftest jabber-test-message-reply-elements-builder () "The elements builder emits reply with optional to and fallback." (let* ((els (jabber-message-reply--elements "id-1" "alice@example.com" 10)) (reply-el (cl-find 'reply els :key #'car)) (fb-el (cl-find 'fallback els :key #'car))) (should (equal "alice@example.com" (cdr (assq 'to (cadr reply-el))))) (should (equal "id-1" (cdr (assq 'id (cadr reply-el))))) (should fb-el) (should (equal "10" (jabber-xml-get-attribute (car (jabber-xml-get-children fb-el 'body)) 'end)))) (let* ((els (jabber-message-reply--elements "id-2" nil nil)) (reply-el (cl-find 'reply els :key #'car))) (should-not (assq 'to (cadr reply-el))) (should-not (cl-find 'fallback els :key #'car)))) (ert-deftest jabber-test-message-reply-correction-fallback-length () "Quote length is kept only while the corrected body starts with it." (let ((msg (list :body "> a:\n> hi\nanswer" :fallback-range '(0 10) :reply-to-id "orig"))) (should (= 10 (jabber-message-reply--correction-fallback-length msg "> a:\n> hi\nbetter answer"))) (should-not (jabber-message-reply--correction-fallback-length msg "answer without quote")))) (ert-deftest jabber-test-message-reply-send-hook-inert-during-correction () "The send hook adds nothing and keeps its state during a correction." (with-temp-buffer (setq-local jabber-message-reply--id "orig-1") (setq-local jabber-message-reply--jid "alice@example.com") (setq-local jabber-message-reply--fallback-text "> Alice:\n> Hello\n") (let ((jabber-chat--sending-correction t)) (should-not (jabber-message-reply--send-hook "corrected text" "c-1"))) (should (equal "orig-1" jabber-message-reply--id)) (should (equal "alice@example.com" jabber-message-reply--jid)))) (ert-deftest jabber-test-message-reply-state-survives-correction-stanza () "A correction through the hook runner leaves the pending reply intact." (with-temp-buffer (let ((jabber-chat-send-hooks (list #'jabber-message-reply--send-hook))) (setq-local jabber-message-reply--id "orig-1") (setq-local jabber-message-reply--jid "alice@example.com") (setq-local jabber-message-reply--fallback-text nil) (let ((correction `(message ((to . "bob@example.com") (type . "chat") (id . "c-1")) (body () "fixed") (replace ((id . "old-1") (xmlns . "urn:xmpp:message-correct:0")))))) (jabber-chat--run-send-hooks correction "fixed" "c-1") (should-not (jabber-xml-child-with-xmlns correction "urn:xmpp:reply:0")) (should (equal "orig-1" jabber-message-reply--id))) ;; The next plain message still becomes the reply. (let ((stanza `(message ((to . "bob@example.com") (type . "chat") (id . "m-2")) (body () "the actual reply")))) (jabber-chat--run-send-hooks stanza "the actual reply" "m-2") (should (jabber-xml-child-with-xmlns stanza "urn:xmpp:reply:0")) (should-not jabber-message-reply--id))))) ;;; Group 4: incoming fallback parsing (ert-deftest jabber-test-message-reply-keeps-incoming-fallback () "Incoming XEP-0461 reply fallback is kept in the displayed body." (let* ((stanza '(message ((from . "alice@example.com/tablet") (id . "reply-1") (type . "chat")) (body () "> Alice:\n> Hello\nActual reply") (reply ((xmlns . "urn:xmpp:reply:0") (to . "alice@example.com/tablet") (id . "orig-1"))) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . "urn:xmpp:reply:0")) (body ((start . "0") (end . "17")))))) (msg (jabber-chat--msg-plist-from-stanza stanza))) (should (equal "> Alice:\n> Hello\nActual reply" (plist-get msg :body))) (should (equal "orig-1" (plist-get msg :reply-to-id))))) (ert-deftest jabber-test-message-reply-keeps-whole-body-fallback () "Reply fallback with no body range is kept in the displayed body." (let* ((stanza '(message ((from . "alice@example.com/tablet") (id . "reply-1") (type . "chat")) (body () "> Alice:\n> Hello") (reply ((xmlns . "urn:xmpp:reply:0") (to . "alice@example.com/tablet") (id . "orig-1"))) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . "urn:xmpp:reply:0"))))) (msg (jabber-chat--msg-plist-from-stanza stanza))) (should (equal "> Alice:\n> Hello" (plist-get msg :body))) (should (equal "orig-1" (plist-get msg :reply-to-id))))) (ert-deftest jabber-test-message-reply-preserves-malformed-fallback () "Malformed XEP-0461 fallback ranges leave the body unchanged." (let* ((body "> Alice:\n> Hello\nActual reply") (stanza `(message ((from . "alice@example.com/tablet") (id . "reply-2") (type . "chat")) (body () ,body) (reply ((xmlns . "urn:xmpp:reply:0") (to . "alice@example.com/tablet") (id . "orig-1"))) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . "urn:xmpp:reply:0")) (body ((start . "x") (end . "17")))))) (msg (jabber-chat--msg-plist-from-stanza stanza))) (should (equal body (plist-get msg :body))))) (ert-deftest jabber-test-message-reply-preserves-fallback-without-reply () "Fallback text is preserved when no XEP-0461 reply element is present." (let* ((body "> Alice:\n> Hello\nActual reply") (stanza `(message ((from . "alice@example.com/tablet") (id . "reply-3") (type . "chat")) (body () ,body) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . "urn:xmpp:reply:0")) (body ((start . "0") (end . "17")))))) (msg (jabber-chat--msg-plist-from-stanza stanza))) (should (equal body (plist-get msg :body))))) (ert-deftest jabber-test-message-reply-preserves-whole-fallback-without-reply () "Whole-body fallback is preserved when no XEP-0461 reply element is present." (let* ((body "> Alice:\n> Hello") (stanza `(message ((from . "alice@example.com/tablet") (id . "reply-4") (type . "chat")) (body () ,body) (fallback ((xmlns . "urn:xmpp:fallback:0") (for . "urn:xmpp:reply:0"))))) (msg (jabber-chat--msg-plist-from-stanza stanza))) (should (equal body (plist-get msg :body))))) ;;; Group 5: jabber-chat-reply input placement (ert-deftest jabber-test-message-reply-inserts-fallback-at-input-start () "`jabber-chat-reply' puts the quote at offset 0 of the input area. The range is start=0, so the quote must land at `jabber-point-insert' even when a draft is already present, not at `point-max'." (with-temp-buffer (let ((ewoc (ewoc-create (lambda (d) (insert (format "%s\n" (plist-get (cadr d) :body))))))) (setq-local jabber-chat-ewoc ewoc) (let ((node (ewoc-enter-last ewoc (list :foreign (list :id "orig-1" :from "alice@example.com/phone" :body "Hello"))))) (goto-char (point-max)) (setq-local jabber-point-insert (point-marker)) (insert "my draft") (goto-char (ewoc-location node)) (jabber-chat-reply) (let ((input (buffer-substring-no-properties jabber-point-insert (point-max))) (quote (jabber-message-reply--build-fallback-text "alice" "Hello"))) (should (string-prefix-p quote input)) (should (string-suffix-p "my draft" input)) (should (equal quote jabber-message-reply--fallback-text)) (should (equal "orig-1" jabber-message-reply--id)) (should-not jabber-message-reply--thread)))))) (ert-deftest jabber-test-message-reply-captures-thread-context () "Replying to a threaded message records its exact thread context." (with-temp-buffer (let ((ewoc (ewoc-create (lambda (data) (insert (format "%s\n" (plist-get (cadr data) :body))))))) (setq-local jabber-chat-ewoc ewoc) (let ((node (ewoc-enter-last ewoc '(:foreign (:id "orig-1" :from "alice@example.com/phone" :body "Hello" :thread-id "thread-1" :thread-parent-id "parent-1"))))) (goto-char (point-max)) (setq-local jabber-point-insert (point-marker)) (goto-char (ewoc-location node)) (jabber-chat-reply) (should (equal '(:thread-id "thread-1" :thread-parent-id "parent-1") jabber-message-reply--thread)))))) (ert-deftest jabber-test-message-reply-captures-thread-summary-context () "A locally registered root supplies reply context through its summary." (with-temp-buffer (let ((ewoc (ewoc-create (lambda (data) (insert (format "%s\n" (plist-get (cadr data) :body))))))) (setq-local jabber-chat-ewoc ewoc) (let ((node (ewoc-enter-last ewoc '(:foreign (:id "orig-1" :from "alice@example.com/phone" :body "Hello" :thread-summary (:thread-id "thread-1" :thread-parent-id "parent-1")))))) (goto-char (point-max)) (setq-local jabber-point-insert (point-marker)) (goto-char (ewoc-location node)) (jabber-chat-reply) (should (equal '(:thread-id "thread-1" :thread-parent-id "parent-1") jabber-message-reply--thread)))))) (ert-deftest jabber-test-message-reply-quote-not-nested () "Replying to a reply quotes only the answer, not the old quote." (with-temp-buffer (let ((ewoc (ewoc-create (lambda (d) (insert (format "%s\n" (plist-get (cadr d) :body))))))) (setq-local jabber-chat-ewoc ewoc) (let ((node (ewoc-enter-last ewoc (list :foreign (list :id "reply-1" :from "alice@example.com/phone" :body "> alice:\n> hi\nanswer" :fallback-range '(0 14)))))) (goto-char (point-max)) (setq-local jabber-point-insert (point-marker)) (goto-char (ewoc-location node)) (jabber-chat-reply) (let ((input (buffer-substring-no-properties jabber-point-insert (point-max)))) (should (equal "> alice:\n> answer\n" input))))))) (ert-deftest jabber-test-message-reply-self-reply-uses-own-bare-jid () "Replying to our own 1:1 message sets to= to our bare JID." (with-temp-buffer (let ((ewoc (ewoc-create (lambda (d) (insert (format "%s\n" (plist-get (cadr d) :body))))))) (setq-local jabber-chat-ewoc ewoc) (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chatting-with "bob@example.com") (let ((node (ewoc-enter-last ewoc (list :local (list :id "my-msg-1" :body "my message"))))) (goto-char (point-max)) (setq-local jabber-point-insert (point-marker)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-muc-sender-p) (lambda (_jid) nil))) (goto-char (ewoc-location node)) (jabber-chat-reply)) (let* ((body (buffer-substring-no-properties jabber-point-insert (point-max))) (elements (jabber-message-reply--send-hook body "new-id")) (reply-el (cl-find 'reply elements :key #'car))) (should (equal "me@example.com" (cdr (assq 'to (cadr reply-el)))))))))) (ert-deftest jabber-test-message-reply-self-reply-muc-pm-omits-to () "Replying to our own MUC-PM message omits the to attribute." (with-temp-buffer (let ((ewoc (ewoc-create (lambda (d) (insert (format "%s\n" (plist-get (cadr d) :body))))))) (setq-local jabber-chat-ewoc ewoc) (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chatting-with "room@conf.example.com/me") (let ((node (ewoc-enter-last ewoc (list :local (list :id "my-msg-1" :body "my message"))))) (goto-char (point-max)) (setq-local jabber-point-insert (point-marker)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-muc-sender-p) (lambda (_jid) t))) (goto-char (ewoc-location node)) (jabber-chat-reply)) (let* ((body (buffer-substring-no-properties jabber-point-insert (point-max))) (elements (jabber-message-reply--send-hook body "new-id")) (reply-el (cl-find 'reply elements :key #'car))) (should reply-el) (should-not (assq 'to (cadr reply-el)))))))) ;;; Group 6: jabber-chat-cancel-reply (ert-deftest jabber-test-message-reply-cancel-removes-intact-quote () "Cancelling a reply deletes the still-intact quote from the input area." (with-temp-buffer (setq-local jabber-point-insert (point-marker)) (insert "> Alice:\n> Hello\nmy text") (setq-local jabber-message-reply--id "orig-1") (setq-local jabber-message-reply--jid "alice@example.com") (setq-local jabber-message-reply--fallback-text "> Alice:\n> Hello\n") (setq-local jabber-message-reply--thread '(:thread-id "thread-1" :thread-parent-id nil)) (jabber-chat-cancel-reply) (should (equal "my text" (buffer-string))) (should-not jabber-message-reply--id) (should-not jabber-message-reply--fallback-text) (should-not jabber-message-reply--thread))) (ert-deftest jabber-test-message-reply-cancel-keeps-edited-input () "Cancelling a reply leaves edited input untouched but clears state." (with-temp-buffer (setq-local jabber-point-insert (point-marker)) (insert "> Alice: edited quote\nmy text") (setq-local jabber-message-reply--id "orig-1") (setq-local jabber-message-reply--jid "alice@example.com") (setq-local jabber-message-reply--fallback-text "> Alice:\n> Hello\n") (jabber-chat-cancel-reply) (should (equal "> Alice: edited quote\nmy text" (buffer-string))) (should-not jabber-message-reply--id) (should-not jabber-message-reply--fallback-text))) (ert-deftest jabber-test-message-reply-cancel-short-buffer-no-error () "Cancelling with input shorter than the quote does not error." (with-temp-buffer (setq-local jabber-point-insert (point-marker)) (insert "> A") (setq-local jabber-message-reply--id "orig-1") (setq-local jabber-message-reply--jid "alice@example.com") (setq-local jabber-message-reply--fallback-text "> Alice:\n> Hello\n") (jabber-chat-cancel-reply) (should (equal "> A" (buffer-string))) (should-not jabber-message-reply--id))) (provide 'jabber-test-message-reply) ;;; jabber-test-message-reply.el ends here emacs-jabber-0.13.1/tests/jabber-test-message-thread.el000066400000000000000000002250751523531702000226750ustar00rootroot00000000000000;;; jabber-test-message-thread.el --- Tests for XEP-0201 threads -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0201 message thread parsing, persistence, routing, and buffers. ;;; Code: (require 'ert) (require 'cl-lib) (require 'jabber-chat) (require 'jabber-message-correct) (require 'jabber-message-thread) (require 'jabber-moderation) (require 'jabber-muc) (require 'jabber-reactions) (defvar jabber-message-thread-buffer-created-functions) ;;; Protocol data (ert-deftest jabber-test-message-thread-fields () "Parse an opaque thread ID and its optional parent." (should (equal '(:thread-id "child-1" :thread-parent-id "parent-1") (jabber-message-thread--fields '(message ((type . "chat")) (body () "hello") (thread ((parent . "parent-1")) "child-1")))))) (ert-deftest jabber-test-message-thread-fields-without-parent () "Parse a thread that has no parent." (should (equal '(:thread-id "thread-1" :thread-parent-id nil) (jabber-message-thread--fields '(message ((type . "groupchat")) (thread () "thread-1")))))) (ert-deftest jabber-test-message-thread-fields-rejects-invalid-shapes () "Ignore empty and ambiguous thread elements." (should-not (jabber-message-thread--fields '(message ((type . "chat")) (thread () "")))) (should-not (jabber-message-thread--fields '(message ((type . "chat")) (thread () "one") (thread () "two")))) (should-not (jabber-message-thread--fields '(message ((type . "chat")) (thread ((xmlns . "urn:example:foreign")) "thread-1")))) (should-not (jabber-db--extract-thread-fields '(message ((type . "chat")) (thread ((xmlns . "urn:example:foreign")) "thread-1"))))) (ert-deftest jabber-test-message-thread-fields-ignore-foreign-elements () "A foreign thread element does not make one core thread ambiguous." (let ((stanza '(message ((type . "chat")) (thread ((xmlns . "urn:example:foreign")) "foreign") (thread ((xmlns . "jabber:client")) "thread-1")))) (dolist (parser '(jabber-message-thread--fields jabber-db--extract-thread-fields)) (should (equal '(:thread-id "thread-1" :thread-parent-id nil) (funcall parser stanza)))))) (ert-deftest jabber-test-message-thread-fields-reject-mixed-content () "Thread content must contain character data only." (dolist (stanza '((message () (thread () (foreign () "x") "thread-1")) (message () (thread () "thread" (foreign () "x") "-1")) (message () (thread () "thread-1" (foreign () "x"))))) (dolist (parser '(jabber-message-thread--fields jabber-db--extract-thread-fields)) (should-not (funcall parser stanza))))) (ert-deftest jabber-test-message-thread-fields-join-character-data () "All character data in a thread element forms the opaque ID." (let ((stanza '(message () (thread () "thread" "-" "1")))) (dolist (parser '(jabber-message-thread--fields jabber-db--extract-thread-fields)) (should (equal '(:thread-id "thread-1" :thread-parent-id nil) (funcall parser stanza)))))) (ert-deftest jabber-test-message-thread-element () "Build one core thread element with an optional distinct parent." (should (equal '((thread ((parent . "parent-1")) "child-1")) (jabber-message-thread--elements "child-1" "parent-1"))) (should (equal '((thread () "thread-1")) (jabber-message-thread--elements "thread-1" nil))) (should-not (jabber-message-thread--elements "same" "same")) (should-not (jabber-message-thread--elements "thread-1" ""))) (ert-deftest jabber-test-message-thread-generate-id () "Generate non-empty opaque IDs that do not repeat." (let ((first (jabber-message-thread--generate-id)) (second (jabber-message-thread--generate-id))) (should (string-match-p "\\`[[:xdigit:]]\\{64\\}\\'" first)) (should-not (equal first second)))) (ert-deftest jabber-test-message-thread-root-preview () "Normalize and truncate a root message for display." (should (equal "First line with extra space" (jabber-message-thread--root-preview '(:body " First\nline\twith extra space ")))) (let ((preview (jabber-message-thread--root-preview (list :body (make-string 60 ?x))))) (should (= 48 (string-width preview))) (should (string-suffix-p "…" preview))) (should (equal "[Message retracted]" (jabber-message-thread--root-preview '(:body "secret" :retracted t)))) (should (equal "(no text)" (jabber-message-thread--root-preview '(:body " ")))) (should-not (jabber-message-thread--root-preview nil))) (ert-deftest jabber-test-message-thread-buffer-name-uses-display-label () "Name a thread buffer after its root preview instead of its opaque ID." (let ((parent (generate-new-buffer "*jabber-chat-alice*"))) (unwind-protect (should (equal "*jabber-chat-alice [Release planning]*" (jabber-message-thread--buffer-name (string-remove-suffix "*" (buffer-name parent)) "Release planning"))) (kill-buffer parent)))) (ert-deftest jabber-test-message-thread-send-hook () "A thread buffer adds its thread element to outgoing messages." (with-temp-buffer (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-thread-parent-id "parent-1") (should (equal '((thread ((parent . "parent-1")) "thread-1")) (jabber-message-thread--send-hook "hello" "msg-1"))))) (ert-deftest jabber-test-message-thread-create-runs-buffer-functions () "Creating a thread runs setup functions in it with its parent." (let ((parent (generate-new-buffer " *jabber-thread-parent*")) thread called) (unwind-protect (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) nil)) ((symbol-function 'jabber-chat-mode-setup) #'ignore) ((symbol-function 'jabber-buffer-registry-register) #'ignore) ((symbol-function 'jabber-db-thread-backlog) #'ignore)) (let ((jabber-message-thread-buffer-created-functions (list (lambda (parent-buffer) (setq called (list (current-buffer) parent-buffer)))))) (setq thread (jabber-message-thread-create-buffer 'fake-jc "alice@example.com" "chat" "thread-1" nil parent))) (should (equal called (list thread parent)))) (kill-buffer parent) (when (buffer-live-p thread) (kill-buffer thread))))) (ert-deftest jabber-test-message-thread-header-renders-receipt-status () "A chat thread header includes its current receipt status." (let ((parent (generate-new-buffer "*jabber-thread-header-parent*")) thread) (unwind-protect (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) nil)) ((symbol-function 'jabber-chat-mode-setup) #'ignore) ((symbol-function 'jabber-buffer-registry-register) #'ignore) ((symbol-function 'jabber-db-message-thread-summary) (lambda (&rest _) '(:title "100% ready"))) ((symbol-function 'jabber-db-thread-backlog) #'ignore)) (setq thread (jabber-message-thread-create-buffer 'fake-jc "alice@example.com" "chat" "thread-1" nil parent '(:body "Root message fallback"))) (with-current-buffer thread (setq-local jabber-chat-receipt-message " seen 10:00") (should (equal " 100%% ready · Thread in alice@example.com" (jabber-message-thread--header))) (should (equal "100% ready" jabber-message-thread-title)) (setq-local jabber-message-thread-title nil) (should (equal " Root message fallback · Thread in alice@example.com" (jabber-message-thread--header))) (should (equal "*jabber-thread-header-parent [100% ready]*" (buffer-name thread))) (should (member '(:eval jabber-chat-receipt-message) header-line-format)))) (kill-buffer parent) (when (buffer-live-p thread) (kill-buffer thread))))) (ert-deftest jabber-test-message-thread-redisplay-keeps-thread-header () "Redisplaying direct and group threads preserves their header." (dolist (type '("chat" "groupchat")) (let ((parent (generate-new-buffer " *jabber-thread-redisplay-parent*")) (jabber-chat-header-line-format '("direct header")) (jabber-muc-header-line-format '("room header")) thread) (unwind-protect (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) nil)) ((symbol-function 'jabber-chat-mode-setup) #'ignore) ((symbol-function 'jabber-buffer-registry-register) #'ignore) ((symbol-function 'jabber-db-message-thread-summary) (lambda (&rest _) '(:title "Roadmap"))) ((symbol-function 'jabber-db-thread-backlog) #'ignore) ((symbol-function 'ewoc-refresh) #'ignore) ((symbol-function 'jabber-chat--peer-jid) #'ignore) ((symbol-function 'jabber-chat-encryption--update-header) #'ignore) ((symbol-function 'jabber-chat-buffer-recenter-input) #'ignore)) (setq thread (jabber-message-thread-create-buffer 'fake-jc (if (equal type "groupchat") "room@example.com" "alice@example.com") type "thread-1" nil parent)) (with-current-buffer thread (jabber-chat-redisplay) (should (equal '((:eval (jabber-message-thread--header)) (:eval jabber-chat-receipt-message)) header-line-format)))) (kill-buffer parent) (when (buffer-live-p thread) (kill-buffer thread)))))) (ert-deftest jabber-test-message-thread-first-send-links-root () "The first local reply links to the root and later replies do not." (with-temp-buffer (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-thread--root-reply-id "root-1") (setq-local jabber-message-thread--root-reply-jid "alice@example.com") (should (equal '((thread () "thread-1") (reply ((xmlns . "urn:xmpp:reply:0") (to . "alice@example.com") (id . "root-1")))) (jabber-message-thread--send-hook "hello" "msg-1"))) (should (equal '((thread () "thread-1")) (jabber-message-thread--send-hook "again" "msg-2"))))) (ert-deftest jabber-test-message-thread-correction-keeps-thread-context () "Corrections keep the thread element without consuming the root link." (with-temp-buffer (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-thread--root-reply-id "root-1") (let ((jabber-chat--sending-correction t)) (should (equal '((thread () "thread-1")) (jabber-message-thread--send-hook "corrected" "msg-2")))) (should (equal "root-1" jabber-message-thread--root-reply-id)))) (ert-deftest jabber-test-message-thread-captured-reply-is-single-owner () "An explicit reply overrides and consumes the initial thread root link." (with-temp-buffer (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-thread--root-reply-id "root-link") (setq-local jabber-message-thread--root-reply-jid "alice@example.com") (setq-local jabber-message-reply--id "explicit-target") (setq-local jabber-message-reply--jid "alice@example.com") (setq-local jabber-message-reply--thread '(:thread-id "thread-1")) (let* ((context (jabber-chat--capture-send-context "answer" nil)) (extra (plist-get context :extra-elements)) (stanza `(message () ,@extra)) (replies (jabber-xml-get-children stanza 'reply))) (should (= 1 (length replies))) (should (equal "explicit-target" (jabber-xml-get-attribute (car replies) 'id))) (should (= 1 (length (jabber-xml-get-children stanza 'thread)))) (should-not jabber-message-reply--id) (should-not jabber-message-thread--root-reply-id) (jabber-chat--restore-send-context context) (should (equal "explicit-target" jabber-message-reply--id)) (should (equal "root-link" jabber-message-thread--root-reply-id))))) (ert-deftest jabber-test-message-thread-correction-capture-is-inert () "Capturing a correction does not consume the next composed reply." (with-temp-buffer (setq-local jabber-message-reply--id "next-reply") (let* ((replace '(replace ((xmlns . "urn:xmpp:message-correct:0") (id . "old")))) (context (jabber-chat--capture-send-context "fixed" (list replace)))) (should (equal (list replace) (plist-get context :extra-elements))) (should-not (plist-get context :state)) (should (equal "next-reply" jabber-message-reply--id))))) (ert-deftest jabber-test-message-thread-message-at-input-is-nil () "Do not treat the last rendered message as the input-area target." (with-temp-buffer (let ((jabber-chat-ewoc (ewoc-create #'ignore))) (ewoc-enter-last jabber-chat-ewoc '(:foreign (:id "message-1" :body "hello"))) (insert "\nDraft") (setq-local jabber-point-insert (copy-marker (- (point-max) 5))) (goto-char (point-max)) (should-not (jabber-message-thread--message-at-point))))) (ert-deftest jabber-test-message-thread-start-sends-chat-draft () "Send a chat draft with a fresh thread and open its sibling buffer." (let ((thread-buffer (generate-new-buffer " *jabber-thread-start*"))) (unwind-protect (with-temp-buffer (insert "Prompt: root message") (let ((jabber-connections '(connection)) sent created popped registered) (setq-local jabber-buffer-connection 'connection) (setq-local jabber-chatting-with "alice@example.com/resource") (setq-local jabber-point-insert (copy-marker 9)) (setq-local jabber-send-function (lambda (jc body &optional extra-elements) (setq sent (list jc body extra-elements)))) (cl-letf (((symbol-function 'jabber-db-ensure-open) (lambda () t)) ((symbol-function 'jabber-message-thread--generate-id) (lambda () "thread-1")) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-register-message-thread) (lambda (&rest args) (setq registered args))) ((symbol-function 'jabber-message-thread-create-buffer) (lambda (&rest args) (setq created args) thread-buffer)) ((symbol-function 'pop-to-buffer) (lambda (buffer &rest _) (setq popped buffer)))) (let ((parent (current-buffer))) (jabber-message-thread-start) (should (equal sent '(connection "root message" ((thread () "thread-1"))))) (should (equal created (list 'connection "alice@example.com" "chat" "thread-1" nil parent nil '(:body "root message")))) (should (equal (seq-take registered 7) '("me@example.com" "alice@example.com" "chat" "thread-1" nil nil nil))) (should (numberp (nth 7 registered))) (should (eq popped thread-buffer)) (should (string= (buffer-string) "Prompt: ")))))) (kill-buffer thread-buffer)))) (ert-deftest jabber-test-message-thread-renew-id-rekeys-buffer () "Renewing a thread ID keeps lineage and replaces its registry key." (let ((jabber-buffer-registry--buffers (make-hash-table :test #'equal))) (with-temp-buffer (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-thread-type "chat") (setq-local jabber-message-thread-peer "alice@example.org") (setq-local jabber-buffer-connection 'fake-jc) (jabber-buffer-registry-register 'thread '("me@example.org" "alice@example.org" "chat" "thread-1")) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.org")) ((symbol-function 'jabber-message-thread--generate-id) (lambda () "thread-2"))) (should (equal (jabber-message-thread--renew-id) "thread-2"))) (should-not (jabber-message-thread-find-buffer "me@example.org" "alice@example.org" "chat" "thread-1")) (should (eq (jabber-message-thread-find-buffer "me@example.org" "alice@example.org" "chat" "thread-2") (current-buffer))) (should (equal jabber-message-thread-id "thread-2")) (should (equal jabber-message-thread-parent-id "thread-1"))))) (ert-deftest jabber-test-message-thread-renewed-title-persists-after-reopen () "A reopened renewed thread inherits title and lineage." (let* ((dir (make-temp-file "jabber-thread-renew" t)) (jabber-db-path (expand-file-name "test.sqlite" dir)) (jabber-db--connection nil) (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) (parent (generate-new-buffer " *jabber-thread-renew-parent*")) reopened) (unwind-protect (progn (jabber-db-ensure-open) (jabber-db-register-message-thread "me@example.org" "alice@example.org" "chat" "thread-1" nil nil nil 1) (jabber-db-set-message-thread-title "me@example.org" "alice@example.org" "chat" "thread-1" "Old") (with-temp-buffer (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-thread-peer "alice@example.org") (setq-local jabber-message-thread-type "chat") (setq-local jabber-message-thread-title "Old") (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.org")) ((symbol-function 'jabber-message-thread--generate-id) (lambda () "thread-2"))) (jabber-message-thread--renew-id))) (jabber-db-close) (jabber-db-ensure-open) (let ((summary (jabber-db-message-thread-summary "me@example.org" "alice@example.org" "chat" "thread-2"))) (should (equal "thread-1" (plist-get summary :thread-parent-id))) (should (equal "Old" (plist-get summary :title))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.org")) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) nil)) ((symbol-function 'jabber-chat-mode-setup) #'ignore) ((symbol-function 'jabber-buffer-registry-register) #'ignore) ((symbol-function 'jabber-db-thread-backlog) #'ignore)) (setq reopened (jabber-message-thread-create-buffer 'fake-jc "alice@example.org" "chat" "thread-2" (plist-get summary :thread-parent-id) parent))) (with-current-buffer reopened (should (equal "thread-1" jabber-message-thread-parent-id)) (should (equal "Old" jabber-message-thread-title))))) (jabber-db-close) (kill-buffer parent) (when (buffer-live-p reopened) (kill-buffer reopened)) (when (file-directory-p dir) (delete-directory dir t))))) (ert-deftest jabber-test-message-thread-start-sends-muc-draft () "Send a MUC draft as a public thread root." (let ((thread-buffer (generate-new-buffer " *jabber-muc-thread-start*"))) (unwind-protect (with-temp-buffer (insert "root message") (let ((jabber-connections '(connection)) sent created registered) (setq-local jabber-buffer-connection 'connection) (setq-local jabber-group "room@example.com") (setq-local jabber-point-insert (copy-marker (point-min))) (setq-local jabber-send-function (lambda (_jc body &optional extra-elements) (setq sent (list body extra-elements)))) (cl-letf (((symbol-function 'jabber-db-ensure-open) (lambda () t)) ((symbol-function 'jabber-message-thread--generate-id) (lambda () "thread-1")) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-register-message-thread) (lambda (&rest args) (setq registered args))) ((symbol-function 'jabber-message-thread-create-buffer) (lambda (&rest args) (setq created args) thread-buffer)) ((symbol-function 'pop-to-buffer) #'ignore)) (let ((parent (current-buffer))) (jabber-message-thread-start) (should (equal sent '("root message" ((thread () "thread-1"))))) (should (equal created (list 'connection "room@example.com" "groupchat" "thread-1" nil parent nil '(:body "root message")))) (should (equal (seq-take registered 7) '("me@example.com" "room@example.com" "groupchat" "thread-1" nil nil nil))))))) (kill-buffer thread-buffer)))) (ert-deftest jabber-test-message-thread-start-requires-a-draft () "Reject starting a thread without input text." (with-temp-buffer (let ((jabber-connections '(connection))) (setq-local jabber-buffer-connection 'connection) (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-point-insert (copy-marker (point-max))) (setq-local jabber-send-function (lambda (&rest _) (ert-fail "Sent an empty draft"))) (should-error (jabber-message-thread-start) :type 'user-error)))) (ert-deftest jabber-test-message-thread-refreshes-missing-root () "Reload an open thread buffer when its stored root is not rendered." (let ((thread-buffer (generate-new-buffer " *jabber-thread-refresh*")) refreshed) (unwind-protect (with-current-buffer thread-buffer (setq-local jabber-chat-ewoc (ewoc-create #'ignore)) (cl-letf (((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) thread-buffer)) ((symbol-function 'jabber-db-message-thread-summary) (lambda (&rest _) '(:thread-id "thread-1" :root-message-id 1))) ((symbol-function 'jabber-chat-buffer-refresh) (lambda () (setq refreshed t)))) (jabber-message-thread--refresh-thread-root "me@example.com" "alice@example.com" "chat" "thread-1") (should refreshed) (setq refreshed nil) (ewoc-enter-last jabber-chat-ewoc '(:local (:db-id 1 :thread-id "thread-1"))) (jabber-message-thread--refresh-thread-root "me@example.com" "alice@example.com" "chat" "thread-1") (should-not refreshed))) (kill-buffer thread-buffer)))) (ert-deftest jabber-test-message-thread-refreshes-idless-parent-root () "Reload new 1:1 and MUC roots when only their rows identify them." (let ((parent-buffer (generate-new-buffer " *jabber-parent-refresh*")) (summary '(:thread-id "thread-1" :thread-type "chat" :root-message-id 7 :reply-count 0)) (refresh-count 0)) (unwind-protect (with-current-buffer parent-buffer (setq-local jabber-chat-ewoc (ewoc-create #'ignore)) (cl-letf (((symbol-function 'jabber-message-thread--parent-buffer) (lambda (&rest _) parent-buffer)) ((symbol-function 'jabber-db-message-thread-summary) (lambda (&rest _) summary)) ((symbol-function 'jabber-chat-buffer-refresh) (lambda () (setq refresh-count (1+ refresh-count))))) (jabber-message-thread--refresh-root "me@example.com" "alice@example.com" "chat" "thread-1") (setq summary '(:thread-id "thread-2" :thread-type "groupchat" :root-message-id 8 :root-stanza-id "untrusted-client-id" :reply-count 0)) (jabber-message-thread--refresh-root "me@example.com" "room@example.com" "groupchat" "thread-2") (should (= refresh-count 2)))) (kill-buffer parent-buffer)))) (ert-deftest jabber-test-message-thread-open-reuses-stored-thread-id () "Open an ID-less stored root with its received opaque ThreadID." (let ((thread-buffer (generate-new-buffer " *jabber-thread-open*")) created) (unwind-protect (with-temp-buffer (setq-local jabber-buffer-connection 'connection) (setq-local jabber-chatting-with "alice@example.com") (cl-letf (((symbol-function 'jabber-db-ensure-open) (lambda () t)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-thread-summary) (lambda (_account _peer _type thread-id) (and (equal thread-id "received-thread") '(:thread-id "received-thread" :thread-parent-id "parent-thread" :local-reply-count 1)))) ((symbol-function 'jabber-message-thread--generate-id) (lambda () (ert-fail "Generated a replacement ThreadID"))) ((symbol-function 'jabber-db-register-message-thread) (lambda (&rest _) (ert-fail "Re-registered a stored thread"))) ((symbol-function 'jabber-message-thread--refresh-root) #'ignore) ((symbol-function 'jabber-db-mark-message-thread-read) #'ignore) ((symbol-function 'jabber-message-thread-create-buffer) (lambda (&rest args) (setq created args) thread-buffer)) ((symbol-function 'pop-to-buffer) #'ignore)) (let ((parent (current-buffer)) (msg '(:body "root" :thread-id "received-thread"))) (jabber-message-thread-open msg) (should (equal created (list 'connection "alice@example.com" "chat" "received-thread" "parent-thread" parent nil msg)))))) (kill-buffer thread-buffer)))) (ert-deftest jabber-test-message-thread-completion-items () "Format compact unique thread candidates with useful annotations." (let* ((latest (seconds-to-time 30)) (threads `((:thread-id "thread-1" :thread-type "groupchat" :root-message (:from "room@example.com/Alice" :body " Same\nroot ") :reply-count 1 :latest-at ,latest :unread t) (:thread-id "thread-2" :thread-type "groupchat" :root-message (:from "room@example.com/Alice" :body "Same root") :reply-count 2 :latest-at ,latest :unread nil) (:thread-id "thread-3" :thread-type "chat" :title "Release planning" :root-message (:body "Alice: Same root (2)") :reply-count 0 :latest-at ,latest :unread nil))) (items (jabber-message-thread--completion-items threads))) (should (equal '("Alice: Same root" "Alice: Same root (2)" "Release planning") (mapcar #'car items))) (should (equal (format " 1 reply · active %s · unread" (format-time-string "%Y-%m-%d %H:%M" latest)) (jabber-message-thread--completion-annotation (cdar items)))) (should (equal (format " 2 replies · active %s" (format-time-string "%Y-%m-%d %H:%M" latest)) (jabber-message-thread--completion-annotation (cdadr items)))) (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) "Release planning"))) (should (eq (nth 2 threads) (jabber-message-thread--read-thread threads)))))) (ert-deftest jabber-test-message-thread-set-title-updates-storage-and-header () "Set or clear a thread title through its owning buffer." (let ((parent (generate-new-buffer "*jabber-chat-alice*")) (thread (generate-new-buffer "*jabber-chat-alice [Initial root]*"))) (unwind-protect (with-current-buffer thread (setq-local jabber-buffer-connection 'connection) (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-thread-peer "alice@example.com") (setq-local jabber-message-thread-type "chat") (setq-local jabber-message-thread-root-preview "Initial root") (setq-local jabber-message-thread-parent-name "*jabber-chat-alice") (kill-buffer parent) (let ((long-title (make-string 60 ?x)) stored) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-ensure-open) (lambda () t)) ((symbol-function 'jabber-db-set-message-thread-title) (lambda (&rest args) (push args stored) (jabber-db--normalize-message-thread-title (car (last args)))))) (jabber-message-thread-set-title " Roadmap ") (should (equal "Roadmap" jabber-message-thread-title)) (should (equal " Roadmap · Thread in alice@example.com" (jabber-message-thread--header))) (should (equal "*jabber-chat-alice [Roadmap]*" (buffer-name))) (jabber-message-thread-set-title long-title) (should (equal (format "*jabber-chat-alice [%s]*" long-title) (buffer-name))) (jabber-message-thread-set-title " ") (should-not jabber-message-thread-title) (should (equal " Initial root · Thread in alice@example.com" (jabber-message-thread--header))) (should (equal "*jabber-chat-alice [Initial root]*" (buffer-name))) (should (equal `(("me@example.com" "alice@example.com" "chat" "thread-1" " ") ("me@example.com" "alice@example.com" "chat" "thread-1" ,long-title) ("me@example.com" "alice@example.com" "chat" "thread-1" " Roadmap ")) stored))))) (when (buffer-live-p parent) (kill-buffer parent)) (when (buffer-live-p thread) (kill-buffer thread))))) (ert-deftest jabber-test-message-thread-retracted-root-clears-live-preview () "Hide cached root text when moderation arrives before backlog rendering." (let ((thread (generate-new-buffer "*jabber-chat-room [Sensitive root text]*"))) (unwind-protect (with-current-buffer thread (setq-local jabber-buffer-connection 'connection) (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-thread-peer "room@example.com") (setq-local jabber-message-thread-type "groupchat") (setq-local jabber-message-thread-root-preview "Sensitive root text") (setq-local jabber-message-thread-parent-name "*jabber-chat-room") (cl-letf (((symbol-function 'jabber-chat-ewoc-find-by-id) (lambda (_) nil)) ((symbol-function 'jabber-chat-ewoc-invalidate) (lambda (&rest _) (ert-fail "Invalidated a missing root node"))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.com")) ((symbol-function 'jabber-db-message-thread-summary) (lambda (&rest _) '(:thread-type "groupchat" :root-message-id 7 :root-server-id "root-1")))) (jabber-moderation--mark-ewoc-retracted "root-1" "room@example.com/Mod" "spam") (should (equal "[Message retracted]" jabber-message-thread-root-preview)) (should (equal "*jabber-chat-room [[Message retracted]]*" (buffer-name))) (should-not (string-match-p "Sensitive" (jabber-message-thread--header))))) (when (buffer-live-p thread) (kill-buffer thread))))) (ert-deftest jabber-test-message-thread-completion-handles-missing-muc-root () "Represent a stored MUC thread even when its root row is unavailable." (should (equal "(no text)" (jabber-message-thread--completion-label '(:thread-type "groupchat" :root-message nil))))) (ert-deftest jabber-test-message-thread-completion-truncates-title () "Keep a titled completion candidate within the compact width." (let ((label (jabber-message-thread--completion-label (list :title (make-string 80 ?x) :thread-type "chat")))) (should (= 72 (string-width label))) (should (string-suffix-p "…" label)))) (ert-deftest jabber-test-message-thread-completion-hides-retracted-root () "Never expose retained plaintext for a retracted root." (let ((label (jabber-message-thread--completion-label '(:thread-type "chat" :root-message (:body "Sensitive root" :retracted t))))) (should (equal "[Message retracted]" label)) (should-not (string-match-p "Sensitive" label)))) (ert-deftest jabber-test-message-thread-read-preserves-activity-order () "Keep database order and expose annotations to completion UIs." (let* ((first '(:thread-id "new" :root-message (:body "Newest") :reply-count 0 :latest-at (0 30 0 0))) (second '(:thread-id "old" :root-message (:body "Older") :reply-count 0 :latest-at (0 20 0 0))) observed) (cl-letf (((symbol-function 'completing-read) (lambda (_prompt table &rest _) (let* ((metadata (completion-metadata "" table nil)) (sorter (completion-metadata-get metadata 'display-sort-function)) (candidates (all-completions "" table))) (setq observed (list (funcall sorter candidates) (funcall (plist-get completion-extra-properties :annotation-function) "Newest"))) "Newest")))) (should (eq first (jabber-message-thread--read-thread (list first second))))) (should (equal '("Newest" "Older") (car observed))) (should (string-prefix-p " 0 replies · active " (cadr observed))))) (ert-deftest jabber-test-message-thread-browse-opens-selected-thread () "Browse the current chat and open the selected stored thread." (let ((target-buffer (generate-new-buffer " *jabber-browse-target*")) (summary '(:thread-id "thread-1" :thread-parent-id nil :thread-type "chat" :local-reply-count 0 :root-message (:id "root-1" :from "alice@example.com" :body "Root"))) created marked refreshed popped) (unwind-protect (with-temp-buffer (setq-local jabber-buffer-connection 'connection) (setq-local jabber-chatting-with "alice@example.com/resource") (cl-letf (((symbol-function 'jabber-db-ensure-open) (lambda () t)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-threads) (lambda (&rest _) (list summary))) ((symbol-function 'jabber-message-thread--read-thread) (lambda (threads) (should (equal threads (list summary))) summary)) ((symbol-function 'jabber-message-thread-create-buffer) (lambda (&rest args) (setq created args) target-buffer)) ((symbol-function 'jabber-db-mark-message-thread-read) (lambda (&rest args) (setq marked args))) ((symbol-function 'jabber-message-thread--refresh-root) (lambda (&rest args) (setq refreshed args))) ((symbol-function 'pop-to-buffer) (lambda (buffer &rest _) (setq popped buffer)))) (let ((parent (current-buffer))) (jabber-message-thread-browse) (should (equal created (list 'connection "alice@example.com" "chat" "thread-1" nil parent (plist-get summary :root-message) (plist-get summary :root-message)))) (should (equal marked '("me@example.com" "alice@example.com" "chat" "thread-1"))) (should (equal refreshed marked)) (should (eq popped target-buffer))))) (kill-buffer target-buffer)))) (ert-deftest jabber-test-message-thread-browse-context-uses-parent-chat () "Browsing from a thread uses its live parent conversation buffer." (let ((parent (generate-new-buffer " *jabber-browse-parent*"))) (unwind-protect (with-temp-buffer (setq-local jabber-buffer-connection 'connection) (setq-local jabber-chatting-with "alice@example.com/resource") (setq-local jabber-message-thread-id "thread-1") (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-message-thread--parent-buffer) (lambda (&rest _) parent))) (should (equal (jabber-message-thread--browse-context) (list "me@example.com" "alice@example.com" "chat" parent))))) (kill-buffer parent)))) (ert-deftest jabber-test-message-thread-browse-opens-muc-without-root () "Browse a stored MUC thread whose root row is unavailable." (let ((target (generate-new-buffer " *jabber-browse-muc-target*")) (summary '(:thread-id "thread-1" :thread-type "groupchat" :thread-parent-id nil :local-reply-count 0 :root-message nil)) created) (unwind-protect (with-temp-buffer (setq-local jabber-buffer-connection 'connection) (setq-local jabber-group "room@example.com") (cl-letf (((symbol-function 'jabber-db-ensure-open) (lambda () t)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-threads) (lambda (&rest _) (list summary))) ((symbol-function 'jabber-message-thread--read-thread) (lambda (_threads) summary)) ((symbol-function 'jabber-message-thread-create-buffer) (lambda (&rest args) (setq created args) target)) ((symbol-function 'jabber-db-mark-message-thread-read) #'ignore) ((symbol-function 'jabber-message-thread--refresh-root) #'ignore) ((symbol-function 'pop-to-buffer) #'ignore)) (let ((parent (current-buffer))) (jabber-message-thread-browse) (should (equal created (list 'connection "room@example.com" "groupchat" "thread-1" nil parent nil nil)))))) (kill-buffer target)))) (ert-deftest jabber-test-message-thread-summary-marker () "Render the reply count as a compact link." (with-temp-buffer (jabber-chat--insert-thread-summary '(:thread-summary (:thread-id "thread-1" :reply-count 3 :unread t))) (should (equal "\n[3 Replies]" (buffer-string))) (should (equal '(:inherit link :weight bold) (get-text-property 2 'face))))) (ert-deftest jabber-test-message-thread-summary-button-uses-its-message () "Activating a marker opens its root even when point moved elsewhere." (with-temp-buffer (let ((msg '(:thread-summary (:thread-id "thread-1" :reply-count 1 :unread nil))) opened button-start) (cl-letf (((symbol-function 'jabber-message-thread--message-at-point) (lambda () (should (= (point) button-start)) msg)) ((symbol-function 'jabber-message-thread-open) (lambda (&optional root) (setq opened root)))) (jabber-chat--insert-thread-summary msg) (let ((button (button-at 2))) (setq button-start (button-start button)) (goto-char (point-max)) (button-activate button)) (should (eq msg opened)))))) (ert-deftest jabber-test-message-thread-disabled-hides-summary () "Do not render thread UI when dedicated buffers are disabled." (with-temp-buffer (let ((jabber-message-thread-use-buffers nil)) (jabber-chat--insert-thread-summary '(:thread-summary (:reply-count 2 :thread-id "thread-1"))) (should (string-empty-p (buffer-string)))))) (ert-deftest jabber-test-message-thread-read-summary-is-shadowed-button () "Keep a read thread actionable while rendering its count as shadowed." (with-temp-buffer (jabber-chat--insert-thread-summary '(:thread-summary (:reply-count 2 :thread-id "thread-1"))) (let ((button (button-at 2))) (should button) (should (eq 'shadow (button-get button 'face)))))) (ert-deftest jabber-test-message-thread-root-node-does-not-fall-back-from-row () "A stored root row never falls through to a recycled MUC client ID." (with-temp-buffer (let ((ewoc (ewoc-create #'ignore)) (summary '(:thread-id "thread-1" :thread-type "groupchat" :root-message-id 7 :root-stanza-id "same-id"))) (ewoc-enter-last ewoc '(:muc-foreign (:from "room@example.com/Bob" :id "same-id"))) (ewoc-enter-last ewoc '(:muc-foreign (:from "room@example.com/Alice" :id "same-id" :thread-id "thread-1"))) (should-not (jabber-message-thread--node-for-root ewoc summary))))) (ert-deftest jabber-test-message-thread-live-muc-root-uses-server-id () "Match a row-less live MUC root by its trusted room server ID." (with-temp-buffer (let ((ewoc (ewoc-create #'ignore)) (summary '(:thread-id "thread-1" :thread-type "groupchat" :root-message-id 7 :root-stanza-id "same-id" :root-server-id "root-server-id"))) (ewoc-enter-last ewoc '(:muc-local (:id "same-id" :server-id "reply-server-id" :thread-id "thread-1"))) (let ((root (ewoc-enter-last ewoc '(:muc-local (:id "same-id" :server-id "root-server-id" :thread-id "thread-1"))))) (should (eq root (jabber-message-thread--node-for-root ewoc summary))))))) (ert-deftest jabber-test-message-thread-root-node-id-precedence () "Do not fall through from row or MUC server identity." (should-not (jabber-message-thread--root-node-p '(:db-id 8 :server-id "root-server-id") '(:thread-type "groupchat" :root-server-id "root-server-id"))) (should-not (jabber-message-thread--root-node-p '(:id "root-id" :thread-id "thread-1") '(:thread-type "groupchat" :root-stanza-id "root-id" :thread-id "thread-1")))) (ert-deftest jabber-test-message-thread-exclusive-display-target () "Known replies use only their open thread buffer." (let ((thread-buffer (generate-new-buffer " *jabber-thread-test*"))) (unwind-protect (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-thread-known-p) (lambda (&rest _) t)) ((symbol-function 'jabber-db-message-thread-root-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) thread-buffer))) (should (eq thread-buffer (jabber-message-thread-display-target 'jc "alice@example.com" "chat" '(:thread-id "thread-1" :id "reply-1")))) (cl-letf (((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) nil))) (should-not (jabber-message-thread-display-target 'jc "alice@example.com" "chat" '(:thread-id "thread-1" :id "reply-1"))))) (kill-buffer thread-buffer)))) (ert-deftest jabber-test-message-thread-disabled-display-target-is-parent () "Route threaded messages through the original parent-buffer path." (let ((jabber-message-thread-use-buffers nil)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-thread-known-p) (lambda (&rest _) t)) ((symbol-function 'jabber-db-message-thread-root-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) (ert-fail "Looked up a disabled thread buffer")))) (should (eq 'parent (jabber-message-thread-display-target 'jc "alice@example.com" "chat" '(:thread-id "thread-1" :id "reply-1"))))))) (ert-deftest jabber-test-message-thread-muc-private-is-unavailable () "Dedicated thread commands reject MUC private chat buffers." (with-temp-buffer (let ((jabber-message-thread-use-buffers t)) (setq-local jabber-muc-private-p t) (should-not (jabber-message-thread-available-p)) (should-error (jabber-message-thread--ensure-buffers) :type 'user-error)))) (ert-deftest jabber-test-message-thread-muc-private-routes-through-parent () "A threaded MUC private message keeps the ordinary occupant buffer path." (let ((parent (generate-new-buffer " *jabber-muc-private-thread-parent*")) displayed) (unwind-protect (cl-letf (((symbol-function 'jabber-muc-message-p) (lambda (_) nil)) ((symbol-function 'jabber-muc-sender-p) (lambda (_) t)) ((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-chat--select-buffer) (lambda (&rest _) parent)) ((symbol-function 'jabber-message-thread-display-target) (lambda (&rest _) (ert-fail "Selected a dedicated private thread"))) ((symbol-function 'jabber-chat--display-message) (lambda (_jc _xml buffer &rest _) (setq displayed buffer))) ((symbol-function 'run-hook-with-args-until-success) (lambda (&rest _) t)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.com"))) (jabber-process-chat 'fake-jc '(message ((from . "room@example.com/Alice") (type . "chat")) (body () "reply") (thread () "thread-1"))) (should (eq displayed parent))) (kill-buffer parent)))) (ert-deftest jabber-test-message-thread-disabled-uses-original-update-routing () "Leave buffer selection to the original non-thread update path." (let ((jabber-message-thread-use-buffers nil)) (cl-letf (((symbol-function 'jabber-message-thread--parent-buffer) (lambda (&rest _) (ert-fail "Looked up a disabled thread parent"))) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) (ert-fail "Looked up a disabled thread buffer")))) (should-not (jabber-message-thread--update-targets "me@example.com" "alice@example.com" "chat" '(:thread-id "thread-1" :root nil)))))) (ert-deftest jabber-test-message-thread-disabled-rejects-thread-send-hook () "Prevent stale thread buffers from sending threaded messages." (with-temp-buffer (let ((jabber-message-thread-use-buffers nil)) (setq-local jabber-message-thread-id "thread-1") (should-error (jabber-message-thread--send-hook "reply" "message-1") :type 'user-error)))) (ert-deftest jabber-test-message-thread-local-reply-uses-open-thread-buffer () "A local threaded reply is echoed only in its open thread buffer." (let ((parent (generate-new-buffer " *jabber-local-parent*")) (thread (generate-new-buffer " *jabber-local-thread*"))) (unwind-protect (progn (dolist (buffer (list parent thread)) (with-current-buffer buffer (setq-local jabber-chat-ewoc (ewoc-create #'ignore)) (setq-local jabber-chat--msg-nodes (make-hash-table :test #'equal)))) (with-current-buffer parent (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-chat-encryption nil) (let ((jabber-chat-printers (list (lambda (&rest _) t))) (jabber-chat-send-hooks (list (lambda (&rest _) '((thread () "thread-1")))))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-thread-location) (lambda (&rest _) '(:thread-id "thread-1" :root nil))) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) thread)) ((symbol-function 'jabber-send-sexp) #'ignore)) (jabber-chat-send 'connection "reply")))) (should-not (with-current-buffer parent (ewoc-nth jabber-chat-ewoc 0))) (should (equal "thread-1" (with-current-buffer thread (plist-get (cadr (ewoc-data (ewoc-nth jabber-chat-ewoc -1))) :thread-id))))) (kill-buffer parent) (kill-buffer thread)))) (ert-deftest jabber-test-message-thread-local-reply-stays-closed () "A local reply to a closed thread is not echoed into the parent." (with-temp-buffer (setq-local jabber-chat-ewoc (ewoc-create #'ignore)) (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-chat-encryption nil) (let ((jabber-chat-printers (list (lambda (&rest _) t))) (jabber-chat-send-hooks (list (lambda (&rest _) '((thread () "thread-1")))))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-thread-location) (lambda (&rest _) '(:thread-id "thread-1" :root nil))) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) nil)) ((symbol-function 'jabber-send-sexp) #'ignore)) (jabber-chat-send 'connection "reply"))) (should-not (ewoc-nth jabber-chat-ewoc 0)))) (ert-deftest jabber-test-message-thread-local-root-stays-in-parent () "A newly sent thread root keeps its canonical parent echo." (with-temp-buffer (setq-local jabber-chat-ewoc (ewoc-create #'ignore)) (setq-local jabber-chat--msg-nodes (make-hash-table :test #'equal)) (setq-local jabber-chatting-with "alice@example.com") (setq-local jabber-chat-encryption nil) (let ((jabber-chat-printers (list (lambda (&rest _) t))) (jabber-chat-send-hooks nil)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-thread-location) (lambda (&rest _) '(:thread-id "thread-1" :root t))) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) (ert-fail "Looked up a root as a reply"))) ((symbol-function 'jabber-send-sexp) #'ignore)) (jabber-chat-send 'connection "root" '((thread () "thread-1"))))) (should (equal "thread-1" (plist-get (cadr (ewoc-data (ewoc-nth jabber-chat-ewoc -1))) :thread-id))))) (ert-deftest jabber-test-message-thread-unknown-message-is-local-root () "The first message seen for an unknown thread stays in the parent." (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-thread-known-p) (lambda (&rest _) nil))) (should (eq 'parent (jabber-message-thread-display-target 'jc "alice@example.com" "chat" '(:thread-id "thread-1" :id "first-seen")))))) (ert-deftest jabber-test-message-thread-known-idless-message-is-reply () "An ID-less message in a known thread is not inferred to be its root." (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-thread-known-p) (lambda (&rest _) t)) ((symbol-function 'jabber-db-message-thread-root-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) nil))) (should-not (jabber-message-thread-display-target 'jc "alice@example.com" "chat" '(:thread-id "thread-1"))))) (ert-deftest jabber-test-message-thread-update-targets () "Roots update both views and closed replies do not fall back to parent." (let ((parent (generate-new-buffer " *jabber-thread-parent*")) (thread (generate-new-buffer " *jabber-thread-child*"))) (unwind-protect (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-message-thread--parent-buffer) (lambda (&rest _) parent)) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) thread)) ((symbol-function 'jabber-db-message-thread-location) (lambda (&rest _) '(:thread-id "thread-1" :root t)))) (should (equal (list parent thread) (jabber-message-thread-update-targets 'jc "alice@example.com" "chat" "root-1"))) (cl-letf (((symbol-function 'jabber-db-message-thread-location) (lambda (&rest _) '(:thread-id "thread-1" :root nil))) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) nil))) (should (eq 'closed (jabber-message-thread-update-targets 'jc "alice@example.com" "chat" "reply-1"))))) (kill-buffer parent) (kill-buffer thread)))) (ert-deftest jabber-test-message-thread-chat-correction-uses-original-owner () "A 1:1 correction follows the replaced message, not its own thread field." (let ((target (generate-new-buffer " *jabber-thread-correction*")) applied) (unwind-protect (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-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-message-thread-update-targets-for-row) (lambda (_jc _peer _type row-id) (should (= row-id 7)) (list target))) ((symbol-function 'jabber-chat--select-buffer) (lambda (&rest _) (ert-fail "selected parent buffer"))) ((symbol-function 'jabber-message-correct--apply) (lambda (&rest args) (setq applied (funcall (nth 4 args) '(:row-id 7)))))) (jabber-process-chat 'jc '(message ((from . "alice@example.com/phone") (type . "chat") (id . "correction-1")) (body () "corrected") (replace ((xmlns . "urn:xmpp:message-correct:0") (id . "reply-1"))) (thread () "wrong-thread"))) (should (equal (list target) applied))) (kill-buffer target)))) (ert-deftest jabber-test-message-thread-unthreaded-correction-does-not-create () "An unthreaded correction keeps the old find-only buffer behavior." (let (applied) (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-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-message-thread-update-targets-for-row) (lambda (&rest _) nil)) ((symbol-function 'jabber-chat-find-buffer) (lambda (_) nil)) ((symbol-function 'jabber-chat--select-buffer) (lambda (&rest _) (ert-fail "created parent buffer"))) ((symbol-function 'jabber-message-correct--apply) (lambda (&rest args) (setq applied (funcall (nth 4 args) '(:row-id 7)))))) (jabber-process-chat 'jc '(message ((from . "alice@example.com/phone") (type . "chat") (id . "correction-1")) (body () "corrected") (replace ((xmlns . "urn:xmpp:message-correct:0") (id . "message-1"))))) (should-not applied)))) (ert-deftest jabber-test-message-thread-muc-correction-uses-original-owner () "A MUC correction follows the replaced message's thread." (let ((target (generate-new-buffer " *jabber-muc-thread-correction*")) applied) (unwind-protect (cl-letf (((symbol-function 'jabber-muc-message-p) (lambda (_) t)) ((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc xml) xml)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-muc--classify-message) (lambda (&rest _) :muc-foreign)) ((symbol-function 'jabber-message-thread-update-targets-for-row) (lambda (_jc _peer _type row-id) (should (= row-id 8)) (list target))) ((symbol-function 'jabber-muc-find-buffer) (lambda (&rest _) (ert-fail "selected parent buffer"))) ((symbol-function 'jabber-message-correct--apply) (lambda (&rest args) (setq applied (funcall (nth 4 args) '(:row-id 8))))) ((symbol-function 'jabber-message-correct--muc-current-target-p) (lambda (&rest _) t))) (jabber-muc-process-message 'jc '(message ((from . "room@example.com/Alice") (type . "groupchat") (id . "correction-1")) (body () "corrected") (replace ((xmlns . "urn:xmpp:message-correct:0") (id . "reply-1"))) (thread () "wrong-thread"))) (should (equal (list target) applied))) (kill-buffer target)))) (ert-deftest jabber-test-message-thread-muc-correction-resolves-authorized-row () "A recycled MUC client ID routes through the sender-authorized row." (let (corrected-row resolved-row) (cl-letf (((symbol-function 'jabber-db-message-correction-candidates) (lambda (&rest _) '((:row-id 7 :from "room@example.com/Alice") (:row-id 8 :from "room@example.com/Bob")))) ((symbol-function 'jabber-db-correct-message-row) (lambda (row-id _body) (setq corrected-row row-id)))) (should (jabber-message-correct--apply "same-id" "corrected" "room@example.com/Alice" t (lambda (original) (setq resolved-row (plist-get original :row-id)) nil) nil "me@example.com" "room@example.com" t)) (should (= 7 corrected-row)) (should (= 7 resolved-row))))) (ert-deftest jabber-test-message-thread-closed-chat-alert-has-parent-buffer () "A closed reply alerts with the parent buffer without inserting there." (let ((parent (generate-new-buffer " *jabber-thread-alert-parent*")) seen) (unwind-protect (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-chat--find-buffer-on-connection) (lambda (&rest _) parent)) ((symbol-function 'jabber-chat--select-buffer) (lambda (&rest _) (ert-fail "Closed thread alert created a parent buffer")))) (let ((jabber-message-hooks (list (lambda (_from buffer _body _alert) (setq seen buffer)))) (jabber-alert-message-hooks nil) (jabber-alert-message-function (lambda (&rest _) "alert"))) (jabber-chat--display-message 'jc nil nil nil "alice@example.com" '(:body "reply" :thread-id "thread-1")) (should (eq parent seen)) (should (equal "" (with-current-buffer parent (buffer-string)))))) (kill-buffer parent)))) (ert-deftest jabber-test-message-thread-closed-alert-finds-buffer-by-account () "A closed reply alerts through the parent buffer on its connection." (let ((account-a-buffer (generate-new-buffer " *alert-account-a*")) (account-b-buffer (generate-new-buffer " *alert-account-b*")) (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) seen) (unwind-protect (progn (dolist (entry `((,account-b-buffer account-b) (,account-a-buffer account-a))) (with-current-buffer (car entry) (setq-local major-mode 'jabber-chat-mode) (setq-local jabber-buffer-connection (cadr entry)) (setq-local jabber-chatting-with "friend@example.com") (jabber-buffer-registry-register 'chat "friend@example.com"))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (jc) (pcase jc ('account-a "a@example.com") ('account-b "b@example.com"))))) (let ((jabber-message-hooks (list (lambda (_from buffer _body _alert) (setq seen buffer)))) (jabber-alert-message-hooks nil) (jabber-alert-message-function (lambda (&rest _) "alert"))) (jabber-chat--display-message 'account-b nil nil nil "friend@example.com" '(:body "reply" :thread-id "thread-1")))) (should (eq seen account-b-buffer))) (kill-buffer account-a-buffer) (kill-buffer account-b-buffer)))) (ert-deftest jabber-test-message-thread-closed-chat-alert-without-parent-is-safe () "A closed reply without a parent leaves buffer-dependent hooks inert." (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-chat--find-buffer-on-connection) (lambda (&rest _) nil)) ((symbol-function 'jabber-chat--select-buffer) (lambda (&rest _) (ert-fail "Closed thread alert created a parent buffer"))) ((symbol-function 'display-buffer) (lambda (&rest _) (ert-fail "Alert displayed a missing buffer"))) ((symbol-function 'switch-to-buffer) (lambda (&rest _) (ert-fail "Alert switched to a missing buffer"))) ((symbol-function 'get-buffer-window-list) (lambda (&rest _) (ert-fail "Alert scrolled a missing buffer")))) (dolist (hook '(jabber-message-display jabber-message-switch jabber-message-scroll)) (let ((jabber-message-hooks nil) (jabber-alert-message-hooks (list hook)) (jabber-alert-message-function (lambda (&rest _) "alert"))) (jabber-chat--display-message 'jc nil nil nil "alice@example.com" '(:body "reply" :thread-id "thread-1")))))) (ert-deftest jabber-test-message-thread-closed-muc-alert-has-parent-buffer () "A closed MUC reply alerts with the room buffer without insertion." (let ((parent (generate-new-buffer " *jabber-thread-muc-alert-parent*")) seen) (unwind-protect (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (&rest _) parent))) (let ((jabber-muc-hooks (list (lambda (_nick _group buffer _body _alert) (setq seen buffer)))) (jabber-alert-muc-hooks nil) (jabber-alert-muc-function (lambda (&rest _) "alert"))) (jabber-muc--display-message 'jc '(message ((from . "room@example.com/Alice") (type . "groupchat"))) "room@example.com" "Alice" :muc-foreign '(:body "reply" :thread-id "thread-1") 'closed) (should (eq parent seen)) (should (equal "" (with-current-buffer parent (buffer-string)))))) (kill-buffer parent)))) (ert-deftest jabber-test-message-thread-closed-muc-reply-stays-closed () "MUC dispatch maps a closed known reply to the closed sentinel." (let (display-target) (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--classify-message) (lambda (&rest _) :muc-foreign)) ((symbol-function 'jabber-message-thread-display-target) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-find-buffer) (lambda (&rest _) (ert-fail "selected parent buffer"))) ((symbol-function 'jabber-muc--display-message) (lambda (_jc _xml _group _nick _type _msg &optional target) (setq display-target target)))) (jabber-muc-process-message 'jc '(message ((from . "room@example.com/Alice") (type . "groupchat")) (body () "reply") (thread () "thread-1"))) (should (eq display-target 'closed))))) (ert-deftest jabber-test-message-thread-root-reaction-updates-both-views () "A reaction to a root updates the canonical and thread views." (let ((parent (generate-new-buffer " *jabber-reaction-parent*")) (thread (generate-new-buffer " *jabber-reaction-thread*")) seen) (unwind-protect (cl-letf (((symbol-function 'jabber-reactions--unwrap-stanza) (lambda (_jc xml) (cons xml nil))) ((symbol-function 'jabber-reactions--single-element) (lambda (_) 'reactions)) ((symbol-function 'jabber-reactions--parse-element) (lambda (_) '("root-1" ("👍")))) ((symbol-function 'jabber-reactions--persist-update) (lambda (&rest _) :ok)) ((symbol-function 'jabber-reactions--storage-peer) (lambda (&rest _) "alice@example.com")) ((symbol-function 'jabber-message-thread-update-targets) (lambda (&rest _) (list parent thread))) ((symbol-function 'jabber-chat-ewoc-find-by-id) (lambda (_) 'node)) ((symbol-function 'jabber-reactions--apply-incoming-update) (lambda (&rest _) (push (current-buffer) seen)))) (jabber-reactions--handle-message 'jc '(message ((from . "alice@example.com") (type . "chat")))) (should (equal (list thread parent) seen))) (kill-buffer parent) (kill-buffer thread)))) (ert-deftest jabber-test-message-thread-root-moderation-updates-both-views () "Moderating a root updates the canonical and thread views." (let ((parent (generate-new-buffer " *jabber-moderation-parent*")) (thread (generate-new-buffer " *jabber-moderation-thread*")) seen) (unwind-protect (cl-letf (((symbol-function 'jabber-moderation--retraction-element) (lambda (_) (cons '(retract () (moderated ()) (reason () "spam")) nil))) ((symbol-function 'jabber-moderation--target-id) (lambda (&rest _) "root-1")) ((symbol-function 'jabber-moderation--moderator) (lambda (&rest _) "mod@example.com")) ((symbol-function 'jabber-message-thread-update-targets) (lambda (&rest _) (list parent thread))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-retract-message-in-peer) #'ignore) ((symbol-function 'jabber-moderation--mark-ewoc-retracted) (lambda (&rest _) (push (current-buffer) seen)))) (jabber-moderation--handle-message 'jc '(message ((from . "room@example.com") (type . "groupchat")))) (should (equal (list thread parent) seen))) (kill-buffer parent) (kill-buffer thread)))) (ert-deftest jabber-test-message-thread-local-moderation-updates-owner () "Successful local moderation updates a reply's owning thread view." (let ((thread (generate-new-buffer " *jabber-local-moderation-thread*")) seen) (unwind-protect (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-retract-message-in-peer) #'ignore) ((symbol-function 'jabber-message-thread-update-targets) (lambda (jc peer type id server-id-p) (should (eq jc 'jc)) (should (equal peer "room@example.com")) (should (equal type "groupchat")) (should (equal id "reply-1")) (should server-id-p) (list thread))) ((symbol-function 'jabber-muc-find-buffer) (lambda (&rest _) (ert-fail "Selected the parent MUC buffer"))) ((symbol-function 'jabber-moderation--mark-ewoc-retracted) (lambda (&rest _) (push (current-buffer) seen)))) (jabber-moderation--mark-local-retracted 'jc nil '("room@example.com" "reply-1" "room@example.com/Mod" "spam")) (should (equal (list thread) seen))) (kill-buffer thread)))) (ert-deftest jabber-test-message-thread-display-plist () "Chat display data retains thread identity." (let ((msg (jabber-chat--msg-plist-from-stanza '(message ((from . "alice@example.com") (type . "chat")) (body () "hello") (thread ((parent . "parent-1")) "child-1"))))) (should (equal "child-1" (plist-get msg :thread-id))) (should (equal "parent-1" (plist-get msg :thread-parent-id))))) (provide 'jabber-test-message-thread) ;;; jabber-test-message-thread.el ends here emacs-jabber-0.13.1/tests/jabber-test-modeline.el000066400000000000000000000050521523531702000215670ustar00rootroot00000000000000;;; jabber-test-modeline.el --- Tests for jabber-modeline -*- lexical-binding: t; -*- ;;; Commentary: ;; Mode-line display and debounce logic. ;;; Code: (require 'ert) (require 'jabber-modeline) ;;; Group 1: jabber-mode-line-count-contacts debounce (ert-deftest jabber-test-modeline-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-test-modeline-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-test-modeline-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-test-modeline) ;;; jabber-test-modeline.el ends here emacs-jabber-0.13.1/tests/jabber-test-moderation.el000066400000000000000000000371701523531702000221420ustar00rootroot00000000000000;;; jabber-test-moderation.el --- Tests for jabber-moderation -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0424/XEP-0425 Message Retraction and Moderation. ;;; Code: (require 'ert) (require 'ewoc) (require 'jabber-chatbuffer) (require 'jabber-chat) (require 'jabber-muc) (require 'jabber-moderation) ;;; Test helpers (defmacro jabber-test-moderation-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-test-moderation-server-id-indexed () "Ewoc hash stores and retrieves by :server-id." (jabber-test-moderation-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-test-moderation-server-id-nil-no-index () "A nil :server-id does not pollute the hash table." (jabber-test-moderation-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-test-moderation-retract-updates-ewoc () "Retraction stanza sets :retracted on the original message." (jabber-test-moderation-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 &optional _jc) buf)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@muc.example.com")) ((symbol-function 'jabber-db-retract-message-in-peer) #'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 'fake-jc 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))))))) (ert-deftest jabber-test-moderation-tombstone-updates-ewoc () "Archived tombstone sets :retracted using the MAM archive id." (jabber-test-moderation-with-ewoc (let ((msg (list :id "client-id-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))) (let ((buf (current-buffer)) db-call) (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (_group &optional _jc) buf)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@muc.example.com")) ((symbol-function 'jabber-db-retract-message-in-peer) (lambda (account peer server-id moderator reason) (setq db-call (list account peer server-id moderator reason))))) (let ((tombstone-xml '(message ((from . "room@muc.example.com/alice") (type . "groupchat") (jabber-mam--origin . "t") (jabber-mam--archive-id . "stanza-id-1")) (retracted ((stamp . "2026-01-01T00:00:00Z") (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 'fake-jc tombstone-xml))) (let* ((node (jabber-chat-ewoc-find-by-id "stanza-id-1")) (msg (cadr (ewoc-data node)))) (should (equal '("me@muc.example.com" "room@muc.example.com" "stanza-id-1" "room@muc.example.com/admin" "spam") db-call)) (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-test-moderation-rejects-client-id () "Retraction targeting a client message-id (not server stanza-id) is ignored." (jabber-test-moderation-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 &optional _jc) buf)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@muc.example.com")) ((symbol-function 'jabber-db-retract-message-in-peer) #'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 'fake-jc 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-test-moderation-validates-sender () "Retraction from a participant (not MUC service) is ignored." (jabber-test-moderation-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-test-moderation-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-test-moderation-missing-message-ignored () "Retraction for unknown stanza-id doesn't error." (jabber-test-moderation-with-ewoc (let ((buf (current-buffer))) (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (_group &optional _jc) buf)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@muc.example.com")) ((symbol-function 'jabber-db-retract-message-in-peer) #'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 'fake-jc retract-xml))))))) ;;; Group 6: tombstone rendering (ert-deftest jabber-test-moderation-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-test-moderation-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-test-moderation-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-test-moderation-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-test-moderation-retract-sends-iq () "jabber-moderation-retract sends correct IQ XML." (jabber-test-moderation-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) (db-call nil) (buf (current-buffer))) (jabber-chat-ewoc-enter (list :muc-foreign msg)) (goto-char (point-min)) (cl-letf (((symbol-function 'jabber-send-iq) (lambda (jc to type query success success-data error error-data) (setq sent-iq (list :jc jc :to to :type type :query query :success success :success-data success-data :error error :error-data error-data)))) ((symbol-function 'read-string) (lambda (&rest _) "test reason")) ((symbol-function 'jabber-muc-nickname) (lambda (_room _jc) "nick")) ((symbol-function 'jabber-muc-find-buffer) (lambda (_room &optional _jc) buf)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-retract-message-in-peer) (lambda (&rest args) (setq db-call args)))) (jabber-moderation-retract) (should (equal "room@muc.example.com" (plist-get sent-iq :to))) (should (equal "set" (plist-get sent-iq :type))) (should-not db-call) (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))))) (funcall (plist-get sent-iq :success) 'fake-jc '(iq ((type . "result"))) (plist-get sent-iq :success-data)) (should (equal '("me@example.com" "room@muc.example.com" "sid-retract" "room@muc.example.com/nick" "test reason") db-call)) (let* ((node (jabber-chat-ewoc-find-by-id "sid-retract")) (msg (cadr (ewoc-data node)))) (should (plist-get msg :retracted))))))) (ert-deftest jabber-test-moderation-retract-errors-without-server-id () "jabber-moderation-retract signals error when no server-id." (jabber-test-moderation-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-test-moderation-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-test-moderation) ;;; jabber-test-moderation.el ends here emacs-jabber-0.13.1/tests/jabber-test-muc.el000066400000000000000000002610351523531702000205640ustar00rootroot00000000000000;;; jabber-test-muc.el --- Tests for jabber-muc -*- lexical-binding: t; -*- ;;; Commentary: ;; Multi-user chat rooms. ;;; Code: (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-core) (require 'jabber-alert) (require 'jabber-muc) (require 'jabber-muc-nick-completion) (defmacro jabber-test-muc-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-test-muc-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-test-muc-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-test-muc-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-test-muc-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-test-muc-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-test-muc-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-test-muc-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-test-muc-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-test-muc-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-test-muc-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 (_group &optional _jc) 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 (_group &optional _jc) 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 (_group &optional _jc) 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 (_group &optional _jc) 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))))))) (ert-deftest jabber-test-muc-direct-invite-password-reaches-join () "Accepting a direct invite retains its password for the join." (let ((jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--session-passwords (make-hash-table :test #'equal)) (jabber-buffer-connection 'jc) joined) (with-temp-buffer (setq-local jabber-buffer-connection 'jc) (cl-letf (((symbol-function 'jabber-muc-read-my-nickname) (lambda (&rest _) "nick")) ((symbol-function 'jabber-muc-join) (lambda (jc group nick &optional _popup) (setq joined (list jc group nick (jabber-muc--session-password jc group)))))) (jabber-muc-print-invite (list :xml-data '(message ((from . "alice@example.com/home")) (x ((xmlns . "jabber:x:conference") (jid . "room@conference.example.com") (password . "secret"))))) nil :insert) (button-activate (next-button (point-min)))) (should (equal '(jc "room@conference.example.com" "nick" "secret") joined))))) (ert-deftest jabber-test-muc-direct-invite-without-password-reaches-join () "Accepting a passwordless direct invite joins without storing a secret." (let ((jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--session-passwords (make-hash-table :test #'equal)) joined) (with-temp-buffer (setq-local jabber-buffer-connection 'jc) (cl-letf (((symbol-function 'jabber-muc-read-my-nickname) (lambda (&rest _) "nick")) ((symbol-function 'jabber-get-conference-data) #'ignore) ((symbol-function 'jabber-muc-join) (lambda (jc group nick &optional _popup) (setq joined (list jc group nick (jabber-muc--session-password jc group)))))) (jabber-muc-print-invite (list :xml-data '(message ((from . "alice@example.com/home")) (x ((xmlns . "jabber:x:conference") (jid . "room@conference.example.com"))))) nil :insert) (button-activate (next-button (point-min)))) (should (equal '(jc "room@conference.example.com" "nick" nil) joined)) (should-not (gethash '(jc "room@conference.example.com") jabber-muc--session-passwords))))) (ert-deftest jabber-test-muc-direct-invite-includes-known-password () "Outgoing direct invitations include a known session password." (let ((jabber-muc--session-passwords (make-hash-table :test #'equal)) sent) (puthash '(jc "room@conference.example.com") "secret" jabber-muc--session-passwords) (cl-letf (((symbol-function 'jabber-send-iq) #'ignore) ((symbol-function 'jabber-send-sexp) (lambda (_jc stanza) (setq sent stanza)))) (jabber-muc-invite 'jc "bob@example.com" "room@conference.example.com" "")) (let ((x (car (jabber-xml-get-children sent 'x)))) (should (equal "secret" (jabber-xml-get-attribute x 'password)))))) (ert-deftest jabber-test-muc-direct-invite-omits-unknown-password () "Outgoing direct invitations omit the password attribute when unknown." (let ((jabber-muc--session-passwords (make-hash-table :test #'equal)) sent) (cl-letf (((symbol-function 'jabber-send-iq) #'ignore) ((symbol-function 'jabber-get-conference-data) #'ignore) ((symbol-function 'jabber-send-sexp) (lambda (_jc stanza) (setq sent stanza)))) (jabber-muc-invite 'jc "bob@example.com" "room@conference.example.com" "")) (let ((x (car (jabber-xml-get-children sent 'x)))) (should x) (should-not (jabber-xml-get-attribute x 'password))))) (ert-deftest jabber-test-muc-disable-disco-uses-bookmarked-password () "The no-disco join path falls back to a bookmarked password." (let ((jabber-muc-disable-disco-check t) (jabber-muc--session-passwords (make-hash-table :test #'equal)) conference-args args) (cl-letf (((symbol-function 'jabber-muc-joined-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc--autojoin-dequeue) #'ignore) ((symbol-function 'jabber-get-conference-data) (lambda (&rest values) (setq conference-args values) "secret")) ((symbol-function 'read-passwd) (lambda (&rest _) (ert-fail "password prompt called"))) ((symbol-function 'jabber-muc--send-join-presence) (lambda (&rest values) (setq args values)))) (jabber-muc-join 'jc "room@conference.example.com" "nick")) (should-not (gethash '(jc "room@conference.example.com") jabber-muc--session-passwords)) (should (equal '(jc "room@conference.example.com" nil :password) conference-args)) (should (equal '(jc "room@conference.example.com" "nick" "secret" nil) args)))) (ert-deftest jabber-test-muc-prompted-password-survives-self-ping-rejoin () "A prompted room password is retained for forced self-ping rejoin." (let ((jabber-muc--session-passwords (make-hash-table :test #'equal)) (jabber-pending-groupchats (make-hash-table :test #'eq)) (jabber-jid-obarray (make-vector 127 0)) sent) (cl-letf (((symbol-function 'jabber-muc--validate-disco-result) (lambda (_result) '(:status ok :features ("muc_passwordprotected")))) ((symbol-function 'read-passwd) (lambda (&rest _) "secret")) ((symbol-function 'jabber-presence-children) (lambda (_jc) nil)) ((symbol-function 'jabber-send-sexp) (lambda (_jc stanza) (push stanza sent))) ((symbol-function 'jabber-muc-remove-groupchat) #'ignore) ((symbol-function 'jabber-iq-error) (lambda (_xml) '(error nil))) ((symbol-function 'jabber-error-condition) (lambda (_error) 'not-acceptable))) (jabber-muc--disco-callback 'jc '("room@example.org" "nick" nil) '(iq nil)) (should (equal "secret" (gethash '(jc "room@example.org") jabber-muc--session-passwords))) (jabber-muc--self-ping-failed 'jc '(iq nil) '("room@example.org" . "nick"))) (should (= 2 (length sent))) (dolist (presence sent) (should (equal "secret" (jabber-xml-path presence '(x password ""))))))) (ert-deftest jabber-test-muc-disable-disco-empty-password-stays-nil () "An empty no-disco password prompt keeps the passwordless join shape." (let ((jabber-muc-disable-disco-check t) (jabber-muc--session-passwords (make-hash-table :test #'equal)) sent-password) (cl-letf (((symbol-function 'jabber-muc-joined-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc--autojoin-dequeue) #'ignore) ((symbol-function 'jabber-get-conference-data) #'ignore) ((symbol-function 'read-passwd) (lambda (&rest _) "")) ((symbol-function 'jabber-muc--send-join-presence) (lambda (_jc _group _nick password _popup &optional _configure) (setq sent-password password)))) (jabber-muc-join 'jc "room@example.org" "nick" t) (should-not sent-password)))) (ert-deftest jabber-test-muc-session-password-cleared-on-leave () "Leaving a room clears its in-memory password." (let ((jabber-muc--session-passwords (make-hash-table :test #'equal)) (jabber-muc--rooms-before-disconnect (make-hash-table :test #'equal)) (jabber-bookmarks-auto-add nil) dequeued) (puthash '(jc "room@conference.example.com") "secret" jabber-muc--session-passwords) (puthash "account@example.com" '(("room@conference.example.com" "nick" "secret") ("other@conference.example.com" "nick" nil)) jabber-muc--rooms-before-disconnect) (cl-letf (((symbol-function 'jabber-muc-nickname) (lambda (&rest _) "nick")) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "account@example.com")) ((symbol-function 'jabber-send-sexp) #'ignore) ((symbol-function 'jabber-muc--autojoin-dequeue) (lambda (jc group) (setq dequeued (list jc group))))) (jabber-muc-leave 'jc "room@conference.example.com")) (should (equal dequeued '(jc "room@conference.example.com"))) (should-not (gethash '(jc "room@conference.example.com") jabber-muc--session-passwords)) (should (equal (gethash "account@example.com" jabber-muc--rooms-before-disconnect) '(("other@conference.example.com" "nick" nil)))))) (ert-deftest jabber-test-muc-disco-preserves-invited-password () "Disco joins use a direct invitation password even without a feature flag." (let ((jabber-muc--session-passwords (make-hash-table :test #'equal)) sent-password) (jabber-muc--remember-password 'jc "room@example.org" "secret") (cl-letf (((symbol-function 'jabber-muc--validate-disco-result) (lambda (_result) '(:status ok :features nil))) ((symbol-function 'jabber-muc--send-join-presence) (lambda (_jc _group _nick password _popup &optional _configure) (setq sent-password password)))) (jabber-muc--disco-callback 'jc '("room@example.org" "romeo" nil) nil) (should (equal sent-password "secret"))))) (ert-deftest jabber-test-muc-session-password-is-account-scoped () "Passwords for the same room do not cross account boundaries." (let ((jabber-muc--session-passwords (make-hash-table :test #'equal)) (first (list :first)) (second (list :second))) (cl-letf (((symbol-function 'jabber-get-conference-data) #'ignore)) (jabber-muc--remember-password first "room@example.org" "secret") (should (equal (jabber-muc--session-password first "room@example.org") "secret")) (should-not (jabber-muc--session-password second "room@example.org"))))) (ert-deftest jabber-test-muc-rejected-session-password-prompts-for-replacement () "A rejected session password prompts without changing other cached secrets." (let ((jabber-muc-disable-disco-check nil) (jabber-muc--session-passwords (make-hash-table :test #'equal)) (room "room@example.org") (bookmark-reads 0) prompt sent) (puthash (list 'jc room) "rejected" jabber-muc--session-passwords) (puthash '(jc "other@example.org") "other-room" jabber-muc--session-passwords) (puthash '(other-jc "room@example.org") "other-account" jabber-muc--session-passwords) (cl-letf (((symbol-function 'jabber-muc-remove-groupchat) #'ignore) ((symbol-function 'jabber-muc-get-buffer) (lambda (&rest _) " *missing-muc-test*")) ((symbol-function 'run-with-timer) #'ignore) ((symbol-function 'message) #'ignore) ((symbol-function 'jabber-muc-joined-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc--autojoin-dequeue) #'ignore) ((symbol-function 'jabber-muc--validate-disco-result) (lambda (_result) '(:status no-disco :features nil))) ((symbol-function 'jabber-disco-get-info) (lambda (jc _group _node callback closure) (funcall callback jc closure nil))) ((symbol-function 'jabber-get-conference-data) (lambda (&rest _) (setq bookmark-reads (1+ bookmark-reads)) "bookmarked")) ((symbol-function 'read-passwd) (lambda (&rest _) (setq prompt t) "replacement")) ((symbol-function 'jabber-muc--send-join-presence) (lambda (&rest args) (setq sent args)))) (jabber-muc--process-self-leave 'jc room "error" nil `(error ((code . "401")) (not-authorized ((xmlns . ,jabber-stanzas-xmlns)))) nil nil) (should-not (gethash (list 'jc room) jabber-muc--session-passwords 'missing)) (should (equal "other-room" (gethash '(jc "other@example.org") jabber-muc--session-passwords))) (should (equal "other-account" (gethash '(other-jc "room@example.org") jabber-muc--session-passwords))) (jabber-muc-join 'jc room "nick" t)) (should prompt) (should (zerop bookmark-reads)) (should (equal '(jc "room@example.org" "nick" "replacement" t) sent)))) (ert-deftest jabber-test-muc-unrelated-error-preserves-session-password () "A non-authorization MUC error preserves the cached session password." (let ((jabber-muc--session-passwords (make-hash-table :test #'equal)) (room "room@example.org")) (puthash (list 'jc room) "valid" jabber-muc--session-passwords) (cl-letf (((symbol-function 'jabber-muc-remove-groupchat) #'ignore) ((symbol-function 'jabber-muc-get-buffer) (lambda (&rest _) " *missing-muc-test*")) ((symbol-function 'run-with-timer) #'ignore) ((symbol-function 'message) #'ignore)) (jabber-muc--process-self-leave 'jc room "error" nil `(error ((code . "503")) (service-unavailable ((xmlns . ,jabber-stanzas-xmlns)))) nil nil)) (should (equal "valid" (gethash (list 'jc room) jabber-muc--session-passwords))))) (ert-deftest jabber-test-muc-rejoin-snapshots-are-account-scoped () "Rejoining one account leaves another account's snapshot untouched." (let ((jabber-muc--rooms-before-disconnect (make-hash-table :test #'equal)) (jabber-muc--session-passwords (make-hash-table :test #'equal)) enqueued) (puthash "first@example.com" '(("one@muc.example" "one" "secret")) jabber-muc--rooms-before-disconnect) (puthash "second@example.com" '(("two@muc.example" "two" nil)) jabber-muc--rooms-before-disconnect) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (jc) (if (eq jc 'first) "first@example.com" "second@example.com"))) ((symbol-function 'jabber-muc-joined-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc--autojoin-queued-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc--autojoin-enqueue-pending) (lambda (jc room nick) (setq enqueued (list jc room nick))))) (jabber-muc--rejoin-snapshot 'first)) (should (equal enqueued '(first "one@muc.example" "one"))) (should (equal (jabber-muc--session-password 'first "one@muc.example") "secret")) (should-not (gethash "first@example.com" jabber-muc--rooms-before-disconnect)) (should (gethash "second@example.com" jabber-muc--rooms-before-disconnect)))) (ert-deftest jabber-test-muc-session-reset-snapshots-transient-password () "Unexpected reconnectable disconnect snapshots then clears room secrets." (let ((jabber-auto-reconnect t) (jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--room-jids (make-hash-table :test #'equal)) (jabber-muc--nonanonymous-rooms (make-hash-table :test #'equal)) (jabber-muc--session-passwords (make-hash-table :test #'equal)) (jabber-muc--rooms-before-disconnect (make-hash-table :test #'equal)) (jabber-muc-participants nil)) (puthash "room@example.org" '((jc . "nick")) jabber-muc--rooms) (jabber-muc--remember-password 'jc "room@example.org" "secret") (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "a@example.org")) ((symbol-function 'fsm-get-state-data) (lambda (_jc) '(:ever-session-established t)))) (jabber-muc--session-reset 'jc) (should-not (gethash '(jc "room@example.org") jabber-muc--session-passwords)) (should (equal (gethash "a@example.org" jabber-muc--rooms-before-disconnect) '(("room@example.org" "nick" "secret"))))))) (ert-deftest jabber-test-muc-session-reset-discards-terminal-password () "Expected terminal disconnects discard secrets and reconnect snapshots." (let ((jabber-auto-reconnect t) (jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--room-jids (make-hash-table :test #'equal)) (jabber-muc--nonanonymous-rooms (make-hash-table :test #'equal)) (jabber-muc--session-passwords (make-hash-table :test #'equal)) (jabber-muc--rooms-before-disconnect (make-hash-table :test #'equal)) (jabber-muc-participants nil)) (puthash "room@example.org" '((jc . "nick")) jabber-muc--rooms) (jabber-muc--remember-password 'jc "room@example.org" "secret") (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "a@example.org")) ((symbol-function 'fsm-get-state-data) (lambda (_jc) '(:disconnection-expected t :ever-session-established t)))) (jabber-muc--session-reset 'jc) (should-not (gethash '(jc "room@example.org") jabber-muc--session-passwords)) (should-not (gethash "a@example.org" jabber-muc--rooms-before-disconnect))))) (ert-deftest jabber-test-muc-disconnect-cancels-pending-secret-rejoin () "Public disconnect cancels a pending reconnect and clears its room secret." (let* ((jc (make-symbol "jabber-test-pending-reconnect")) (jabber-connections (list jc)) (jabber-auto-reconnect t) (jabber-lifecycle-session-reset-functions '(jabber-muc--session-reset)) (jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--room-jids (make-hash-table :test #'equal)) (jabber-muc--nonanonymous-rooms (make-hash-table :test #'equal)) (jabber-muc--session-passwords (make-hash-table :test #'equal)) (jabber-muc--rooms-before-disconnect (make-hash-table :test #'equal)) (jabber-muc-participants nil) (room "room@conference.example.com") (account "a@example.org") enqueued) (put jc :name 'jabber-connection) (put jc :state nil) (put jc :state-data '(:username "a" :server "example.org" :ever-session-established t)) (put jc :deferred nil) (put jc :timeout (run-with-timer 60 nil #'ignore)) (puthash account (list (list room "nick" "secret")) jabber-muc--rooms-before-disconnect) (jabber-muc--remember-password jc room "secret") (unwind-protect (cl-letf (((symbol-function 'jabber-muc--autojoin-enqueue-pending) (lambda (&rest args) (setq enqueued args)))) (jabber-disconnect-one jc) (should (plist-get (fsm-get-state-data jc) :disconnection-expected)) (should-not (memq jc jabber-connections)) (should-not (get jc :timeout)) (should-not (gethash (list jc room) jabber-muc--session-passwords)) (should-not (gethash account jabber-muc--rooms-before-disconnect)) (jabber-muc--rejoin-snapshot jc) (should-not enqueued)) (when (timerp (get jc :timeout)) (cancel-timer (get jc :timeout)))))) (ert-deftest jabber-test-muc-legacy-close-preserves-reconnect-snapshot () "The legacy one-argument close call preserves rooms for reconnect." (let ((jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--room-jids (make-hash-table :test #'equal)) (jabber-muc--nonanonymous-rooms (make-hash-table :test #'equal)) (jabber-muc--session-passwords (make-hash-table :test #'equal)) (jabber-muc--rooms-before-disconnect (make-hash-table :test #'equal)) (jabber-muc-participants nil)) (puthash "room@example.org" '((jc . "nick")) jabber-muc--rooms) (jabber-muc--remember-password 'jc "room@example.org" "secret") (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "a@example.org"))) (jabber-muc-connection-closed "a@example.org")) (should (equal (gethash "a@example.org" jabber-muc--rooms-before-disconnect) '(("room@example.org" "nick" "secret")))))) ;;; 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"))))) ;;; Group 20: Participant list UI (ert-deftest jabber-muc-test-names-revert-refreshes-participants () "Reverting a MUC names buffer refreshes participant entries." (let ((jabber-muc-participants '(("room@muc" ("alice" role "participant" affiliation "member" jid "alice@example.com/res"))))) (with-temp-buffer (jabber-muc-names-mode) (setq jabber-muc-names--group "room@muc") (jabber-muc-names--refresh) (should (equal ["alice" "participant" "member" "alice@example.com/res"] (cadar tabulated-list-entries))) (setq jabber-muc-participants '(("room@muc" ("alice" role "moderator" affiliation "admin" jid "alice@example.com/res") ("bob" role "visitor" affiliation "none" jid "bob@example.com/res")))) (revert-buffer nil t) (should (= 2 (length tabulated-list-entries))) (should (equal ["alice" "moderator" "admin" "alice@example.com/res"] (cadar tabulated-list-entries))) (should (equal ["bob" "visitor" "none" "bob@example.com/res"] (cadr (cadr tabulated-list-entries))))))) ;;; Group 21: MUC status-code notices (ert-deftest jabber-test-muc-status-notices-privacy-and-logging () "Privacy and logging status codes produce user-visible notices." (should (equal '("This room exposes your real JID to other occupants" "This room is publicly logged" "This room is no longer publicly logged" "This room is now non-anonymous" "This room is now semi-anonymous") (jabber-muc--status-notices (list jabber-muc-status-nonanonymous jabber-muc-status-logging-enabled jabber-muc-status-logging-disabled jabber-muc-status-now-nonanonymous jabber-muc-status-now-semianonymous))))) (ert-deftest jabber-test-muc-enter-extra-notices-inserts-status-notices () "Entering a room inserts notices for privacy and logging status codes." (let (notices) (cl-letf (((symbol-function 'jabber-muc--insert-notice) (lambda (notice) (push notice notices)))) (jabber-muc--enter-extra-notices "me" (list jabber-muc-status-nonanonymous jabber-muc-status-logging-enabled jabber-muc-status-now-nonanonymous)) (should (equal '("This room exposes your real JID to other occupants" "This room is publicly logged" "This room is now non-anonymous") (nreverse notices)))))) (ert-deftest jabber-test-muc-personal-nick-is-literal () "Regexp characters in a nickname are matched literally." (cl-letf (((symbol-function 'jabber-my-nick) (lambda (&optional _) "bob.m"))) (should (jabber-muc-looks-like-personal-p "bob.m, hello")) (should (jabber-muc-looks-like-personal-p "bob.m: hello")) (should (jabber-muc-looks-like-personal-p "bob.m> hello")) (should-not (jabber-muc-looks-like-personal-p "bobXm: hello")))) (ert-deftest jabber-test-muc-personal-plus-nick-matches () "A plus sign in a nickname does not alter mention matching." (cl-letf (((symbol-function 'jabber-my-nick) (lambda (&optional _) "bob+m"))) (should (jabber-muc-looks-like-personal-p "bob+m: hello")))) (ert-deftest jabber-test-muc-personal-rejects-non-string-inputs () "Personal mention detection ignores missing rooms and non-string messages." (jabber-test-muc-with-rooms nil (let ((jabber-muc-default-nicknames nil)) (should-not (jabber-muc-looks-like-personal-p "hello" "unknown@conference.example.com")) (should-not (jabber-muc-looks-like-personal-p 'not-a-message))))) (ert-deftest jabber-test-muc-unknown-room-personal-alert-is-ignored () "An inbound alert from an unknown room does not signal or run its action." (jabber-test-muc-with-rooms nil (let ((jabber-muc-default-nicknames nil) called) (cl-letf (((symbol-function 'jabber-muc-beep) (lambda (&rest _ignore) (setq called t)))) (jabber-muc-beep-personal "sender" "unknown@conference.example.com" nil "hello" t)) (should-not called)))) (ert-deftest jabber-test-muc-buffer-registry-is-account-scoped () "Two accounts may hold distinct buffers for the same room." (let ((jabber-buffer-registry--buffers (make-hash-table :test #'equal)) (a (generate-new-buffer " *muc-account-a*")) (b (generate-new-buffer " *muc-account-b*")) (group "room@conference.example.com")) (unwind-protect (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (jc) (if (eq jc 'jc-a) "a@example.com" "b@example.com")))) (with-current-buffer a (setq-local jabber-group group) (jabber-buffer-registry-register 'muc (jabber-muc--buffer-key 'jc-a group))) (with-current-buffer b (setq-local jabber-group group) (jabber-buffer-registry-register 'muc (jabber-muc--buffer-key 'jc-b group))) (should (eq a (jabber-muc-find-buffer group 'jc-a))) (should (eq b (jabber-muc-find-buffer group 'jc-b))) (should-not (jabber-muc-find-buffer group))) (kill-buffer a) (kill-buffer b)))) (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 (_group &optional _jc) 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))) ;;; Group 22: MUC nick completion sorting (ert-deftest jabber-test-muc-sort-nicks-default-delimiter () "Nick sorting honors activity with the default completion delimiter." (let ((jabber-muc-completion-delimiter ": ") (jabber-muc-participant-last-speaking '(("room@muc" ("zoe" . 20) ("alice" . 10))))) (should (equal '("zoe: " "alice: " "bob: ") (jabber-sort-nicks '("alice: " "zoe: " "bob: ") "room@muc"))))) (ert-deftest jabber-test-muc-sort-nicks-custom-delimiters () "Nick sorting honors activity with shorter and longer delimiters." (let ((jabber-muc-participant-last-speaking '(("room@muc" ("zoe" . 20) ("alice" . 10))))) (dolist (delimiter '(">" " -> ")) (let ((jabber-muc-completion-delimiter delimiter)) (should (equal (mapcar (lambda (nick) (concat nick delimiter)) '("zoe" "alice" "bob")) (jabber-sort-nicks (mapcar (lambda (nick) (concat nick delimiter)) '("alice" "zoe" "bob")) "room@muc"))))))) ;;; Group 23: MUC nickname faces (defun jabber-test-muc--relative-luminance (color) "Return relative luminance for COLOR." (let ((linear (lambda (component) (if (<= component 0.04045) (/ component 12.92) (expt (/ (+ component 0.055) 1.055) 2.4))))) (pcase-let ((`(,red ,green ,blue) (let ((values (color-values-from-color-spec color))) (if values (mapcar (lambda (component) (/ component 65535.0)) values) (color-name-to-rgb color))))) (+ (* 0.2126 (funcall linear red)) (* 0.7152 (funcall linear green)) (* 0.0722 (funcall linear blue)))))) (defun jabber-test-muc--contrast-ratio (first second) "Return the contrast ratio between FIRST and SECOND." (let ((a (jabber-test-muc--relative-luminance first)) (b (jabber-test-muc--relative-luminance second))) (/ (+ (max a b) 0.05) (+ (min a b) 0.05)))) (defun jabber-test-muc--hue-distance (first second) "Return the circular distance between hue angles FIRST and SECOND." (min (mod (- first second) 360.0) (mod (- second first) 360.0))) (ert-deftest jabber-test-muc-nick-colors-follow-theme-changes () "Theme changes refresh direct nickname faces." (should (memq #'jabber-muc--refresh-nick-faces enable-theme-functions)) (should (memq #'jabber-muc--refresh-nick-faces disable-theme-functions))) (ert-deftest jabber-test-muc-refresh-nick-faces-refreshes-muc-ewoc () "Theme changes redisplay existing MUC messages." (with-temp-buffer (setq major-mode 'jabber-chat-mode) (setq-local jabber-group "room@conference.example.com") (setq-local jabber-chat-ewoc 'ewoc) (let (refreshed) (cl-letf (((symbol-function 'buffer-list) (lambda () (list (current-buffer)))) ((symbol-function 'ewoc-refresh) (lambda (ewoc) (setq refreshed ewoc)))) (jabber-muc--refresh-nick-faces) (should (eq 'ewoc refreshed)))))) (ert-deftest jabber-test-muc-refresh-nick-faces-preserves-history-view () "Theme changes preserve a MUC window reading history." (save-window-excursion (with-temp-buffer (switch-to-buffer (current-buffer)) (setq major-mode 'jabber-chat-mode) (setq-local jabber-group "room@conference.example.com") (setq-local jabber-chat--msg-nodes (make-hash-table :test #'equal)) (setq-local jabber-chat-ewoc (ewoc-create (lambda (data) (insert (plist-get (cadr data) :body) "\n")))) (dotimes (index 100) (ewoc-enter-last jabber-chat-ewoc (list :muc-foreign (list :server-id (format "message-%03d" index) :body (format "Message %03d" index))))) (let* ((window (selected-window)) (anchor-id "message-040") (anchor (jabber-chat-ewoc-find-by-id anchor-id)) (position (ewoc-location anchor))) (set-window-start window position) (set-window-point window position) (redisplay t) (cl-letf (((symbol-function 'buffer-list) (lambda () (list (current-buffer))))) (jabber-muc--refresh-nick-faces)) (setq anchor (jabber-chat-ewoc-find-by-id anchor-id) position (ewoc-location anchor)) (should (= position (window-start window))) (should (= position (window-point window))))))) (ert-deftest jabber-test-muc-nick-hue-matches-xep-0392 () "Nickname hues match the XEP-0392 test vectors." (dolist (entry '(("Romeo" . 327.255249) ("juliet@capulet.lit" . 209.410400) ("😺" . 331.199341) ("council" . 359.994507) ("Board" . 171.430664))) (should (< (abs (- (jabber-muc--nick-hue (car entry)) (cdr entry))) 0.0001)))) (ert-deftest jabber-test-muc-display-hue-stays-near-xep-hue () "Display hue stays within eighteen degrees of the XEP hue." (dolist (nick '("wanderer000" "wanderer017" "wanderer178" "wanderer001" "wanderer209" "willow205")) (pcase-let ((`(,base ,display . ,_rest) (jabber-muc--nick-color-components nick))) (should (<= (min (mod (- base display) 360.0) (mod (- display base) 360.0)) 18.0))))) (ert-deftest jabber-test-muc-nick-color-components-are-stable () "Hash-derived nickname color components remain stable." (cl-mapc (lambda (actual expected) (should (< (abs (- actual expected)) 0.000001))) (jabber-muc--nick-color-components "wanderer000") '(21.5386962890625 36.36425671633333 96.86274509803921 0.01568627450980392))) (ert-deftest jabber-test-muc-color-matches-xep-0392 () "Nickname colors match the XEP-0392 RGB test vectors." (dolist (entry '(("Romeo" . (0.865 0.000 0.686)) ("juliet@capulet.lit" . (0.000 0.515 0.573)) ("😺" . (0.872 0.000 0.659)) ("council" . (0.918 0.000 0.394)) ("Board" . (0.000 0.527 0.457)))) (cl-mapc (lambda (actual expected) (should (< (abs (- actual expected)) 0.001))) (jabber-muc--hsluv-rgb (jabber-muc--nick-hue (car entry)) 100 50) (cdr entry)))) (ert-deftest jabber-test-muc-hsluv-matches-reference-vectors () "HSLuv conversion handles varied saturation and lightness." (dolist (entry '(((76.4373779 75 70) . (0.7311863 0.6755247 0.3317136)) ((75.8715820 60 80) . (0.8374650 0.7814542 0.4900905)))) (cl-mapc (lambda (actual expected) (should (< (abs (- actual expected)) 0.0001))) (apply #'jabber-muc--hsluv-rgb (car entry)) (cdr entry)))) (ert-deftest jabber-test-muc-nick-colors-are-distinct-and-readable () "Generated nickname colors stay distinct and readable on common backgrounds." (dolist (background '("#000000" "#202020" "#eeeeee" "#ffffff" "black" "white")) (dolist (saturation '(60 80 100)) (dolist (variation '(0 0.5 1)) (let ((colors (mapcar (lambda (hue) (jabber-muc--nick-color hue saturation variation background)) '(15 60 105 150 195 240 285 330)))) (should (>= (length (delete-dups (copy-sequence colors))) 6)) (dolist (color colors) (should (>= (jabber-test-muc--contrast-ratio color background) 4.5)))))))) (ert-deftest jabber-test-muc-nick-colors-are-readable-on-midtones () "Generated nickname colors choose the stronger contrast on midtones." (dolist (background '("#414141" "#777777" "#989898")) (dolist (saturation '(60 100)) (dolist (variation '(0 1)) (dolist (hue '(15 60 105 150 195 240 285 330)) (should (>= (jabber-test-muc--contrast-ratio (jabber-muc--nick-color hue saturation variation background) background) 4.5))))))) (ert-deftest jabber-test-muc-local-nick-face-keeps-plaintext-style () "The local MUC nickname retains its established face and weight." (should (eq 'jabber-chat-nick-plaintext (face-attribute 'jabber-muc-nick-local-face :inherit nil nil))) (should (eq 'semi-bold (face-attribute 'jabber-muc-nick-local-face :weight nil nil))) (should (eq 'unspecified (face-attribute 'jabber-muc-nick-local-face :slant nil nil)))) (ert-deftest jabber-test-muc-nick-face-stable () "A known nickname gets a stable semi-bold foreground." (cl-letf (((symbol-function 'jabber-muc--default-background) (lambda () "#202020"))) (let ((face (jabber-muc--nick-face "alice"))) (should (equal (apply #'jabber-muc--nick-color (append (cdr (jabber-muc--nick-color-components "alice")) '("#202020"))) (plist-get face :foreground))) (should (eq 'semi-bold (plist-get face :weight))) (should-not (plist-member face :slant))))) (ert-deftest jabber-test-muc-nick-face-varies-clustered-hues () "Later hash bytes distinguish synthetic clustered hues." (cl-letf (((symbol-function 'jabber-muc--default-background) (lambda () "#202020"))) (dolist (nicks '(("wanderer000" "wanderer017" "wanderer178") ("wanderer001" "wanderer209" "willow205"))) (let ((faces (mapcar #'jabber-muc--nick-face nicks))) (should (= (length faces) (length (delete-dups faces)))))))) (ert-deftest jabber-test-muc-display-hue-separates-clustered-hues () "Display hue separates synthetic clustered pairs." (dolist (pair '(("wanderer000" "wanderer017") ("wanderer000" "wanderer178") ("wanderer001" "wanderer209") ("wanderer001" "willow205"))) (pcase-let* ((`(,base-a ,display-a . ,_) (jabber-muc--nick-color-components (car pair))) (`(,base-b ,display-b . ,_) (jabber-muc--nick-color-components (cadr pair)))) (should (> (jabber-test-muc--hue-distance display-a display-b) (jabber-test-muc--hue-distance base-a base-b)))))) (ert-deftest jabber-test-muc-nick-face-disabled () "Disabling nickname colors restores the existing face." (let ((jabber-muc-colorize-nicks nil)) (should (equal '((:weight semi-bold) jabber-chat-nick-foreign-plaintext) (jabber-muc--nick-face "alice"))))) (ert-deftest jabber-test-muc-obsolete-palette-option-retains-toggle () "Obsolete palette values retain enabled and disabled behavior." (with-suppressed-warnings ((obsolete jabber-muc-nick-color-faces)) (let ((jabber-muc-nick-color-faces nil)) (should-not jabber-muc-colorize-nicks) (should (equal '((:weight semi-bold) jabber-chat-nick-foreign-plaintext) (jabber-muc--nick-face "alice")))) (let ((jabber-muc-nick-color-faces '(font-lock-keyword-face))) (should jabber-muc-colorize-nicks) (should (plist-member (jabber-muc--nick-face "alice") :foreground))))) (ert-deftest jabber-test-muc-print-prompt-colors-foreign-nick () "A foreign MUC prompt receives its selected nickname face." (let (prompt-args) (cl-letf (((symbol-function 'jabber-chat--format-time) (lambda (&rest _args) "12:34")) ((symbol-function 'jabber-muc--default-background) (lambda () "#202020")) ((symbol-function 'jabber-chat--insert-prompt) (lambda (&rest args) (setq prompt-args args)))) (jabber-muc-print-prompt '(:from "room@conference.example.com/alice" :timestamp nil)) (should (equal `("12:34" "alice" (:weight semi-bold :foreground ,(apply #'jabber-muc--nick-color (append (cdr (jabber-muc--nick-color-components "alice")) '("#202020"))))) prompt-args))))) (ert-deftest jabber-test-muc-print-prompt-keeps-local-face () "A local MUC prompt retains the existing nickname face." (let (prompt-args) (cl-letf (((symbol-function 'jabber-chat--format-time) (lambda (&rest _args) "12:34")) ((symbol-function 'jabber-chat--insert-prompt) (lambda (&rest args) (setq prompt-args args)))) (jabber-muc-print-prompt '(:from "room@conference.example.com/me" :timestamp nil) t) (should (equal '("12:34" "me" jabber-muc-nick-local-face) prompt-args))))) (ert-deftest jabber-test-muc-private-print-prompt-is-semi-bold () "A private MUC prompt uses a semi-bold nickname." (let (prompt-args) (cl-letf (((symbol-function 'jabber-chat--format-time) (lambda (&rest _args) "12:34")) ((symbol-function 'jabber-jid-rostername) (lambda (_jid) "Room")) ((symbol-function 'jabber-chat--insert-prompt) (lambda (&rest args) (setq prompt-args args)))) (jabber-muc-private-print-prompt '(:from "room@conference.example.com/alice" :timestamp nil)) (should (equal '("12:34" "Room/alice" ((:weight semi-bold) jabber-chat-nick-foreign-plaintext)) prompt-args))))) (ert-deftest jabber-test-muc-receive-config-opens-data-form-in-origin () "A live originating buffer opens a dedicated configuration form." (let (shown-form shown-actions) (cl-letf (((symbol-function 'pop-to-buffer) #'ignore) ((symbol-function 'jabber-xdata-form-open) (lambda (form actions) (setq shown-form form shown-actions actions)))) (with-temp-buffer (jabber-muc--receive-config 'fake-jc '(iq ((from . "room@conference.example.org") (type . "result")) (query ((xmlns . "http://jabber.org/protocol/muc#owner")) (x ((xmlns . "jabber:x:data") (type . "form")) (field ((var . "FORM_TYPE") (type . "hidden")) (value nil "http://jabber.org/protocol/muc#roomconfig")) (field ((var . "roles") (type . "list-multi")) (value nil "moderator") (option nil (value nil "moderator")) (option nil (value nil "participant")))))) (list (current-buffer) "room@conference.example.org")))) (should (equal (plist-get (jabber-xdata-field shown-form "roles") :values) '("moderator"))) (should (equal (plist-get shown-form :title) "Configuration: room@conference.example.org")) (should (equal (mapcar (lambda (action) (plist-get action :label)) shown-actions) '("Submit" "Cancel"))))) (ert-deftest jabber-test-muc-overlapping-forms-keep-room-context () "Submitting an older form uses its original room and connection." (let (opened sent) (cl-letf (((symbol-function 'pop-to-buffer) #'ignore) ((symbol-function 'jabber-xdata-form-open) (lambda (_form actions) (setq opened (append opened (list actions))))) ((symbol-function 'jabber-connection-active-p) #'identity) ((symbol-function 'jabber-send-iq) (lambda (jc to _type _query &rest _ignore) (setq sent (list jc to))))) (with-temp-buffer (dolist (request '((first-jc "one@conference.example.org") (second-jc "two@conference.example.org"))) (jabber-muc--receive-config (nth 0 request) '(iq ((type . "result")) (query ((xmlns . "http://jabber.org/protocol/muc#owner")) (x ((xmlns . "jabber:x:data") (type . "form"))))) (list (current-buffer) (nth 1 request))))) (with-temp-buffer (setq-local jabber-xdata-form--form '(:fields nil)) (let ((jabber-connections '(first-jc second-jc))) (call-interactively (plist-get (car (car opened)) :command))))) (should (equal sent '(first-jc "one@conference.example.org"))))) (ert-deftest jabber-test-muc-submit-config-preserves-form-values () "MUC configuration submits hidden and ordered list-multi values." (let (sent-query) (cl-letf (((symbol-function 'jabber-connection-active-p) #'identity) ((symbol-function 'jabber-send-iq) (lambda (_jc to type query &rest _ignore) (should (equal to "room@conference.example.org")) (should (equal type "set")) (setq sent-query query)))) (with-temp-buffer (setq-local jabber-muc--config-connection 'fake-jc) (setq-local jabber-muc--config-group "room@conference.example.org") (setq-local jabber-xdata-form--form (jabber-xdata-parse '(x ((xmlns . "jabber:x:data") (type . "form")) (field ((var . "FORM_TYPE") (type . "hidden")) (value nil "urn:roomconfig")) (field ((var . "roles") (type . "list-multi")) (value nil "visitor") (value nil "moderator") (option nil (value nil "moderator")) (option nil (value nil "visitor")))))) (let ((jabber-connections '(fake-jc))) (jabber-muc-submit-config)))) (let* ((xdata (car (jabber-xml-get-children sent-query 'x))) (fields (jabber-xml-get-children xdata 'field))) (should (equal (mapcar (lambda (value) (car (jabber-xml-node-children value))) (jabber-xml-get-children (cadr fields) 'value)) '("moderator" "visitor"))) (should (equal (car (jabber-xml-node-children (car (jabber-xml-get-children (car fields) 'value)))) "urn:roomconfig"))))) (ert-deftest jabber-test-muc-cancel-config-sends-cancel-form () "Canceling a room configuration sends XEP-0004 type cancel." (let (sent-query) (cl-letf (((symbol-function 'jabber-connection-active-p) #'identity) ((symbol-function 'jabber-send-iq) (lambda (_jc _to _type query &rest _ignore) (setq sent-query query)))) (with-temp-buffer (setq-local jabber-muc--config-connection 'fake-jc) (setq-local jabber-muc--config-group "room@conference.example.org") (let ((jabber-connections '(fake-jc))) (jabber-muc-cancel-config)))) (let ((xdata (car (jabber-xml-get-children sent-query 'x)))) (should (equal (jabber-xml-get-attribute xdata 'type) "cancel"))))) (ert-deftest jabber-test-muc-config-rejects-reconnecting-connection () "MUC submit and cancel reject a reconnecting FSM before sending." (let ((reconnecting (make-symbol "reconnecting")) jabber-connections called) (setq jabber-connections (list reconnecting)) (put reconnecting :state :connecting) (cl-letf (((symbol-function 'jabber-send-iq) (lambda (&rest _ignore) (setq called t)))) (with-temp-buffer (setq-local jabber-muc--config-connection reconnecting) (setq-local jabber-muc--config-group "room@conference.example.org") (should-error (jabber-muc-submit-config) :type 'user-error) (should-error (jabber-muc-cancel-config) :type 'user-error))) (should-not called))) (ert-deftest jabber-test-muc-config-resolves-established-replacement () "MUC configuration resolves an established replacement connection." (let ((jabber-muc--config-connection 'dead-jc)) (cl-letf (((symbol-function 'jabber-find-active-connection) (lambda (_jc) 'live-jc)) ((symbol-function 'jabber-connection-active-p) (lambda (jc) (eq jc 'live-jc)))) (should (eq (jabber-muc--config-active-connection) 'live-jc))))) (provide 'jabber-test-muc) ;;; jabber-test-muc.el ends here emacs-jabber-0.13.1/tests/jabber-test-notifications.el000066400000000000000000000065531523531702000226530ustar00rootroot00000000000000;;; jabber-test-notifications.el --- Tests for jabber-notifications -*- lexical-binding: t; -*- ;;; Commentary: ;; Desktop notification actions. ;;; Code: (require 'ert) (require 'cl-lib) (require 'jabber-notifications) (defun jabber-test-notifications--arguments (buffer) "Return notification arguments produced for BUFFER." (let (arguments) (cl-letf (((symbol-function 'notifications-notify) (lambda (&rest args) (setq arguments args)))) (jabber-message-notifications "romeo@example.net" buffer "Hello" "Romeo")) arguments)) (ert-deftest jabber-test-notifications-default-action () (with-temp-buffer (should (equal (plist-get (jabber-test-notifications--arguments (current-buffer)) :actions) '("default" "Switch to buffer"))))) (ert-deftest jabber-test-notifications-action-opens-chat-buffer () (with-temp-buffer (let* ((buffer (current-buffer)) (callback (plist-get (jabber-test-notifications--arguments buffer) :on-action)) opened) (cl-letf (((symbol-function 'pop-to-buffer) (lambda (target &rest _) (setq opened target)))) (funcall callback "notification-id" "default")) (should (eq opened buffer))))) (ert-deftest jabber-test-notifications-action-ignores-killed-buffer () (let* ((buffer (generate-new-buffer " jabber-notification-test")) (callback (plist-get (jabber-test-notifications--arguments buffer) :on-action))) (kill-buffer buffer) (cl-letf (((symbol-function 'pop-to-buffer) (lambda (&rest _) (ert-fail "pop-to-buffer called for a killed buffer")))) (should-not (funcall callback "notification-id" "default"))))) (ert-deftest jabber-test-notifications-close-removes-only-own-action () (with-temp-buffer (let* ((arguments (jabber-test-notifications--arguments (current-buffer))) (action (plist-get arguments :on-action)) (on-close (plist-get arguments :on-close)) (other-action (lambda (&rest _))) (notifications-on-action-map `(((bus service 1) ,action) ((bus service 2) ,other-action)))) (funcall on-close "notification-id" 'expired) (should (equal notifications-on-action-map `(((bus service 2) ,other-action))))))) (ert-deftest jabber-test-notifications-close-unregisters-action-signal () (with-temp-buffer (let* ((arguments (jabber-test-notifications--arguments (current-buffer))) (action (plist-get arguments :on-action)) (on-close (plist-get arguments :on-close)) (notifications-on-action-map `(((bus service 1) ,action))) (notifications-on-action-object 'action-signal) unregistered) (cl-letf (((symbol-function 'dbus-unregister-object) (lambda (object) (setq unregistered object)))) (funcall on-close "notification-id" 'expired)) (should (null notifications-on-action-map)) (should (eq unregistered 'action-signal)) (should (null notifications-on-action-object))))) (provide 'jabber-test-notifications) ;;; jabber-test-notifications.el ends here emacs-jabber-0.13.1/tests/jabber-test-omemo-message.el000066400000000000000000002113151523531702000225320ustar00rootroot00000000000000;;; jabber-test-omemo-message.el --- Tests for jabber-omemo-message -*- lexical-binding: t; -*- ;;; Commentary: ;; OMEMO message encryption and decryption. ;;; Code: (require 'ert) (require 'jabber-chat) (require 'jabber-message-reply) (require 'jabber-omemo) (require 'jabber-receipts) (defvar jabber-group nil) (defvar jabber-muc-participants nil) ;;; Test infrastructure (defmacro jabber-test-omemo-message-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-test-omemo-message--dir (make-temp-file "jabber-omemo-msg-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-test-omemo-message--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-test-omemo-message--dir) (delete-directory jabber-test-omemo-message--dir t))))) ;;; Group 1: Fallback body (ert-deftest jabber-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-build-encrypted-structure () "build-encrypted-xml produces correct sexp structure." (jabber-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-muc-echo-requires-exact-occupant () "Only the exact local occupant echo may recover sent plaintext." (let* ((jc 'connection) (room "room@conf.example.com") (id "msg-001") (key (jabber-omemo--muc-echo-key jc room (concat room "/me") id)) (jabber-omemo--sent-muc-plaintexts (make-hash-table :test #'equal)) (xml-data `(message ((from . ,(concat room "/me")) (id . ,id) (type . "groupchat")) (body () "fallback"))) (detected '(:type omemo :parsed (:payload "ciphertext")))) (puthash key "secret text" jabber-omemo--sent-muc-plaintexts) (jabber-omemo--decrypt-handler jc xml-data detected) (should (string= "secret text" (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'body)))))) (should-not (gethash key jabber-omemo--sent-muc-plaintexts)))) (ert-deftest jabber-test-omemo-message-muc-echo-rejects-foreign-occupant () "A foreign occupant reusing our message id cannot read cached plaintext." (let* ((jc 'connection) (room "room@conf.example.com") (id "msg-001") (key (jabber-omemo--muc-echo-key jc room (concat room "/me") id)) (jabber-omemo--sent-muc-plaintexts (make-hash-table :test #'equal)) (xml-data `(message ((from . ,(concat room "/mallory")) (id . ,id) (type . "groupchat")) (body () "fallback"))) (runs 0)) (puthash key "secret text" jabber-omemo--sent-muc-plaintexts) (cl-letf (((symbol-function 'jabber-omemo--decrypt-stanza) (lambda (_jc xml _parsed) (cl-incf runs) (jabber-chat--set-body xml "decrypted foreign")))) (jabber-omemo--decrypt-handler jc xml-data '(:type omemo :parsed (:payload "ciphertext")))) (should (= 1 runs)) (should (gethash key jabber-omemo--sent-muc-plaintexts)))) (ert-deftest jabber-test-omemo-message-muc-echo-rejects-other-room () "Another room reusing our message id cannot read cached plaintext." (let* ((jc 'connection) (room "room@conf.example.com") (other "other@conf.example.com") (id "msg-001") (key (jabber-omemo--muc-echo-key jc room (concat room "/me") id)) (jabber-omemo--sent-muc-plaintexts (make-hash-table :test #'equal)) (xml-data `(message ((from . ,(concat other "/me")) (id . ,id) (type . "groupchat")) (body () "fallback"))) (runs 0)) (puthash key "secret text" jabber-omemo--sent-muc-plaintexts) (cl-letf (((symbol-function 'jabber-omemo--decrypt-stanza) (lambda (_jc xml _parsed) (cl-incf runs) (jabber-chat--set-body xml "decrypted other")))) (jabber-omemo--decrypt-handler jc xml-data '(:type omemo :parsed (:payload "ciphertext")))) (should (= 1 runs)) (should (gethash key jabber-omemo--sent-muc-plaintexts)))) ;;; Group 5: Trust label formatting (ert-deftest jabber-test-omemo-message-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-test-omemo-message-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-test-omemo-message-encrypt-decrypt-roundtrip () "Encrypt and decrypt a message round-trips the plaintext." (jabber-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-httpupload-send-url-handles-aesgcm () "Send-url override returns non-nil for aesgcm:// URLs." (let (sent) (cl-letf (((symbol-function 'jabber-muc-joined-p) (lambda (_group &optional _jc) nil)) ((symbol-function 'jabber-chat-create-buffer) (lambda (_jc _jid) (current-buffer))) ((symbol-function 'jabber-omemo--send-chat) (lambda (jc body &rest _) (setq sent (list jc body (current-buffer)))))) (should (jabber-omemo--httpupload-send-url 'fake-jc "alice@example.com" "aesgcm://host/file#abc123")) (should (equal (list 'fake-jc "aesgcm://host/file#abc123" (current-buffer)) sent))))) (ert-deftest jabber-test-omemo-message-httpupload-stall-fails-on-reset () "A reset cancels a direct upload URL send before its late callback." (let ((chat-buffer (generate-new-buffer " *omemo-upload-chat-test*")) (jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (failures 0) (encrypted 0) continuation) (unwind-protect (progn (with-current-buffer chat-buffer (setq-local jabber-chatting-with "alice@example.com")) (cl-letf (((symbol-function 'jabber-muc-joined-p) (lambda (_group &optional _jc) nil)) ((symbol-function 'jabber-chat-create-buffer) (lambda (_jc _jid) chat-buffer)) ((symbol-function 'jabber-jid-user) #'identity) ((symbol-function 'jabber-omemo--display-pending) (lambda (&rest _) 'pending-node)) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc _jid callback) (setq continuation callback))) ((symbol-function 'jabber-omemo--send-encrypted) (lambda (&rest _) (cl-incf encrypted))) ((symbol-function 'jabber-omemo--send-failed) (lambda (&rest _) (cl-incf failures)))) (jabber-omemo--httpupload-send-url 'fake-jc "alice@example.com" "aesgcm://host/file#abc123") (jabber-omemo--session-reset 'fake-jc) (funcall continuation '((1 . session)))) (should (= 1 failures)) (should (= 0 encrypted))) (kill-buffer chat-buffer)))) (ert-deftest jabber-test-omemo-message-httpupload-send-url-muc-from-any-buffer () "An aesgcm URL for a joined room is sent in that room's buffer. The upload callback fires from a process sentinel where the current buffer is arbitrary; the room must be derived from the JID, not from buffer-local `jabber-group'." (let ((room "room@conference.example.com") (room-buffer (generate-new-buffer " *omemo-muc-upload-test*")) (sent-group nil)) (unwind-protect (progn (with-current-buffer room-buffer (setq-local jabber-group room)) (cl-letf (((symbol-function 'jabber-muc-joined-p) (lambda (group &optional _jc) (equal group room))) ((symbol-function 'jabber-muc-create-buffer) (lambda (_jc _group) room-buffer)) ((symbol-function 'jabber-omemo--send-muc) (lambda (_jc _body &optional _extra) (setq sent-group (bound-and-true-p jabber-group))))) (with-temp-buffer (should (jabber-omemo--httpupload-send-url 'fake-jc room "aesgcm://host/file#abc123")))) (should (equal sent-group room))) (kill-buffer room-buffer)))) (ert-deftest jabber-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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-test-omemo-message-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) ;; Use a real session pointer because the C module rejects placeholders. (puthash (jabber-omemo--session-key "me@example.com" "alice@example.com" 999) (jabber-omemo-make-session) 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-test-omemo-message-decrypt-handler-swallows-bodyless-not-for-us () "decrypt-handler leaves a bodyless stanza unchanged when it 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-test-omemo-message-empty-decrypt-failure-remains-bodyless () "A failed empty OMEMO stanza stays bodyless and retryable." (let* ((detected (list :type 'omemo :parsed (list :payload nil))) (jabber-chat-decrypt-handlers (list (cons 'omemo (list :detect (lambda (_xml) detected) :decrypt #'jabber-omemo--decrypt-handler :priority 10 :error-label "OMEMO")))) (jabber-chat--sorted-decrypt-handlers-cache nil) (jabber-chat--decrypt-cache (make-hash-table :test #'equal)) (calls 0)) (cl-letf (((symbol-function 'jabber-omemo--decrypt-stanza) (lambda (&rest _) (cl-incf calls) (signal 'jabber-omemo-no-session '("alice@example.com" 999))))) (dotimes (_ 2) (let* ((xml-data '(message ((from . "alice@example.com/phone") (type . "chat")) (encrypted nil))) (result (jabber-chat--dispatch-decrypt 'fake-jc xml-data 'cache-key 'context))) (should-not (jabber-xml-get-children result 'body))))) (should (= calls 2)) (should-not (gethash 'cache-key jabber-chat--decrypt-cache)))) (ert-deftest jabber-test-omemo-message-empty-generic-error-remains-bodyless () "A generic failure on an empty OMEMO stanza stays bodyless." (cl-letf (((symbol-function 'jabber-omemo--decrypt-stanza) (lambda (&rest _) (error "Sender JID unknown")))) (let* ((xml-data '(message ((from . "room@example.com/nick") (type . "groupchat")) (encrypted nil))) (detected (list :type 'omemo :parsed (list :payload nil))) (props (list :decrypt #'jabber-omemo--decrypt-handler :error-label "OMEMO")) (result (jabber-chat--try-decrypt 'fake-jc xml-data detected props))) (should-not (jabber-xml-get-children result 'body))))) (ert-deftest jabber-test-omemo-message-empty-post-ratchet-failure-is-cached () "An empty failure after ratchet consumption is cached as bodyless." (let* ((detected (list :type 'omemo :parsed (list :payload nil))) (jabber-chat-decrypt-handlers (list (cons 'omemo (list :detect (lambda (_xml) detected) :decrypt #'jabber-omemo--decrypt-handler :priority 10 :error-label "OMEMO")))) (jabber-chat--sorted-decrypt-handlers-cache nil) (jabber-chat--decrypt-cache (make-hash-table :test #'equal))) (cl-letf (((symbol-function 'jabber-omemo--decrypt-stanza) (lambda (&rest _) (setq jabber-chat--decrypt-consumed-p t) (signal 'jabber-omemo-error '("failed after ratchet consumption"))))) (let* ((xml-data '(message ((from . "alice@example.com/phone") (type . "chat")) (encrypted nil))) (result (jabber-chat--dispatch-decrypt 'fake-jc xml-data 'cache-key 'context))) (should-not (jabber-xml-get-children result 'body)) (should (eq 'no-body (plist-get (gethash 'cache-key jabber-chat--decrypt-cache) :outcome))))))) (ert-deftest jabber-test-omemo-message-empty-prekey-recovery-error-is-bodyless () "An empty pre-key failure stays bodyless when recovery also fails." (let* ((detected (list :type 'omemo :parsed (list :payload nil))) (props (list :decrypt #'jabber-omemo--decrypt-handler :error-label "OMEMO"))) (cl-letf (((symbol-function 'jabber-omemo--decrypt-stanza) (lambda (&rest _) (signal 'jabber-omemo-prekey-failed '("alice@example.com" 999 "bad pre-key")))) ((symbol-function 'jabber-omemo--recover-prekey-failure) (lambda (&rest _) (error "Recovery failed")))) (let* ((xml-data '(message ((from . "alice@example.com/phone") (type . "chat")) (encrypted nil))) (result (jabber-chat--try-decrypt 'fake-jc xml-data detected props))) (should-not (jabber-xml-get-children result 'body)))))) (ert-deftest jabber-test-omemo-message-decrypt-handler-rejects-payload-not-for-us () "decrypt-handler re-signals when a payload-bearing 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")) (body () "OMEMO encrypted message") (encrypted nil))) (detected (list :type 'omemo :parsed (list :payload "ciphertext")))) (should-error (jabber-omemo--decrypt-handler 'fake-jc xml-data detected) :type 'jabber-omemo-not-for-us)))) (ert-deftest jabber-test-omemo-message-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))) ;; Session recovery is exercised elsewhere; keep this ;; test focused on bundle publishing. ((symbol-function 'jabber-omemo--recover-prekey-failure) (lambda (&rest _) nil))) (let ((xml-data '(message ((from . "alice@example.com/phone") (type . "chat")))) (detected (list :type 'omemo :parsed (list :payload "ciphertext")))) (should-error (jabber-omemo--decrypt-handler 'fake-jc xml-data detected) :type 'jabber-omemo-prekey-failed) (should-not publish-called))))) (ert-deftest jabber-test-omemo-message-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 (list :payload "ciphertext")))) (should-error (jabber-omemo--decrypt-handler 'fake-jc xml-data detected) :type 'jabber-omemo-no-session)))) (ert-deftest jabber-test-omemo-message-decrypt-stanza-no-publish-on-prekey-success () "decrypt-stanza does NOT republish bundle on successful prekey decrypt." (jabber-test-omemo-message-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) (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))))))) ;;; Group 14: MUC send hook buffer (ert-deftest jabber-test-omemo-message-chat-stalled-device-list-fails-on-reset () "A reset fails a chat send stalled before recipient sessions arrive." (let ((jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (jabber-chatting-with "friend@example.com") (successes 0) (failures 0) (encrypted 0) continuation) (cl-letf (((symbol-function 'jabber-jid-user) #'identity) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc _jid callback) (setq continuation callback))) ((symbol-function 'jabber-omemo--send-encrypted) (lambda (&rest _) (cl-incf encrypted))) ((symbol-function 'jabber-omemo--send-failed) (lambda (&rest _) nil))) (jabber-omemo--send-chat 'fake-jc "corrected" '((replace ((xmlns . "urn:xmpp:message-correct:0") (id . "old")))) (lambda () (cl-incf successes)) (lambda (_reason) (cl-incf failures))) (jabber-omemo--session-reset 'fake-jc) (funcall continuation '((1 . session))) (should (= 0 successes)) (should (= 1 failures)) (should (= 0 encrypted)) (should-not (gethash 'fake-jc jabber-omemo--pending-send-operations))))) (ert-deftest jabber-test-omemo-message-chat-setup-error-finishes-operation () "A synchronous session setup error fails and unregisters the send." (let ((jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (jabber-chatting-with "friend@example.com") (failures 0)) (cl-letf (((symbol-function 'jabber-jid-user) #'identity) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (&rest _) (error "setup failed"))) ((symbol-function 'jabber-omemo--send-failed) (lambda (&rest _) nil))) (jabber-omemo--send-chat 'fake-jc "corrected" '((replace ((xmlns . "urn:xmpp:message-correct:0") (id . "old")))) #'ignore (lambda (_reason) (cl-incf failures)))) (should (= 1 failures)) (should-not (gethash 'fake-jc jabber-omemo--pending-send-operations)))) (ert-deftest jabber-test-omemo-message-ordinary-chat-stall-fails-on-reset () "A reset fails an ordinary chat send and makes its late callback inert." (let ((jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (jabber-chatting-with "friend@example.com") (failures 0) (encrypted 0) continuation) (cl-letf (((symbol-function 'jabber-jid-user) #'identity) ((symbol-function 'jabber-omemo--display-pending) (lambda (&rest _) 'pending-node)) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc _jid callback) (setq continuation callback))) ((symbol-function 'jabber-omemo--send-encrypted) (lambda (&rest _) (cl-incf encrypted))) ((symbol-function 'jabber-omemo--send-failed) (lambda (&rest _) (cl-incf failures)))) (jabber-omemo--send-chat 'fake-jc "hello") (jabber-omemo--session-reset 'fake-jc) (funcall continuation '((1 . session))) (should (= 1 failures)) (should (= 0 encrypted)) (should-not (gethash 'fake-jc jabber-omemo--pending-send-operations))))) (ert-deftest jabber-test-omemo-message-parent-thread-reply-has-no-pending-echo () "A pending encrypted thread reply never appears in its parent buffer." (with-temp-buffer (setq-local jabber-chat-ewoc (ewoc-create #'ignore)) (setq-local jabber-chat--msg-nodes (make-hash-table :test #'equal)) (setq-local jabber-message-reply--thread '(:thread-id "thread-1" :thread-parent-id nil)) (let ((jabber-chat-printers (list (lambda (&rest _) t)))) (cl-letf (((symbol-function 'jabber-db--outgoing-handler) #'ignore)) (should-not (jabber-omemo--display-pending (current-buffer) "reply" "reply-1")))) (should-not (ewoc-nth jabber-chat-ewoc 0)))) (ert-deftest jabber-test-omemo-message-pending-thread-reply-is-stored-threaded () "A pending encrypted reply remains threaded if encryption later fails." (jabber-test-omemo-message-with-db (with-temp-buffer (setq-local jabber-chatting-with "friend@example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chat-encryption 'omemo) (setq-local jabber-message-reply--thread '(:thread-id "thread-1" :thread-parent-id nil)) (jabber-db-register-message-thread "me@example.com" "friend@example.com" "chat" "thread-1" nil "root-1" nil 1) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (jabber-omemo--display-pending (current-buffer) "reply" "pending-1")) (should (equal '("thread-1") (car (sqlite-select jabber-db--connection "SELECT thread_id FROM message WHERE stanza_id = ?" '("pending-1"))))) (should-not (seq-find (lambda (msg) (equal "pending-1" (plist-get msg :id))) (jabber-db-backlog "me@example.com" "friend@example.com" t 0 nil "chat")))))) (ert-deftest jabber-test-omemo-message-thread-buffer-keeps-pending-echo () "A pending encrypted reply remains visible in its thread buffer." (with-temp-buffer (setq-local jabber-chat-ewoc (ewoc-create #'ignore)) (setq-local jabber-chat--msg-nodes (make-hash-table :test #'equal)) (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-reply--thread '(:thread-id "thread-1" :thread-parent-id nil)) (let ((jabber-chat-printers (list (lambda (&rest _) t)))) (cl-letf (((symbol-function 'jabber-db--outgoing-handler) #'ignore)) (should (jabber-omemo--display-pending (current-buffer) "reply" "reply-1")))) (should (ewoc-nth jabber-chat-ewoc -1)))) (ert-deftest jabber-test-omemo-message-pending-clears-receipt-header () "A pending OMEMO message immediately owns the receipt header." (with-temp-buffer (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chatting-with "friend@example.com") (setq-local jabber-chat-ewoc (ewoc-create #'ignore)) (setq-local jabber-chat--msg-nodes (make-hash-table :test #'equal)) (setq-local jabber-chat-receipt-message " seen 10:00") (let ((jabber-chat-printers (list (lambda (&rest _) t))) (jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) continuation) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.com")) ((symbol-function 'jabber-db--outgoing-handler) #'ignore) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc _jid callback) (setq continuation callback)))) (jabber-omemo--send-chat 'fake-jc "hello") (let ((node (ewoc-nth jabber-chat-ewoc -1))) (should (eq :sending (plist-get (cadr (ewoc-data node)) :status))) (should (equal "" jabber-chat-receipt-message)) (funcall continuation nil) (should (eq :undelivered (plist-get (cadr (ewoc-data node)) :status))) (should (equal "" jabber-chat-receipt-message))))))) (ert-deftest jabber-test-omemo-message-reused-pending-clears-receipt-header () "Reusing a pending OMEMO node still clears its stale receipt header." (with-temp-buffer (setq-local jabber-chat-ewoc (ewoc-create #'ignore)) (setq-local jabber-chat--msg-nodes (make-hash-table :test #'equal)) (setq-local jabber-chat-receipt-message " seen 10:00") (setq-local header-line-format '((:eval jabber-chat-receipt-message))) (let ((jabber-chat-printers (list (lambda (&rest _) t)))) (cl-letf (((symbol-function 'jabber-db--outgoing-handler) #'ignore)) (let* ((existing (jabber-chat-ewoc-enter (list :local (list :id "pending-1" :body "old" :status :sent :timestamp (current-time))))) (pending (jabber-omemo--display-pending (current-buffer) "retry" "pending-1"))) (should (eq existing (plist-get pending :node))) (should (equal "" jabber-chat-receipt-message)) (should (equal "" (format-mode-line header-line-format)))))))) (defun jabber-test-omemo-message--thread-send-result (source-kind outcome) "Run an OMEMO thread send from SOURCE-KIND through OUTCOME." (jabber-test-omemo-message-with-db (let ((parent (generate-new-buffer " *omemo-thread-parent*")) (thread (generate-new-buffer " *omemo-thread-buffer*")) (jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) sent continuation (session-calls 0)) (unwind-protect (progn (dolist (buffer (list parent thread)) (with-current-buffer buffer (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chatting-with "friend@example.com") (setq-local jabber-chat-encryption 'omemo) (setq-local jabber-chat-ewoc (ewoc-create #'ignore)) (setq-local jabber-chat--msg-nodes (make-hash-table :test #'equal)))) (with-current-buffer thread (setq-local jabber-message-thread-id "thread-1") (setq-local jabber-message-thread-parent-id nil) (setq-local jabber-chat-send-hooks '(jabber-message-thread--send-hook jabber-db--outgoing-handler))) (with-current-buffer parent (setq-local jabber-message-reply--id "root-1") (setq-local jabber-message-reply--jid "friend@example.com") (setq-local jabber-message-reply--thread '(:thread-id "thread-1" :thread-parent-id nil)) (setq-local jabber-chat-send-hooks '(jabber-message-reply--send-hook jabber-db--outgoing-handler))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "root" 1 nil "root-1" nil nil nil nil nil '(:thread-id "thread-1" :thread-parent-id nil)) (let ((root-id (caar (sqlite-select jabber-db--connection "SELECT id FROM message WHERE stanza_id = ?" '("root-1"))))) (with-current-buffer thread (ewoc-enter-last jabber-chat-ewoc (list :foreign (list :db-id root-id :id "root-1" :body "root" :thread-id "thread-1"))))) (let ((source-buffer (if (eq source-kind 'parent) parent thread))) (with-current-buffer source-buffer (let ((jabber-chat-printers (list (lambda (&rest _) t)))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-message-thread-find-buffer) (lambda (&rest _) thread)) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc _jid callback) (setq session-calls (1+ session-calls)) (cond ((and (eq outcome 'delayed-dead) (= session-calls 1)) (setq continuation callback)) ((eq outcome 'failure) (funcall callback nil)) (t (funcall callback '((1 . session))))))) ((symbol-function 'jabber-omemo-encrypt-message) (lambda (_plaintext) '(:iv "iv" :key "key" :payload "payload"))) ((symbol-function 'jabber-omemo--build-encrypted-xml) (lambda (&rest _) '(encrypted ((xmlns . "eu.siacs.conversations.axolotl"))))) ((symbol-function 'jabber-send-sexp) (lambda (_jc _stanza &optional success _failure) (setq sent t) (when success (funcall success))))) (jabber-omemo--send-chat 'fake-jc "reply") (when (eq outcome 'delayed-dead) (kill-buffer source-buffer) (funcall continuation '((1 . session)))))))) (let* ((row (car (sqlite-select jabber-db--connection "SELECT stanza_id, thread_id FROM message \ WHERE body = 'reply'"))) (node (and (buffer-live-p thread) (with-current-buffer thread (ewoc-nth jabber-chat-ewoc -1))))) (list :sent sent :active (gethash 'fake-jc jabber-omemo--pending-send-operations) :stored-thread (cadr row) :parent-empty (or (not (buffer-live-p parent)) (not (with-current-buffer parent (ewoc-nth jabber-chat-ewoc 0)))) :status (and node (plist-get (cadr (ewoc-data node)) :status)) :live-thread (and node (plist-get (cadr (ewoc-data node)) :thread-id)) :restored (when-let* ((source (and (buffer-live-p (if (eq source-kind 'parent) parent thread)) (if (eq source-kind 'parent) parent thread)))) (with-current-buffer source (buffer-string)))))) (when (buffer-live-p parent) (kill-buffer parent)) (when (buffer-live-p thread) (kill-buffer thread)))))) (ert-deftest jabber-test-omemo-message-thread-send-pending-lifecycle () "Pending thread ownership survives success and failure from both views." (dolist (source '(parent thread)) (dolist (outcome '(success failure)) (let ((result (jabber-test-omemo-message--thread-send-result source outcome))) (should (equal "thread-1" (plist-get result :stored-thread))) (should (plist-get result :parent-empty)) (should (equal "thread-1" (plist-get result :live-thread))) (should (eq (if (eq outcome 'success) :sent :undelivered) (plist-get result :status))) (should (eq (eq outcome 'success) (plist-get result :sent))) (should-not (plist-get result :active)) (should (eq (eq outcome 'failure) (string-suffix-p "reply" (plist-get result :restored)))))))) (ert-deftest jabber-test-omemo-message-concurrent-sends-keep-thread-owner () "Reverse OMEMO completion cannot move reply and thread metadata." (jabber-test-omemo-message-with-db (with-temp-buffer (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chatting-with "friend@example.com") (setq-local jabber-chat-encryption 'omemo) (setq-local jabber-chat-ewoc (ewoc-create #'ignore)) (setq-local jabber-chat--msg-nodes (make-hash-table :test #'equal)) (setq-local jabber-chat-send-hooks '(jabber-message-reply--send-hook jabber-db--outgoing-handler)) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "root" 1 "phone" "root-1" nil nil nil nil nil '(:thread-id "thread-1")) (let ((jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) callbacks sent (ticks 10)) (cl-letf (((symbol-function 'float-time) (lambda (&optional _) (cl-incf ticks))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.com")) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc jid callback) (if (equal jid "friend@example.com") (push callback callbacks) (funcall callback '((2 . own-session)))))) ((symbol-function 'jabber-omemo-encrypt-message) (lambda (_) '(:iv "iv" :key "key" :payload "payload"))) ((symbol-function 'jabber-omemo--build-encrypted-xml) (lambda (&rest _) '(encrypted ()))) ((symbol-function 'jabber-chat--display-local-message) #'ignore) ((symbol-function 'jabber-send-sexp) (lambda (_jc stanza &optional success _failure) (push stanza sent) (when success (funcall success))))) (setq-local jabber-message-reply--id "root-1") (setq-local jabber-message-reply--jid "friend@example.com") (setq-local jabber-message-reply--thread '(:thread-id "thread-1")) (jabber-omemo--send-chat 'fake-jc "first") (jabber-omemo--send-chat 'fake-jc "second") (funcall (car callbacks) '((1 . peer-session))) (funcall (cadr callbacks) '((1 . peer-session))) (let ((first (car sent)) (second (cadr sent))) (should (= 1 (length (jabber-xml-get-children first 'thread)))) (should (equal "thread-1" (car (jabber-xml-node-children (car (jabber-xml-get-children first 'thread)))))) (should (jabber-xml-child-with-xmlns first "urn:xmpp:reply:0")) (should (= 1 (length (jabber-xml-get-children second 'thread)))) (should-not (equal "thread-1" (car (jabber-xml-node-children (car (jabber-xml-get-children second 'thread)))))) (should-not (jabber-xml-child-with-xmlns second "urn:xmpp:reply:0")) (should (equal `(("first" "thread-1") ("second" ,(car (jabber-xml-node-children (car (jabber-xml-get-children second 'thread)))))) (sqlite-select jabber-db--connection "SELECT body, thread_id FROM message \ WHERE body IN ('first', 'second') ORDER BY body"))))))))) (ert-deftest jabber-test-omemo-message-dead-thread-source-cancels-send () "A delayed OMEMO thread send stops when its source buffer dies." (dolist (source '(parent thread)) (let ((result (jabber-test-omemo-message--thread-send-result source 'delayed-dead))) (should-not (plist-get result :sent)) (should-not (plist-get result :active)) (should (equal "thread-1" (plist-get result :stored-thread))) (should (plist-get result :parent-empty)) (when (eq source 'parent) (should (eq :undelivered (plist-get result :status))))))) (ert-deftest jabber-test-omemo-message-muc-stalled-bundle-fails-on-reset () "A reset fails a MUC send stalled while own sessions are fetched." (let ((jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (jabber-group "room@conf.example.com") (jabber-muc-participants nil) (successes 0) (failures 0) (encrypted 0) continuation) (cl-letf (((symbol-function 'jabber-omemo--muc-participant-jids) (lambda (&rest _) '("alice@example.com"))) ((symbol-function 'jabber-omemo--ensure-sessions-multi) (lambda (_jc _jids callback) (funcall callback '((1 . participant-session))))) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc _jid callback) (setq continuation callback))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo--send-encrypted-muc) (lambda (&rest _) (cl-incf encrypted))) ((symbol-function 'jabber-omemo--send-failed) (lambda (&rest _) nil))) (jabber-omemo--send-muc 'fake-jc "corrected" '((replace ((xmlns . "urn:xmpp:message-correct:0") (id . "old")))) (lambda () (cl-incf successes)) (lambda (_reason) (cl-incf failures))) (jabber-omemo--session-reset 'fake-jc) (funcall continuation '((2 . own-session))) (should (= 0 successes)) (should (= 1 failures)) (should (= 0 encrypted)) (should-not (gethash 'fake-jc jabber-omemo--pending-send-operations))))) (ert-deftest jabber-test-omemo-message-ordinary-muc-stall-fails-on-reset () "A reset fails an ordinary MUC send and makes its late callback inert." (let ((jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (jabber-group "room@conf.example.com") (jabber-muc-participants nil) (failures 0) (encrypted 0) continuation) (cl-letf (((symbol-function 'jabber-omemo--muc-participant-jids) (lambda (&rest _) '("alice@example.com"))) ((symbol-function 'jabber-omemo--ensure-sessions-multi) (lambda (_jc _jids callback) (setq continuation callback))) ((symbol-function 'jabber-omemo--send-encrypted-muc) (lambda (&rest _) (cl-incf encrypted))) ((symbol-function 'jabber-omemo--send-failed) (lambda (&rest _) (cl-incf failures)))) (jabber-omemo--send-muc 'fake-jc "hello") (jabber-omemo--session-reset 'fake-jc) (funcall continuation '((1 . session))) (should (= 1 failures)) (should (= 0 encrypted)) (should-not (gethash 'fake-jc jabber-omemo--pending-send-operations))))) (defmacro jabber-test-omemo-message--with-muc-send-stubs (sent-var &rest body) "Run BODY with the MUC encrypt/send path stubbed. SENT-VAR is bound to the stanza passed to `jabber-send-sexp'." (declare (indent 1) (debug t)) `(let ((,sent-var nil)) (cl-letf (((symbol-function 'jabber-omemo-encrypt-message) (lambda (_plaintext) '(:iv "iv" :key "key" :payload "payload"))) ((symbol-function 'jabber-omemo--build-encrypted-xml) (lambda (_jc _sessions _enc) '(encrypted ((xmlns . "eu.siacs.conversations.axolotl"))))) ((symbol-function 'jabber-send-sexp) (lambda (_jc stanza) (setq ,sent-var stanza)))) ,@body))) (ert-deftest jabber-test-omemo-message-muc-send-hooks-run-in-buffer () "MUC send hooks run in the originating buffer, not the IQ callback's." (let* ((muc-buffer (generate-new-buffer "*test-omemo-muc*")) (hook-buffer nil) (jabber-chat-send-hooks (list (lambda (_body _id) (setq hook-buffer (current-buffer)) '((probe ((xmlns . "test:probe")))))))) (unwind-protect (jabber-test-omemo-message--with-muc-send-stubs sent (with-temp-buffer (jabber-omemo--send-encrypted-muc 'fake-jc "hello" "room@conf.example.com" nil muc-buffer)) (should (eq hook-buffer muc-buffer)) (should sent) (should (jabber-xml-get-children sent 'probe))) (kill-buffer muc-buffer)))) (ert-deftest jabber-test-omemo-message-muc-send-dead-buffer-still-sends () "A dead originating buffer skips send hooks but the stanza still goes out." (let* ((muc-buffer (generate-new-buffer "*test-omemo-muc*")) (jabber-chat-send-hooks (list (lambda (_body _id) '((probe ((xmlns . "test:probe")))))))) (kill-buffer muc-buffer) (jabber-test-omemo-message--with-muc-send-stubs sent (jabber-omemo--send-encrypted-muc 'fake-jc "hello" "room@conf.example.com" nil muc-buffer) (should sent) (should-not (jabber-xml-get-children sent 'probe))))) (ert-deftest jabber-test-omemo-message-correction-handoff-skips-new-echo () "A successful correction runs its callback without inserting a new node." (let ((entered nil) (successes 0) (jabber-chat-send-hooks nil)) (cl-letf (((symbol-function 'jabber-omemo-encrypt-message) (lambda (_plaintext) '(:iv "iv" :key "key" :payload "payload"))) ((symbol-function 'jabber-omemo--build-encrypted-xml) (lambda (&rest _) '(encrypted ((xmlns . "eu.siacs.conversations.axolotl"))))) ((symbol-function 'jabber-chat-ewoc-enter) (lambda (&rest _) (setq entered t))) ((symbol-function 'jabber-send-sexp) (lambda (_jc _stanza success _failure) (funcall success)))) (jabber-omemo--send-encrypted 'fake-jc "corrected" "friend@example.com" nil (current-buffer) nil "correction-1" '((replace ((xmlns . "urn:xmpp:message-correct:0") (id . "original-1")))) (lambda () (cl-incf successes)) #'ignore)) (should (= 1 successes)) (should-not entered))) ;;; Group 12: Signed pre-key rotation (defmacro jabber-test-omemo-message--with-rotation-stubs (rotated-var &rest body) "Run BODY with rotation collaborators stubbed. ROTATED-VAR is bound to non-nil when a rotation was performed." (declare (indent 1) (debug t)) `(jabber-test-omemo-message-with-db (let ((,rotated-var nil)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo--get-store) (lambda (_jc) 'fake-store)) ((symbol-function 'jabber-omemo-rotate-signed-pre-key) (lambda (_store) (setq ,rotated-var t))) ((symbol-function 'jabber-omemo--persist-store) (lambda (_jc) nil))) (jabber-omemo-store-save "me@example.com" (unibyte-string 1)) ,@body)))) (ert-deftest jabber-test-omemo-message-spk-rotation-records-baseline () "First rotation check records a timestamp without rotating." (jabber-test-omemo-message--with-rotation-stubs rotated (jabber-omemo--maybe-rotate-signed-pre-key 'fake-jc) (should-not rotated) (should (jabber-omemo-store-spk-rotated-at "me@example.com")))) (ert-deftest jabber-test-omemo-message-spk-rotation-skips-when-fresh () "A recent rotation timestamp is left alone." (jabber-test-omemo-message--with-rotation-stubs rotated (let ((now (time-convert nil 'integer))) (jabber-omemo-store-set-spk-rotated-at "me@example.com" now) (jabber-omemo--maybe-rotate-signed-pre-key 'fake-jc) (should-not rotated) (should (= now (jabber-omemo-store-spk-rotated-at "me@example.com")))))) (ert-deftest jabber-test-omemo-message-spk-rotation-rotates-when-due () "A timestamp older than the rotation period triggers a rotation." (jabber-test-omemo-message--with-rotation-stubs rotated (let* ((now (time-convert nil 'integer)) (stale (- now jabber-omemo-signed-pre-key-rotation-period 10))) (jabber-omemo-store-set-spk-rotated-at "me@example.com" stale) (jabber-omemo--maybe-rotate-signed-pre-key 'fake-jc) (should rotated) (should (> (jabber-omemo-store-spk-rotated-at "me@example.com") stale))))) (provide 'jabber-test-omemo-message) ;;; jabber-test-omemo-message.el ends here emacs-jabber-0.13.1/tests/jabber-test-omemo-module.el000066400000000000000000001066721523531702000224040ustar00rootroot00000000000000;;; jabber-test-omemo-module.el --- Tests for jabber-omemo-module -*- lexical-binding: t; -*- ;;; Commentary: ;; OMEMO native C module interface. ;;; Code: (require 'ert) (require 'jabber-omemo-core) ;; The C module signals `jabber-omemo-error' but doesn't register it ;; with `define-error'. ERT's :type matching needs the hierarchy. (define-error 'jabber-omemo-error "OMEMO error") ;;; Group 1: Module loading (ert-deftest jabber-test-omemo-module-provides-feature () "The module provides the `jabber-omemo-core' feature." (should (featurep 'jabber-omemo-core))) (ert-deftest jabber-test-omemo-module-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--session-skipped-keys)) (should (fboundp 'jabber-omemo--session-set-skipped-keys)) (should (fboundp 'jabber-omemo--heartbeat)) (should (fboundp 'jabber-omemo--aesgcm-decrypt)) (should (fboundp 'jabber-omemo--aesgcm-encrypt))) ;;; Group 2: Store lifecycle (ert-deftest jabber-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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)))) (ert-deftest jabber-test-omemo-module-protobuf-rejects-bad-varints () "Deserialization rejects oversized and unterminated uint32 varints." (dolist (blob (list (unibyte-string #x08 #x80 #x80 #x80 #x80 #x80 #x00) (unibyte-string #x08 #x80 #x80 #x80 #x80 #x80) (unibyte-string #x08 #x80 #x80 #x80 #x80 #x10))) (should-error (jabber-omemo--deserialize-store blob) :type 'jabber-omemo-error))) (ert-deftest jabber-test-omemo-module-protobuf-rejects-truncated-field () "Deserialization rejects a length field beyond the remaining input." (should-error (jabber-omemo--deserialize-store (unibyte-string #x12 #x20)) :type 'jabber-omemo-error)) (ert-deftest jabber-test-omemo-module-pointer-kinds-are-distinct () "Store and session wrappers reject the other native pointer kind." (let ((store (jabber-omemo--deserialize-store (jabber-omemo--setup-store))) (session (jabber-omemo--make-session))) (dolist (form (list (lambda () (jabber-omemo--serialize-store session)) (lambda () (jabber-omemo--get-bundle session)) (lambda () (jabber-omemo--serialize-session store)) (lambda () (jabber-omemo--used-pre-key-id store)) (lambda () (jabber-omemo--encrypt-key store (make-string 32 0))) (lambda () (jabber-omemo--decrypt-key session session nil "bad")) (lambda () (jabber-omemo--heartbeat session session)))) (should-error (funcall form) :type 'jabber-omemo-error)))) ;;; Group 3: Bundle extraction (ert-deftest jabber-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-decrypt-requires-exact-key-and-iv () "Message decryption rejects short and oversized keys and IVs." (let* ((enc (jabber-omemo--encrypt-message "payload")) (key (plist-get enc :key)) (iv (plist-get enc :iv)) (ciphertext (plist-get enc :ciphertext))) (dolist (bad-key (list (substring key 1) (concat key "x"))) (should-error (jabber-omemo--decrypt-message bad-key iv ciphertext) :type 'jabber-omemo-error)) (dolist (bad-iv (list (substring iv 1) (concat iv "x"))) (should-error (jabber-omemo--decrypt-message key bad-iv ciphertext) :type 'jabber-omemo-error)))) (ert-deftest jabber-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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)))) (defun jabber-test-omemo-module--set-u32 (string offset value) "Store big-endian VALUE in STRING at OFFSET." (dotimes (i 4) (aset string (+ offset i) (logand 255 (ash value (* -8 (- 3 i)))))) string) (ert-deftest jabber-test-omemo-module-session-envelope-validation () "Malformed envelopes, excess keys, and trailing data are rejected." (let* ((session (jabber-omemo--make-session)) (blob (jabber-omemo--serialize-session session)) (bad-version (copy-sequence blob)) (too-many (copy-sequence blob))) (aset bad-version 11 2) (jabber-test-omemo-module--set-u32 too-many 16 1001) (dolist (bad (list bad-version too-many (concat blob "x"))) (should-error (jabber-omemo--deserialize-session bad) :type 'jabber-omemo-error)))) (ert-deftest jabber-test-omemo-module-session-legacy-blob-loads () "The raw picomemo payload remains a valid legacy session blob." (let* ((session (jabber-omemo--make-session)) (blob (jabber-omemo--serialize-session session)) (raw-size (+ (ash (aref blob 12) 24) (ash (aref blob 13) 16) (ash (aref blob 14) 8) (aref blob 15))) (raw (substring blob 20 (+ 20 raw-size)))) (should-not (jabber-omemo--legacy-session-blob-p blob)) (should (jabber-omemo--legacy-session-blob-p raw)) (should (user-ptrp (jabber-omemo--deserialize-session raw))))) (ert-deftest jabber-test-omemo-module-skipped-key-fifo-limit () "A session retains the newest 1000 imported skipped keys in FIFO order." (let* ((session (jabber-omemo--make-session)) (dh (make-string 32 ?d)) (keys (cl-loop for i below 1001 collect (list i dh (make-string 32 ?m))))) (jabber-omemo--session-set-skipped-keys session keys) (let ((stored (jabber-omemo--session-skipped-keys session))) (should (= 1000 (length stored))) (should (= 1 (caar stored))) (should (= 1000 (car (car (last stored)))))))) (ert-deftest jabber-test-omemo-module-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))) (ert-deftest jabber-test-omemo-module-initiate-requires-exact-inputs () "Session initiation rejects short and oversized cryptographic inputs." (let* ((alice (jabber-omemo--deserialize-store (jabber-omemo--setup-store))) (bob (jabber-omemo--deserialize-store (jabber-omemo--setup-store))) (bundle (jabber-omemo--get-bundle bob)) (signature (plist-get bundle :signature)) (spk (plist-get bundle :signed-pre-key)) (ik (plist-get bundle :identity-key)) (pk (car (plist-get bundle :pre-keys))) (inputs (list signature spk ik (cdr pk)))) (dotimes (index 4) (dolist (bad (list (substring (nth index inputs) 1) (concat (nth index inputs) "x"))) (let ((changed (copy-sequence inputs))) (setf (nth index changed) bad) (should-error (apply #'jabber-omemo--initiate-session alice (append changed (list (plist-get bundle :signed-pre-key-id) (car pk)))) :type 'jabber-omemo-error)))))) ;;; Group 7: Key encrypt/decrypt round-trip (ert-deftest jabber-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-decrypt-key-rejects-bad-protobuf () "Key decryption rejects hostile varints and truncated length fields." (let ((store (jabber-omemo--deserialize-store (jabber-omemo--setup-store))) (session (jabber-omemo--make-session))) (dolist (message (list (unibyte-string #x33 #x08 #x80 #x80 #x80 #x80 #x80 #x00) (unibyte-string #x33 #x08 #x80 #x80 #x80 #x80 #x80) (unibyte-string #x33 #x08 #x80 #x80 #x80 #x80 #x10) (unibyte-string #x33 #x12 #x20))) (should-error (jabber-omemo--decrypt-key session store t message) :type 'jabber-omemo-error)))) (ert-deftest jabber-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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-test-omemo-module-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))))) ;;; Group 10: One-time pre-key removal (ert-deftest jabber-test-omemo-module-remove-pre-key () "remove-pre-key zeroes exactly the matching slot." (let* ((store (jabber-omemo--deserialize-store (jabber-omemo--setup-store))) (before (plist-get (jabber-omemo--get-bundle store) :pre-keys)) (victim (car (nth 3 before)))) (should (jabber-omemo--remove-pre-key store victim)) (let ((after (plist-get (jabber-omemo--get-bundle store) :pre-keys))) (should (= (1- (length before)) (length after))) (should-not (assq victim after))) ;; Removing an already-removed id is a no-op. (should-not (jabber-omemo--remove-pre-key store victim)))) (ert-deftest jabber-test-omemo-module-remove-pre-key-unknown-id () "remove-pre-key returns nil for an id not in the store." (let ((store (jabber-omemo--deserialize-store (jabber-omemo--setup-store)))) (should-not (jabber-omemo--remove-pre-key store 999999)) (should-not (jabber-omemo--remove-pre-key store 0)))) (ert-deftest jabber-test-omemo-module-remove-then-refill-uses-fresh-id () "Refilling after removal restores the count with a new id." (let* ((store (jabber-omemo--deserialize-store (jabber-omemo--setup-store))) (before (plist-get (jabber-omemo--get-bundle store) :pre-keys)) (victim (car (car before)))) (jabber-omemo--remove-pre-key store victim) (jabber-omemo--refill-pre-keys store) (let ((after (plist-get (jabber-omemo--get-bundle store) :pre-keys))) (should (= (length before) (length after))) (should-not (assq victim after))))) (ert-deftest jabber-test-omemo-module-used-pre-key-id-fresh-session () "A session that never consumed a pre-key reports id 0." (should (zerop (jabber-omemo--used-pre-key-id (jabber-omemo--make-session))))) (ert-deftest jabber-test-omemo-module-used-pre-key-id-after-decrypt () "After a pre-key decrypt the session reports the consumed id." (let* ((alice (jabber-omemo--deserialize-store (jabber-omemo--setup-store))) (bob (jabber-omemo--deserialize-store (jabber-omemo--setup-store))) (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))) (encrypted (jabber-omemo--encrypt-key alice-session (make-string 32 ?K))) (bob-session (jabber-omemo--make-session))) (jabber-omemo--decrypt-key bob-session bob (plist-get encrypted :pre-key-p) (plist-get encrypted :data)) (should (= (car pk) (jabber-omemo--used-pre-key-id bob-session))))) ;;; Group: Skipped message keys (defmacro jabber-test-omemo-module--with-session-pair (&rest body) "Run BODY with `alice', `bob', and `alice-session' bound. Alice has initiated a session towards Bob's bundle." (declare (indent 0) (debug t)) `(let* ((alice (jabber-omemo--deserialize-store (jabber-omemo--setup-store))) (bob (jabber-omemo--deserialize-store (jabber-omemo--setup-store))) (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)))) (ignore alice-session) ,@body)) (ert-deftest jabber-test-omemo-module-skipped-keys-accessors-roundtrip () "Skipped keys set on a session read back unchanged." (let* ((session (jabber-omemo--make-session)) (keys (list (list 3 (make-string 32 ?d) (make-string 32 ?m)) (list 7 (make-string 32 ?e) (make-string 32 ?n))))) (should (null (jabber-omemo--session-skipped-keys session))) (jabber-omemo--session-set-skipped-keys session keys) (should (equal keys (jabber-omemo--session-skipped-keys session))) ;; Replacing clears the previous list. (jabber-omemo--session-set-skipped-keys session nil) (should (null (jabber-omemo--session-skipped-keys session))))) (ert-deftest jabber-test-omemo-module-skipped-key-import-is-atomic () "Rejected skipped-key imports preserve the session's original keys." (let* ((session (jabber-omemo--make-session)) (dh (make-string 32 ?d)) (mk (make-string 32 ?m)) (original (list (list 7 dh mk))) (bad-lists (list (cons (list 8 dh mk) 9) (list 8 dh) (list 8 dh mk 'extra) (list (cons 8 (cons dh mk))) (list (list 'bad dh mk)) (list (list -1 dh mk)) (list (list (1+ #xffffffff) dh mk)) (list (list 8 'bad mk)) (list (list 8 dh 'bad)) (list (list 8 (make-string 31 ?d) mk)) (list (list 8 (make-string 33 ?d) mk)) (list (list 8 dh (make-string 31 ?m))) (list (list 8 dh (make-string 33 ?m)))))) (jabber-omemo--session-set-skipped-keys session original) (dolist (bad bad-lists) (should-error (jabber-omemo--session-set-skipped-keys session bad) :type 'jabber-omemo-error) (should (equal original (jabber-omemo--session-skipped-keys session)))))) (ert-deftest jabber-test-omemo-module-skipped-keys-survive-finalizers () "Enumerating skipped keys is safe while other sessions are finalized." (let* ((session (jabber-omemo--make-session)) (keys (list (list 3 (make-string 32 ?d) (make-string 32 ?m)) (list 7 (make-string 32 ?e) (make-string 32 ?n))))) (jabber-omemo--session-set-skipped-keys session keys) (dotimes (i 200) (let ((disposable (jabber-omemo--make-session))) (jabber-omemo--session-set-skipped-keys disposable (list (list i (make-string 32 (+ ?a (% i 26))) (make-string 32 (+ ?A (% i 26)))))))) (let ((gc-cons-threshold 1)) (should (equal keys (jabber-omemo--session-skipped-keys session)))) (garbage-collect) (should (equal keys (jabber-omemo--session-skipped-keys session))))) (ert-deftest jabber-test-omemo-module-out-of-order-decrypt () "A message skipped over in the ratchet still decrypts afterwards." (jabber-test-omemo-module--with-session-pair (let* ((k1 (make-string 32 ?1)) (k2 (make-string 32 ?2)) (k3 (make-string 32 ?3)) (m1 (jabber-omemo--encrypt-key alice-session k1)) (m2 (jabber-omemo--encrypt-key alice-session k2)) (m3 (jabber-omemo--encrypt-key alice-session k3)) (bob-session (jabber-omemo--make-session))) ;; Deliver message 3 first: keys for 1 and 2 must be skipped. (should (string= k3 (jabber-omemo--decrypt-key bob-session bob (plist-get m3 :pre-key-p) (plist-get m3 :data)))) (should (= 2 (length (jabber-omemo--session-skipped-keys bob-session)))) ;; The late arrivals decrypt from the skipped keys, single-use. (should (string= k1 (jabber-omemo--decrypt-key bob-session bob (plist-get m1 :pre-key-p) (plist-get m1 :data)))) (should (string= k2 (jabber-omemo--decrypt-key bob-session bob (plist-get m2 :pre-key-p) (plist-get m2 :data)))) (should (null (jabber-omemo--session-skipped-keys bob-session)))))) (ert-deftest jabber-test-omemo-module-failed-decrypt-keeps-skipped-key () "A corrupted late message does not consume its skipped key." (jabber-test-omemo-module--with-session-pair (let* ((k1 (make-string 32 ?1)) (k2 (make-string 32 ?2)) (m1 (jabber-omemo--encrypt-key alice-session k1)) (m2 (jabber-omemo--encrypt-key alice-session k2)) (bob-session (jabber-omemo--make-session))) (jabber-omemo--decrypt-key bob-session bob (plist-get m2 :pre-key-p) (plist-get m2 :data)) (let* ((corrupt (copy-sequence (plist-get m1 :data))) (last (1- (length corrupt)))) (aset corrupt last (logxor 1 (aref corrupt last))) (should-error (jabber-omemo--decrypt-key bob-session bob (plist-get m1 :pre-key-p) corrupt) :type 'jabber-omemo-error)) (should (= 1 (length (jabber-omemo--session-skipped-keys bob-session)))) (should (string= k1 (jabber-omemo--decrypt-key bob-session bob (plist-get m1 :pre-key-p) (plist-get m1 :data)))) (should (null (jabber-omemo--session-skipped-keys bob-session))) (should-error (jabber-omemo--decrypt-key bob-session bob (plist-get m1 :pre-key-p) (plist-get m1 :data)) :type 'jabber-omemo-error)))) (ert-deftest jabber-test-omemo-module-skipped-keys-survive-reserialization () "Skipped keys carried over to a reloaded session still decrypt." (jabber-test-omemo-module--with-session-pair (let* ((k1 (make-string 32 ?1)) (k2 (make-string 32 ?2)) (m1 (jabber-omemo--encrypt-key alice-session k1)) (m2 (jabber-omemo--encrypt-key alice-session k2)) (bob-session (jabber-omemo--make-session))) ;; Deliver message 2 first; message 1's key is skipped. (should (string= k2 (jabber-omemo--decrypt-key bob-session bob (plist-get m2 :pre-key-p) (plist-get m2 :data)))) ;; Simulate a restart. The session blob owns its skipped keys. (let* ((blob (jabber-omemo--serialize-session bob-session)) (restored (jabber-omemo--deserialize-session blob))) (should (= 1 (length (jabber-omemo--session-skipped-keys restored)))) (should (string= k1 (jabber-omemo--decrypt-key restored bob (plist-get m1 :pre-key-p) (plist-get m1 :data)))))))) (provide 'jabber-test-omemo-module) ;;; jabber-test-omemo-module.el ends here emacs-jabber-0.13.1/tests/jabber-test-omemo-protocol.el000066400000000000000000001124061523531702000227500ustar00rootroot00000000000000;;; jabber-test-omemo-protocol.el --- Tests for jabber-omemo-protocol -*- lexical-binding: t; -*- ;;; Commentary: ;; OMEMO protocol session management. ;;; Code: (require 'ert) (require 'jabber-chat) (require 'jabber-omemo) ;;; Test infrastructure (defmacro jabber-test-omemo-protocol-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-test-omemo-protocol--dir (make-temp-file "jabber-omemo-proto-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-test-omemo-protocol--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-test-omemo-protocol--dir) (delete-directory jabber-test-omemo-protocol--dir t))))) ;;; Group 1: Device list XML (ert-deftest jabber-test-omemo-protocol-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-test-omemo-protocol-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-test-omemo-protocol-parse-device-list-no-items () "parse-device-list returns nil for no items." (should (equal '() (jabber-omemo--parse-device-list nil)))) (ert-deftest jabber-test-omemo-protocol-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-test-omemo-protocol-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-test-omemo-protocol-build-bundle-xml () "build-bundle-xml produces valid sexp with base64 keys." (jabber-test-omemo-protocol-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-test-omemo-protocol-parse-bundle-xml () "parse-bundle-xml returns correct plist keys." (jabber-test-omemo-protocol-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-test-omemo-protocol-bundle-xml-roundtrip () "parse-bundle-xml round-trips with build-bundle-xml." (jabber-test-omemo-protocol-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-test-omemo-protocol-parsed-bundle-key-lengths () "Parsed bundle keys have correct byte lengths." (jabber-test-omemo-protocol-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-test-omemo-protocol-device-id-roundtrip () "save and load device ID round-trips." (jabber-test-omemo-protocol-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-test-omemo-protocol-device-id-unknown () "load returns nil for unknown account." (jabber-test-omemo-protocol-with-db (should (null (jabber-omemo-store-load-device-id "nobody@example.com"))))) (ert-deftest jabber-test-omemo-protocol-device-id-upsert () "save overwrites existing device ID." (jabber-test-omemo-protocol-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-test-omemo-protocol-get-store-creates-new () "get-store creates new store on first call." (jabber-test-omemo-protocol-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-test-omemo-protocol-get-store-cached () "get-store returns cached ptr on second call." (jabber-test-omemo-protocol-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-test-omemo-protocol-get-store-from-db () "get-store loads from DB on cold start." (jabber-test-omemo-protocol-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-test-omemo-protocol-establish-session () "establish-session creates and persists a session." (jabber-test-omemo-protocol-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-test-omemo-protocol-establish-session-trust () "establish-session stores trust record." (jabber-test-omemo-protocol-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-test-omemo-protocol-get-session-unknown () "get-session returns nil for unknown device." (jabber-test-omemo-protocol-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-test-omemo-protocol-get-session-from-db () "get-session loads from DB when not cached." (jabber-test-omemo-protocol-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-test-omemo-protocol-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-test-omemo-protocol-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-test-omemo-protocol-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-test-omemo-protocol-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-test-omemo-protocol-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-test-omemo-protocol-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-test-omemo-protocol-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-test-omemo-protocol-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-test-omemo-protocol-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))))) ;;; Group 7: Pre-key session selection (defun jabber-test-omemo-protocol--initiate-toward (jc) "Create a peer store with a session initiated toward JC's store. Returns (PEER-SESSION . PK-ID) where PEER-SESSION is the sending side session and PK-ID the pre-key id it consumed." (let* ((our-bundle (jabber-omemo-get-bundle (jabber-omemo--get-store jc))) (peer-store (jabber-omemo-deserialize-store (jabber-omemo-setup-store))) (pk (car (plist-get our-bundle :pre-keys)))) (cons (jabber-omemo-initiate-session peer-store (plist-get our-bundle :signature) (plist-get our-bundle :signed-pre-key) (plist-get our-bundle :identity-key) (cdr pk) (plist-get our-bundle :signed-pre-key-id) (car pk)) (car pk)))) (ert-deftest jabber-test-omemo-protocol-prekey-reuses-established-session () "A second pre-key message decrypts via the saved session, not a fresh one." (jabber-test-omemo-protocol-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)) (alice (car (jabber-test-omemo-protocol--initiate-toward jc))) (key-1 (make-string 32 ?A)) (key-2 (make-string 32 ?B)) (msg-1 (jabber-omemo-encrypt-key alice key-1)) (msg-2 (jabber-omemo-encrypt-key alice key-2))) (should (plist-get msg-1 :pre-key-p)) (should (plist-get msg-2 :pre-key-p)) (pcase-let ((`(,session ,decrypted ,fresh-p) (jabber-omemo--decrypt-key-with-session jc "alice@example.com" 7 store-ptr t (plist-get msg-1 :data)))) (should (string= key-1 decrypted)) (should fresh-p) (jabber-omemo--save-session jc "alice@example.com" 7 session)) (pcase-let ((`(,_session ,decrypted ,fresh-p) (jabber-omemo--decrypt-key-with-session jc "alice@example.com" 7 store-ptr t (plist-get msg-2 :data)))) (should (string= key-2 decrypted)) (should-not fresh-p)))))) (ert-deftest jabber-test-omemo-protocol-prekey-out-of-order-falls-back () "An earlier pre-key message still decrypts after a later one. The established session serves the older ratchet position from its skipped message keys, so no fresh-session fallback is needed." (jabber-test-omemo-protocol-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)) (alice (car (jabber-test-omemo-protocol--initiate-toward jc))) (key-1 (make-string 32 ?A)) (key-2 (make-string 32 ?B)) (msg-1 (jabber-omemo-encrypt-key alice key-1)) (msg-2 (jabber-omemo-encrypt-key alice key-2))) (pcase-let ((`(,session ,decrypted ,fresh-p) (jabber-omemo--decrypt-key-with-session jc "alice@example.com" 7 store-ptr t (plist-get msg-2 :data)))) (should (string= key-2 decrypted)) (should fresh-p) (jabber-omemo--save-session jc "alice@example.com" 7 session)) (pcase-let ((`(,_session ,decrypted ,fresh-p) (jabber-omemo--decrypt-key-with-session jc "alice@example.com" 7 store-ptr t (plist-get msg-1 :data)))) (should (string= key-1 decrypted)) (should-not fresh-p)))))) (ert-deftest jabber-test-omemo-protocol-prekey-falls-back-on-peer-reset () "A pre-key message from a re-initialized peer session decrypts fresh." (jabber-test-omemo-protocol-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)) (alice-1 (car (jabber-test-omemo-protocol--initiate-toward jc))) (msg-1 (jabber-omemo-encrypt-key alice-1 (make-string 32 ?A)))) (pcase-let ((`(,session ,_decrypted ,_fresh-p) (jabber-omemo--decrypt-key-with-session jc "alice@example.com" 7 store-ptr t (plist-get msg-1 :data)))) (jabber-omemo--save-session jc "alice@example.com" 7 session)) ;; Alice lost her state and initiates a brand new session. (let* ((alice-2 (car (jabber-test-omemo-protocol--initiate-toward jc))) (key-2 (make-string 32 ?B)) (msg-2 (jabber-omemo-encrypt-key alice-2 key-2))) (pcase-let ((`(,_session ,decrypted ,fresh-p) (jabber-omemo--decrypt-key-with-session jc "alice@example.com" 7 store-ptr t (plist-get msg-2 :data)))) (should (string= key-2 decrypted)) (should fresh-p))))))) (ert-deftest jabber-test-omemo-protocol-prekey-failure-triggers-recovery () "A pre-key decrypt failure drops the stale session and re-ensures." (jabber-test-omemo-protocol-with-db (let (deleted ensured) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo--decrypt-stanza) (lambda (_jc _xml _parsed) (signal 'jabber-omemo-prekey-failed (list "alice@example.com" 7 "stale pre-key")))) ((symbol-function 'jabber-omemo-store-delete-session) (lambda (account jid did) (setq deleted (list account jid did)))) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc jid _callback) (setq ensured jid)))) (puthash (jabber-omemo--session-key "me@example.com" "alice@example.com" 7) 'stale-session jabber-omemo--sessions) (should-error (jabber-omemo--decrypt-handler 'fake-jc '(message ((from . "alice@example.com/phone"))) '(:type omemo :parsed (:payload "ciphertext"))) :type 'jabber-omemo-prekey-failed) (should (equal '("me@example.com" "alice@example.com" 7) deleted)) (should (equal "alice@example.com" ensured)) (should-not (gethash (jabber-omemo--session-key "me@example.com" "alice@example.com" 7) jabber-omemo--sessions)))))) (ert-deftest jabber-test-omemo-protocol-regular-message-requires-session () "A non-pre-key message without an established session signals no-session." (jabber-test-omemo-protocol-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))) (should-error (jabber-omemo--decrypt-key-with-session jc "alice@example.com" 7 store-ptr nil "junk") :type 'jabber-omemo-no-session))))) ;;; Group 8: One-time pre-key removal (ert-deftest jabber-test-omemo-protocol-prekey-removal-deferred-until-flush () "Both pre-key messages decrypt before the consumed key is removed." (jabber-test-omemo-protocol-with-db (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo--schedule-prekey-flush) #'ignore) ((symbol-function 'jabber-omemo--publish-bundle) #'ignore) ((symbol-function 'jabber-omemo--mam-syncing-p) (lambda () nil))) (let* ((jc (list :bare-jid "me@example.com")) (store-ptr (jabber-omemo--get-store jc)) (pair (jabber-test-omemo-protocol--initiate-toward jc)) (alice (car pair)) (victim (cdr pair)) (key-2 (make-string 32 ?B)) (msg-1 (jabber-omemo-encrypt-key alice (make-string 32 ?A))) (msg-2 (jabber-omemo-encrypt-key alice key-2)) (jabber-omemo--pending-prekey-removals (make-hash-table :test #'equal))) (pcase-let ((`(,session ,_key ,fresh-p) (jabber-omemo--decrypt-key-with-session jc "alice@example.com" 7 store-ptr t (plist-get msg-1 :data)))) (should fresh-p) (jabber-omemo--save-session jc "alice@example.com" 7 session) (jabber-omemo--note-consumed-prekey jc session)) (should (equal (list victim) (gethash "me@example.com" jabber-omemo--pending-prekey-removals))) ;; Removal is deferred, so the second pre-key message on the ;; same pre-key still decrypts (via the established session). (pcase-let ((`(,_session ,decrypted ,fresh-p) (jabber-omemo--decrypt-key-with-session jc "alice@example.com" 7 store-ptr t (plist-get msg-2 :data)))) (should (string= key-2 decrypted)) (should-not fresh-p)) (jabber-omemo--flush-prekey-removals jc) (let ((after (plist-get (jabber-omemo-get-bundle store-ptr) :pre-keys))) (should-not (assq victim after)) (should (gethash "me@example.com" jabber-omemo--stores))) (should-not (gethash "me@example.com" jabber-omemo--pending-prekey-removals)))))) (ert-deftest jabber-test-omemo-protocol-flush-noop-while-syncing () "Pending removals survive a flush attempted during MAM catchup." (jabber-test-omemo-protocol-with-db (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo--mam-syncing-p) (lambda () t)) ((symbol-function 'jabber-omemo--publish-bundle) #'ignore)) (let ((jc (list :bare-jid "me@example.com")) (jabber-omemo--pending-prekey-removals (make-hash-table :test #'equal))) (puthash "me@example.com" '(42) jabber-omemo--pending-prekey-removals) (jabber-omemo--flush-prekey-removals jc) (should (equal '(42) (gethash "me@example.com" jabber-omemo--pending-prekey-removals))))))) (ert-deftest jabber-test-omemo-protocol-flush-republishes-bundle () "A flush republishes the bundle unconditionally." (jabber-test-omemo-protocol-with-db (let (published) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-omemo--mam-syncing-p) (lambda () nil)) ((symbol-function 'jabber-omemo--publish-bundle) (lambda (_jc) (setq published t)))) (let* ((jc (list :bare-jid "me@example.com")) (store-ptr (jabber-omemo--get-store jc)) (victim (car (car (plist-get (jabber-omemo-get-bundle store-ptr) :pre-keys)))) (jabber-omemo--pending-prekey-removals (make-hash-table :test #'equal))) (puthash "me@example.com" (list victim) jabber-omemo--pending-prekey-removals) (jabber-omemo--flush-prekey-removals jc) (should published)))))) (ert-deftest jabber-test-omemo-protocol-mam-sync-complete-flushes () "The MAM sync-complete hook flushes all connections when idle." (let ((flushed nil) (jabber-connections '(jc-a jc-b))) (cl-letf (((symbol-function 'jabber-omemo--flush-prekey-removals) (lambda (jc) (push jc flushed)))) (cl-letf (((symbol-function 'jabber-omemo--mam-syncing-p) (lambda () t))) (jabber-omemo--on-mam-sync-complete nil) (should-not flushed)) (cl-letf (((symbol-function 'jabber-omemo--mam-syncing-p) (lambda () nil))) (jabber-omemo--on-mam-sync-complete nil) (should (equal '(jc-b jc-a) flushed)))))) ;;; Group: Skipped message keys (ert-deftest jabber-test-omemo-protocol-legacy-session-migrates-atomically () "A raw session imports legacy keys and saves one self-contained blob." (jabber-test-omemo-protocol-with-db (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (let* ((jc 'jc) (session (jabber-omemo-make-session)) (envelope (jabber-omemo-serialize-session session)) (raw-size (+ (ash (aref envelope 12) 24) (ash (aref envelope 13) 16) (ash (aref envelope 14) 8) (aref envelope 15))) (raw (substring envelope 20 (+ 20 raw-size))) (dh (make-string 32 ?d)) (mk (make-string 32 ?m))) (jabber-omemo-store-save-session "me@example.com" "alice@example.com" 111 raw) (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" 111 dh 7 mk 0)) (let ((loaded (jabber-omemo--get-session jc "alice@example.com" 111))) (should (equal (list (list 7 dh mk)) (jabber-omemo--session-skipped-keys loaded))) (jabber-omemo--save-session jc "alice@example.com" 111 loaded)) (let ((blob (jabber-omemo-store-load-session "me@example.com" "alice@example.com" 111))) (should-not (jabber-omemo--legacy-session-blob-p blob)) (should (= 1 (length (jabber-omemo--session-skipped-keys (jabber-omemo-deserialize-session blob)))))) (should-not (jabber-omemo-store-all-skipped-keys "me@example.com" "alice@example.com" 111)))))) (ert-deftest jabber-test-omemo-protocol-skipped-keys-recover-across-restart () "An out-of-order message decrypts after a session cache flush. Skipped ratchet keys persist inside the session blob." (jabber-test-omemo-protocol-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)) (my-bundle (jabber-omemo-get-bundle store-ptr)) (alice (jabber-omemo-deserialize-store (jabber-omemo-setup-store))) (pk (car (plist-get my-bundle :pre-keys))) (alice-session (jabber-omemo-initiate-session alice (plist-get my-bundle :signature) (plist-get my-bundle :signed-pre-key) (plist-get my-bundle :identity-key) (cdr pk) (plist-get my-bundle :signed-pre-key-id) (car pk))) (k1 (make-string 32 ?1)) (k2 (make-string 32 ?2)) (m1 (jabber-omemo-encrypt-key alice-session k1)) (m2 (jabber-omemo-encrypt-key alice-session k2))) ;; Deliver message 2 first; its decrypt skips message 1's key. (pcase-let ((`(,session ,key ,fresh-p) (jabber-omemo--decrypt-key-with-session jc "alice@example.com" 111 store-ptr (plist-get m2 :pre-key-p) (plist-get m2 :data)))) (should (string= k2 key)) (should fresh-p) (jabber-omemo--save-session jc "alice@example.com" 111 session)) (should-not (jabber-omemo-store-all-skipped-keys "me@example.com" "alice@example.com" 111)) ;; Simulate a restart: drop all in-memory session state. (clrhash jabber-omemo--sessions) ;; The late message decrypts from the reloaded skipped key. (pcase-let ((`(,_session ,key ,_fresh-p) (jabber-omemo--decrypt-key-with-session jc "alice@example.com" 111 store-ptr (plist-get m1 :pre-key-p) (plist-get m1 :data)))) (should (string= k1 key))) ;; No separate skipped-key rows are written or consumed. (should (null (jabber-omemo-store-all-skipped-keys "me@example.com" "alice@example.com" 111))))))) (provide 'jabber-test-omemo-protocol) ;;; jabber-test-omemo-protocol.el ends here emacs-jabber-0.13.1/tests/jabber-test-omemo-store.el000066400000000000000000000414761523531702000222530ustar00rootroot00000000000000;;; jabber-test-omemo-store.el --- Tests for jabber-omemo-store -*- lexical-binding: t; -*- ;;; Commentary: ;; OMEMO state persistence in SQLite. ;;; Code: (require 'ert) (require 'jabber-omemo-store) ;;; Test infrastructure (defmacro jabber-test-omemo-store-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-test-omemo-store--dir (make-temp-file "jabber-omemo-test" t)) (jabber-db-path (expand-file-name "test.sqlite" jabber-test-omemo-store--dir)) (jabber-db--connection nil)) (unwind-protect (progn (jabber-db-ensure-open) ,@body) (jabber-db-close) (when (file-directory-p jabber-test-omemo-store--dir) (delete-directory jabber-test-omemo-store--dir t))))) ;;; Group 1: Schema creation (ert-deftest jabber-test-omemo-store-schema-creates-tables () "Migration v2 creates all 5 OMEMO tables." (jabber-test-omemo-store-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-test-omemo-store-schema-idempotent () "Calling schema init twice does not error." (jabber-test-omemo-store-with-db (jabber-db--init-schema jabber-db--connection) (should t))) ;;; Group 2: Store blob CRUD (ert-deftest jabber-test-omemo-store-save-load-roundtrip () "Save + load round-trips a unibyte blob." (jabber-test-omemo-store-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-test-omemo-store-load-unknown-account () "Load returns nil for unknown account." (jabber-test-omemo-store-with-db (should (null (jabber-omemo-store-load "nobody@example.com"))))) (ert-deftest jabber-test-omemo-store-save-upsert () "Save overwrites existing blob (upsert)." (jabber-test-omemo-store-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-test-omemo-store-delete () "Delete removes the store record." (jabber-test-omemo-store-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"))))) (ert-deftest jabber-test-omemo-store-spk-rotated-at-roundtrip () "Signed pre-key rotation timestamp round-trips; nil when unset." (jabber-test-omemo-store-with-db (jabber-omemo-store-save "me@example.com" (unibyte-string 1 2)) (should (null (jabber-omemo-store-spk-rotated-at "me@example.com"))) (jabber-omemo-store-set-spk-rotated-at "me@example.com" 1234567) (should (= 1234567 (jabber-omemo-store-spk-rotated-at "me@example.com"))))) (ert-deftest jabber-test-omemo-store-save-preserves-spk-rotated-at () "Re-saving the store blob does not clear the rotation timestamp." (jabber-test-omemo-store-with-db (jabber-omemo-store-save "me@example.com" (unibyte-string 1 2)) (jabber-omemo-store-set-spk-rotated-at "me@example.com" 1234567) (jabber-omemo-store-save "me@example.com" (unibyte-string 3 4)) (should (= 1234567 (jabber-omemo-store-spk-rotated-at "me@example.com"))) (should (equal (unibyte-string 3 4) (jabber-omemo-store-load "me@example.com"))))) ;;; Group 3: Trust CRUD (ert-deftest jabber-test-omemo-store-trust-save-load-roundtrip () "save-trust + load-trust round-trips." (jabber-test-omemo-store-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-test-omemo-store-trust-load-unknown () "load-trust returns nil for unknown device." (jabber-test-omemo-store-with-db (should (null (jabber-omemo-store-load-trust "me@example.com" "alice@example.com" 99999))))) (ert-deftest jabber-test-omemo-store-set-trust-updates-level () "set-trust updates level without changing identity-key or first-seen." (jabber-test-omemo-store-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-test-omemo-store-all-trust-multiple () "all-trust returns multiple devices for same JID." (jabber-test-omemo-store-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-test-omemo-store-trust-levels () "Trust levels: 0 (undecided), 1 (tofu), 2 (verified), -1 (untrusted)." (jabber-test-omemo-store-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-test-omemo-store-trust-upsert-preserves-first-seen () "Upserting trust preserves the original first_seen." (jabber-test-omemo-store-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-test-omemo-store-device-save-load-roundtrip () "save-device + load-devices round-trips." (jabber-test-omemo-store-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-test-omemo-store-device-load-unknown () "load-devices returns empty list for unknown JID." (jabber-test-omemo-store-with-db (should (null (jabber-omemo-store-load-devices "me@example.com" "nobody@example.com"))))) (ert-deftest jabber-test-omemo-store-device-set-active () "set-device-active toggles the flag." (jabber-test-omemo-store-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-test-omemo-store-device-delete () "delete-device removes the record." (jabber-test-omemo-store-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-test-omemo-store-device-last-seen () "last-seen is set on save." (jabber-test-omemo-store-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-test-omemo-store-session-save-load-roundtrip () "save-session + load-session round-trips." (jabber-test-omemo-store-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-test-omemo-store-session-load-unknown () "load-session returns nil for unknown." (jabber-test-omemo-store-with-db (should (null (jabber-omemo-store-load-session "me@example.com" "alice@example.com" 99))))) (ert-deftest jabber-test-omemo-store-session-delete () "delete-session removes the session." (jabber-test-omemo-store-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-test-omemo-store-session-all () "all-sessions lists all devices for a peer." (jabber-test-omemo-store-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: Legacy skipped-key migration (ert-deftest jabber-test-omemo-store-session-save-clears-legacy-keys () "Saving a self-contained session removes its legacy key rows." (jabber-test-omemo-store-with-db (let ((dh (encode-coding-string "dh-key-data" 'raw-text)) (mk (encode-coding-string "msg-key-data" 'raw-text))) (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 7 mk 0)) (jabber-omemo-store-save-session-and-clear-legacy-keys "me@example.com" "alice@example.com" 42 "session") (should (equal "session" (jabber-omemo-store-load-session "me@example.com" "alice@example.com" 42))) (should-not (jabber-omemo-store-all-skipped-keys "me@example.com" "alice@example.com" 42))))) (ert-deftest jabber-test-omemo-store-session-save-composes-with-transaction () "Session migration succeeds inside an existing transaction." (jabber-test-omemo-store-with-db (sqlite-execute jabber-db--connection "\ INSERT INTO omemo_skipped_keys (account, jid, device_id, dh_key, message_number, message_key, created_at) VALUES ('me@example.com', 'alice@example.com', 42, 'dh', 7, 'mk', 0)") (sqlite-execute jabber-db--connection "BEGIN") (jabber-omemo-store-save-session-and-clear-legacy-keys "me@example.com" "alice@example.com" 42 "session") (sqlite-execute jabber-db--connection "COMMIT") (should (equal "session" (jabber-omemo-store-load-session "me@example.com" "alice@example.com" 42))) (should-not (jabber-omemo-store-all-skipped-keys "me@example.com" "alice@example.com" 42)))) (ert-deftest jabber-test-omemo-store-session-save-rolls-back-on-delete-error () "A failed legacy-key deletion restores the old session and key rows." (jabber-test-omemo-store-with-db (jabber-omemo-store-save-session "me@example.com" "alice@example.com" 42 "old-session") (sqlite-execute jabber-db--connection "\ INSERT INTO omemo_skipped_keys (account, jid, device_id, dh_key, message_number, message_key, created_at) VALUES ('me@example.com', 'alice@example.com', 42, 'dh', 7, 'mk', 0)") (cl-letf (((symbol-function 'jabber-omemo-store-delete-skipped-keys) (lambda (&rest _) (error "injected deletion failure")))) (should-error (jabber-omemo-store-save-session-and-clear-legacy-keys "me@example.com" "alice@example.com" 42 "new-session") :type 'error)) (should (equal "old-session" (jabber-omemo-store-load-session "me@example.com" "alice@example.com" 42))) (should (= 1 (length (jabber-omemo-store-all-skipped-keys "me@example.com" "alice@example.com" 42)))))) (ert-deftest jabber-test-omemo-store-legacy-keys-load-fifo () "Legacy keys load chronologically with insertion order as a tie-breaker." (jabber-test-omemo-store-with-db (dolist (row '((30 "dh-3" "mk-3" 20) (10 "dh-1" "mk-1" 10) (20 "dh-2" "mk-2" 10))) (sqlite-execute jabber-db--connection "\ INSERT INTO omemo_skipped_keys (account, jid, device_id, message_number, dh_key, message_key, created_at) VALUES ('me@example.com', 'alice@example.com', 42, ?, ?, ?, ?)" row)) (should (equal '(10 20 30) (mapcar #'car (jabber-omemo-store-all-skipped-keys "me@example.com" "alice@example.com" 42)))))) (provide 'jabber-test-omemo-store) ;;; jabber-test-omemo-store.el ends here emacs-jabber-0.13.1/tests/jabber-test-omemo-trust.el000066400000000000000000000112541523531702000222670ustar00rootroot00000000000000;;; jabber-test-omemo-trust.el --- Tests for jabber-omemo-trust -*- lexical-binding: t; -*- ;;; Commentary: ;; OMEMO trust management. ;;; Code: (require 'ert) (require 'jabber-omemo-trust) ;;; Group 1: trust label mapping (ert-deftest jabber-test-omemo-trust-label-undecided () "Trust level 0 maps to undecided." (should (string= "undecided" (jabber-omemo--trust-label 0)))) (ert-deftest jabber-test-omemo-trust-label-tofu () "Trust level 1 maps to TOFU." (should (string= "TOFU" (jabber-omemo--trust-label 1)))) (ert-deftest jabber-test-omemo-trust-label-verified () "Trust level 2 maps to verified." (should (string= "verified" (jabber-omemo--trust-label 2)))) (ert-deftest jabber-test-omemo-trust-label-untrusted () "Trust level -1 maps to UNTRUSTED." (should (string= "UNTRUSTED" (jabber-omemo--trust-label -1)))) (ert-deftest jabber-test-omemo-trust-label-unknown () "Unknown trust level shows the number." (should (string= "unknown(99)" (jabber-omemo--trust-label 99)))) ;;; Group 2: fingerprint formatting (ert-deftest jabber-test-omemo-trust-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-test-omemo-trust-format-fingerprint-empty () "Empty key produces empty string." (should (string= "" (jabber-omemo--format-fingerprint "")))) ;;; Group 3: key type stripping (ert-deftest jabber-test-omemo-trust-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-test-omemo-trust-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-test-omemo-trust-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-test-omemo-trust-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-test-omemo-trust-column-format () "Mode sets a 4-column tabulated-list-format." (cl-letf (((symbol-function 'window-width) (lambda (&rest _) 20))) (with-temp-buffer (jabber-omemo-trust-mode) (should (= 4 (length tabulated-list-format))) (should (equal "Device ID" (car (aref tabulated-list-format 0)))) (should (= 9 (cadr (aref tabulated-list-format 0)))) (should (equal "Trust" (car (aref tabulated-list-format 1)))) (should (= 8 (cadr (aref tabulated-list-format 1)))) (should (equal "Fingerprint" (car (aref tabulated-list-format 2)))) (should (= 32 (cadr (aref tabulated-list-format 2)))) (should (equal "First Seen" (car (aref tabulated-list-format 3)))) (should (= 16 (cadr (aref tabulated-list-format 3))))))) (provide 'jabber-test-omemo-trust) ;;; jabber-test-omemo-trust.el ends here emacs-jabber-0.13.1/tests/jabber-test-openpgp-legacy.el000066400000000000000000000044671523531702000227160ustar00rootroot00000000000000;;; jabber-test-openpgp-legacy.el --- Tests for jabber-openpgp-legacy -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0373 OpenPGP for XMPP. ;;; Code: (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-test-openpgp-legacy-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-test-openpgp-legacy-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-test-openpgp-legacy-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-test-openpgp-legacy) ;;; jabber-test-openpgp-legacy.el ends here emacs-jabber-0.13.1/tests/jabber-test-openpgp.el000066400000000000000000000231411523531702000214420ustar00rootroot00000000000000;;; jabber-test-openpgp.el --- Tests for jabber-openpgp -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0373 OpenPGP send paths. ;;; Code: (require 'ert) (require 'jabber-chat) (require 'jabber-openpgp) (require 'jabber-openpgp-legacy) (defmacro jabber-test-openpgp--with-db (&rest body) "Run BODY with a temporary message database." (declare (indent 0) (debug t)) `(let* ((dir (make-temp-file "jabber-openpgp-test" t)) (jabber-db-path (expand-file-name "test.sqlite" dir)) (jabber-db--connection nil)) (unwind-protect (progn (jabber-db-ensure-open) ,@body) (jabber-db-close) (delete-directory dir t)))) ;;; Group 1: MUC send hooks (XEP-0373) (defmacro jabber-test-openpgp--with-muc-send-stubs (sent-var &rest body) "Run BODY with the OpenPGP MUC encrypt/send path stubbed. SENT-VAR is bound to the stanza passed to `jabber-send-sexp'." (declare (indent 1) (debug t)) `(let ((,sent-var nil)) (cl-letf (((symbol-function 'jabber-openpgp--muc-participant-jids) (lambda (_group) '("alice@example.com"))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-openpgp--ensure-recipient-keys) (lambda (_jc _jids callback &optional _failure) (funcall callback))) ((symbol-function 'jabber-openpgp--build-crypt-xml) (lambda (_jids _body) '(payload ()))) ((symbol-function 'jabber-openpgp--encrypt) (lambda (_jc _xml _jids &optional _sign) "cipher")) ((symbol-function 'jabber-send-sexp) (lambda (_jc stanza) (setq ,sent-var stanza)))) ,@body))) (ert-deftest jabber-test-openpgp-muc-send-hooks-run-in-buffer () "MUC send hooks run in the originating buffer, not the callback's." (let* ((muc-buffer (generate-new-buffer "*test-openpgp-muc*")) (hook-buffer nil) (jabber-chat-send-hooks (list (lambda (_body _id) (setq hook-buffer (current-buffer)) '((probe ((xmlns . "test:probe")))))))) (unwind-protect (jabber-test-openpgp--with-muc-send-stubs sent (with-current-buffer muc-buffer (setq-local jabber-group "room@conf.example.com") (jabber-openpgp--send-muc 'fake-jc "hello")) (should (eq hook-buffer muc-buffer)) (should sent) (should (jabber-xml-get-attribute sent 'id)) (should (jabber-xml-get-children sent 'probe))) (kill-buffer muc-buffer)))) (ert-deftest jabber-test-openpgp-muc-send-dead-buffer-cancels () "A dead originating buffer cancels the deferred encrypted send." (let* ((muc-buffer (generate-new-buffer "*test-openpgp-muc*")) (pending-callback nil) (jabber-chat-send-hooks (list (lambda (_body _id) '((probe ((xmlns . "test:probe")))))))) (jabber-test-openpgp--with-muc-send-stubs sent (cl-letf (((symbol-function 'jabber-openpgp--ensure-recipient-keys) (lambda (_jc _jids callback &optional _failure) (setq pending-callback callback)))) (with-current-buffer muc-buffer (setq-local jabber-group "room@conf.example.com") (jabber-openpgp--send-muc 'fake-jc "hello"))) ;; Buffer dies while the key fetch is in flight. (kill-buffer muc-buffer) (funcall pending-callback) (should-not sent)))) (ert-deftest jabber-test-openpgp-muc-preflight-preserves-send-context () "Missing MUC recipients leave pending reply and thread state intact." (with-temp-buffer (setq-local jabber-group "room@conf.example.com") (setq-local jabber-message-reply--id "reply-1") (setq-local jabber-message-reply--jid "alice@example.com") (setq-local jabber-message-reply--fallback-text "> Alice:\n> root\n") (setq-local jabber-message-reply--thread '(:thread-id "thread-1" :thread-parent-id "parent-1")) (setq-local jabber-message-thread--root-reply-id "root-1") (setq-local jabber-message-thread--root-reply-jid "alice@example.com") (cl-letf (((symbol-function 'jabber-openpgp--muc-participant-jids) (lambda (_group) nil)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (should-error (jabber-openpgp--send-muc 'fake-jc "answer") :type 'user-error)) (should (equal "reply-1" jabber-message-reply--id)) (should (equal "alice@example.com" jabber-message-reply--jid)) (should (equal "> Alice:\n> root\n" jabber-message-reply--fallback-text)) (should (equal '(:thread-id "thread-1" :thread-parent-id "parent-1") jabber-message-reply--thread)) (should (equal "root-1" jabber-message-thread--root-reply-id)) (should (equal "alice@example.com" jabber-message-thread--root-reply-jid)))) (ert-deftest jabber-test-openpgp-concurrent-sends-keep-thread-owner () "Reverse key completion cannot move reply and thread metadata." (jabber-test-openpgp--with-db (with-temp-buffer (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-chatting-with "friend@example.com") (setq-local jabber-chat-encryption 'openpgp) (setq-local jabber-chat-send-hooks '(jabber-message-reply--send-hook jabber-db--outgoing-handler)) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "root" 1 "phone" "root-1" nil nil nil nil nil '(:thread-id "thread-1")) (let (callbacks sent (ticks 20)) (cl-letf (((symbol-function 'float-time) (lambda (&optional _) (cl-incf ticks))) ((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.com")) ((symbol-function 'jabber-openpgp--ensure-recipient-keys) (lambda (_jc _jids callback &optional _failure) (push callback callbacks))) ((symbol-function 'jabber-openpgp--build-signcrypt-xml) (lambda (&rest _) "payload")) ((symbol-function 'jabber-openpgp--encrypt) (lambda (&rest _) "cipher")) ((symbol-function 'jabber-chat--display-local-message) #'ignore) ((symbol-function 'jabber-send-sexp) (lambda (_jc stanza &optional success _failure) (push stanza sent) (when success (funcall success))))) (setq-local jabber-message-reply--id "root-1") (setq-local jabber-message-reply--jid "friend@example.com") (setq-local jabber-message-reply--thread '(:thread-id "thread-1")) (jabber-openpgp--send-chat 'fake-jc "first") (jabber-openpgp--send-chat 'fake-jc "second") (funcall (car callbacks)) (funcall (cadr callbacks)) (let ((first (car sent)) (second (cadr sent))) (should (= 1 (length (jabber-xml-get-children first 'thread)))) (should (jabber-xml-child-with-xmlns first "urn:xmpp:reply:0")) (should (= 1 (length (jabber-xml-get-children second 'thread)))) (should-not (equal "thread-1" (car (jabber-xml-node-children (car (jabber-xml-get-children second 'thread)))))) (should-not (jabber-xml-child-with-xmlns second "urn:xmpp:reply:0")) (should (equal `(("first" "thread-1") ("second" ,(car (jabber-xml-node-children (car (jabber-xml-get-children second 'thread)))))) (sqlite-select jabber-db--connection "SELECT body, thread_id FROM message \ WHERE body IN ('first', 'second') ORDER BY body"))))))))) ;;; Group 2: MUC send hooks (XEP-0027 legacy) (ert-deftest jabber-test-openpgp-legacy-muc-send-runs-hooks () "Legacy MUC send stamps an id and runs the send hooks." (let* ((muc-buffer (generate-new-buffer "*test-openpgp-legacy-muc*")) (hook-buffer nil) (sent nil) (jabber-chat-send-hooks (list (lambda (_body _id) (setq hook-buffer (current-buffer)) '((probe ((xmlns . "test:probe")))))))) (unwind-protect (cl-letf (((symbol-function 'jabber-openpgp-legacy--muc-participant-jids) (lambda (_group) '("alice@example.com"))) ((symbol-function 'jabber-openpgp--our-key) (lambda (_jc) 'our-key)) ((symbol-function 'jabber-openpgp--recipient-key) (lambda (_jid) 'their-key)) ((symbol-function 'epg-find-configuration) (lambda (_protocol) '((program . "gpg")))) ((symbol-function 'epg-encrypt-string) (lambda (&rest _) "-----BEGIN PGP MESSAGE-----\n\nZm9v\n-----END PGP MESSAGE-----")) ((symbol-function 'jabber-send-sexp) (lambda (_jc stanza) (setq sent stanza)))) (with-current-buffer muc-buffer (setq-local jabber-group "room@conf.example.com") (jabber-openpgp-legacy--send-muc 'fake-jc "hello")) (should (eq hook-buffer muc-buffer)) (should sent) (should (jabber-xml-get-attribute sent 'id)) (should (jabber-xml-get-children sent 'probe))) (kill-buffer muc-buffer)))) (provide 'jabber-test-openpgp) ;;; jabber-test-openpgp.el ends here emacs-jabber-0.13.1/tests/jabber-test-presence.el000066400000000000000000000372221523531702000216030ustar00rootroot00000000000000;;; jabber-test-presence.el --- Tests for jabber-presence -*- lexical-binding: t; -*- ;;; Commentary: ;; Presence tracking and resource management. ;;; Code: (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-current-show) (defvar jabber-current-status) (defvar jabber-current-priority) (require 'jabber-presence) (require 'jabber-xml) ;;; Group 1: jabber-presence-children (ert-deftest jabber-test-presence-children-default-omits-nil-elements () "Default empty status/show presence serializes no nil elements." (let ((jabber-current-status "") (jabber-current-show "") (jabber-current-priority 10) (jabber-presence-element-functions nil)) (should (equal (jabber-presence-children nil) '((priority () "10")))) (should-not (string-match-p " 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-test-sm-enabled-p () "Detect SM element." (should (jabber-sm--enabled-p '(enabled ((xmlns . "urn:xmpp:sm:3") (id . "abc") (resume . "true")))))) (ert-deftest jabber-test-sm-resumed-p () "Detect SM element." (should (jabber-sm--resumed-p '(resumed ((xmlns . "urn:xmpp:sm:3") (h . "5") (previd . "abc")))))) (ert-deftest jabber-test-sm-failed-p () "Detect SM element." (should (jabber-sm--failed-p '(failed ((xmlns . "urn:xmpp:sm:3")))))) ;;; State-data reset (ert-deftest jabber-test-sm-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-test-sm-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-test-sm-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-test-sm-features-nil () "Nil stream features." (should-not (jabber-sm--features-have-sm-p '(:stream-features nil)))) ;;; Stanza counting (ert-deftest jabber-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-prune-queue-empty () "Prune on empty queue returns empty." (should (null (jabber-sm--prune-queue nil 5)))) (ert-deftest jabber-test-sm-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)))) (ert-deftest jabber-test-sm-process-ack-ahead-signals-protocol-error () "An acknowledgement beyond the sent count is a protocol error." (let* ((sd (list :sm-enabled t :sm-outbound-count 11501 :sm-outbound-queue (list (cons 11501 'a)) :sm-last-acked 11501 :sm-stall-since 1.0)) (ack '(a ((xmlns . "urn:xmpp:sm:3") (h . "11502")))) (before (copy-tree sd))) (should-error (jabber-sm--process-ack sd ack) :type 'jabber-sm-handled-count-too-high) (should (equal before sd))) (dolist (h '("11502" "11501")) (let* ((sd (list :sm-enabled t :sm-outbound-count 11502 :sm-outbound-queue (list (cons 11502 'a)) :sm-last-acked 11502 :sm-stall-since 1.0)) (before (copy-tree sd)) (ack `(a ((xmlns . "urn:xmpp:sm:3") (h . ,h)))) (result (jabber-sm--process-ack sd ack))) (should (equal result before))))) (ert-deftest jabber-test-sm-stall-reconnects-with-unacked-state () "An acknowledgement stall reconnects without fabricating an ack." (let* ((outbound '((1 . first))) (pending '((0 message nil (body nil "second")))) (connection 'fake-process) (state-data (list :connection connection :sm-outbound-count 1 :sm-last-acked 0 :sm-outbound-queue outbound :sm-pending-queue pending :sm-stall-since 1.0)) deleted) (cl-letf (((symbol-function 'processp) (lambda (_process) t)) ((symbol-function 'delete-process) (lambda (process) (setq deleted process)))) (jabber-sm--recover-stall 'fake-jc state-data)) (should (eq connection deleted)) (should (equal outbound (plist-get state-data :sm-outbound-queue))) (should (equal pending (plist-get state-data :sm-pending-queue))) (should (equal "Stream Management acknowledgement timeout" (plist-get state-data :disconnection-reason))))) ;;; FSM routing helper (ert-deftest jabber-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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-test-sm-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))))) (ert-deftest jabber-test-sm-handle-failed-resume-preserves-unacked () "A failed resume carries unacknowledged stanzas into the new session." (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"))) (pending (list (cons 0 msg-c))) (sd (list :sm-enabled t :sm-id "expired" :sm-outbound-count 2 :sm-outbound-queue (list (cons 1 msg-a) (cons 2 msg-b)) :sm-pending-queue pending :sm-last-acked 0 :sm-resuming t)) (failed '(failed ((xmlns . "urn:xmpp:sm:3") (h . "1")))) (result (jabber-sm--handle-failed-resume sd failed))) (should-not (plist-get result :sm-enabled)) (should-not (plist-get result :sm-id)) (should-not (plist-get result :sm-resuming)) (should (equal (mapcar #'jabber-sm--pending-stanza (plist-get result :sm-pending-queue)) (list msg-b msg-c))))) (ert-deftest jabber-test-sm-resume-failure-binds-without-reauthentication () "A failed post-SASL resume continues with resource binding." (let* ((msg '(message ((to . "a@x")) (body () "unacked"))) (fsm 'fake-jc) (state-data (list :resource "emacs" :sm-enabled t :sm-id "expired" :sm-resuming t :sm-outbound-count 1 :sm-outbound-queue (list (cons 1 msg)) :sm-last-acked 0 :stream-features `(features () (bind ((xmlns . ,jabber-bind-xmlns))) (sm ((xmlns . ,jabber-sm-xmlns)))))) (event `(:stanza (failed ((xmlns . ,jabber-sm-xmlns))))) (handler (gethash :sm-resume (get 'jabber-connection :fsm-event))) (enter-bind (gethash :bind (get 'jabber-connection :fsm-enter))) sent-iq stream-header-sent) (cl-letf (((symbol-function 'jabber-lifecycle-dispatch-session-reset) #'ignore) ((symbol-function 'jabber-send-stream-header) (lambda (_jc) (setq stream-header-sent t))) ((symbol-function 'jabber-send-iq) (lambda (&rest args) (setq sent-iq args)))) (pcase-let* ((`(,next-state ,next-data) (funcall handler fsm state-data event #'ignore)) (`(,entered-data nil) (funcall enter-bind fsm next-data))) (should (eq next-state :bind)) (should sent-iq) (should-not stream-header-sent) (should-not (plist-get entered-data :sm-resuming)) (should (equal (mapcar #'jabber-sm--pending-stanza (plist-get entered-data :sm-pending-queue)) (list msg))))))) (ert-deftest jabber-test-sm-new-session-drains-recovered-stanzas () "A newly established session sends stanzas recovered from failed resume." (let* ((msg '(message ((to . "a@x")) (body () "unacked"))) (state-data (jabber-sm--reset nil)) (enter (gethash :session-established (get 'jabber-connection :fsm-enter))) sent) (setq state-data (plist-put state-data :sm-pending-queue (list (cons 0 msg)))) (cl-letf (((symbol-function 'jabber-lifecycle-dispatch-session-bootstrap) #'ignore) ((symbol-function 'jabber-send-sexp--raw) (lambda (_jc sexp) (push sexp sent)))) (pcase-let ((`(,result nil) (funcall enter 'fake-jc state-data))) (should (equal sent (list msg))) (should-not (plist-get result :sm-pending-queue)))))) ;;; Ack XML generation (ert-deftest jabber-test-sm-make-ack-xml () "Ack XML includes h value." (should (string-match-p "h='7'" (jabber-sm--make-ack-xml 7)))) (ert-deftest jabber-test-sm-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-test-styling-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-test-styling-classify-pre-close () "Bare ``` line classifies as pre-close." (should (eq 'pre-close (jabber-styling--classify-block "```")))) (ert-deftest jabber-test-styling-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-test-styling-span-bold () "Asterisks produce bold span." (let ((spans (jabber-styling--parse-spans "*bold*"))) (should (equal '((0 6 jabber-styling-bold)) spans)))) (ert-deftest jabber-test-styling-span-italic () "Underscores produce italic span." (let ((spans (jabber-styling--parse-spans "_italic_"))) (should (equal '((0 8 jabber-styling-italic)) spans)))) (ert-deftest jabber-test-styling-span-strike () "Tildes produce strikethrough span." (let ((spans (jabber-styling--parse-spans "~strike~"))) (should (equal '((0 8 jabber-styling-strike)) spans)))) (ert-deftest jabber-test-styling-span-pre () "Backticks produce preformatted span." (let ((spans (jabber-styling--parse-spans "`code`"))) (should (equal '((0 6 jabber-styling-pre)) spans)))) (ert-deftest jabber-test-styling-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-test-styling-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-test-styling-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-test-styling-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-test-styling-span-empty-rejected () "Empty span ** is not valid." (let ((spans (jabber-styling--parse-spans "**"))) (should (null spans)))) (ert-deftest jabber-test-styling-span-triple-star () "*** produces no spans (star excluded from content)." (let ((spans (jabber-styling--parse-spans "***"))) (should (null spans)))) (ert-deftest jabber-test-styling-span-quad-star () "**** produces no spans (star excluded from content)." (let ((spans (jabber-styling--parse-spans "****"))) (should (null spans)))) (ert-deftest jabber-test-styling-span-no-close () "Unclosed span produces no styling." (let ((spans (jabber-styling--parse-spans "*no close"))) (should (null spans)))) (ert-deftest jabber-test-styling-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-test-styling-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-test-styling-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-test-styling-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-test-styling-blocks-plain () "Single plain line." (let ((blocks (jabber-styling--parse-blocks "hello\n"))) (should (equal '((plain 0 6)) blocks)))) (ert-deftest jabber-test-styling-blocks-quote () "Block quote line." (let ((blocks (jabber-styling--parse-blocks "> quoted\n"))) (should (equal '((quote 0 9)) blocks)))) (ert-deftest jabber-test-styling-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-test-styling-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-test-styling-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-test-styling-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-test-styling-strip-quote-space () "Strip > followed by space." (should (equal "text" (jabber-styling--strip-quote-prefix "> text")))) (ert-deftest jabber-test-styling-strip-quote-no-space () "Strip > not followed by space." (should (equal "text" (jabber-styling--strip-quote-prefix ">text")))) (ert-deftest jabber-test-styling-strip-quote-bare () "Strip bare >." (should (equal "" (jabber-styling--strip-quote-prefix ">")))) ;;; Group 5: jabber-styling--apply-region (integration) (ert-deftest jabber-test-styling-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-test-styling-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-test-styling-apply-pre-block-face () "The code body carries the block background face." (with-temp-buffer (insert "```emacs-lisp\ncode\n```\n") (jabber-styling--apply-region (point-min) (point-max)) (goto-char 16) ;; inside the code body (let ((face (get-text-property (point) 'face))) (should (memq 'jabber-styling-pre-block (if (listp face) face (list face))))))) (ert-deftest jabber-test-styling-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-test-styling-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-test-styling-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-test-styling-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-test-styling-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-test-styling-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-test-styling-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-test-styling-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))))))) ;;; Group 7: pre-span suppression and adjacent spans (ert-deftest jabber-test-styling-pre-suppresses-bold () "Bold inside a preformatted span is not styled." (let ((spans (jabber-styling--parse-spans "`*not bold*`"))) (should (equal 1 (length spans))) (should (eq 'jabber-styling-pre (nth 2 (car spans)))))) (ert-deftest jabber-test-styling-adjacent-spans () "Adjacent spans separated by directive char are both matched." (let ((spans (jabber-styling--parse-spans "*a*_b_"))) (should (equal 2 (length spans))) (should (eq 'jabber-styling-bold (nth 2 (nth 0 spans)))) (should (eq 'jabber-styling-italic (nth 2 (nth 1 spans)))))) ;;; Group 8: jabber-styling--fence-lang (ert-deftest jabber-test-styling-fence-lang-simple () (should (equal "python" (jabber-styling--fence-lang "```python")))) (ert-deftest jabber-test-styling-fence-lang-none () (should-not (jabber-styling--fence-lang "```"))) (ert-deftest jabber-test-styling-fence-lang-first-token () (should (equal "python" (jabber-styling--fence-lang "```python extra")))) (ert-deftest jabber-test-styling-fence-lang-downcase () (should (equal "elisp" (jabber-styling--fence-lang "```Elisp")))) ;;; Group 9: jabber-styling--pre-block-parts (ert-deftest jabber-test-styling-pre-block-parts-basic () (should (equal '("elisp" 9 15) (jabber-styling--pre-block-parts "```elisp\n(foo)\n```")))) (ert-deftest jabber-test-styling-pre-block-parts-unterminated () "Unterminated blocks extend the code region to end of text." (should (equal '("elisp" 9 14) (jabber-styling--pre-block-parts "```elisp\n(foo)")))) (ert-deftest jabber-test-styling-pre-block-parts-no-lang () (should (equal '(nil 4 6) (jabber-styling--pre-block-parts "```\nx\n```")))) (ert-deftest jabber-test-styling-pre-block-parts-empty-code () (should (equal '("elisp" 9 9) (jabber-styling--pre-block-parts "```elisp\n```")))) (ert-deftest jabber-test-styling-pre-block-parts-trailing-newline () "Closing fence line is excluded even with a trailing newline." (should (equal '(nil 4 6) (jabber-styling--pre-block-parts "```\nx\n```\n")))) ;;; Group 10: jabber-styling--lang-mode (ert-deftest jabber-test-styling-lang-mode-direct () (should (eq 'emacs-lisp-mode (jabber-styling--lang-mode "emacs-lisp")))) (ert-deftest jabber-test-styling-lang-mode-alias () "Aliases in jabber-styling-code-lang-modes resolve first." (should (eq 'emacs-lisp-mode (jabber-styling--lang-mode "elisp")))) (ert-deftest jabber-test-styling-lang-mode-missing () (should-not (jabber-styling--lang-mode "nosuchlang"))) (ert-deftest jabber-test-styling-lang-mode-nil () (should-not (jabber-styling--lang-mode nil))) (ert-deftest jabber-test-styling-lang-mode-remap () (let ((major-mode-remap-alist '((emacs-lisp-mode . lisp-interaction-mode)))) (should (eq 'lisp-interaction-mode (jabber-styling--lang-mode "emacs-lisp"))))) ;;; Group 11: jabber-styling--fontify-code (defun jabber-test-styling--stretch-faces-at (offset stretches) "Return faces from STRETCHES covering OFFSET, flattened to a list." (cl-loop for (s e face) in stretches when (and (<= s offset) (< offset e)) append (if (listp face) face (list face)))) (ert-deftest jabber-test-styling-fontify-code-keyword () "The defun keyword gets font-lock-keyword-face." (let ((stretches (jabber-styling--fontify-code "(defun f ())" 'emacs-lisp-mode))) (should (memq 'font-lock-keyword-face (jabber-test-styling--stretch-faces-at 1 stretches))))) (ert-deftest jabber-test-styling-fontify-code-string-face () (let ((stretches (jabber-styling--fontify-code "\"hi\"" 'emacs-lisp-mode))) (should (memq 'font-lock-string-face (jabber-test-styling--stretch-faces-at 1 stretches))))) (ert-deftest jabber-test-styling-fontify-code-bounded () "All stretch offsets fall inside the code string." (let* ((code "(defun f () \"doc\" nil)") (stretches (jabber-styling--fontify-code code 'emacs-lisp-mode))) (should stretches) (dolist (stretch stretches) (should (<= 0 (nth 0 stretch))) (should (< (nth 0 stretch) (nth 1 stretch))) (should (<= (nth 1 stretch) (length code)))))) (ert-deftest jabber-test-styling-fontify-code-buffer-reused () "The per-mode work buffer persists and results are stable." (let ((first (jabber-styling--fontify-code "(defun f ())" 'emacs-lisp-mode)) (second (jabber-styling--fontify-code "(defun f ())" 'emacs-lisp-mode))) (should (buffer-live-p (get-buffer " *jabber-styling-fontify:emacs-lisp-mode*"))) (should (equal first second)))) ;;; Group 12: code block fontification (integration) (defun jabber-test-styling--faces-at (pos) "Return the face property at POS as a list." (let ((face (get-text-property pos 'face))) (if (listp face) face (list face)))) (ert-deftest jabber-test-styling-apply-code-block () "Lang blocks fontify the body and tint it with the block bg. The mode's face wins (it precedes the bg), and the body is marked." (with-temp-buffer (insert "```emacs-lisp\n(defun f ())\n```") (jabber-styling--apply-region (point-min) (point-max)) (let ((faces (jabber-test-styling--faces-at 16))) ; d of defun (should (memq 'font-lock-keyword-face faces)) (should (memq 'jabber-styling-pre-block faces)) (should (< (seq-position faces 'font-lock-keyword-face) (seq-position faces 'jabber-styling-pre-block)))) (should (get-text-property 16 'jabber-styling-fontified)))) (ert-deftest jabber-test-styling-pre-block-regions () "Fence lines get the fence face; the body gets the block bg. Neither face carries the other's, mirroring Org's src blocks." (with-temp-buffer (insert "```emacs-lisp\n(defun f ())\n```") (jabber-styling--apply-region (point-min) (point-max)) ;; Fence lines: fence face, no block bg. (dolist (pos '(2 5 29)) (should (memq 'jabber-styling-pre-block-fence (jabber-test-styling--faces-at pos))) (should-not (memq 'jabber-styling-pre-block (jabber-test-styling--faces-at pos)))) ;; Body: block bg, no fence face. (dolist (pos '(15 16 22 26)) (should (memq 'jabber-styling-pre-block (jabber-test-styling--faces-at pos))) (should-not (memq 'jabber-styling-pre-block-fence (jabber-test-styling--faces-at pos)))))) (ert-deftest jabber-test-styling-apply-code-block-unknown-lang () "Unknown languages: no native fontification, but the body still gets the block background and the fences the fence face." (with-temp-buffer (insert "```nosuchlang\nx\n```") (jabber-styling--apply-region (point-min) (point-max)) (should (memq 'jabber-styling-pre-block-fence (jabber-test-styling--faces-at 2))) (should (memq 'jabber-styling-pre-block (jabber-test-styling--faces-at 15))) (should-not (text-property-any (point-min) (point-max) 'jabber-styling-fontified t)))) (ert-deftest jabber-test-styling-apply-code-block-disabled () (with-temp-buffer (insert "```emacs-lisp\n(defun f ())\n```") (let ((jabber-styling-fontify-code-blocks nil)) (jabber-styling--apply-region (point-min) (point-max))) (should-not (text-property-any (point-min) (point-max) 'jabber-styling-fontified t)))) (ert-deftest jabber-test-styling-apply-code-block-max-size () "Oversized blocks get the background but no native fontification." (with-temp-buffer (insert "```emacs-lisp\n(defun f ())\n```") (let ((jabber-styling-fontify-max-size 1)) (jabber-styling--apply-region (point-min) (point-max))) (should-not (text-property-any (point-min) (point-max) 'jabber-styling-fontified t)))) (ert-deftest jabber-test-styling-remove-code-fontification () "Removal clears native faces and the marker property." (with-temp-buffer (insert "```emacs-lisp\n(defun f ())\n```") (jabber-styling--apply-region (point-min) (point-max)) (jabber-styling--remove-code-fontification (point-min) (point-max)) (should-not (memq 'font-lock-keyword-face (jabber-test-styling--faces-at 16))) (should-not (text-property-any (point-min) (point-max) 'jabber-styling-fontified t)))) (ert-deftest jabber-test-styling-code-block-clears-chat-face () "The body drops any preexisting chat face uniformly. Both a recognized and an unrecognized language lose the surrounding face, replaced by the block background." (dolist (lang '("emacs-lisp" "nosuchlang")) (with-temp-buffer (insert "```" lang "\n") (let ((code-start (point))) (insert (propertize "xy" 'face 'jabber-chat-text-local) "\n```") (jabber-styling--apply-region (point-min) (point-max)) (let ((faces (jabber-test-styling--faces-at code-start))) (should-not (memq 'jabber-chat-text-local faces)) (should (memq 'jabber-styling-pre-block faces))))))) (ert-deftest jabber-test-styling-code-block-disabled-keeps-chat-face () "With fontification disabled the body keeps its chat face, still tinted by the block background." (with-temp-buffer (insert "```emacs-lisp\n") (let ((code-start (point))) (insert (propertize "xy" 'face 'jabber-chat-text-local) "\n```") (let ((jabber-styling-fontify-code-blocks nil)) (jabber-styling--apply-region (point-min) (point-max))) (let ((faces (jabber-test-styling--faces-at code-start))) (should (memq 'jabber-chat-text-local faces)) (should (memq 'jabber-styling-pre-block faces)))))) (provide 'jabber-test-styling) ;;; jabber-test-styling.el ends here emacs-jabber-0.13.1/tests/jabber-test-time.el000066400000000000000000000021071523531702000207270ustar00rootroot00000000000000;;; jabber-test-time.el --- Tests for jabber-time -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0012, XEP-0090, and XEP-0202 time handling. ;;; Code: (require 'ert) (require 'cl-lib) (require 'jabber-time) ;;; Last activity (ert-deftest jabber-test-time-return-last-sends-query () (let ((sent nil) (iq '(iq ((from . "romeo@example.net/orchard") (id . "last1")) (query ((xmlns . "jabber:iq:last")))))) (cl-letf (((symbol-function 'jabber-autoaway-get-idle-time) (lambda () 42.7)) ((symbol-function 'jabber-send-iq) (lambda (&rest args) (setq sent args)))) (jabber-return-last 'jc iq) (should (equal sent (list 'jc "romeo@example.net/orchard" "result" '(query ((xmlns . "jabber:iq:last") (seconds . "42"))) nil nil nil nil "last1")))))) (provide 'jabber-test-time) ;;; jabber-test-time.el ends here emacs-jabber-0.13.1/tests/jabber-test-util.el000066400000000000000000000377361523531702000207660ustar00rootroot00000000000000;;; jabber-test-util.el --- Tests for jabber-util -*- lexical-binding: t; -*- ;;; Commentary: ;; JID manipulation, time parsing, and utility functions. ;;; Code: (require 'ert) (require 'jabber-util) (require 'jabber-uri) (defvar jabber-jid-obarray (make-vector 127 0)) (ert-deftest jabber-test-util-connection-active-requires-session () "Only a listed FSM with an established session is active." (let* ((connection (make-symbol "connection")) (jabber-connections (list connection))) (put connection :state :connecting) (should-not (jabber-connection-active-p connection)) (put connection :state :session-established) (should (jabber-connection-active-p connection)))) ;;; Group 1: JID functions (ert-deftest jabber-test-util-jid-username-normal () "Extract username from full JID." (should (string= (jabber-jid-username "alice@example.com/home") "alice"))) (ert-deftest jabber-test-util-jid-username-bare () "Extract username from bare JID." (should (string= (jabber-jid-username "alice@example.com") "alice"))) (ert-deftest jabber-test-util-jid-username-no-at () "Return nil for server-only JID." (should (null (jabber-jid-username "example.com")))) (ert-deftest jabber-test-util-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-util-jid-user-bare () "Bare JID returned unchanged." (should (string= (jabber-jid-user "alice@example.com") "alice@example.com"))) (ert-deftest jabber-test-util-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-util-jid-server-normal () "Extract server from normal JID." (should (string= (jabber-jid-server "alice@example.com/home") "example.com"))) (ert-deftest jabber-test-util-jid-server-bare () "Extract server from bare JID." (should (string= (jabber-jid-server "alice@example.com") "example.com"))) (ert-deftest jabber-test-util-jid-server-no-at () "Extract server from server-only JID." (should (string= (jabber-jid-server "example.com") "example.com"))) (ert-deftest jabber-test-util-jid-resource-present () "Extract resource from full JID." (should (string= (jabber-jid-resource "alice@example.com/home") "home"))) (ert-deftest jabber-test-util-jid-resource-absent () "Return nil when no resource." (should (null (jabber-jid-resource "alice@example.com")))) (ert-deftest jabber-test-util-jid-resource-multiple-slashes () "Resource can contain slashes." (should (string= (jabber-jid-resource "alice@example.com/home/desk") "home/desk"))) (ert-deftest jabber-test-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-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-util-unhex () "Decode hex-encoded UTF-8 string." (should (string= (jabber-unhex "hello%20world") "hello world"))) (ert-deftest jabber-test-util-jabber-string>-numerical-greater () "Larger number returns t." (should (jabber-string>-numerical "200" "100"))) (ert-deftest jabber-test-util-jabber-string>-numerical-less () "Smaller number returns nil." (should-not (jabber-string>-numerical "50" "100"))) (ert-deftest jabber-test-util-jabber-string>-numerical-equal () "Equal numbers return nil." (should-not (jabber-string>-numerical "100" "100"))) (ert-deftest jabber-test-util-jabber-string>-numerical-longer () "Longer string (more digits) is greater." (should (jabber-string>-numerical "1000" "999"))) (ert-deftest jabber-test-util-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-util-tree-map () "Apply function to all atoms in a tree." (should (equal (jabber-tree-map #'1+ '(1 (2 3) 4)) '(2 (3 4) 5)))) ;;; Group: Decrypt-failure placeholder predicate (ert-deftest jabber-test-util-decrypt-failure-body-p-matches-placeholder () (should (jabber--decrypt-failure-body-p "[OMEMO: could not decrypt]")) (should (jabber--decrypt-failure-body-p "[OpenPGP: could not decrypt]"))) (ert-deftest jabber-test-util-decrypt-failure-body-p-rejects-real-text () (should-not (jabber--decrypt-failure-body-p nil)) (should-not (jabber--decrypt-failure-body-p "hello there")) (should-not (jabber--decrypt-failure-body-p "quoting [OMEMO: could not decrypt] in a longer message")) (should-not (jabber--decrypt-failure-body-p "[OMEMO: could not decrypt] trailing text"))) ;;; Group: Roster membership predicate (defun jabber-test-util--make-jc-with-roster (&rest jids) "Create a fake connection whose roster contains JIDS." (let ((jc (gensym "jabber-test-util-jc-"))) (put jc :state-data (list :roster (mapcar #'jabber-jid-symbol jids))) jc)) (ert-deftest jabber-test-util-roster-contact-p-bare-jid () (let ((jc (jabber-test-util--make-jc-with-roster "alice@example.com"))) (should (jabber-roster-contact-p jc "alice@example.com")))) (ert-deftest jabber-test-util-roster-contact-p-full-jid () "Resource is stripped before the roster lookup." (let ((jc (jabber-test-util--make-jc-with-roster "alice@example.com"))) (should (jabber-roster-contact-p jc "alice@example.com/laptop")))) (ert-deftest jabber-test-util-roster-contact-p-stranger () (let ((jc (jabber-test-util--make-jc-with-roster "alice@example.com"))) (should-not (jabber-roster-contact-p jc "mallory@example.com")))) (ert-deftest jabber-test-util-roster-contact-p-nil-args () (let ((jc (jabber-test-util--make-jc-with-roster "alice@example.com"))) (should-not (jabber-roster-contact-p nil "alice@example.com")) (should-not (jabber-roster-contact-p jc nil)))) ;;; Group: JID completion sorting (defun jabber-test-util--contact (jid show &optional name) "Return an uninterned roster symbol JID with SHOW and NAME set." (let ((sym (make-symbol jid))) (put sym 'show show) (when name (put sym 'name name)) sym)) (ert-deftest jabber-test-util-presence-rank-orders-shows () "Available shows rank ahead of away shows, offline ranks last." (let ((online (jabber-test-util--contact "a@x.com" "")) (chatty (jabber-test-util--contact "b@x.com" "chat")) (away (jabber-test-util--contact "c@x.com" "away")) (offline (jabber-test-util--contact "d@x.com" nil))) (should (< (jabber--presence-rank chatty) (jabber--presence-rank online))) (should (< (jabber--presence-rank online) (jabber--presence-rank away))) (should (< (jabber--presence-rank away) (jabber--presence-rank offline))))) (ert-deftest jabber-test-util-jid-candidate-lessp-availability-first () "An online contact sorts before an offline one regardless of name." (let* ((online (jabber-test-util--contact "zed@x.com" "")) (offline (jabber-test-util--contact "ann@x.com" nil)) (table (list (cons "zed@x.com" online) (cons "ann@x.com" offline)))) (should (jabber--jid-candidate-lessp "zed@x.com" "ann@x.com" table)) (should-not (jabber--jid-candidate-lessp "ann@x.com" "zed@x.com" table)))) (ert-deftest jabber-test-util-jid-candidate-lessp-name-tiebreak () "Same availability falls back to case-insensitive name order." (let* ((a (jabber-test-util--contact "ann@x.com" "")) (b (jabber-test-util--contact "Bob@x.com" "")) (table (list (cons "ann@x.com" a) (cons "Bob@x.com" b)))) (should (jabber--jid-candidate-lessp "ann@x.com" "Bob@x.com" table)) (should-not (jabber--jid-candidate-lessp "Bob@x.com" "ann@x.com" table)))) (ert-deftest jabber-test-util-completion-metadata-sorts-by-availability () "The completion table's display sort puts available contacts first." (let* ((jabber-jid-completion-display 'jid) (table (list (cons "off@x.com" (jabber-test-util--contact "off@x.com" nil)) (cons "away@x.com" (jabber-test-util--contact "away@x.com" "away")) (cons "on@x.com" (jabber-test-util--contact "on@x.com" "")))) (collection (jabber--jid-completion-with-metadata table)) (metadata (funcall collection "" nil 'metadata)) (sorter (cdr (assq 'display-sort-function (cdr metadata))))) (should (functionp sorter)) (should (equal '("on@x.com" "away@x.com" "off@x.com") (funcall sorter '("off@x.com" "away@x.com" "on@x.com")))))) ;;; Group 7: XMPP URI parsing (ert-deftest jabber-test-uri-parse-chat () "Parse a plain chat URI without a query method." (should (equal (jabber-uri-parse "xmpp:alice@example.com") '(:jid "alice@example.com" :method nil :args nil)))) (ert-deftest jabber-test-uri-parse-method-and-arguments () "Parse and decode an XMPP URI method and its arguments." (should (equal (jabber-uri-parse "xmpp:room@example.com?command;node=hello%20world;action=next") '(:jid "room@example.com" :method "command" :args (("node" . "hello world") ("action" . "next")))))) (ert-deftest jabber-test-uri-rejects-authority () "Reject XMPP URIs containing an authority part." (should-error (jabber-uri-parse "xmpp://alice@example.com"))) (ert-deftest jabber-test-uri-rejects-trailing-text () "Reject text after a complete XMPP URI." (should-error (jabber-uri-parse "xmpp:alice@example.com?join trailing"))) (provide 'jabber-test-util) ;;; jabber-test-util.el ends here emacs-jabber-0.13.1/tests/jabber-test-vcard-avatars.el000066400000000000000000000017571523531702000225410ustar00rootroot00000000000000;;; jabber-test-vcard-avatars.el --- Tests for vCard avatars -*- lexical-binding: t; -*- ;;; Commentary: ;; vCard avatar presence publishing. ;;; Code: (require 'cl-lib) (require 'ert) (require 'jabber-vcard-avatars) (require 'jabber-xml) ;;; Group 1: presence elements (ert-deftest jabber-test-vcard-avatars-presence-no-hash-omits-element () "Publishing with no known avatar hash serializes no nil elements." (let ((jabber-vcard-avatars-publish t) (jabber-vcard-avatars-current-hash (make-hash-table :test 'equal))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "alice@example.com"))) (should-not (jabber-vcard-avatars-presence-element nil)) (should-not (string-match-p " (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-0.13.1/tests/load-all.el000066400000000000000000000003541523531702000172600ustar00rootroot00000000000000;; 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-0.13.1/tests/nick-change-fail.el000066400000000000000000000060161523531702000206540ustar00rootroot00000000000000;; -*- 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-0.13.1/tests/parse-date.el000066400000000000000000000056411523531702000176240ustar00rootroot00000000000000;;; 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-0.13.1/tests/parse-next-stanza.el000066400000000000000000000010521523531702000211530ustar00rootroot00000000000000;; 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")))