pax_global_header00006660000000000000000000000064152711103360014511gustar00rootroot0000000000000052 comment=60568dd5f0d3a499c8ff521edf67185f0cd64db8 emacs-jabber-0.15.1/000077500000000000000000000000001527111033600141105ustar00rootroot00000000000000emacs-jabber-0.15.1/.elpaignore000066400000000000000000000001641527111033600162370ustar00rootroot00000000000000tests src/picomemo/.github src/picomemo/test src/picomemo/example src/picomemo/.clang-format *.nix flake.lock admin emacs-jabber-0.15.1/.gitignore000066400000000000000000000002231527111033600160750ustar00rootroot00000000000000*.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.15.1/CHANGELOG.org000066400000000000000000000673161527111033600161250ustar00rootroot00000000000000#+TITLE: Changelog * [0.15.1] #+date: 2026-10-30 ** Fixes - Leave the published OMEMO device list and bundles unchanged when fetching our own device list fails; distinguish authoritative empty lists from errors. - Preserve binary OMEMO module inputs on Neomacs runtimes that reject unibyte strings through the native string-copy API; keep GNU Emacs behavior unchanged. - Load the OMEMO module into any Emacs 28+ module interface, not only the one it was compiled against; disable OMEMO with a warning when the module cannot be loaded instead of failing to open chats. - Add =MBED_STATIC=1= to link Mbed TLS into the module; the Nix development shell uses it so modules survive store garbage collection. - Store a sender's reaction timestamp and reactions as one database change. A storage error or quit no longer leaves a partial snapshot whose newer timestamp makes the same live or archived update look stale on retry. - Look up reply and reaction targets through the identity indexes instead of scanning a conversation's history, keeping room-ID precedence, the historical server-ID fallback and ambiguity checks unchanged. - Stop exact archive replays from rewriting stored messages and their search index; thread views read only the messages they display. - Let historical room archive messages stored without a room stanza ID be replied to and reacted to again: upgrading copies their room archive ID into the message when that ID is unambiguous within the room (#81). - Keep that upgrade fast on large histories: identity changes no longer rewrite the search index, and Emacs reports when it upgrades the database. - Store each archived message in its own short database transaction instead of holding one open across archive page requests, so a failed page no longer rolls back unrelated live messages or OMEMO state, and a retry decrypts from the restored state (#87). - Stay in rooms where we are an admin or owner on Prosody. Its unavailable presence from the bare room JID, which lists absent affiliated members, no longer counts as our own departure; the room's own departure notices still come from our occupant JID and are still honoured. - Stop announcing "has left the chatroom" on join for members who were never in the room; Prosody lists absent members with reserved nicknames that way. * [0.15.0] #+date: 2026-10-02 ** Changed - Synchronize server blocklists before fetching peer OMEMO keys; ignore stale blocklist replies and recheck blocked recipients before sending. - Verify received OpenPGP messages against the expected sender's signing key. - Test the declared minimum Emacs, pinned upstream Emacs and Thanos Emacs fork. ** Fixes - Preserve chat drafts, undo history and reply navigation while updating the transcript; failed sends cannot restore stale text over a newer draft. - Keep popup help bindings and user keymap customizations across Lisp reloads. - Preserve encrypted attachment bytes under compressed filename suffixes. - Keep connection attempts, transport callbacks and queued stanza order attached to the session that owns them. - Retain archive query outcomes and pagination progress until storage commits; preserve unfetched history and reject conflicting message identities. - Preserve OMEMO trust and sessions on identity conflicts; keep encrypted room recipients attached to the current membership snapshot. - Preserve reply targets, retractions, reactions and receipt boundaries during live-message and archive replay. - Stop link-preview scanning from revisiting rejected URLs. - Exclude development administration files from ELPA archives. - Speed up archive duplicate lookup with indexed message identities instead of scanning a contact's history; preserve ambiguous-message and archive-UID checks. - Upgrade existing message databases non-destructively with origin-ID and room-ID indexes while retaining message, archive and encryption state. - Drop rejected incoming message corrections silently, including missing or ambiguous archive targets, instead of flooding =*Messages*=. - Keep contact names, presence, subscriptions, avatars and resource capabilities separate for each connection, including completion and background chat alerts. - Keep unread activity and subscription prompts attached to their originating account when several accounts share a contact or room. - Scope service-discovery observations and pending room errors to their connection; capability retries retain the advertising account and node. - Keep named resources independently selectable, preserving resource case. - Reclaim retired discovery observations when storing new observations, without clearing other live accounts or globally verified capabilities. ** Extension compatibility - Restart Emacs disconnected before first using this version. Existing live global-symbol rosters and pending-room tables are not migrated by reloading Lisp files. - =jabber-jid-symbol=, the roster/display/bookmark name helpers and =jabber-avatar-set= accept a final optional connection argument. Pass it when reading or writing automatic roster metadata. Without it, these APIs use only supplied symbols or legacy accountless data, never a guessed account. - Presence hooks and title callbacks keep their existing arities. Their WHO argument is an account-scoped symbol; =jabber-jid-owner= returns its connection. Direct symbol-property reads on WHO remain supported. - =jabber-read-jid-completing= accepts the connection as its seventh argument. An explicitly selected empty account does not fall back to other rosters. - Activity entries now retain connection/JID pairs internally. Existing custom activity formatters and visibility predicates still receive JID strings. Legacy JID-only navigation refuses ambiguous owners instead of choosing one. Legacy JID widgets can carry their owner in the =:jabber-connection= property. * [0.14.0] #+date: 2026-09-05 ** Fixes - Restore broadcast presence after connection. A room-recovery check rejected presence without a recipient, leaving the client unavailable to the server: contacts appeared offline and incoming messages could require archive sync * [0.13.3] #+date: 2026-09-05 ** Added - Automatically preview shared links locally when URL expansion is enabled ** Fixes - Reconnect failed transports after wake and check keepalive responses for new and resumed sessions - Preserve Stream Management replay order, validate handled counts, and ignore stale transport input and lifecycle callbacks - Preserve room recovery state, encrypted messages, and local echoes across reconnects, including nickname and credential ownership - Propagate picomemo encryption errors instead of reporting success - Restore serialized picomemo stores after refilling prekeys - Fix compiler dependencies and check every library with isolated byte and native compilation, including regression tests for compiler failures - Cancel orphaned Stream Management timers and bind callbacks to their owning connection state - Retire stale Stream Management requests during TLS negotiation - Fix OMEMO random generation and shared-module linking on OpenBSD * [0.13.2] #+date: 2026-08-28 ** Added - Navigate previously sent chat input - Reset an individual OMEMO peer-device session from the trust buffer ** Fixes - Persist OMEMO heartbeat ratchets before sending, preventing key reuse after restart - Preserve OMEMO trust while rebuilding sessions and reject changed device identities - Clear OMEMO session state atomically and wipe temporary store secrets - Preserve exact OMEMO cryptographic bytes in SQLite - Harden STARTTLS negotiation against malformed, premature, and stale replies - Skip queued real-time text sends after their chat session has ended - Handle MUC author retractions * [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: #+date: 2025-03-09 ** 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.15.1/CONTRIBUTING.org000066400000000000000000000104001527111033600165230ustar00rootroot00000000000000#+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. * Compatibility testing Run the complete compatibility matrix from the host shell, before entering =nix develop=: #+begin_src sh make test-matrix # Override the installed executable (a single program, not shell arguments): make test-matrix THANOS_EMACS=/path/to/emacs # Keep a focused selector and deterministic single-worker debugging: make test-matrix TESTS=tests/jabber-test-time.el JOBS=1 make test-matrix-runner make test-matrix-public #+end_src The three required lanes are: 1. The exact Emacs version in =lisp/jabber.el='s =Package-Requires= header: currently *29.1*. The immutable NixOS 23.11 release input supplies that toolchain; a later 29.x patch release is not a substitute. This older closure is for isolated compatibility testing, not daily use. 2. The default =pkgs.emacs= from the project's pinned nixpkgs input. The runtime version is reported, rather than assuming a particular major. 3. *Thanos Emacs fork*. Thanos uses his own Emacs fork. This lane resolves =THANOS_EMACS= (default =emacs=) in the host PATH before Nix runs, then invokes that absolute executable inside the dependency/build environment. Other contributors can point it at their installed Emacs. It is never silently replaced with Nix's Emacs. Every lane runs =make check=: the ordinary isolated-file ERT suite followed by two combined-suite runs, with the native OMEMO module rebuilt in that lane. Each lane has its own source/build tree, dependency source copies, bytecode/native output, HOME, XDG directories and temporary test data. The fork uses the pinned default's module header (Emacs' stable module API), not its executable or Elisp bytecode. Existing =make test=, =make test-oneshot=, =make dev= and their =TESTS=/=JOBS= overrides remain available. Python 3 and Nix are required for the matrix. It attempts every lane even if another fails or is unavailable. Any missing runtime, version mismatch, nonzero exit or absent completion receipt fails the matrix. Python validates per-file and both combined ERT inventories/counts, successful summaries and fresh autoload/native build outputs independently of the selected Emacs. Receipts and worker logs remain available even after a successful matrix. The public regression target exercises real positive and ERT-failure controls, version-only zero-exit runtimes, missing combined/summary completion and tracked-suite manifest drift. It needs host Nix and the installed Emacs; the fast runner unit tests are also part of the pure Nix checks. Output prints runtime versions and per-lane log locations; the reported temporary evidence directory is retained for inspection and can be removed after debugging. Pure Nix checks cannot execute an arbitrary host binary. =nix flake check= includes =matrix-minimum= and =matrix-default=; the existing default/nox, per-file/combined and compiler checks remain. Use =make test-matrix= for all three required versions, including *Thanos Emacs fork*. Build inputs are explicitly listed in =admin/source-manifest.json=. Add new source/test fixtures to that list and stage new files before using Nix. Pure evaluation rejects tracked ordinary suites omitted from the manifest before filtering; this does not admit ignored or untracked private inputs. The Make wrapper uses a Git-aware flake reference, so ignored/private files are not copied into the Nix store; the manifest further restricts the build source. Never put secrets in tracked files or this manifest. * 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.15.1/Makefile000066400000000000000000000157011527111033600155540ustar00rootroot00000000000000.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-byte-comp lint-native-comp lint-compile-check \ clean clean-elc clean-module install uninstall check test test-oneshot test-debian \ release-check load native-check do-native-check lint-gate-check do-lint-gate-check \ 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-byte-comp do-lint-native-comp NIX := $(shell command -v nix 2>/dev/null) ENV_MAKE = $(MAKE) --no-print-directory ifeq ($(JABBER_ENV_WRAPPED)$(IN_NIX_SHELL),) ifneq ($(wildcard flake.nix),) ifneq ($(NIX),) ENV_MAKE = nix develop 'git+file://$(CURDIR)' --command env JABBER_ENV_WRAPPED=1 $(MAKE) --no-print-directory endif endif endif EMACS_CMD ?= emacs EMACS_OPTS ?= -Q --batch EMACSCLIENT ?= emacsclient JOBS ?= $(shell nproc 2>/dev/null || echo 4) TEST_RESULTS := .test-results # Ordinary ERT suites have one inventory, shared by both execution modes. # Keep TESTS overridable for focused runs. TESTS ?= $(sort $(wildcard tests/jabber-test-*.el)) LINT_FILES ?= $(wildcard admin/*.el lisp/*.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-native-check $(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 # CBC/store/RNG faults; API simulations do not certify native OS builds. native-check: @$(ENV_MAKE) do-native-check do-native-check: $(MAKE) -C src check compile: @$(ENV_MAKE) do-compile do-compile: autoload $(EMACS_CMD) $(EMACS_OPTS) -L . -L lisp \ --eval="(setq jabber-db-path nil print-length nil load-prefer-newer t byte-compile-error-on-warn t)" \ -f batch-byte-compile lisp/*.el lint-check-declare: @$(ENV_MAKE) do-lint-check-declare # Both declaration checks and their regression fixtures consume native exports. do-lint-check-declare: do-module @set -e; for file in $(LINT_FILES); do \ JABBER_LINT_MODE=declare JABBER_LINT_FILE="$$file" \ $(EMACS_CMD) $(EMACS_OPTS) -L admin -L lisp -l admin/check-lisp; \ done lint-checkdoc: @$(ENV_MAKE) do-lint-checkdoc do-lint-checkdoc: @set -e; for file in $(LINT_FILES); do \ case "$$file" in lisp/jabber-autoloads.el) continue;; esac; \ JABBER_LINT_MODE=checkdoc JABBER_LINT_FILE="$$file" \ $(EMACS_CMD) $(EMACS_OPTS) -L admin -L lisp -l admin/check-lisp; \ done lint-package-lint: @set -e; for file in lisp/*.el; do \ $(EMACS_CMD) $(EMACS_OPTS) -l admin/check-package-lint "$$file"; \ done 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 \ --eval="(setq jabber-db-path nil byte-compile-error-on-warn t)" \ -f batch-byte-compile admin/*.el tests/*.el lint-test-autoloads: @$(EMACS_CMD) $(EMACS_OPTS) --script admin/check-test-autoloads tests/*.el lint-byte-comp: @$(ENV_MAKE) do-lint-byte-comp do-lint-byte-comp: EMACS_CMD="$(EMACS_CMD)" EMACS_OPTS="$(EMACS_OPTS)" ./admin/check-compile byte lint-native-comp: @$(ENV_MAKE) do-lint-native-comp do-lint-native-comp: EMACS_CMD="$(EMACS_CMD)" EMACS_OPTS="$(EMACS_OPTS)" ./admin/check-compile native lint-compile-check: EMACS_CMD="$(EMACS_CMD)" EMACS_OPTS="$(EMACS_OPTS)" ./admin/test-compile-check lint-gate-check: @$(ENV_MAKE) do-lint-gate-check do-lint-gate-check: do-module EMACS_CMD="$(EMACS_CMD)" EMACS_OPTS="$(EMACS_OPTS)" \ $(EMACS_CMD) $(EMACS_OPTS) -l admin/test-gates -f ert-run-tests-batch-and-exit 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 do-lint-byte-comp do-lint-native-comp lint-compile-check do-lint-gate-check # Resolve Thanos' installed fork in the calling environment, never Nix's PATH. # Other contributors can supply their own installed executable. THANOS_EMACS ?= emacs .PHONY: test-matrix test-matrix-runner test-matrix-public test-matrix: @THANOS_EMACS="$(THANOS_EMACS)" MATRIX_TESTS="$(TESTS)" MATRIX_JOBS="$(JOBS)" \ python3 admin/test-matrix test-matrix-runner: @python3 admin/test-matrix-runner.py # Real public-entrypoint controls; needs host Nix and an installed Emacs. test-matrix-public: @python3 admin/test-matrix-public.py --emacs "$(THANOS_EMACS)" 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 @EMACS_CMD="$(EMACS_CMD)" EMACS_OPTS="$(EMACS_OPTS)" \ ./admin/run-test "$@" "$<" 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 @JABBER_TEST_RUNS=2 EMACS_CMD="$(EMACS_CMD)" EMACS_OPTS="$(EMACS_OPTS)" \ ./admin/run-test "$(TEST_RESULTS)/oneshot.stamp" $(TESTS) @$(EMACS_CMD) $(EMACS_OPTS) -l admin/test-summary "$(TEST_RESULTS)/oneshot.stamp" @if [ -z "$$JABBER_MATRIX_EVIDENCE" ]; then \ rm -f "$(TEST_RESULTS)/oneshot.stamp" "$(TEST_RESULTS)/oneshot.stamp.ert" "$(TEST_RESULTS)/oneshot.stamp.log"; fi do-test-summary: $(TEST_STAMPS) @$(EMACS_CMD) $(EMACS_OPTS) -l admin/test-summary $(TEST_STAMPS) @if [ -z "$$JABBER_MATRIX_EVIDENCE" ]; then rm -rf $(TEST_RESULTS); fi 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.15.1/README.org000066400000000000000000000071121527111033600155570ustar00rootroot00000000000000#+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 from the ELPA package directory: #+begin_src sh cd /path/to/elpa/jabber-VERSION 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=; if it exists but cannot be loaded, Jabber warns and continues without OMEMO. If the Emacs that loads the module cannot see the library directory used at build time (for example a Nix development shell, or an Emacs linked against a different C library), link Mbed TLS statically: #+begin_src sh make module MBED_STATIC=1 #+end_src This needs =libmbedcrypto.a= and leaves the C library as the module's only runtime dependency. The repository's Nix development shell sets it by default; pass =MBED_STATIC== to link dynamically there. * Installation =jabber.el= is available via [[https://elpa.nongnu.org/nongnu/jabber.html][NonGNU ELPA]]. That is the only supported install path. #+begin_src emacs-lisp (use-package jabber :ensure t :config (setq jabber-account-list `(("user@example.org" (:password . ,(auth-source-pass-get 'secret "xmpp/example.org"))))) (jabber-modeline-mode 1) :bind-keymap (("C-x C-j" . jabber-global-keymap)) :hook (kill-emacs . jabber-disconnect)) #+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 ** 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.15.1/admin/000077500000000000000000000000001527111033600152005ustar00rootroot00000000000000emacs-jabber-0.15.1/admin/check-compile000077500000000000000000000032141527111033600176310ustar00rootroot00000000000000#!/bin/sh # Compile each library in a fresh Emacs, with source-only package dependencies. set -eu root=$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd) mode=${1:?Expected byte or native} shift case "$mode" in byte|native) ;; *) exit 2 ;; esac work=$(mktemp -d) trap 'rm -rf "$work"' EXIT HUP INT TERM mkdir -p "$work/lisp" "$work/home" cp "$root"/lisp/*.el "$work/lisp/" # No generated autoloads, bytecode or native cache may conceal a missing require. rm -f "$work/lisp/jabber-autoloads.el" if [ "$#" -eq 0 ]; then set -- "$work"/lisp/*.el fi for file do name=$(basename -- "$file") if [ "$file" != "$work/lisp/$name" ]; then cp "$file" "$work/lisp/$name" fi rm -f "$work/output.elc" "$work/output.eln" printf '%s compile: %s\n' "$mode" "$name" status=0 HOME="$work/home" XDG_CACHE_HOME="$work/home/cache" \ XDG_CONFIG_HOME="$work/home/config" XDG_DATA_HOME="$work/home/data" \ XDG_STATE_HOME="$work/home/state" \ JABBER_COMPILE_MODE="$mode" JABBER_COMPILE_FILE="$work/lisp/$name" \ JABBER_COMPILE_OUTPUT="$work/output" \ ${EMACS_CMD:-emacs} ${EMACS_OPTS:--Q --batch} -L "$work/lisp" \ -l "$root/admin/compile-file" > "$work/compiler.log" 2>&1 || status=$? cat "$work/compiler.log" [ "$status" -eq 0 ] || exit "$status" # Macro expansion during dependency loading can report warnings directly. if LC_ALL=C grep -Eq '(^|: )(Warning|Error):' "$work/compiler.log"; then exit 1 fi case "$mode" in byte) artifact="$work/output.elc" ;; native) artifact="$work/output.eln" ;; esac test -s "$artifact" || { printf 'Compiler produced no artifact: %s\n' "$name" >&2; exit 1; } done emacs-jabber-0.15.1/admin/check-lisp000066400000000000000000000042521527111033600171500ustar00rootroot00000000000000;;; check-lisp --- Fail on documentation and declaration warnings -*- lexical-binding: t; -*- (require 'checkdoc) (require 'check-declare) (let ((file (or (getenv "JABBER_LINT_FILE") (error "Missing lint file")))) (pcase (getenv "JABBER_LINT_MODE") ("declare" ;; Malformed declarations warn during scanning without entering the ;; returned error list. Keep those diagnostics fatal too. (let ((warnings 0)) (advice-add 'check-declare-warn :before (lambda (&rest _) (setq warnings (1+ warnings)))) (when (or (check-declare-file file) (> warnings 0)) (error "Invalid declarations in %s" file))) ;; check-declare cannot recognize dynamic-module exports. The module's ;; FILEONLY declarations still require its file; verify the actual ;; definitions in this disposable Emacs, without loading jabber itself. (let ((loaded nil) (count 0)) (dolist (declaration (check-declare-scan file)) (let ((library (car declaration)) (function (intern (cadr declaration)))) (when (equal (file-name-base library) "jabber-omemo-core") (unless loaded (load (expand-file-name library) nil t t) (setq loaded t)) (unless (and (fboundp function) (module-function-p (symbol-function function)) (equal (file-truename (symbol-file function 'defun)) (file-truename library))) (error "Missing native export %s in %s" function library)) (setq count (1+ count))))) (when loaded (message "Verified %d native declarations in %s" count file)))) ("checkdoc" ;; checkdoc-file emits warnings but neither returns nor signals failure. ;; Observe its diagnostic boundary without replacing diagnostic delivery. (let ((warnings 0)) (advice-add 'checkdoc-error :before (lambda (&rest _) (setq warnings (1+ warnings)))) (checkdoc-file file) (unless (zerop warnings) (error "%s: %d checkdoc warnings" file warnings)))) (_ (error "Expected declare or checkdoc mode")))) emacs-jabber-0.15.1/admin/check-package-lint000066400000000000000000000021361527111033600205370ustar00rootroot00000000000000;;; check-package-lint --- Installed dependency catalog -*- lexical-binding: t; -*- (require 'package) (require 'cl-lib) (package-initialize) (require 'package-lint) ;; Nix trivialBuild libraries are loadable without package.el registration. ;; Read their real source headers rather than assuming an archive or version. (dolist (name '(fsm keymap-popup)) (let* ((library (locate-library (concat (symbol-name name) ".el") t)) (descriptor (with-temp-buffer (unless library (error "Missing dependency source: %s" name)) (insert-file-contents library) (package-buffer-info)))) (unless (eq name (package-desc-name descriptor)) (error "Wrong dependency source: %s" library)) (setf (alist-get name package-alist) (list descriptor)))) (setq package-lint-main-file "lisp/jabber.el" package-lint-batch-fail-on-warnings t) ;; package-lint initializes again; preserve the verified installed catalog. (kill-emacs (if (cl-letf (((symbol-function 'package-initialize) #'ignore)) (package-lint-batch-and-exit-1 command-line-args-left)) 0 1)) emacs-jabber-0.15.1/admin/check-test-autoloads000077500000000000000000000056621527111033600211620ustar00rootroot00000000000000;;; 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.15.1/admin/compile-file000066400000000000000000000025361527111033600174760ustar00rootroot00000000000000;;; compile-file --- Fatal-warning compiler entry point -*- lexical-binding: t; -*- ;; Run only via check-compile, in a fresh batch Emacs for each source file. (require 'bytecomp) (require 'comp) (setq jabber-db-path nil native-comp-jit-compilation nil native-comp-deferred-compilation nil byte-compile-error-on-warn t byte-compile-warnings t) (let* ((file (getenv "JABBER_COMPILE_FILE")) (output (getenv "JABBER_COMPILE_OUTPUT")) (byte-compile-dest-file-function (lambda (_) (concat output ".elc")))) ;; Also catch warnings emitted through `display-warning', not just bytecomp. (advice-add 'display-warning :before (lambda (_type message &rest _) (error "%s" message))) (if (equal (getenv "JABBER_COMPILE_MODE") "byte") (unless (byte-compile-file file) (error "Byte compilation failed: %s" file)) (unless (and (fboundp 'native-comp-available-p) (native-comp-available-p)) (error "Native compilation is required for this gate")) (unless (native-compile file (concat output ".eln")) (error "Native compilation failed: %s" file))) (unless (file-regular-p (concat output (if (equal (getenv "JABBER_COMPILE_MODE") "byte") ".elc" ".eln"))) (error "Compiler produced no artifact: %s" file))) emacs-jabber-0.15.1/admin/jabber-reload.el000066400000000000000000000400131527111033600202110ustar00rootroot00000000000000;;; 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--maps (form) "Return map variables declared at load time in FORM." (if-let* ((symbol (jabber-reload--map-symbol form))) (list symbol) (mapcan #'jabber-reload--maps (jabber-reload--load-time-children form)))) (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 (mapcan #'jabber-reload--maps 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--char-table-extra-slots (table) "Return the retained extra slot values of TABLE." (let ((index 0) values) ;; The purpose symbol's property need not still describe this table's ;; allocation. Ask the actual table for its slots instead. (condition-case nil (while t (push (char-table-extra-slot table index) values) (setq index (1+ index))) (args-out-of-range nil)) (nreverse values))) (defun jabber-reload--snapshot-map-cells (maps) "Record mutable cells reachable from MAPS without copying their identities." (let ((seen (make-hash-table :test #'eq)) (pending (mapcar #'symbol-value (seq-filter #'boundp maps))) cells) (while pending (let ((object (pop pending))) (unless (gethash object seen) (puthash object t seen) (cond ((consp object) (push (list object (car object) (cdr object)) cells) (when (eq (car object) 'menu-item) ;; Follow only the actual callable edge, not function cells of ;; arbitrary symbols in a closure's body or captured data. (let ((filter (plist-get (nthcdr 3 object) :filter)) aliases) (while (and (symbolp filter) (fboundp filter) (not (memq filter aliases))) (push filter aliases) (push (list filter (symbol-function filter)) cells) (setq filter (symbol-function filter))) (push filter pending))) (push (car object) pending) (push (cdr object) pending)) ((stringp object) (push (list object (copy-sequence object)) cells) (let ((position 0)) (while (< position (length object)) (setq pending (append (text-properties-at position object) pending) position (next-property-change position object (length object)))))) ((vectorp object) (push (list object (copy-sequence object)) cells) (setq pending (append object pending))) ((char-table-p object) (let ((ranges (copy-sequence object)) (default (char-table-range object nil)) (parent (char-table-parent object)) (extras (jabber-reload--char-table-extra-slots object))) ;; map-char-table enumerates effective values. Remove metadata ;; only from the private copy to visit and replay stored ranges, ;; never materializing inherited/default bindings in a live map. (set-char-table-parent ranges nil) (set-char-table-range ranges nil nil) (push (list object ranges default parent extras) cells) (push default pending) (push parent pending) (setq pending (append extras pending)) (map-char-table (lambda (_key value) (push value pending)) ranges))) ((hash-table-p object) (push (list object (copy-hash-table object)) cells) (maphash (lambda (key value) (push key pending) (push value pending)) object)) ((or (byte-code-function-p object) (eq (type-of object) 'interpreted-function)) ;; Slot 2 holds bytecode constants or the lexical environment. ;; Emacs 29's list closures are covered by the cons case above. ;; Never invoke a menu filter to discover its captured maps. (push (aref object 2) pending)) ((and (symbolp object) (fboundp object) (keymapp object)) (push (list object (symbol-function object)) cells) (push (symbol-function object) pending)))))) cells)) (defun jabber-reload--restore-map-cells (cells) "Restore recorded map CELLS in place, including shared prefix maps." ;; A failed load can reverse a parent edge legally. Detach all captured ;; tables first so restoration order cannot introduce a temporary cycle. (dolist (entry cells) (when (char-table-p (car entry)) (set-char-table-parent (car entry) nil))) (dolist (entry cells) (let ((object (car entry))) (cond ((symbolp object) (fset object (cadr entry))) ((consp object) (setcar object (cadr entry)) (setcdr object (caddr entry))) ((stringp object) (let ((saved (cadr entry))) (unless (equal-including-properties object saved) ;; Some runtimes allow only ASCII-to-ASCII multibyte writes, ;; even when a non-ASCII character would be stored unchanged. (cl-loop for character across saved for index from 0 unless (= (aref object index) character) do (aset object index character)) (set-text-properties 0 (length object) nil object) (let ((position 0)) (while (< position (length saved)) (let ((end (next-property-change position saved (length saved)))) (set-text-properties position end (text-properties-at position saved) object) (setq position end))))))) ((vectorp object) (cl-loop for value across (cadr entry) for index from 0 do (aset object index value))) ((char-table-p object) (set-char-table-range object nil nil) (set-char-table-range object t nil) (map-char-table (lambda (key value) (set-char-table-range object key value)) (cadr entry)) (set-char-table-range object nil (nth 2 entry)) (set-char-table-parent object (nth 3 entry)) (cl-loop for value in (nth 4 entry) for index from 0 do (set-char-table-extra-slot object index value)))))) ;; Rehash only after retained keys' mutable cells have been restored. A key ;; can itself be an earlier-seen map whose rollback changes its equal hash. (dolist (entry cells) (when (hash-table-p (car entry)) (let ((object (car entry))) (clrhash object) (maphash (lambda (key value) (puthash key value object)) (cadr entry)))))) (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. Preserve existing keymaps and user bindings. Restore Jabber functions and map contents 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)) (cells (jabber-reload--snapshot-map-cells maps)) (buffers (jabber-reload--capture-buffer-maps maps)) (old-binding (lookup-key ctl-x-map (kbd "C-j"))) succeeded) (unwind-protect (progn (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-map-cells cells) (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.15.1/admin/run-test000077500000000000000000000016611527111033600167130ustar00rootroot00000000000000#!/bin/sh # One process per suite; keep both diagnostics and process/completion evidence. set -eu stamp=${1:?Expected result path} shift [ "$#" -gt 0 ] || { printf 'No test files selected\n' >&2; exit 1; } mkdir -p "$(dirname -- "$stamp")" rm -f "$stamp" "$stamp.ert" work=$(mktemp -d) trap 'rm -rf "$work"' EXIT HUP INT TERM mkdir -p "$work/home" "$work/tmp" status=0 HOME="$work/home" XDG_CACHE_HOME="$work/home/cache" \ XDG_CONFIG_HOME="$work/home/config" XDG_DATA_HOME="$work/home/data" \ XDG_STATE_HOME="$work/home/state" TMPDIR="$work/tmp" \ JABBER_TEST_RECEIPT="$stamp.ert" \ ${EMACS_CMD:-emacs} ${EMACS_OPTS:--Q --batch} -L admin -L lisp -L tests \ --eval='(setq jabber-db-path nil load-prefer-newer t)' \ -l admin/test-file "$@" > "$stamp.log" 2>&1 || status=$? printf '%s\n' "$status" > "$stamp" printf 'Finished %s (process exit %s)\n' "$stamp" "$status" # Return success so Make settles every selected worker before aggregation. emacs-jabber-0.15.1/admin/source-manifest.json000066400000000000000000000133761527111033600212110ustar00rootroot00000000000000[ "Makefile", "admin/check-compile", "admin/check-lisp", "admin/check-package-lint", "admin/check-test-autoloads", "admin/compile-file", "admin/jabber-reload.el", "admin/run-test", "admin/source-manifest.json", "admin/test-compile-check", "admin/test-debian", "admin/test-file", "admin/test-gates", "admin/test-matrix", "admin/test-matrix-public.py", "admin/test-matrix-runner.py", "admin/test-summary", "lisp/jabber-activity.el", "lisp/jabber-ahc-presence.el", "lisp/jabber-ahc.el", "lisp/jabber-alert.el", "lisp/jabber-autoaway.el", "lisp/jabber-avatar.el", "lisp/jabber-blocking.el", "lisp/jabber-bookmarks.el", "lisp/jabber-browse.el", "lisp/jabber-buffer-registry.el", "lisp/jabber-carbons.el", "lisp/jabber-chat-commands.el", "lisp/jabber-chat.el", "lisp/jabber-chatbuffer.el", "lisp/jabber-chatstates.el", "lisp/jabber-compose.el", "lisp/jabber-conn.el", "lisp/jabber-console.el", "lisp/jabber-core.el", "lisp/jabber-csi.el", "lisp/jabber-db.el", "lisp/jabber-disco-menu.el", "lisp/jabber-disco.el", "lisp/jabber-eme.el", "lisp/jabber-hints.el", "lisp/jabber-httpupload.el", "lisp/jabber-image.el", "lisp/jabber-info.el", "lisp/jabber-input.el", "lisp/jabber-iq.el", "lisp/jabber-jid.el", "lisp/jabber-keepalive.el", "lisp/jabber-keymap.el", "lisp/jabber-lifecycle.el", "lisp/jabber-link-preview.el", "lisp/jabber-mam.el", "lisp/jabber-message-correct.el", "lisp/jabber-message-reply.el", "lisp/jabber-message-thread-protocol.el", "lisp/jabber-message-thread.el", "lisp/jabber-modeline.el", "lisp/jabber-moderation.el", "lisp/jabber-muc-menu.el", "lisp/jabber-muc-nick-completion.el", "lisp/jabber-muc-protocol.el", "lisp/jabber-muc-state.el", "lisp/jabber-muc.el", "lisp/jabber-notifications.el", "lisp/jabber-omemo-store.el", "lisp/jabber-omemo-trust.el", "lisp/jabber-omemo.el", "lisp/jabber-openpgp-legacy.el", "lisp/jabber-openpgp.el", "lisp/jabber-ping.el", "lisp/jabber-presence-display.el", "lisp/jabber-presence-events.el", "lisp/jabber-presence.el", "lisp/jabber-private.el", "lisp/jabber-pubsub.el", "lisp/jabber-reactions.el", "lisp/jabber-receipts.el", "lisp/jabber-register.el", "lisp/jabber-roster-menu.el", "lisp/jabber-roster.el", "lisp/jabber-rtt.el", "lisp/jabber-sasl.el", "lisp/jabber-search.el", "lisp/jabber-sm-runtime.el", "lisp/jabber-sm.el", "lisp/jabber-srv.el", "lisp/jabber-stanza.el", "lisp/jabber-state.el", "lisp/jabber-styling.el", "lisp/jabber-subscription.el", "lisp/jabber-time.el", "lisp/jabber-truncate.el", "lisp/jabber-uri.el", "lisp/jabber-util.el", "lisp/jabber-vcard-avatars.el", "lisp/jabber-vcard.el", "lisp/jabber-version.el", "lisp/jabber-widget.el", "lisp/jabber-xdata-form.el", "lisp/jabber-xdata.el", "lisp/jabber-xml.el", "lisp/jabber.el", "src/Makefile", "src/jabber-omemo-core.c", "src/picomemo/LICENSE", "src/picomemo/README", "src/picomemo/driver.h", "src/picomemo/hacl.c", "src/picomemo/mbedtls.c", "src/picomemo/omemo.c", "src/picomemo/omemo.h", "tests/fixtures/archive-schema-v11.eld", "tests/jabber-archive-test-helpers.el", "tests/jabber-disco-test-helpers.el", "tests/jabber-test-action-storage.el", "tests/jabber-test-activity-owners.el", "tests/jabber-test-activity.el", "tests/jabber-test-ahc.el", "tests/jabber-test-alert.el", "tests/jabber-test-archive-identity.el", "tests/jabber-test-archive-migration.el", "tests/jabber-test-archive-persistence.el", "tests/jabber-test-archive-recovery.el", "tests/jabber-test-archive-repair.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-console.el", "tests/jabber-test-contact-owners.el", "tests/jabber-test-csi.el", "tests/jabber-test-db.el", "tests/jabber-test-disco-owner.el", "tests/jabber-test-disco.el", "tests/jabber-test-history-cost.el", "tests/jabber-test-httpupload.el", "tests/jabber-test-image.el", "tests/jabber-test-keepalive.el", "tests/jabber-test-link-preview.el", "tests/jabber-test-mam-room-identity.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-affiliations.el", "tests/jabber-test-muc.el", "tests/jabber-test-notifications.el", "tests/jabber-test-omemo-admission.el", "tests/jabber-test-omemo-message.el", "tests/jabber-test-omemo-module.el", "tests/jabber-test-omemo-own-list.el", "tests/jabber-test-omemo-protocol.el", "tests/jabber-test-omemo-store.el", "tests/jabber-test-omemo-trust.el", "tests/jabber-test-openpgp-legacy.el", "tests/jabber-test-openpgp.el", "tests/jabber-test-presence.el", "tests/jabber-test-pubsub.el", "tests/jabber-test-reactions.el", "tests/jabber-test-receipts.el", "tests/jabber-test-reload.el", "tests/jabber-test-reply-protocol.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-vcard-avatars.el", "tests/jabber-test-widgetless.el", "tests/jabber-test-xdata.el", "tests/jabber-test-xml.el", "tests/jabberd.el", "tests/load-all.el", "tests/nick-change-fail.el", "tests/omemo-c-test.c", "tests/omemo-random-test.c", "tests/parse-next-stanza.el", "tests/skip-tag-forward.el" ] emacs-jabber-0.15.1/admin/test-compile-check000077500000000000000000000060341527111033600206110ustar00rootroot00000000000000#!/bin/sh # Exercise both real compilers and propagation of a failed Emacs process. set -eu root=$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd) work=$(mktemp -d) trap 'rm -rf "$work"' EXIT HUP INT TERM printf '%s\n' ';;; good.el -*- lexical-binding: t; -*-' \ '(require (quote jabber-xml))' \ '(defun good () "Read a stanza tag." (jabber-xml-node-name (quote (message nil))))' > "$work/good.el" printf '%s\n' ';;; warning.el -*- lexical-binding: t; -*-' \ '(defun warning () "Return an unbound value." compile-check-unbound)' > "$work/warning.el" printf '%s\n' ';;; broken.el -*- lexical-binding: t; -*-' \ '(eval-when-compile (error "Compiler fixture failure"))' > "$work/broken.el" printf '%s\n' ';;; unknown.el -*- lexical-binding: t; -*-' \ '(defun unknown () "Call a missing function." (compile-check-unknown))' > "$work/unknown.el" printf '%s\n' ';;; warning-api.el -*- lexical-binding: t; -*-' \ '(eval-when-compile (display-warning (quote compiler) "Compiler warning API fixture"))' > "$work/warning-api.el" printf '%s\n' ';;; diagnostic.el -*- lexical-binding: t; -*-' \ '(eval-when-compile (message "Warning: Compiler diagnostic fixture"))' > "$work/diagnostic.el" for mode in byte native; do "$root/admin/check-compile" "$mode" "$work/good.el" for file in warning unknown warning-api diagnostic broken; do if "$root/admin/check-compile" "$mode" "$work/$file.el" > "$work/$mode-$file.log" 2>&1; then printf 'FAIL: %s compiler accepted %s\n' "$mode" "$file" >&2 exit 1 fi case "$file" in diagnostic) grep -q 'Compiler diagnostic fixture' "$work/$mode-$file.log" ;; warning-api) grep -q 'Compiler warning API fixture' "$work/$mode-$file.log" ;; unknown) grep -q 'compile-check-unknown' "$work/$mode-$file.log" ;; warning) grep -q 'compile-check-unbound' "$work/$mode-$file.log" ;; broken) grep -q 'Compiler fixture failure' "$work/$mode-$file.log" ;; esac done if EMACS_CMD=false "$root/admin/check-compile" "$mode" "$work/good.el"; then printf 'FAIL: %s compiler process failure was ignored\n' "$mode" >&2 exit 1 fi if EMACS_CMD=true "$root/admin/check-compile" "$mode" "$work/good.el" > "$work/no-artifact.log" 2>&1; then printf 'FAIL: %s compiler produced no artifact but passed\n' "$mode" >&2 exit 1 fi grep -q 'Compiler produced no artifact' "$work/no-artifact.log" printf 'PASS: %s artifact, missing function, free variable, warning API, compiler error, process failure\n' "$mode" done printf '%s\n' '(require (quote comp))' \ '(fset (quote native-comp-available-p) (lambda () nil))' > "$work/no-native.el" if EMACS_OPTS="${EMACS_OPTS:--Q --batch} -l $work/no-native.el" \ "$root/admin/check-compile" native "$work/good.el" > "$work/no-native.log" 2>&1; then printf 'FAIL: unsupported native compiler was accepted\n' >&2 exit 1 fi grep -q 'Native compilation is required' "$work/no-native.log" printf 'PASS: unsupported native compiler fails explicitly\n' emacs-jabber-0.15.1/admin/test-debian000077500000000000000000000031631527111033600173300ustar00rootroot00000000000000#!/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.15.1/admin/test-file000066400000000000000000000044131527111033600170210ustar00rootroot00000000000000;;; test-file --- Run ERT and publish explicit completion statistics -*- lexical-binding: t; -*- (require 'ert) (require 'cl-lib) (require 'json) (let ((files command-line-args-left) (runs (or (getenv "JABBER_TEST_RUNS") "1")) (total 0) (expected 0) (unexpected 0) (skipped 0) (receipts nil)) (setq command-line-args-left nil) (unless (member runs '("1" "2")) (error "Expected one or two ERT runs")) ;; Match Debian's combined test bootstrap, while per-file runs stay isolated. (when (equal runs "2") (require 'jabber)) (unless files (error "No test files selected")) (dolist (file files) (load (expand-file-name file) nil t)) ;; Nothing is published until all requested runs actually return. (dotimes (_ (string-to-number runs)) (let ((stats (ert-run-tests-batch t))) (unless (and (> (ert-stats-total stats) 0) (= (ert-stats-total stats) (ert-stats-completed stats))) (error "Incomplete or empty ERT run")) (cl-incf total (ert-stats-total stats)) (cl-incf expected (ert-stats-completed-expected stats)) (cl-incf unexpected (ert-stats-completed-unexpected stats)) (cl-incf skipped (ert-stats-skipped stats)) (push `((tests . ,(vconcat (mapcar (lambda (test) (symbol-name (ert-test-name test))) (append (ert--stats-tests stats) nil)))) (total . ,(ert-stats-total stats)) (completed . ,(ert-stats-completed stats)) (expected . ,(ert-stats-completed-expected stats)) (unexpected . ,(ert-stats-completed-unexpected stats)) (skipped . ,(ert-stats-skipped stats))) receipts))) ;; Matrix consumers validate this outside the selected Emacs executable. (when (getenv "JABBER_MATRIX_EVIDENCE") (with-temp-file (concat (getenv "JABBER_TEST_RECEIPT") ".json") (insert (json-encode `((files . ,(vconcat files)) (runs . ,(vconcat (nreverse receipts)))))))) (with-temp-file (or (getenv "JABBER_TEST_RECEIPT") (error "Missing ERT receipt path")) (prin1 (list 'complete total expected unexpected skipped) (current-buffer)) (terpri (current-buffer))) (kill-emacs (if (zerop unexpected) 0 1))) emacs-jabber-0.15.1/admin/test-gates000066400000000000000000000336551527111033600172170ustar00rootroot00000000000000;;; test-gates --- Exercise real Make gates with disposable faults -*- lexical-binding: t; -*- (require 'ert) (require 'cl-lib) (defconst jabber-gate-root (file-name-directory (directory-file-name (file-name-directory (or load-file-name buffer-file-name))))) (defun jabber-gate-write (file text) "Write fixture TEXT to FILE in the disposable checkout." (with-temp-file file (insert text))) (defmacro jabber-gate-with-checkout (&rest body) "Run BODY in a disposable Make checkout without building the package." (declare (indent 0) (debug t)) `(let* ((work (make-temp-file "jabber-gates-" t)) (default-directory (file-name-as-directory work)) (process-environment (copy-sequence process-environment))) (unwind-protect (progn (setenv "MAKEFLAGS" nil) (setenv "MFLAGS" nil) (copy-file (expand-file-name "Makefile" jabber-gate-root) "Makefile") (copy-directory (expand-file-name "admin" jabber-gate-root) "admin") (make-directory "lisp") (make-directory "tests") ,@body) (delete-directory work t)))) (defun jabber-gate-make (&rest arguments) "Run Make with ARGUMENTS and return its exit code and full diagnostics." (with-temp-buffer (let ((status (apply #'call-process "make" nil t nil "--no-print-directory" "JABBER_ENV_WRAPPED=1" (concat "EMACS_CMD=" (or (getenv "EMACS_CMD") (expand-file-name invocation-name invocation-directory))) (concat "EMACS_OPTS=" (or (getenv "EMACS_OPTS") "-Q --batch")) arguments))) (cons status (buffer-string))))) (defun jabber-gate-read (file) "Read FILE's full diagnostic text." (with-temp-buffer (insert-file-contents file) (buffer-string))) (ert-deftest jabber-gate-lint-warning-and-process-failure () (jabber-gate-with-checkout ;; These Lisp-only fixtures deliberately bypass the production native build. (jabber-gate-write "lisp/good.el" ";;; good.el --- A fixture -*- lexical-binding: t; -*-\n;;; Commentary:\n;; Check lint.\n;;; Code:\n(defun good () \"Return nil.\" nil)\n(provide 'good)\n;;; good.el ends here\n") (jabber-gate-write "lisp/doc.el" "(defun fixture (arg) \"bad\" arg)\n") (jabber-gate-write "lisp/decl.el" "(declare-function fixture \"missing-fixture-library\")\n") (jabber-gate-write "lisp/valid-decl.el" "(declare-function good \"good\" ())\n") (dolist (case '(("checkdoc" "doc.el" "checkdoc warnings") ("declare" "decl.el" "Invalid declarations"))) (let ((target (concat "do-lint-check" (if (equal (car case) "declare") "-declare" "doc")))) (let ((result (jabber-gate-make target "-o" "do-module" (if (equal (car case) "declare") "LINT_FILES=lisp/good.el lisp/valid-decl.el" "LINT_FILES=lisp/good.el")))) (ert-info ((cdr result)) (should (zerop (car result))))) (let ((result (jabber-gate-make target "-o" "do-module" (concat "LINT_FILES=lisp/" (cadr case) " lisp/good.el")))) (should-not (zerop (car result))) (should (string-match-p (nth 2 case) (cdr result)))))) ;; Successful last file must not launder a failed first child process. (jabber-gate-write "fail-first" "#!/bin/sh\ncase \"$JABBER_LINT_FILE\" in *first*) exit 7;; *) exit 0;; esac\n") (set-file-modes "fail-first" #o755) (dolist (target '("do-lint-checkdoc" "do-lint-check-declare")) (should-not (zerop (car (jabber-gate-make target "-o" "do-module" "EMACS_CMD=./fail-first" "LINT_FILES=first last"))))))) (ert-deftest jabber-gate-native-declarations () ;; Use the real compiled module, never Lisp stand-ins for native exports. ;; Bypass the build only in these fixtures: they supply or omit that module. (let* ((name (concat "jabber-omemo-core" module-file-suffix)) (module (expand-file-name (concat "lisp/" name) jabber-gate-root)) (valid "(declare-function jabber-omemo--heartbeat \"jabber-omemo-core\" t t)\n")) (should (file-exists-p module)) (jabber-gate-with-checkout (copy-file module (concat "lisp/" name)) (jabber-gate-write "lisp/native.el" valid) (let ((result (jabber-gate-make "do-lint-check-declare" "-o" "do-module" "LINT_FILES=lisp/native.el"))) (ert-info ((cdr result)) (should (zerop (car result))))) (dolist (declaration '("(declare-function jabber-omemo--heartbeat-typo \"jabber-omemo-core\" t t)\n" "(declare-function car \"jabber-omemo-core\" t t)\n")) (jabber-gate-write "lisp/native.el" declaration) (let ((result (jabber-gate-make "do-lint-check-declare" "-o" "do-module" "LINT_FILES=lisp/native.el"))) (should-not (zerop (car result))) (should (string-match-p "Missing native export" (cdr result))))) ;; The native exception must not hide ordinary or malformed declarations ;; in the same file, even when their library exists. (jabber-gate-write "lisp/ordinary.el" "(defun ordinary () nil)\n") (dolist (declaration '("(declare-function absent \"ordinary\" ())\n" "(declare-function ordinary 42 ())\n")) (jabber-gate-write "lisp/native.el" (concat valid declaration)) (let ((result (jabber-gate-make "do-lint-check-declare" "-o" "do-module" "LINT_FILES=lisp/native.el"))) (should-not (zerop (car result))) (should (string-match-p "Invalid declarations" (cdr result))))) ;; No module is an incomplete native check, never a silent pass. (jabber-gate-write "lisp/native.el" valid) (delete-file (concat "lisp/" name)) (let ((result (jabber-gate-make "do-lint-check-declare" "-o" "do-module" "LINT_FILES=lisp/native.el"))) (should-not (zerop (car result))) (should (string-match-p "file not found" (cdr result))))))) (ert-deftest jabber-gate-native-build-prerequisites () ;; Test the real Make graph separately from native-export fixture semantics. (jabber-gate-with-checkout (make-directory "src") (jabber-gate-write "src/Makefile" "all:\n\t@sleep 0.2; printf ready > ../module-state\n") (jabber-gate-write "consumer" "#!/bin/sh\n[ \"$(cat module-state 2>/dev/null)\" = ready ] || exit 9\nprintf 'lint-consumer-ran\\n'\n") (set-file-modes "consumer" #o755) (dolist (targets '(("-j2" "do-module" "do-lint-check-declare" "do-lint-gate-check") ("lint-check-declare") ("lint-gate-check"))) ;; Both a clean build and a stale artifact must be settled before lint. (dolist (state '(nil "stale")) (if state (jabber-gate-write "module-state" state) (when (file-exists-p "module-state") (delete-file "module-state"))) (let ((result (apply #'jabber-gate-make "EMACS_CMD=./consumer" "LINT_FILES=lisp/native.el" targets))) (ert-info ((cdr result)) (should (zerop (car result)))) (should (string-match-p "lint-consumer-ran" (cdr result))))) ;; Even a previously built artifact cannot hide a failed refresh. (jabber-gate-write "src/Makefile" "all:\n\t@printf 'native-build-failed\\n'; exit 7\n") (let ((result (apply #'jabber-gate-make "EMACS_CMD=./consumer" "LINT_FILES=lisp/native.el" targets))) (should-not (zerop (car result))) (should (string-match-p "native-build-failed" (cdr result))) (should-not (string-match-p "^lint-consumer-ran" (cdr result)))) (jabber-gate-write "src/Makefile" "all:\n\t@sleep 0.2; printf ready > ../module-state\n")))) (ert-deftest jabber-gate-ert-completion-counts-and-logs () (jabber-gate-with-checkout (jabber-gate-write "tests/jabber-test-good.el" "(ert-deftest good () (should t))\n") (jabber-gate-write "tests/jabber-test-mixed.el" "(ert-deftest good () (should t))\n(ert-deftest bad () (should nil))\n") (jabber-gate-write "tests/jabber-test-early.el" "(kill-emacs 0)\n") (jabber-gate-write "tests/jabber-test-broken.el" "(error \"GATE-LOAD-FAILURE\")\n") (jabber-gate-write "tests/jabber-test-empty.el" ";; No ERT tests.\n") (jabber-gate-write "tests/jabber-test-skipped.el" "(ert-deftest skipped () (ert-skip \"fixture\"))\n") (let ((result (jabber-gate-make "do-test-summary" "TESTS=tests/jabber-test-good.el" "EMACS_OPTS=-Q --batch -L lisp"))) (should (zerop (car result))) (should (string-match-p "1 completed tests: 1 expected, 0 unexpected, 0 skipped; 0 failed files" (cdr result))) (should-not (file-exists-p ".test-results"))) ;; Parallel mixed outcomes must finish every worker and preserve every log. (let ((result (jabber-gate-make "-j3" "do-test-summary" "TESTS=tests/jabber-test-mixed.el tests/jabber-test-early.el tests/jabber-test-broken.el tests/jabber-test-empty.el tests/jabber-test-skipped.el"))) (should-not (zerop (car result))) (should (string-match-p "3 completed tests: 1 expected, 1 unexpected, 1 skipped; 4 failed files" (cdr result))) (should (string-match-p "GATE-LOAD-FAILURE" (jabber-gate-read ".test-results/jabber-test-broken.stamp.log"))) (should (string-match-p "ert-test-failed" (jabber-gate-read ".test-results/jabber-test-mixed.stamp.log"))) (should-not (file-exists-p ".test-results/jabber-test-early.stamp.ert"))) (should-not (zerop (car (jabber-gate-make "do-test-summary" "TESTS=")))))) (ert-deftest jabber-gate-oneshot-requires-both-completions () (jabber-gate-with-checkout ;; Only the suite runner is under test, not the package bootstrap here. (jabber-gate-write "lisp/jabber.el" "(provide 'jabber)\n") (jabber-gate-write "tests/jabber-test-good.el" "(ert-deftest good () (should t))\n") (let ((result (jabber-gate-make "do-test-oneshot" "-o" "autoload" "-o" "do-module" "TESTS=tests/jabber-test-good.el"))) (should (zerop (car result))) (should (string-match-p "2 completed tests: 2 expected" (cdr result)))) (jabber-gate-write "tests/jabber-test-early.el" "(kill-emacs 0)\n") (should-not (zerop (car (jabber-gate-make "do-test-oneshot" "-o" "autoload" "-o" "do-module" "TESTS=tests/jabber-test-early.el")))) (jabber-gate-write "tests/jabber-test-second.el" "(defvar fixture-count 0)\n(ert-deftest second () (when (= (cl-incf fixture-count) 2) (kill-emacs 0)))\n") (should-not (zerop (car (jabber-gate-make "do-test-oneshot" "-o" "autoload" "-o" "do-module" "TESTS=tests/jabber-test-second.el")))) (should-not (file-exists-p ".test-results/oneshot.stamp.ert")))) (ert-deftest jabber-gate-ert-rejects-invalid-receipts () (jabber-gate-with-checkout (make-directory ".test-results") (jabber-gate-write "tests/jabber-test-good.el" "(ert-deftest good () (should t))\n") ;; Existing stamps avoid rerunning the fixture, exercising the aggregator. (jabber-gate-write ".test-results/jabber-test-good.stamp" "0\n") (dolist (receipt '("" "(complete 0 0 0 0)" "(complete 2 1 0 0)" "(complete 1 -1 2 0)" "(complete 1 1 0 0) junk" "(complete 1 1 0 0 . invalid)")) (jabber-gate-write ".test-results/jabber-test-good.stamp.ert" receipt) (should-not (zerop (car (jabber-gate-make "do-test-summary" "TESTS=tests/jabber-test-good.el"))))) (jabber-gate-write ".test-results/jabber-test-good.stamp.ert" "(complete 1 1 0 0)") (jabber-gate-write ".test-results/jabber-test-good.stamp" "7\n") (should-not (zerop (car (jabber-gate-make "do-test-summary" "TESTS=tests/jabber-test-good.el")))))) (ert-deftest jabber-gate-module-nix-dispatch () (jabber-gate-with-checkout (make-directory "src") (jabber-gate-write "src/Makefile" "all:\n\t@printf 'native-module-dispatch\\n'\n") (make-directory "bin") (jabber-gate-write "bin/nix" "#!/bin/sh\nprintf 'nix-dispatch\\n'\n") (set-file-modes "bin/nix" #o755) (setenv "PATH" (concat (expand-file-name "bin") path-separator (getenv "PATH"))) (setenv "IN_NIX_SHELL" nil) (let ((result (jabber-gate-make "module" "JABBER_ENV_WRAPPED="))) (should (zerop (car result))) (should (string-match-p "native-module-dispatch" (cdr result))) (should-not (string-match-p "nix-dispatch" (cdr result)))) (jabber-gate-write "flake.nix" "{}\n") (should (string-match-p "nix-dispatch" (cdr (jabber-gate-make "module" "JABBER_ENV_WRAPPED=")))) (should (string-match-p "native-module-dispatch" (cdr (jabber-gate-make "module" "JABBER_ENV_WRAPPED=" "IN_NIX_SHELL=impure")))))) (ert-deftest jabber-gate-inventory-and-native-failure () (jabber-gate-with-checkout (jabber-gate-write "tests/jabber-test-new.el" "(ert-deftest new () (should t))\n") (jabber-gate-write "tests/helper.el" "(error \"Not an ordinary suite\")\n") (let ((result (jabber-gate-make "do-test-summary"))) (should (zerop (car result))) (should (string-match-p "1 completed tests" (cdr result)))) (make-directory "src") (jabber-gate-write "src/Makefile" "check:\n\t@printf 'native-fault-check-executed\\n'\n\t@exit 7\n") ;; Reuse the real dev recipe, bypassing unrelated expensive phases only. (let ((result (jabber-gate-make "do-dev" "-o" "do-compile" "-o" "do-module" "-o" "do-lint"))) (should-not (zerop (car result))) (should (string-match-p "native-fault-check-executed" (cdr result)))))) emacs-jabber-0.15.1/admin/test-matrix000066400000000000000000000276641527111033600174230ustar00rootroot00000000000000#!/usr/bin/env python3 """Run the declared minimum, pinned Nix default, and Thanos Emacs fork.""" import argparse import json import os from pathlib import Path import re import shutil import subprocess import sys import tempfile LABELS = { "minimum": "Package-Requires minimum", "default": "Pinned nixpkgs default Emacs", "fork": "Thanos Emacs fork", } def minimum_version(source): header = (source / "lisp/jabber.el").read_text() matches = re.findall(r'^;; Package-Requires:.*\(emacs "([0-9]+(?:\.[0-9]+)+)"\)', header, re.MULTILINE) if len(matches) != 1: raise ValueError("Expected one exact Emacs Package-Requires minimum") return matches[0] def executable(command): found = shutil.which(command) if not found: raise ValueError(f"Required executable unavailable: {command}") return str(Path(found).resolve()) def snapshot(source, destination): """Copy only manifest inputs; reject symlinks and path escapes.""" files = json.loads((source / "admin/source-manifest.json").read_text()) for name in files: relative = Path(name) if relative.is_absolute() or ".." in relative.parts: raise ValueError(f"Invalid source manifest path: {name}") origin = source / relative if not origin.is_file() or origin.resolve() != source.resolve() / relative: raise ValueError(f"Source input is missing or symlinked: {name}") target = destination / relative target.parent.mkdir(parents=True, exist_ok=True) shutil.copy2(origin, target) def validate_completion(build, files): """Validate actual workers and summaries without invoking Emacs again.""" if not files or len(files) != len(set(files)): raise ValueError("Empty or duplicate matrix test selection") isolated = [".test-results/" + Path(file).stem + ".stamp" for file in files] inventory = [] totals = {} for phase, stamps in (("isolated", isolated), ("combined", [".test-results/oneshot.stamp"])): total = 0 for index, stamp in enumerate(stamps): if (build / stamp).read_text().strip() != "0": raise ValueError(f"Failed worker: {stamp}") receipt = json.loads((build / (stamp + ".ert.json")).read_text()) selected = files if phase == "combined" else [files[index]] if not isinstance(receipt, dict): raise ValueError(f"Invalid ERT receipt: {stamp}") runs = receipt.get("runs") if receipt.get("files") != selected or not isinstance(runs, list) or len(runs) != (2 if phase == "combined" else 1): raise ValueError(f"Incomplete selected ERT runs: {stamp}") for run in runs: if not isinstance(run, dict): raise ValueError(f"Invalid ERT run: {stamp}") tests = run.get("tests") counts = [run.get(key) for key in ("total", "completed", "expected", "unexpected", "skipped")] if (not isinstance(tests, list) or not tests or not all(isinstance(test, str) and test for test in tests) or len(set(tests)) != len(tests) or not all(type(count) is int and count >= 0 for count in counts) or counts != [len(tests), len(tests), len(tests), 0, 0]): raise ValueError(f"Invalid or unsuccessful ERT completion: {stamp}") if phase == "isolated": inventory.extend(tests) elif sorted(tests) != sorted(inventory): raise ValueError("Combined ERT inventory differs from isolated tests") total += len(tests) summary = json.loads((build / (stamps[0] + ".summary.json")).read_text()) if (not isinstance(summary, dict) or not all(type(summary.get(key)) is int for key in ("total", "expected", "unexpected", "skipped")) or summary != {"stamps": stamps, "total": total, "expected": total, "unexpected": 0, "skipped": 0}): raise ValueError(f"Incomplete {phase} ERT summary") totals[phase] = total if len(inventory) != len(set(inventory)): raise ValueError("Duplicate isolated ERT test identities") # These outputs must be freshly produced in the source-only lane copy. suffix = ".dylib" if sys.platform == "darwin" else ".so" for artifact in ("lisp/jabber-autoloads.el", "lisp/jabber-omemo-core" + suffix): if not (build / artifact).is_file() or (build / artifact).stat().st_size == 0: raise ValueError(f"Missing build completion artifact: {artifact}") return {"files": files, "tests": sorted(inventory), "totals": totals} def lane(source, root, name, emacs, expected): """Run one clean build with its own sources, dependencies and state.""" root.mkdir(parents=True, exist_ok=False) build = root / "source" snapshot(source, build) env = os.environ.copy() # Never inherit another Make invocation's runtime, targets or bytecode paths. for key in ("MAKEFLAGS", "MFLAGS", "MAKEOVERRIDES", "EMACSLOADPATH", "EMACSNATIVELOADPATH", "EMACS_OPTS", "EMACS_CMD"): env.pop(key, None) for key, directory in (("HOME", "home"), ("TMPDIR", "tmp"), ("XDG_CONFIG_HOME", "config"), ("XDG_CACHE_HOME", "cache"), ("XDG_DATA_HOME", "data"), ("XDG_STATE_HOME", "state")): env[key] = str(root / directory) Path(env[key]).mkdir() env["JABBER_ENV_WRAPPED"] = "1" env["JABBER_MATRIX_EVIDENCE"] = "1" dependencies = root / "dependencies" shutil.copytree(env["JABBER_MATRIX_DEPS"], dependencies) options = ["-Q", "--batch"] for directory in sorted(dependencies.iterdir()): options.extend(["-L", str(directory)]) # EMACS_OPTS is the existing runner's shell-word interface. if any(any(char.isspace() for char in item) for item in options + [emacs]): raise ValueError("Matrix scratch and executable paths must not contain whitespace") version = subprocess.check_output( [emacs, "-Q", "--batch", "--eval", "(princ emacs-version)"], env=env, text=True).strip() print(f"=== {LABELS[name]}: GNU Emacs {version} ({emacs}) ===", flush=True) if expected is not None and version != expected: raise ValueError(f"{LABELS[name]}: expected {expected}, got {version}") receipt = {"lane": name, "label": LABELS[name], "version": version, "executable": emacs, "source": str(build), "environment": {key: env[key] for key in env if key in ( "HOME", "TMPDIR", "XDG_CONFIG_HOME", "XDG_CACHE_HOME", "XDG_DATA_HOME", "XDG_STATE_HOME")}} (root / "runtime.json").write_text(json.dumps(receipt, indent=2) + "\n") command = ["make", "--no-print-directory", "check", f"EMACS_CMD={emacs}", "EMACS_OPTS=" + " ".join(options)] files = (env["MATRIX_TESTS"].split() if "MATRIX_TESTS" in env else sorted(str(path.relative_to(build)) for path in build.glob("tests/jabber-test-*.el"))) if not files or any(not re.fullmatch(r"tests/jabber-test-[\w-]+\.el", file) or not (build / file).is_file() for file in files): raise ValueError("Invalid or missing matrix test selection") command.append("TESTS=" + " ".join(files)) if "MATRIX_JOBS" in env: command.append("JOBS=" + env["MATRIX_JOBS"]) status = subprocess.run(command, cwd=build, env=env, check=False).returncode if status: raise RuntimeError(f"{LABELS[name]} failed (exit {status}); diagnostics: {root}") completion = validate_completion(build, files) (root / "completion.json").write_text(json.dumps(completion, indent=2) + "\n") (root / "passed").write_text(version + "\n") def matrix(source): # This preflight MUST precede all Nix evaluation/development-shell entry. # A missing fork fails its lane, but must not suppress the other attempts. fork_error = None fork = None try: if os.environ.get("IN_NIX_SHELL") or os.environ.get("JABBER_ENV_WRAPPED"): raise ValueError("Run make test-matrix outside Nix to resolve Thanos Emacs fork") fork = executable(os.environ.get("THANOS_EMACS", "emacs")) print(f"Thanos Emacs fork resolved before Nix: {fork}", flush=True) except ValueError as error: fork_error = str(error) ref = "git+" + source.as_uri() root = Path(tempfile.mkdtemp(prefix="jabber-matrix-")) print(f"Matrix evidence: {root}", flush=True) failed = [] archive_error = None try: # Freeze the Git-aware input once so later lanes cannot read a different # working-tree generation. Archive also realizes the source closure. archive = json.loads(subprocess.check_output( [executable("nix"), "flake", "archive", "--json", "--no-write-lock-file", ref], text=True)) source = Path(archive["path"]) if not source.is_dir(): raise ValueError("Nix did not realize the matrix source") ref = str(source) (root / "source.json").write_text(json.dumps(archive, indent=2) + "\n") except (OSError, ValueError, KeyError, subprocess.SubprocessError) as error: archive_error = str(error) for name in LABELS: log_path = root / (name + ".log") status = 1 with log_path.open("w") as log: try: if name == "fork" and fork_error: raise ValueError(fork_error) if archive_error: raise ValueError(archive_error) # Git-aware input avoids copying ignored/private files into the store. command = [executable("nix"), "develop", ref + "#matrix-" + ("minimum" if name == "minimum" else "default"), "--command", "python3", str(source / "admin/test-matrix"), "--lane", name, "--root", str(root / name)] if name == "fork": command.extend(["--emacs", fork]) status = subprocess.run(command, stdout=log, stderr=subprocess.STDOUT, check=False).returncode except (OSError, ValueError, subprocess.SubprocessError) as error: log.write(str(error) + "\n") # A successful subprocess without the lane's completion is not success. passed = root / name / "passed" ok = status == 0 and passed.is_file() and bool(passed.read_text().strip()) version = passed.read_text().strip() if ok else "incomplete" print(f"{'PASS' if ok else 'FAIL'} {LABELS[name]} ({version}); log: {log_path}", flush=True) if not ok: failed.append(name) if failed: raise RuntimeError("Required matrix lanes failed: " + ", ".join(failed)) print("PASS all three required Emacs lanes", flush=True) def main(): parser = argparse.ArgumentParser(description=__doc__) parser.add_argument("--lane", choices=LABELS) parser.add_argument("--root", type=Path) parser.add_argument("--emacs", default="emacs") parser.add_argument("--expected") args = parser.parse_args() source = Path(__file__).resolve().parent.parent try: if args.lane: if not args.root: parser.error("--lane requires --root") expected = args.expected if args.lane != "fork": expected = expected or os.environ["JABBER_MATRIX_VERSION"] if args.lane == "minimum" and expected != minimum_version(source): raise ValueError("Pinned minimum disagrees with Package-Requires") lane(source, args.root.resolve(), args.lane, executable(args.emacs), expected) else: matrix(source) except (OSError, ValueError, RuntimeError, subprocess.SubprocessError) as error: print(f"FAIL: {error}", file=sys.stderr) return 1 return 0 if __name__ == "__main__": sys.exit(main()) emacs-jabber-0.15.1/admin/test-matrix-public.py000066400000000000000000000152631527111033600213160ustar00rootroot00000000000000"""Exercise the real public matrix and Git-aware pure source evaluation. Run outside Nix with an installed Emacs. No fake Nix or fake ERT receipts: only executable early-exit faults and one genuine failing ERT are injected. All evidence is retained in the printed temporary directory. """ import argparse import json import os from pathlib import Path import re import shutil import subprocess import sys import tempfile SOURCE = Path(__file__).resolve().parent.parent def run(command, source, env, log): with log.open("w") as output: result = subprocess.run(command, cwd=source, env=env, stdout=output, stderr=subprocess.STDOUT, timeout=300, check=False) return result.returncode, log.read_text() def main(): parser = argparse.ArgumentParser(description=__doc__) parser.add_argument("--emacs", default=os.environ.get("THANOS_EMACS", "emacs")) args = parser.parse_args() emacs = str(Path(shutil.which(args.emacs) or args.emacs).resolve(strict=True)) root = Path(tempfile.mkdtemp(prefix="jabber-matrix-public-")) print(f"Public regression evidence: {root}", flush=True) source = root / "source" source.mkdir() env = os.environ.copy() for key in ("IN_NIX_SHELL", "JABBER_ENV_WRAPPED", "MAKEFLAGS", "MFLAGS", "MAKEOVERRIDES"): env.pop(key, None) # Copy tracked inputs, not private/untracked working-tree contents. names = subprocess.check_output(["git", "ls-files", "-z"], cwd=SOURCE).decode().split("\0") for name in filter(None, names): target = source / name target.parent.mkdir(parents=True, exist_ok=True) shutil.copy2(SOURCE / name, target) subprocess.run(["git", "init", "-q", str(source)], check=True) subprocess.run(["git", "add", "."], cwd=source, check=True) results = [] for mode in ("positive", "early-exit", "combined-exit", "summary-exit", "ert-failure"): wrapper = root / mode # The review reproducer's version-only pass-through is kept verbatim # in behavior: genuine version query, zero exit for all other work. wrapper.write_text( f"#!{sys.executable}\nimport json, os, sys\n" f"mode = {mode!r}\nreal = {emacs!r}\n" "version = '(princ emacs-version)' in sys.argv\n" "stop = (mode == 'early-exit' or " "(mode == 'combined-exit' and os.environ.get('JABBER_TEST_RUNS') == '2') or " "(mode == 'summary-exit' and 'admin/test-summary' in sys.argv))\n" "if not version and stop:\n" f" with open({str(root / (mode + '.jsonl'))!r}, 'a') as output:\n" " output.write(json.dumps(sys.argv[1:]) + '\\n')\n" " sys.exit(0)\n" "os.execv(real, [real] + sys.argv[1:])\n") wrapper.chmod(0o755) if mode == "ert-failure": with (source / "tests/jabber-test-time.el").open("a") as test: test.write('\n(ert-deftest matrix-intentional-failure () (should nil))\n') command = ["make", "test-matrix", "TESTS=tests/jabber-test-time.el", "JOBS=1", "THANOS_EMACS=" + str(wrapper)] status, text = run(command, source, env, root / (mode + ".log")) match = re.search(r"Matrix evidence: (.+)", text) assert match, text evidence = Path(match[1]) assert all((evidence / (lane + ".log")).is_file() for lane in ("minimum", "default", "fork")) if mode == "positive": assert status == 0, text for lane in ("minimum", "default", "fork"): assert (evidence / lane / "passed").is_file(), text completion = json.loads((evidence / lane / "completion.json").read_text()) assert completion["totals"] == {"isolated": 1, "combined": 2}, completion assert completion["files"] == ["tests/jabber-test-time.el"], completion assert len(completion["tests"]) == 1, completion else: assert status != 0 and "FAIL Thanos Emacs fork" in text, text assert not (evidence / "fork/passed").exists(), text assert (evidence / "fork/source/.test-results/jabber-test-time.stamp.log").is_file() if mode == "ert-failure": for lane in ("minimum", "default", "fork"): assert not (evidence / lane / "passed").exists(), text log = evidence / lane / "source/.test-results/jabber-test-time.stamp.log" assert "matrix-intentional-failure" in log.read_text() else: assert (root / (mode + ".jsonl")).stat().st_size > 0 assert (evidence / "minimum/passed").is_file(), text assert (evidence / "default/passed").is_file(), text assert "No such file" in (evidence / "fork.log").read_text() results.append({"case": mode, "exit": status, "evidence": str(evidence)}) print(f"PASS public {mode}", flush=True) # No tracked test may disappear through the closed-world source filter. (source / "tests/jabber-test-unlisted.el").write_text(";; tracked manifest drift\n") subprocess.run(["git", "add", "tests/jabber-test-unlisted.el"], cwd=source, check=True) ref = "git+" + source.as_uri() command = ["nix", "eval", "--raw", ref + "#checks." + subprocess.check_output(["nix", "eval", "--impure", "--raw", "--expr", "builtins.currentSystem"], text=True).strip() + ".matrix-default.drvPath"] status, text = run(command, source, env, root / "manifest-drift.log") assert status != 0 and "Ordinary test manifest incomplete: tests/jabber-test-unlisted.el" in text, text subprocess.run(["git", "rm", "-f", "tests/jabber-test-unlisted.el"], cwd=source, check=True, stdout=subprocess.DEVNULL) (source / "tests/jabber-test-private.el").write_text("private untracked sentinel\n") with (source / ".git/info/exclude").open("a") as exclude: exclude.write("tests/jabber-test-ignored.el\n") (source / "tests/jabber-test-ignored.el").write_text("private ignored sentinel\n") status, text = run(command, source, env, root / "manifest-private.log") assert status == 0, text archive = json.loads(subprocess.check_output(["nix", "flake", "archive", "--json", ref], cwd=source, env=env, text=True)) realized = Path(archive["path"]) assert realized.is_dir() for name in ("tests/jabber-test-private.el", "tests/jabber-test-ignored.el"): assert not (realized / name).exists() results.append({"case": "tracked-manifest-drift-and-private-exclusion", "archive": str(realized)}) (root / "results.json").write_text(json.dumps(results, indent=2) + "\n") print("PASS tracked manifest drift and private exclusion", flush=True) if __name__ == "__main__": main() emacs-jabber-0.15.1/admin/test-matrix-runner.py000066400000000000000000000217661527111033600213560ustar00rootroot00000000000000"""Regression tests for matrix failure, provenance, and isolation boundaries.""" from contextlib import redirect_stdout import copy import io import json import os from pathlib import Path import runpy import subprocess import sys import tempfile import unittest from unittest.mock import patch RUNNER = runpy.run_path(str(Path(__file__).with_name("test-matrix"))) SOURCE = Path(__file__).resolve().parent.parent def completion_fixture(build): """Supply explicit synthetic records only for the validator unit tests.""" files = ["tests/jabber-test-time.el"] counts = {"tests": ["time-test"], "total": 1, "completed": 1, "expected": 1, "unexpected": 0, "skipped": 0} for name, runs in (("jabber-test-time", 1), ("oneshot", 2)): stamp = ".test-results/" + name + ".stamp" (build / stamp).parent.mkdir(parents=True, exist_ok=True) (build / stamp).write_text("0\n") (build / (stamp + ".ert.json")).write_text(json.dumps({"files": files, "runs": [counts] * runs})) (build / (stamp + ".summary.json")).write_text(json.dumps( {"stamps": [stamp], "total": runs, "expected": runs, "unexpected": 0, "skipped": 0})) (build / "lisp").mkdir(exist_ok=True) (build / "lisp/jabber-autoloads.el").write_text("fixture") suffix = ".dylib" if sys.platform == "darwin" else ".so" (build / ("lisp/jabber-omemo-core" + suffix)).write_text("fixture") return files class MatrixTests(unittest.TestCase): def setUp(self): self.temporary = tempfile.TemporaryDirectory(prefix="jabber-matrix-selftest-") self.addCleanup(self.temporary.cleanup) self.root = Path(self.temporary.name) def test_header_minimum_is_exact(self): self.assertEqual(RUNNER["minimum_version"](SOURCE), "29.1") def test_snapshot_omits_private_and_generated_files(self): source = self.root / "input" (source / "admin").mkdir(parents=True) (source / "admin/source-manifest.json").write_text('["source.el"]') (source / "source.el").write_text("source") for name in ("private.el", "local.mk", "source.elc", "module.so"): (source / name).write_text("must not copy") destination = self.root / "output" RUNNER["snapshot"](source, destination) self.assertEqual([p.name for p in destination.iterdir()], ["source.el"]) (source / "source.el").unlink() (source / "source.el").symlink_to(source / "private.el") with self.assertRaisesRegex(ValueError, "symlinked"): RUNNER["snapshot"](source, self.root / "rejected") def run_matrix(self, missing_fork=False, fail_minimum=False, missing_receipt=False): calls = [] resolved = [] def resolve(command): resolved.append(command) if command == "user-fork" and missing_fork: raise ValueError("missing user-fork") return "/resolved/" + command def run(command, **_): name = command[command.index("--lane") + 1] calls.append(name) self.assertEqual(resolved[0], "user-fork") self.assertEqual(command[2].split("#")[0], str(SOURCE)) if name == "fork": self.assertEqual(command[-2:], ["--emacs", "/resolved/user-fork"]) if not missing_receipt: lane = Path(command[command.index("--root") + 1]) lane.mkdir() (lane / "passed").write_text("29.1\n") return subprocess.CompletedProcess(command, 1 if fail_minimum and name == "minimum" else 0) with patch.dict(os.environ, {"THANOS_EMACS": "user-fork"}, clear=True), \ patch.dict(RUNNER["matrix"].__globals__, {"executable": resolve}), \ patch("tempfile.mkdtemp", return_value=str(self.root)), \ patch("subprocess.check_output", return_value=json.dumps({"path": str(SOURCE)})), \ patch("subprocess.run", side_effect=run), redirect_stdout(io.StringIO()): if missing_fork or fail_minimum or missing_receipt: with self.assertRaisesRegex(RuntimeError, "Required matrix lanes failed"): RUNNER["matrix"](SOURCE) else: RUNNER["matrix"](SOURCE) return calls def test_success_resolves_fork_before_nix(self): self.assertEqual(self.run_matrix(), ["minimum", "default", "fork"]) def test_failure_still_attempts_every_lane(self): self.assertEqual(self.run_matrix(fail_minimum=True), ["minimum", "default", "fork"]) def test_missing_fork_does_not_suppress_nix_lanes(self): self.assertEqual(self.run_matrix(missing_fork=True), ["minimum", "default"]) def test_zero_exit_without_receipt_is_failure(self): self.assertEqual(self.run_matrix(missing_receipt=True), ["minimum", "default", "fork"]) def test_lane_isolation_and_focused_options(self): dependencies = self.root / "deps" (dependencies / "fsm").mkdir(parents=True) (dependencies / "fsm/fsm.el").write_text("source") observed = [] def run(command, cwd, env, **_): observed.append((cwd, env)) self.assertIn("TESTS=tests/jabber-test-time.el", command) self.assertIn("JOBS=1", command) self.assertNotIn("MAKEFLAGS", env) self.assertNotIn("EMACSLOADPATH", env) self.assertFalse((cwd / "lisp/jabber.elc").exists()) (cwd / "lisp/jabber.elc").write_text("private bytecode") (cwd / "lisp/jabber-omemo-core.so").write_text("private module") completion_fixture(cwd) return subprocess.CompletedProcess(command, 0) with patch.dict(os.environ, {"JABBER_MATRIX_DEPS": str(dependencies), "MATRIX_TESTS": "tests/jabber-test-time.el", "MATRIX_JOBS": "1", "MAKEFLAGS": "bad", "EMACSLOADPATH": "bad"}), \ patch("subprocess.check_output", return_value="29.1"), \ patch("subprocess.run", side_effect=run), redirect_stdout(io.StringIO()): for name in ("minimum", "default", "fork"): RUNNER["lane"](SOURCE, self.root / name, name, "/fake/emacs", "29.1") for key in ("HOME", "TMPDIR", "XDG_CACHE_HOME", "XDG_CONFIG_HOME", "XDG_DATA_HOME", "XDG_STATE_HOME"): self.assertEqual(len({env[key] for _, env in observed}), 3) self.assertEqual(len({cwd for cwd, _ in observed}), 3) def test_wrong_patch_release_is_not_minimum(self): dependencies = self.root / "deps" dependencies.mkdir() with patch.dict(os.environ, {"JABBER_MATRIX_DEPS": str(dependencies)}), \ patch("subprocess.check_output", return_value="29.4"), \ patch("subprocess.run") as run, redirect_stdout(io.StringIO()): with self.assertRaisesRegex(ValueError, "expected 29.1, got 29.4"): RUNNER["lane"](SOURCE, self.root / "minimum", "minimum", "/fake/emacs", "29.1") run.assert_not_called() def test_independent_completion_validation(self): files = completion_fixture(self.root) validate = RUNNER["validate_completion"] self.assertEqual(validate(self.root, files)["totals"], {"isolated": 1, "combined": 2}) receipt = self.root / ".test-results/oneshot.stamp.ert.json" original = json.loads(receipt.read_text()) mutants = [] for key, value in (("completed", 0), ("total", 0), ("unexpected", 1), ("skipped", 1), ("tests", ["omitted-original"]), ("total", True)): mutant = copy.deepcopy(original) mutant["runs"][1][key] = value mutants.append(mutant) mutants.extend(({**original, "runs": original["runs"][:1]}, {**original, "files": ["wrong-file.el"]})) for mutant in mutants: with self.subTest(mutant=mutant): receipt.write_text(json.dumps(mutant)) with self.assertRaises(ValueError): validate(self.root, files) receipt.write_text(json.dumps(original)) for name in ("oneshot.stamp.ert.json", "oneshot.stamp.summary.json", "jabber-test-time.stamp.ert.json", "jabber-test-time.stamp.summary.json"): path = self.root / ".test-results" / name saved = path.read_bytes() path.unlink() with self.assertRaises(OSError): validate(self.root, files) path.write_bytes(saved) def test_make_zero_without_work_does_not_publish_passed(self): deps = self.root / "deps" deps.mkdir() with patch.dict(os.environ, {"JABBER_MATRIX_DEPS": str(deps)}), \ patch("subprocess.check_output", return_value="29.1"), \ patch("subprocess.run", return_value=subprocess.CompletedProcess([], 0)): with self.assertRaises(OSError): RUNNER["lane"](SOURCE, self.root / "fork", "fork", "/fake/emacs", None) self.assertFalse((self.root / "fork/passed").exists()) if __name__ == "__main__": unittest.main() emacs-jabber-0.15.1/admin/test-summary000066400000000000000000000044071527111033600176020ustar00rootroot00000000000000;;; test-summary --- Validate and aggregate ERT receipts -*- lexical-binding: t; -*- (require 'cl-lib) (require 'json) (defun jabber-test-read-record (file) "Read exactly one Lisp record from FILE." (with-temp-buffer (insert-file-contents file) (let ((record (read (current-buffer)))) (skip-chars-forward " \t\r\n") (unless (eobp) (error "Trailing receipt data: %s" file)) record))) (let ((total 0) (expected 0) (unexpected 0) (skipped 0) (bad 0)) (unless command-line-args-left (error "No test files selected")) (dolist (stamp command-line-args-left) (condition-case err (let ((status (jabber-test-read-record stamp)) (record (jabber-test-read-record (concat stamp ".ert")))) (unless (and (integerp status) (<= 0 status 255) (proper-list-p record) (= (length record) 5) (eq (car record) 'complete) (cl-every (lambda (n) (and (integerp n) (>= n 0))) (cdr record)) (> (nth 1 record) 0) (= (nth 1 record) (apply #'+ (cddr record)))) (error "Invalid process or completion record")) (cl-incf total (nth 1 record)) (cl-incf expected (nth 2 record)) (cl-incf unexpected (nth 3 record)) (cl-incf skipped (nth 4 record)) (unless (and (zerop status) (zerop (nth 3 record))) (error "Process exit %s; %s unexpected results" status (nth 3 record))) (princ (format "OK %s (%s tests)\n" stamp (nth 1 record)))) (error (cl-incf bad) (princ (format "FAIL %s: %s\n Diagnostics: %s.log\n" stamp (error-message-string err) stamp))))) (princ (format "%d completed tests: %d expected, %d unexpected, %d skipped; %d failed files\n" total expected unexpected skipped bad)) (when (and (zerop bad) (getenv "JABBER_MATRIX_EVIDENCE")) (with-temp-file (concat (car command-line-args-left) ".summary.json") (insert (json-encode `((stamps . ,(vconcat command-line-args-left)) (total . ,total) (expected . ,expected) (unexpected . ,unexpected) (skipped . ,skipped)))))) (kill-emacs (if (zerop bad) 0 1))) emacs-jabber-0.15.1/doap.xml000066400000000000000000000652201527111033600155620ustar00rootroot00000000000000 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.5.0 0.10.0 Incoming MUC self-retraction is supported when the room supplies trusted XEP-0421 occupant identifiers, including MAM replay and mandatory fallback suppression. XEP-0425 moderated retraction is supported. No outgoing author retraction or standalone 1:1 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.15.1 2026-10-30 0.15.0 2026-10-02 0.14.0 2026-09-05 0.13.3 2026-09-05 0.13.2 2026-08-28 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.15.1/flake.lock000066400000000000000000000031571527111033600160520ustar00rootroot00000000000000{ "nodes": { "keymap-popup": { "flake": false, "locked": { "lastModified": 1786092281, "narHash": "sha256-6zalP/EvksOKfJKERAsRhsKkRJ870f1X/lYrlXX02j0=", "ref": "refs/heads/master", "rev": "d60263ae5b169cbffe4ae90f2615343b59f5d077", "revCount": 146, "type": "git", "url": "https://git.thanosapollo.org/emacs-keymap-popup.git" }, "original": { "type": "git", "url": "https://git.thanosapollo.org/emacs-keymap-popup.git" } }, "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" } }, "nixpkgs-emacs291": { "locked": { "lastModified": 1701282334, "narHash": "sha256-MxCVrXY6v4QmfTwIysjjaX0XUhqBbxTWWB4HXtDYsdk=", "owner": "NixOS", "repo": "nixpkgs", "rev": "057f9aecfb71c4437d2b27d3323df7f93c010b7e", "type": "github" }, "original": { "owner": "NixOS", "repo": "nixpkgs", "rev": "057f9aecfb71c4437d2b27d3323df7f93c010b7e", "type": "github" } }, "root": { "inputs": { "keymap-popup": "keymap-popup", "nixpkgs": "nixpkgs", "nixpkgs-emacs291": "nixpkgs-emacs291" } } }, "root": "root", "version": 7 } emacs-jabber-0.15.1/flake.nix000066400000000000000000000234741527111033600157240ustar00rootroot00000000000000{ description = "XMPP client for Emacs"; inputs.nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; # Immutable 23.11 release: the exact declared minimum, not the final 29.x. inputs.nixpkgs-emacs291.url = "github:NixOS/nixpkgs/057f9aecfb71c4437d2b27d3323df7f93c010b7e"; inputs.keymap-popup = { url = "git+https://git.thanosapollo.org/emacs-keymap-popup.git"; flake = false; }; outputs = { self, nixpkgs, nixpkgs-emacs291, keymap-popup }: 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.2"; # 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; # Closed-world release/build inputs shared with the Make matrix. manifest = builtins.fromJSON (builtins.readFile ./admin/source-manifest.json); # Git flakes expose only tracked files here, before the closed filter. ordinaryTests = map (name: "tests/${name}") (builtins.filter (name: builtins.match "jabber-test-.*\\.el" name != null) (builtins.attrNames (builtins.readDir ./tests))); missingTests = builtins.filter (name: !(builtins.elem name manifest)) ordinaryTests; source = if missingTests != [] then throw "Ordinary test manifest incomplete: ${builtins.concatStringsSep ", " missingTests}" else lib.fileset.toSource { root = ./.; fileset = lib.fileset.unions (map (name: ./. + "/${name}") manifest); }; keymapPopup = emacsPackages.trivialBuild { pname = "keymap-popup"; version = keymapPopupVersion; src = keymap-popup; packageRequires = [ ]; }; emacsWithPackages = emacsPackages.emacsWithPackages (epkgs: [ epkgs.fsm keymapPopup epkgs.package-lint epkgs.relint ]); # Only source dependencies: each matrix lane gets its own copy, # never Elisp bytecode produced by a different Emacs. testDependencies = pkgs.runCommand "jabber-test-dependency-sources" {} '' mkdir -p $out/fsm $out/keymap-popup tar -xf ${emacsPackages.fsm.src} --strip-components=1 -C $out/fsm --wildcards '*/fsm.el' cp ${keymap-popup}/*.el $out/keymap-popup/ ''; 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 ''; }; # Recursive Make and the matrix runner use their own job variables. testJobBudget = '' jobs="''${NIX_BUILD_CORES:-1}" case "$jobs" in *[!0-9]*) jobs=1 ;; esac if ! [ "$jobs" -gt 0 ] 2>/dev/null; then jobs=1 fi ''; # 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 pkgs.gnupg ]; 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" # Keep first-attempt ERT diagnostics, including successful runs. export JABBER_MATRIX_EVIDENCE=1 mkdir -p "$HOME" "$XDG_CACHE_HOME" "$XDG_CONFIG_HOME" \ "$XDG_DATA_HOME" "$XDG_STATE_HOME" ${testJobBudget} CFLAGS="${moduleCFlags}" \ EMACS_CMD=emacs \ JABBER_ENV_WRAPPED=1 \ make ${target} JOBS="$jobs" runHook postBuild ''; installPhase = '' runHook preInstall mkdir -p $out touch $out/tests-passed if [ -d .test-results ]; then cp -r .test-results $out/test-results fi runHook postInstall ''; }; in { inherit emacs emacsWithPackages keymapPopup omemoModule source testDependencies; matrix = pkgs.stdenv.mkDerivation { pname = "emacs-jabber-matrix-${emacs.version}"; version = "git"; src = source; nativeBuildInputs = [ emacs pkgs.python3 pkgs.gnumake pkgs.pkg-config pkgs.gnupg ]; buildInputs = [ pkgs.mbedtls ]; dontConfigure = true; buildPhase = '' export JABBER_MATRIX_DEPS=${testDependencies} export CFLAGS="${moduleCFlags}" ${testJobBudget} MATRIX_JOBS="$jobs" python3 admin/test-matrix --lane ${if emacs.version == "29.1" then "minimum" else "default"} \ --expected ${emacs.version} --root "$TMPDIR/lane" ''; installPhase = '' mkdir -p $out cp "$TMPDIR/lane/runtime.json" "$TMPDIR/lane/completion.json" \ "$TMPDIR/lane/passed" $out/ cp -r "$TMPDIR/lane/source/.test-results" $out/test-results ''; }; matrixShell = pkgs.mkShell { packages = [ emacs pkgs.python3 pkgs.gnumake pkgs.pkg-config pkgs.gnupg ]; buildInputs = [ pkgs.mbedtls ]; shellHook = '' export JABBER_MATRIX_DEPS=${testDependencies} export JABBER_MATRIX_VERSION=${emacs.version} export CFLAGS="${moduleCFlags}" ''; }; compiler = mkTests { pname = "emacs-jabber-compiler"; target = "do-lint-byte-comp do-lint-native-comp lint-compile-check lint-package-lint"; }; # 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; }; pkgs291 = import nixpkgs-emacs291 { inherit system; }; in { inherit pkgs; full = mkVariant pkgs pkgs.emacs; minimum = mkVariant pkgs pkgs291.emacs29-nox; # 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; keymap-popup = jabber.full.keymapPopup; omemo-module = jabber.full.omemoModule; }); checks = forAllSystems (system: let jabber = mkJabber system; in { omemo-module = jabber.full.omemoModule; compiler = jabber.full.compiler; matrix-runner = jabber.pkgs.runCommand "jabber-matrix-runner" { nativeBuildInputs = [ jabber.pkgs.python3 ]; } '' python3 ${jabber.full.source}/admin/test-matrix-runner.py touch $out ''; matrix-minimum = jabber.minimum.matrix; matrix-default = jabber.full.matrix; # 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 { matrix-minimum = jabber.minimum.matrixShell; matrix-default = jabber.full.matrixShell; default = jabber.pkgs.mkShell { packages = with jabber.pkgs; [ cacert gcc git gnumake gnupg jabber.full.emacsWithPackages mbedtls pkg-config ]; shellHook = '' export EMACS_CMD=emacs export CFLAGS="-I${jabber.full.emacs}/include''${CFLAGS:+ $CFLAGS}" # The module is loaded by Emacs outside this shell, after # its store paths may have been garbage-collected. export MBED_STATIC=1 ''; }; }); }; } emacs-jabber-0.15.1/lisp/000077500000000000000000000000001527111033600150575ustar00rootroot00000000000000emacs-jabber-0.15.1/lisp/jabber-activity.el000066400000000000000000000570471527111033600204750ustar00rootroot00000000000000;;; 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 JID strings into an alist of JID -> string. Called separately for each account, with its existing one-argument signature." :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 "List of (CONNECTION . JID) pairs which have caused activity. Legacy string entries are actionable only with an unambiguous owner.") (defvar jabber-activity--event-owner nil "Explicit receiving connection bound by message dispatch, never UI scope.") (defvar jabber-activity--format-owner nil "Owner used by the string-only customization adapters.") (defvar jabber-activity-personal-jids nil "Subset of `jabber-activity-jids' for JIDs with \"personal\" activity.") (defvar jabber-activity-name-alist nil "Alist mapping owner-qualified activity entries to mode line names.") (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 owners and 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 (and jabber-activity--format-owner (jabber-jid-resource jid) (jabber-muc-joined-p (jabber-jid-user jid) jabber-activity--format-owner)) (jabber-jid-resource jid) (let ((nick (jabber-jid-displayname jid jabber-activity--format-owner)) (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 (cons jabber-activity--format-owner (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--jid (entry) "Return the JID string from activity ENTRY or a legacy string." (if (consp entry) (cdr entry) entry)) (defun jabber-activity--owner (entry) "Return the exact live owner of ENTRY, without an account fallback. Legacy strings resolve only when one connection is active." (let ((owner (if (consp entry) (car entry) (and (null (cdr jabber-connections)) (car jabber-connections))))) (and (memq owner jabber-connections) owner))) (defun jabber-activity--buffer (entry) "Return ENTRY's live parent conversation buffer, not a dedicated thread." (when-let* ((jc (jabber-activity--owner entry)) (jid (jabber-activity--jid entry))) (seq-find (lambda (buffer) (with-current-buffer buffer (and (eq major-mode 'jabber-chat-mode) (not (bound-and-true-p jabber-message-thread-id)) (eq jabber-buffer-connection jc) (or (equal jabber-group jid) (and jabber-chatting-with (if jabber-muc-private-p (equal jabber-chatting-with jid) (and (not jabber-group) (equal (jabber-jid-user jabber-chatting-with) (jabber-jid-user jid))))))))) (buffer-list)))) (defun jabber-activity-find-buffer-name (jid) "Find the exact-owner buffer for JID, an entry or legacy JID string." (jabber-activity--buffer jid)) (defun jabber-activity--unused-buffer-format (name) "Return a literal unused buffer format derived from NAME. Do not let reconstruction adopt another account's same-named buffer." (replace-regexp-in-string "%" "%%" (generate-new-buffer-name (if (bufferp name) (buffer-name name) name)) t t)) (defun jabber-activity--switch-to-missing-buffer (entry) "Recreate ENTRY's buffer only on its original live connection." (when-let* ((jc (jabber-activity--owner entry)) (jid (jabber-activity--jid entry))) (cond ((and (jabber-jid-resource jid) (jabber-muc-joined-p (jabber-jid-user jid) jc)) (let ((jabber-muc-private-buffer-format (jabber-activity--unused-buffer-format (jabber-muc-private-get-buffer (jabber-jid-user jid) (jabber-jid-resource jid) jc)))) (switch-to-buffer (jabber-muc-private-create-buffer jc (jabber-jid-user jid) (jabber-jid-resource jid))))) ((jabber-muc-joined-p jid jc) (let ((jabber-groupchat-buffer-format (jabber-activity--unused-buffer-format (jabber-muc-get-buffer jid jc)))) (switch-to-buffer (jabber-muc-create-buffer jc jid)))) (t (let ((jabber-chat-buffer-format (jabber-activity--unused-buffer-format (jabber-chat-get-buffer jid jc)))) (jabber-chat-with jc 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 owner's buffer is not visible. The customization adapter supplies the explicit owner." (let ((buffer (jabber-activity-find-buffer-name (if jabber-activity--format-owner (cons jabber-activity--format-owner jid) jid)))) (and (not (cl-some (lambda (regexp) (string-match-p regexp jid)) jabber-activity-banned)) (or (null buffer) (not (get-buffer-window buffer 'visible)))))) (defun jabber-activity--show-p (entry) "Call the string-taking activity predicate for owned ENTRY." (when-let* ((jabber-activity--format-owner (jabber-activity--owner entry))) (funcall jabber-activity-show-p (jabber-activity--jid entry)))) (defun jabber-activity--names (entries) "Format ENTRIES without changing string-only customization signatures. Call the list formatter separately for each owner. Reattach identity outside the customization boundary, including when names are identical." (mapcan (lambda (group) (let* ((jabber-activity--format-owner (car group)) (entries (cdr group)) (names (funcall jabber-activity-make-strings (mapcar #'jabber-activity--jid entries)))) (mapcar (lambda (entry) (let ((jid (jabber-activity--jid entry))) (cons entry (or (cdr (assoc jid names)) jid)))) entries))) (seq-group-by #'jabber-activity--owner entries))) (defun jabber-activity-make-name-alist (&optional _jc) "Rebuild the owner-qualified names of currently known activity entries." (clrhash jabber-activity--shortened-names) (setq jabber-activity-name-alist (jabber-activity--names (delete-dups (append jabber-activity-jids (mapcar #'car jabber-activity-name-alist))))) (clrhash jabber-activity--shortened-names)) (defun jabber-activity-lookup-name (jid) "Return a (JID . STRING) display pair for an entry or legacy JID string." (or (assoc jid jabber-activity-name-alist) (progn (clrhash jabber-activity--shortened-names) (setq jabber-activity-name-alist (jabber-activity--names (cons jid (mapcar #'car jabber-activity-name-alist)))) (assoc jid jabber-activity-name-alist)))) (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* ((identity (car entry)) (jid (jabber-activity--jid identity)) (owner (jabber-activity--owner identity)) (name (cdr entry)) (mucp (and owner (jabber-muc-joined-p jid owner))) (map (make-sparse-keymap)) (display (if mucp (concat jabber-activity-muc-prefix name) name)) (face (cond ((member identity jabber-activity-personal-jids) 'jabber-activity-mention-face) (mucp 'jabber-activity-muc-face) (t 'jabber-activity-chat-face)))) (define-key map [mode-line mouse-1] (lambda () (interactive) (jabber-activity-switch-to identity))) (propertize display 'face face 'jabber-modeline t 'jabber-activity-entry identity 'local-map map 'mouse-face 'mode-line-highlight '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--event-entry (jid buffer) "Capture JID's owner from explicit BUFFER or the message dispatcher." (let* ((buffer (and buffer (get-buffer buffer))) (owner (or jabber-activity--event-owner (and (buffer-live-p buffer) (buffer-local-value 'jabber-buffer-connection buffer))))) (when (memq owner jabber-connections) (cons owner jid)))) (defun jabber-activity-add (from buffer _text _proposed-alert) "Track FROM on the account captured from BUFFER or message dispatch." (when-let* ((entry (jabber-activity--event-entry from buffer)) (show (jabber-activity--show-p entry))) (add-to-list 'jabber-activity-jids entry) (add-to-list 'jabber-activity-personal-jids entry) (jabber-activity-mode-line-update))) (defun jabber-activity-add-muc (_nick group buffer text _proposed-alert) "Track GROUP on BUFFER's owner, preserving personal mentions in TEXT." (when-let* ((entry (jabber-activity--event-entry group buffer)) (show (jabber-activity--show-p entry))) (add-to-list 'jabber-activity-jids entry) ;; This is the captured event owner, not the selected UI account. (let ((jabber-buffer-connection (car entry))) (when (jabber-muc-looks-like-personal-p text group) (add-to-list 'jabber-activity-personal-jids entry))) (jabber-activity-mode-line-update))) (defun jabber-activity-presence (who _oldstatus newstatus _statustext _proposed-alert) "Track subscription WHO using its scoped symbol owner. NEWSTATUS is the presence type of the incoming stanza." (when (string= newstatus "subscribe") (when-let* ((owner (jabber-jid-owner who)) (entry (cons owner (symbol-name who))) (show (jabber-activity--show-p entry))) (add-to-list 'jabber-activity-jids entry) (add-to-list 'jabber-activity-personal-jids entry) (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. JID-PARAM may be an owner-qualified activity entry or a legacy JID string. Legacy strings require an unambiguous active connection. 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" (jabber-activity--jid 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 () "Remove retired owners without clearing another account's activity." (setq jabber-activity-jids (seq-filter #'jabber-activity--owner jabber-activity-jids) jabber-activity-personal-jids (seq-filter #'jabber-activity--owner jabber-activity-personal-jids) jabber-activity-name-alist (seq-filter (lambda (entry) (jabber-activity--owner (car entry))) jabber-activity-name-alist)) (clrhash jabber-activity--shortened-names) (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.15.1/lisp/jabber-ahc-presence.el000066400000000000000000000111211527111033600211550ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-ahc.el000066400000000000000000000405041527111033600173620ustar00rootroot00000000000000;;; 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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Request command list from: " nil nil nil nil nil jc)))) (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))) ;; Newer popup revisions generate these launchers at first initialization. (declare-function jabber-ahc-command-list-map-popup "jabber-ahc" () t) (unless (boundp 'jabber-ahc-command-list-map) (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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Execute command of: " nil nil nil nil nil jc) (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.15.1/lisp/jabber-alert.el000066400000000000000000000550241527111033600177410ustar00rootroot00000000000000;;; 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) (declare-function jabber-chat--buffer-peer-p "jabber-chat" (buffer from muc-private-p)) (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 (defvar jabber-chatting-with) ; jabber-chatbuffer.el (defvar jabber-group) ; jabber-chatbuffer.el (defvar jabber-send-function) ; jabber-input.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))))) (let ((jc (and (buffer-live-p buffer) (buffer-local-value 'jabber-buffer-connection buffer)))) (if (and jc (jabber-jid-resource from) (jabber-muc-joined-p (jabber-jid-user from) jc)) (format "Private message from %s in %s" (jabber-jid-resource from) (jabber-jid-displayname (jabber-jid-user from) jc)) (format "%s:" (jabber-jid-displayname from jc)))))) (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))))) (let ((jc (and (buffer-live-p buffer) (buffer-local-value 'jabber-buffer-connection buffer)))) (if nick (unless (jabber-muc-our-nick-p group nick) (format "Message from %s in %s" nick (jabber-jid-displayname group jc))) (format "Message in %s" (jabber-jid-displayname group jc)))))) (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-let* ((jc (jabber-jid-owner who)) ((memq jc jabber-connections)) ((seq-find (lambda (buffer) (and (eq (buffer-local-value 'jabber-buffer-connection buffer) jc) (jabber-chat--buffer-peer-p buffer (symbol-name who) nil))) (buffer-list)))) (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--message (text) "Return the first configured automatic reply matching TEXT." (cl-loop for (regexp . answer) in jabber-autoanswer-alist when (string-match regexp text) return answer)) (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-live-p buffer) text proposed-alert jabber-autoanswer-alist) (with-current-buffer buffer (when (and (memq jabber-buffer-connection jabber-connections) (not jabber-group) (stringp jabber-chatting-with) (or (equal from jabber-chatting-with) (and (not (jabber-jid-resource jabber-chatting-with)) (equal (jabber-jid-user from) jabber-chatting-with)))) (when-let* ((message (jabber-autoanswer--message text)) (send jabber-alert-chat-send-function)) (funcall send jabber-buffer-connection message)))))) (cl-pushnew 'jabber-autoanswer-answer (get 'jabber-alert-message-hooks 'custom-options)) (defun jabber-autoanswer-answer-muc (nick group buffer text proposed-alert) "Auto-reply to MUC TEXT from NICK in GROUP using `jabber-autoanswer-alist'. Reply to the room using BUFFER's sender, not privately to NICK. PROPOSED-ALERT gates the action; stale or absent room buffers stay silent." (when (and nick group (buffer-live-p buffer) text proposed-alert jabber-autoanswer-alist) (with-current-buffer buffer (when (and (memq jabber-buffer-connection jabber-connections) (equal jabber-group group) (jabber-muc-joined-p group jabber-buffer-connection)) (when-let* ((message (jabber-autoanswer--message text)) (send jabber-send-function)) (funcall send jabber-buffer-connection message)))))) (cl-pushnew 'jabber-autoanswer-answer-muc (get 'jabber-alert-muc-hooks 'custom-options)) (provide 'jabber-alert) ;;; jabber-alert.el ends here emacs-jabber-0.15.1/lisp/jabber-autoaway.el000066400000000000000000000211311527111033600204540ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-avatar.el000066400000000000000000000164661527111033600201170ustar00rootroot00000000000000;;; 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 &optional jc) "Set the avatar of JID to be AVATAR. JID is a string containing a bare JID. JC selects the contact owner. 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 jc)) 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.15.1/lisp/jabber-blocking.el000066400000000000000000000356311527111033600204240ustar00rootroot00000000000000;;; 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 'subr-x) (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 (defvar jabber-post-connect-hooks) (defvar jabber-blocking-ready-hook nil "Hook called with a connection after blocking discovery settles. Run after a successful blocklist fetch or discovery of an unsupported server.") (defun jabber-blocking-ready-p (jc jid) "Return non-nil when JC's blocking discovery permits work for JID. Own-account work proceeds while peer work waits for a successful snapshot. Connections not using startup discovery retain their previous behavior." (let ((state (fsm-get-state-data jc))) (or (not (memq (plist-get state :blocking-status) '(pending failed))) (equal (jabber-jid-user jid) (concat (plist-get state :username) "@" (plist-get state :server)))))) (defun jabber-blocking--ready (jc status) "Mark blocking discovery on JC as STATUS and release background work." (plist-put (fsm-get-state-data jc) :blocking-status status) (run-hook-with-args 'jabber-blocking-ready-hook jc)) (defun jabber-blocking-blocked-p (jc jid) "Return non-nil if JID is known to be blocked on connection JC. Match full JIDs, bare JIDs, domains and domain/resource entries per XEP-0191. Never block communication with the account's own resources. Unknown blocklists are not treated as evidence of a block." (when (stringp jid) (let* ((state (fsm-get-state-data jc)) (bare (downcase (jabber-jid-user jid))) (domain (car (last (split-string bare "@")))) (resource (jabber-jid-resource jid)) (own (downcase (concat (plist-get state :username) "@" (plist-get state :server))))) (and (not (equal bare own)) (cl-some (lambda (entry) (let ((blocked (downcase (jabber-jid-user entry))) (blocked-resource (jabber-jid-resource entry))) (and (or (equal blocked bare) (equal blocked domain)) (or (null blocked-resource) (equal blocked-resource resource))))) (plist-get state :blocking-list)))))) (defun jabber-blocking--valid-items-p (query) "Return non-nil if every item in QUERY has a nonempty JID." (cl-every (lambda (item) (let ((jid (jabber-xml-get-attribute item 'jid))) (and (stringp jid) (not (string-empty-p jid))))) (jabber-xml-get-children query 'item))) (defun jabber-blocking--set-list (state jids) "Store blocked JIDS in connection STATE and invalidate older snapshots." (plist-put state :blocking-list jids) (plist-put state :blocking-revision (list nil))) (defun jabber-blocking--session-predicate (jc) "Return a predicate checking JC's captured connection and session. FSM state plists may be replaced during ordinary Stream Management work. Capture lifecycle values instead, and always consult the current plist." (let* ((state (fsm-get-state-data jc)) (connection (plist-get state :connection)) (stream (plist-get state :session-id)) (session (plist-get state :blocking-session)) (username (plist-get state :username)) (server (plist-get state :server))) (lambda () (let ((current (fsm-get-state-data jc))) (and (eq connection (plist-get current :connection)) (equal stream (plist-get current :session-id)) (eq session (plist-get current :blocking-session)) (equal username (plist-get current :username)) (equal server (plist-get current :server))))))) (defun jabber-blocking--response-predicate (jc kind) "Return an IQ admission predicate for JC's blocking request of KIND. KIND is `disco', `snapshot' or `command'. Reject foreign senders, connections and retired sessions before they can consume a pending IQ." (let* ((state (fsm-get-state-data jc)) (current-p (jabber-blocking--session-predicate jc)) (server (plist-get state :server)) (bare (concat (plist-get state :username) "@" server))) (lambda (received-jc xml) (let ((from (jabber-xml-get-attribute xml 'from)) (query (jabber-iq-query xml))) (and (eq received-jc jc) (funcall current-p) (or (null from) (equal from server) (and (not (eq kind 'disco)) (equal from bare))) (if (equal (jabber-xml-get-attribute xml 'type) "error") (jabber-iq-error xml) (pcase kind ('disco (and (eq (car-safe query) 'query) (equal (jabber-xml-get-xmlns query) jabber-disco-xmlns-info) (null (jabber-xml-get-attribute query 'node)))) ('snapshot (and (eq (car-safe query) 'blocklist) (equal (jabber-xml-get-xmlns query) jabber-blocking-xmlns) (jabber-blocking--valid-items-p query))) ('command (null query))))))))) (defun jabber-blocking--fetch (jc &optional callback) "Synchronize JC's blocklist, then call CALLBACK with the result stanza. Retain known state on failure. Retry snapshots overtaken by a push." (let* ((state (fsm-get-state-data jc)) (revision (plist-get state :blocking-revision)) (current-p (jabber-blocking--session-predicate jc))) (jabber-send-iq jc nil "get" `(blocklist ((xmlns . ,jabber-blocking-xmlns))) (lambda (_jc xml _ctx) (when (funcall current-p) (let ((state (fsm-get-state-data jc))) (if (not (eq revision (plist-get state :blocking-revision))) (jabber-blocking--fetch jc callback) (let ((query (car (jabber-xml-get-children xml 'blocklist)))) (when (and (equal (jabber-xml-get-xmlns query) jabber-blocking-xmlns) (jabber-blocking--valid-items-p query)) (jabber-blocking--set-list state (jabber-blocking--item-jids query)) (jabber-blocking--ready jc 'ready) (when callback (funcall callback jc xml nil)))))))) nil (lambda (_jc xml _ctx) (when (funcall current-p) (let ((state (fsm-get-state-data jc))) (when (and (eq revision (plist-get state :blocking-revision)) (not (eq (plist-get state :blocking-status) 'ready))) (plist-put state :blocking-status 'failed)) (message "Failed to retrieve blocklist: %s" (jabber-parse-error (jabber-iq-error xml)))))) nil nil (jabber-blocking--response-predicate jc 'snapshot)))) (defun jabber-blocking--on-connect (jc) "Discover blocking support and synchronize the blocklist on JC." (let* ((state (fsm-get-state-data jc)) (session (list nil))) (plist-put state :blocking-session session) (plist-put state :blocking-status 'pending) (let ((current-p (jabber-blocking--session-predicate jc))) (jabber-disco-get-info jc (plist-get state :server) nil (lambda (_jc _ctx info) (when (funcall current-p) (let ((state (fsm-get-state-data jc))) (cond ((eq (car info) 'error) (plist-put state :blocking-status 'failed)) ((member jabber-blocking-xmlns (cadr info)) (jabber-blocking--fetch jc)) (t (jabber-blocking--set-list state nil) (jabber-blocking--ready jc 'unsupported)))))) nil t (jabber-blocking--response-predicate jc 'disco))))) (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))) (if (jabber-xml-get-children query 'item) (cl-remove-if (lambda (jid) (member jid jids)) current) nil))) (_ 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 bare)))) (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 (equal (jabber-xml-get-attribute xml-data 'type) "set") (equal (jabber-xml-get-xmlns query) jabber-blocking-xmlns) (jabber-blocking--valid-items-p query) (jabber-blocking--valid-push-p from state-data) (memq (jabber-xml-node-name query) '(block unblock))) (jabber-blocking--set-list state-data (jabber-blocking--apply-push (plist-get state-data :blocking-list) query)) (jabber-send-iq jc from "result" nil nil nil nil nil id)))) (defun jabber-blocking--change (jc jid action) "Ask JC's server to apply blocking ACTION to JID. Refresh the authoritative snapshot after success instead of replaying a possibly stale command over newer pushes." (let ((current-p (jabber-blocking--session-predicate jc))) (jabber-send-iq jc nil "set" `(,action ((xmlns . ,jabber-blocking-xmlns)) (item ((jid . ,jid)))) (lambda (_jc _xml _ctx) (when (funcall current-p) (jabber-blocking--fetch jc) (message "%s %s" (if (eq action 'block) "Blocked" "Unblocked") jid))) nil (lambda (_jc xml _ctx) (message "Failed to %s %s: %s" action jid (jabber-parse-error (jabber-iq-error xml)))) nil nil (jabber-blocking--response-predicate jc 'command)))) ;;;###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: " nil nil nil nil nil jc)))) (jabber-blocking--change jc jid 'block)) ;;;###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: " nil nil nil nil nil jc)))) (jabber-blocking--change jc jid 'unblock)) ;;;###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-blocking--fetch jc #'jabber-blocking--display-list)) (defun jabber-blocking--display-list (jc xml-data _closure) "Display the blocklist from XML-DATA. JC is the Jabber connection." (let* ((blocklist (jabber-xml-get-children (car (jabber-xml-get-children xml-data 'blocklist)) 'item)) (jids (mapcar (lambda (item) (jabber-xml-get-attribute item 'jid)) blocklist))) (if (null jids) (message "Blocklist for %s is empty" (jabber-connection-bare-jid jc)) (with-output-to-temp-buffer "*jabber-blocklist*" (princ (format "Blocklist for %s:\n\n" (jabber-connection-bare-jid jc))) (dolist (jid jids) (princ (format " %s\n" jid))))))) ;;;###autoload (defun jabber-blocking-block-chat-peer (jc) "Block the JID of the current chat buffer. JC is the Jabber connection." (interactive (list jabber-buffer-connection)) (unless (bound-and-true-p jabber-chatting-with) (user-error "Not in a chat buffer")) (let ((jid (jabber-jid-user jabber-chatting-with))) (when (yes-or-no-p (format "Block %s? " jid)) (jabber-blocking-block-jid jc jid)))) ;;;###autoload (defun jabber-blocking-toggle-chat-peer (jc) "Toggle block state of the JID in the current chat buffer. Fetches the blocklist from the server, then blocks or unblocks accordingly. JC is the Jabber connection." (interactive (list jabber-buffer-connection)) (unless (bound-and-true-p jabber-chatting-with) (user-error "Not in a chat buffer")) (let ((jid (jabber-jid-user jabber-chatting-with))) (jabber-blocking--fetch jc (lambda (jc xml-data _ctx) (jabber-blocking--toggle jc xml-data jid))))) (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) (add-hook 'jabber-post-connect-hooks #'jabber-blocking--on-connect -90) (provide 'jabber-blocking) ;;; jabber-blocking.el ends here emacs-jabber-0.15.1/lisp/jabber-bookmarks.el000066400000000000000000000764431527111033600206320ustar00rootroot00000000000000;;; 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--join-active-p "jabber-muc") (autoload 'jabber-muc--autojoin-queued-p "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 (or (jabber-muc--join-active-p jc jid) (jabber-muc--autojoin-queued-p jc jid)) (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 (defvar jabber-bookmarks-edit-map) (defvar jabber-bookmarks-mode-map) ;; Newer popup revisions generate these launchers at first initialization. (declare-function jabber-bookmarks-edit-map-popup "jabber-bookmarks" () t) (unless (boundp 'jabber-bookmarks-edit-map) (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)) (unless (boundp 'jabber-bookmarks-mode-map) (defvar-keymap jabber-bookmarks-mode-map :doc "Bookmarks commands." :parent tabulated-list-mode-map "h" #'jabber-bookmarks-menu "?" #'jabber-bookmarks-menu "a" #'jabber-bookmarks-add "d" #'jabber-bookmarks-delete "t" #'jabber-bookmarks-toggle-autojoin "e" #'jabber-bookmarks--edit-menu "g" #'revert-buffer) (keymap-popup-annotate jabber-bookmarks-mode-map :group "Bookmark" jabber-bookmarks-add "Add bookmark" jabber-bookmarks-delete "Delete bookmark" jabber-bookmarks-toggle-autojoin "Toggle autojoin" jabber-bookmarks--edit-menu "Edit bookmark" revert-buffer "Refresh")) (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.15.1/lisp/jabber-browse.el000066400000000000000000000103071527111033600201260ustar00rootroot00000000000000;;; 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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "browse: " nil nil nil nil t jc)))) (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.15.1/lisp/jabber-buffer-registry.el000066400000000000000000000052321527111033600217450ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-carbons.el000066400000000000000000000062321527111033600202560ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-chat-commands.el000066400000000000000000000263601527111033600213510ustar00rootroot00000000000000;;; 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 &optional jc)) (declare-function jabber-omemo-fingerprints "jabber-omemo-trust" ()) ;; Generated by `keymap-popup-define' when initializing the operations map. (declare-function jabber-chat-operations-menu-map-popup "jabber-chat-commands" () t) (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)) ;; Newer popup revisions generate these launchers at first initialization. (declare-function jabber-chat-encryption-menu-map-popup "jabber-chat-commands" () t) (unless (boundp 'jabber-chat-encryption-menu-map) (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-buffer-connection))) (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)) ;; Initialize bindings once, including the native title filter: the declared ;; popup floor applies :if only to presentation. Retain user edits on reload. (unless (boundp 'jabber-chat-operations-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)) (keymap-set jabber-chat-operations-menu-map "L" '(menu-item "Set thread title..." jabber-message-thread-set-title :filter (lambda (command) (and (bound-and-true-p jabber-message-thread-id) command))))) (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'.") ;; The predecessor already provided this feature, but had no initialization ;; sentinel. Feature presence distinguishes its retained map from first load ;; without inferring whether any binding belongs to the user. (unless (featurep 'jabber-chat-commands) (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.15.1/lisp/jabber-chat.el000066400000000000000000003761541527111033600175630ustar00rootroot00000000000000;;; 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 'xref) (require 'subr-x) (require 'url-parse) (require 'url-queue) (require 'hex-util) (require 'jabber-image) (require 'jabber-link-preview) (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 jabber-buffer-connection))) (propertize " " 'display (get buddy 'avatar))))) (:eval (jabber-jid-displayname jabber-chatting-with jabber-buffer-connection)) " " (:eval (let ((buddy (jabber-jid-symbol jabber-chatting-with jabber-buffer-connection))) (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 jabber-buffer-connection) '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"))) (defcustom jabber-chat-display-link-previews t "When non-nil, fetch previews for newly displayed live HTTPS links. Archived messages are never fetched automatically." :type 'boolean :group 'jabber-chat) (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-print-link-preview jabber-chat-goto-address jabber-chat-mark-link-preview-url jabber-chat--schedule-link-preview 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 printer-chain functions can style or fontify only the body region.") (defvar jabber-chat--link-preview-waiters (make-hash-table :test #'equal) "Map preview URLs to live (BUFFER . EWOC-NODE) consumers.") (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.") (defvar jabber-chat--send-context-captured nil "Non-nil while hooks run with already captured reply/thread extensions. Composition hooks must not read or consume the current one-shot state.") (defun jabber-chat--run-send-hooks (stanza body id &optional captured check) "Run `jabber-chat-send-hooks' and nconc results onto STANZA. BODY and ID are passed to each hook function. Non-nil CAPTURED means reply/thread extensions were captured before deferred discovery, so composition hooks must leave current input state untouched. CHECK, when non-nil, must signal if ownership changed; call it around each hook. Correction stanzas likewise leave one-shot composition state untouched." (let ((jabber-chat--send-hook-stanza stanza) (jabber-chat--send-context-captured captured) (jabber-chat--sending-correction (and (jabber-xml-child-with-xmlns stanza "urn:xmpp:message-correct:0") t))) (dolist (hook (seq-mapcat (lambda (hook) (if (eq hook t) (when (local-variable-p 'jabber-chat-send-hooks) (copy-sequence (default-value 'jabber-chat-send-hooks))) (list hook))) jabber-chat-send-hooks)) (when check (funcall check)) (nconc stanza (save-current-buffer (funcall hook body id))) (when check (funcall check))))) (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 jabber-chat--send-context-captured (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 &optional stanza) "Return the pending reply extension for BODY unless CORRECTION-P. An explicit reply in STANZA takes precedence over pending composition state." (unless (or correction-p (jabber-xml-child-with-xmlns stanza "urn:xmpp:reply:0")) (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 () "Consume the one-shot reply state of the composed message." (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 stanza)) (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 success-callback failure-callback)) (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 jc)) (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* ((chunk (cl-subseq entries 0 (min jabber-chat-backlog-chunk-size (length entries)))) (rest (nthcdr (length chunk) entries))) (jabber-chat-buffer--call-with-transcript #'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) (jabber-db--message-identity 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.") (defvar jabber-chat--decrypt-undo nil "Functions to call if the enclosing storage transaction rolls back. Nil outside such a transaction. Each restores in-memory state that processing inside it consumed or changed, so a retry starts again from the restored durable state.") (defvar jabber-chat--decrypt-commit nil "Effects deferred until the enclosing storage transaction commits.") (defun jabber-chat--on-decrypt-rollback (function) "Call FUNCTION if the enclosing storage transaction rolls back." (when jabber-chat--decrypt-undo (push function jabber-chat--decrypt-undo))) (defun jabber-chat--restore-on-rollback (&rest symbols) "Restore SYMBOLS' current values here if the transaction rolls back. Buffer-local SYMBOLS are restored in the current buffer." (let ((buffer (current-buffer)) (values (mapcar #'symbol-value symbols))) (jabber-chat--on-decrypt-rollback (lambda () (when (buffer-live-p buffer) (with-current-buffer buffer (let ((values values)) (dolist (symbol symbols) (set symbol (pop values)))))))))) (defun jabber-chat--on-decrypt-commit (function) "Call FUNCTION after the enclosing storage transaction commits. Outside such a transaction, call it now." (if jabber-chat--decrypt-undo (push function jabber-chat--decrypt-commit) (funcall function))) ;;; 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))) (jabber-chat--on-decrypt-rollback (lambda () (remhash key jabber-chat--decrypt-cache))))) result) finally return xml-data)) (defvar jabber-activity--event-owner) (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)))) (origin-peer (and (buffer-live-p alert-buffer) (buffer-local-value 'jabber-chatting-with alert-buffer))) (origin-mode (and (buffer-live-p alert-buffer) (buffer-local-value 'major-mode alert-buffer)))) (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 (buffer-live-p chat-buffer) (buffer-local-value 'jabber-chat-mam-syncing chat-buffer)))) (cl-labels ((origin () ;; Retire the captured origin permanently if a callback ;; changes its account, peer or mode, or kills it. (unless (and (buffer-live-p alert-buffer) (eq (buffer-local-value 'jabber-buffer-connection alert-buffer) jc) (equal (buffer-local-value 'jabber-chatting-with alert-buffer) origin-peer) (eq (buffer-local-value 'major-mode alert-buffer) origin-mode)) (setq alert-buffer nil)) alert-buffer)) (dolist (hook '(jabber-message-hooks jabber-alert-message-hooks)) (let ((title (save-current-buffer (funcall jabber-alert-message-function from (origin) body-text)))) (run-hook-wrapped hook (lambda (function) (save-current-buffer (let ((jabber-activity--event-owner jc)) (funcall function from (origin) body-text title))) nil))))))))) (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 &optional jc) "Log MSG-PLIST's error from FROM on JC when no buffer is open." (message "jabber: error from %s: %s" (jabber-jid-displayname from jc) (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 jc))) (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 jc)) (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 the chat buffer. EXTRA-ELEMENTS are XML elements spliced after the body. Optional SUCCESS-CALLBACK and FAILURE-CALLBACK report transport completion, not merely acceptance into the Stream Management queue." (let ((buffer (current-buffer)) (owner-p (jabber-chat--capture-input-owner)) (context (list :state (jabber-chat--send-context-state (assq 'replace extra-elements)))) (completion (unless (assq 'replace extra-elements) jabber-chat--input-completion)) accepted) (unwind-protect (prog1 (jabber-chat--send jc body extra-elements success-callback failure-callback) (setq accepted t)) (when (and (not accepted) ;; A provider may already have settled failure or lost its ;; composer to a new edit before propagating quit. (or (not completion) (funcall completion nil)) (buffer-live-p buffer)) (with-current-buffer buffer (when (funcall owner-p) (jabber-chat--restore-send-context context))))))) (defun jabber-chat--send (jc body extra-elements success-callback failure-callback) "Dispatch BODY on JC with EXTRA-ELEMENTS using the selected encryption. SUCCESS-CALLBACK and FAILURE-CALLBACK report transport completion." (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 success-callback failure-callback)) (_ (jabber-chat--send-plaintext jc body extra-elements success-callback failure-callback)))) (defun jabber-chat--send-plaintext (jc body extra-elements success failure) "Send plaintext BODY on JC with EXTRA-ELEMENTS. Call SUCCESS or FAILURE on transport completion. Settle input before fallible local publication, never merely on queue admission." (let* ((buffer (current-buffer)) (owner-p (jabber-chat--capture-input-owner)) (correction-p (assq 'replace extra-elements)) (completion (unless correction-p jabber-chat--input-completion)) (context (list :state (jabber-chat--send-context-state correction-p))) (id (format "emacs-msg-%.6f" (float-time))) (stanza `(message ((to . ,jabber-chatting-with) (type . "chat") (id . ,id)) (body () ,body) ,@extra-elements)) settled failure-reason) (when completion (setq jabber-chat--input-deferred t)) (jabber-chat--run-send-hooks stanza body id) (jabber-send-sexp jc stanza (lambda () (unless settled (setq settled t) (when completion (funcall completion t)) (when success (funcall success)) ;; Consumers can replace the owner, even during synchronous sends. (when (and (not correction-p) (funcall owner-p)) (with-current-buffer buffer (let ((msg-plist (jabber-chat--msg-plist-from-stanza stanza))) (plist-put msg-plist :status :sent) (jabber-chat--display-local-message jc msg-plist)))))) (lambda (reason) (unless settled (setq settled t failure-reason reason) (let ((restore (if completion (funcall completion nil) t))) (when (and restore (funcall owner-p)) (with-current-buffer buffer (jabber-chat--restore-send-context context)))) (if failure (funcall failure reason) (message "%s" reason))))) (when failure-reason (error "%s" failure-reason)))) (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 shared reply metadata from XML-DATA." (jabber-xml-reply-fallback-range xml-data)) (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 shared reply metadata from XML-DATA." (jabber-xml-reply-fields 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) :occupant-id (jabber-db--extract-occupant-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 jabber-buffer-connection))) (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 jabber-buffer-connection))))) (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) (plist-get msg :reply-to-jid)))) (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. Save the starting position for `xref-go-back' (\\[xref-go-back])." (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")) (xref-push-marker-stack) (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). (jabber-chat-buffer--call-with-transcript #'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-buffer-connection))))) (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) jabber-buffer-connection))))) (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-print-link-preview (msg _who mode) "Print cached link metadata for MSG in display MODE." (when-let* ((url (jabber-link-preview-url (plist-get msg :body))) (metadata (jabber-link-preview-get url)) ((listp metadata)) ((plist-get metadata :url)) ((not (plist-get metadata :error)))) (when (eql mode :insert) (let ((start (point))) (insert (jabber-link-preview-format metadata)) (jabber-chat--add-url-keymap start (point)))) t)) (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) (define-key map "+" #'jabber-chat-image-enlarge) (define-key map "=" #'jabber-chat-image-enlarge) (define-key map "-" #'jabber-chat-image-shrink) (define-key map "0" #'jabber-chat-image-reset-size) map) "Keymap active on images, attachments, and preview URLs in chats.") (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) (get-text-property (point) 'jabber-chat-link-preview-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--ewoc-node-live-p (node) "Return non-nil when NODE still belongs to `jabber-chat-ewoc'." (let ((candidate (and jabber-chat-ewoc (ewoc-nth jabber-chat-ewoc 0))) found) (while (and candidate (not found)) (if (eq candidate node) (setq found t) (setq candidate (ewoc-next jabber-chat-ewoc candidate)))) found)) (defun jabber-chat--handle-link-preview (result url token _node buffer) "Cache preview RESULT for URL and redraw its waiting messages. TOKEN identifies the request so stale callbacks cannot replace newer state. Report the result in BUFFER. _NODE is retained for existing callbacks." (when (equal (jabber-link-preview-get url) token) (jabber-link-preview-put url result) (jabber-chat--redraw-link-preview-waiters url) (when (buffer-live-p buffer) (with-current-buffer buffer (if (plist-get result :error) (message "Link preview unavailable: %s" (plist-get result :error)) (message "Link preview loaded")))))) (defun jabber-chat--register-link-preview-waiter (url buffer node) "Register BUFFER and NODE as a consumer of URL preview." (let ((entry (cons buffer node))) (unless (member entry (gethash url jabber-chat--link-preview-waiters)) (puthash url (cons entry (gethash url jabber-chat--link-preview-waiters)) jabber-chat--link-preview-waiters)))) (defun jabber-chat--redraw-link-preview-waiters (url) "Redraw every still-live message waiting for URL preview." (let ((waiters (gethash url jabber-chat--link-preview-waiters))) (remhash url jabber-chat--link-preview-waiters) (dolist (entry waiters) (when (buffer-live-p (car entry)) (with-current-buffer (car entry) (when (jabber-chat--ewoc-node-live-p (cdr entry)) (jabber-chat-ewoc-invalidate (cdr entry)))))))) (defun jabber-chat--load-link-preview-at-point (url) "Load or open the link preview for URL at point." (let ((cached (jabber-link-preview-get url)) (node (and jabber-chat-ewoc (ewoc-locate jabber-chat-ewoc (point))))) (cond ((and cached (listp cached) (plist-get cached :url) (not (plist-get cached :error))) (browse-url url)) ((or (not jabber-chat-ewoc) (not node)) (user-error "No chat message at point")) (t (jabber-chat--register-link-preview-waiter url (current-buffer) node) (if (eq (car-safe cached) 'loading) (message "Link preview fetch already in progress") (let ((token (list 'loading (gensym "jabber-preview-")))) (jabber-link-preview-put url token) (jabber-link-preview-fetch url #'jabber-chat--handle-link-preview url token node (current-buffer)) (message "Loading link preview..."))))))) (defun jabber-chat-url-action-at-point (&optional arg) "Load a preview or image at point, 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. A page URL loads its preview; once loaded, RET opens it." (interactive "P") (let ((file-url (get-text-property (point) 'jabber-chat-file-url)) (image-url (get-text-property (point) 'jabber-chat-image-url)) (preview-url (get-text-property (point) 'jabber-chat-link-preview-url))) (cond (file-url (jabber-chat-download-url file-url)) ((and image-url (or arg (get-text-property (point) 'display))) (jabber-chat-download-url image-url)) (image-url (jabber-chat--load-image-at-point)) (preview-url (jabber-chat--load-link-preview-at-point preview-url)) (t (user-error "No actionable URL 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 ;; Preserve the original bytes, but keep handlers such as TRAMP. (let ((jka-compr-inhibit t) (coding-system-for-write 'no-conversion)) (write-region plaintext nil dest-file nil 'silent)) (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) (buffer-undo-list 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." (let ((buffer-undo-list t)) (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) (buffer-undo-list 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) "Put the URL between BEG and END at the start of 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) (jabber-chat-buffer--call-with-transcript (lambda () (let ((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-link-preview-url (msg _who mode) "Mark the first eligible page URL in MSG when MODE is `:insert'." (when (eql mode :insert) (when-let* ((url (jabber-link-preview-url (plist-get msg :body)))) (save-excursion (let ((end (point))) (goto-char (or jabber-chat--body-start (point-min))) (when (search-forward url end t) (let ((start (- (point) (length url)))) (add-text-properties start (point) (list 'jabber-chat-link-preview-url url 'help-echo "RET: load link preview; w: copy URL")) (if-let* ((overlay (seq-find (lambda (candidate) (overlay-get candidate 'goto-address)) (overlays-in start (point))))) (let ((map (copy-keymap jabber-chat-url-keymap))) (set-keymap-parent map (overlay-get overlay 'keymap)) (overlay-put overlay 'keymap map)) (jabber-chat--add-url-keymap start (point)))))))))) (defun jabber-chat--auto-load-link-preview (buffer marker url) "Load URL at MARKER when BUFFER still displays the same preview link." (when (and (buffer-live-p buffer) (marker-position marker)) (with-current-buffer buffer (save-excursion (goto-char marker) (when (and (equal (get-text-property (point) 'jabber-chat-link-preview-url) url) (let ((cached (jabber-link-preview-get url))) (or (null cached) (eq (car-safe cached) 'loading)))) (jabber-chat--load-link-preview-at-point url))))) (set-marker marker nil)) (defun jabber-chat--schedule-link-preview (msg _who mode) "Schedule an automatic preview for a newly displayed live MSG. MODE follows the `jabber-chat-printers' contract." (when (and jabber-chat-display-link-previews (eql mode :insert) (not (plist-get msg :delayed))) (when-let* ((url (jabber-link-preview-url (plist-get msg :body))) (cached (list (jabber-link-preview-get url))) ((or (null (car cached)) (eq (car-safe (car cached)) 'loading)))) (save-excursion (when (search-backward url jabber-chat--body-start t) (run-at-time 0 nil #'jabber-chat--auto-load-link-preview (current-buffer) (copy-marker (point)) url)))))) (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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "to: " nil nil nil nil nil jc) (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.15.1/lisp/jabber-chatbuffer.el000066400000000000000000001063561527111033600207500ustar00rootroot00000000000000;;; 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) (defvar jabber-message-thread-id) ; jabber-message-thread requires this library. (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 "M-p" #'jabber-chat-input-history-previous "M-n" #'jabber-chat-input-history-next "" #'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 (jabber-chat-ewoc-refresh) (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) (jabber-chat-ewoc-register-node (jabber-chat-buffer--call-with-transcript #'ewoc-enter-last jabber-chat-ewoc data) 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-buffer--call-with-transcript (function &rest args) "Call FUNCTION with ARGS without recording transcript edits in undo. Keep composer positions aligned when transcript length changes. FUNCTION must leave the draft text after `jabber-point-insert' untouched." (let* ((input (and (markerp jabber-point-insert) (marker-position jabber-point-insert))) (draft-length (and input (- (point-max) input))) (offset (and input (>= (point) input) (- (point) input))) (windows (and input (mapcar (lambda (window) (cons window (and (>= (window-point window) input) (- (window-point window) input)))) (get-buffer-window-list (current-buffer) nil t))))) (unwind-protect (let ((buffer-undo-list t) (inhibit-read-only t)) (save-excursion (apply function args))) (when input ;; Footer replacement collapses nil-insertion-type markers. The ;; untouched draft tail, not that collapsed marker, fixes the boundary. (set-marker jabber-point-insert (- (point-max) draft-length)) (jabber-chat-buffer--shift-undo-list (- jabber-point-insert input)) (dolist (entry windows) (when (and (window-live-p (car entry)) (cdr entry)) (set-window-point (car entry) (+ jabber-point-insert (cdr entry)))))) (when offset (goto-char (+ jabber-point-insert offset)))))) (defun jabber-chat-buffer--reset-header-footer () "Restore the stored EWOC header and footer as read-only transcript text." (let ((hf (ewoc-get-hf jabber-chat-ewoc))) (ewoc-set-hf jabber-chat-ewoc (propertize (car hf) 'read-only t 'front-sticky t 'rear-nonsticky t) (propertize (cdr hf) 'read-only t 'front-sticky t 'rear-nonsticky t)))) (defun jabber-chat-ewoc-refresh () "Redraw the transcript and footer, preserving the draft and its undo." (jabber-chat-buffer--call-with-transcript (lambda () (ewoc-refresh jabber-chat-ewoc) ;; `ewoc-refresh' only redraws nodes, not orphaned footer text. (jabber-chat-buffer--reset-header-footer)))) (defun jabber-chat-ewoc-invalidate (node) "Redraw ewoc NODE without recording undo." (jabber-chat-buffer--call-with-transcript #'ewoc-invalidate jabber-chat-ewoc node)) (defun jabber-chat-ewoc-delete (node) "Delete ewoc NODE without recording undo." (jabber-chat-buffer--call-with-transcript #'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)) (node (ewoc-nth jabber-chat-ewoc 0))) (jabber-chat-buffer--call-with-transcript (lambda () (while node (let ((next (ewoc-next jabber-chat-ewoc node))) (ewoc-delete jabber-chat-ewoc node) (setq node next))) (jabber-chat-buffer--reset-header-footer))) ;; 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-sync-complete-functions) ; jabber-mam.el (declare-function jabber-muc-find-buffer "jabber-muc" (group &optional jc)) (defun jabber-chat--update-mam-syncing (jc peer type syncing-p) "Update syncing indicator for PEER's chat buffer on JC. TYPE is \"groupchat\" or \"chat\". SYNCING-P is non-nil when sync starts, nil when it ends." (when-let* ((buffer (if (string= type "groupchat") (jabber-muc-find-buffer peer jc) (jabber-buffer-registry-find 'chat peer))) ((buffer-live-p buffer))) (with-current-buffer buffer (setq jabber-chat-mam-syncing syncing-p) (force-mode-line-update)))) (defun jabber-chat-buffer--reading-history-p () "Return non-nil when a window is reading the current buffer's history. Such a window does not follow the input area, and a refresh may evict what it shows from the reloaded backlog." (seq-some (lambda (window) (not (jabber-chat-buffer--recenter-input-p window))) (get-buffer-window-list (current-buffer) nil t))) (defun jabber-chat--handle-mam-sync-complete (peers &optional progressive) "Refresh chat buffers that received MAM messages. PEERS is a list of (ACCOUNT PEER TYPE) entries. When PROGRESSIVE is non-nil, the sync is still running: skip buffers whose reader is scrolled into history and leave them for the completion refresh." (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))) (unless (and progressive (jabber-chat-buffer--reading-history-p)) (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 (unless (and progressive (jabber-chat-buffer--reading-history-p)) (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.15.1/lisp/jabber-chatstates.el000066400000000000000000000514771527111033600210050ustar00rootroot00000000000000;;; 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.") (defvar-local jabber-chatstates--last-input "" "Draft text at the last command, used to distinguish editing from motion.") ;;; 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-buffer-connection))))))) (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) (setq jabber-chatstates--last-input "") (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 () "Retire and cancel the `paused' and `inactive' timers." (let ((paused jabber-chatstates-paused-timer) (inactive jabber-chatstates-inactive-timer)) (setq jabber-chatstates-paused-timer nil jabber-chatstates-inactive-timer nil) (when paused (cancel-timer paused)) (when inactive (cancel-timer inactive)))) (defun jabber-chatstates--run-with-buffer-timer (seconds function slot) "Call FUNCTION after SECONDS if this buffer still owns the timer in SLOT." (add-hook 'kill-buffer-hook #'jabber-chatstates-stop-timer nil t) (add-hook 'change-major-mode-hook #'jabber-chatstates-stop-timer nil t) (let ((buffer (current-buffer)) timer) (setq timer (run-with-timer seconds nil (lambda () (when (buffer-live-p buffer) (with-current-buffer buffer (when (eq (symbol-value slot) timer) (set slot nil) (funcall function))))))) timer)) (defun jabber-chatstates-kick-timer () "Start or restart the `paused' timer." (jabber-chatstates-stop-timer) (setq jabber-chatstates-paused-timer (jabber-chatstates--run-with-buffer-timer 5 #'jabber-chatstates-send-paused 'jabber-chatstates-paused-timer))) (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 'jabber-chatstates-inactive-timer)))) (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 () "Update chat states and idle deadlines after a command edits the draft." (let ((input (buffer-substring-no-properties jabber-point-insert (point-max)))) (unless (equal input jabber-chatstates--last-input) (setq jabber-chatstates--last-input input) (let ((composing-now (not (string-empty-p input)))) (unless composing-now (jabber-chatstates-stop-timer)) (when (and jabber-chatstates-confirm jabber-chatstates-requested (jabber-chatstates--conversation)) (when (or (not composing-now) (not jabber-chatstates-composing-sent)) (when-let* ((stanza (jabber-chatstates--stanza (if composing-now 'composing 'active)))) (jabber-send-sexp-if-connected jabber-buffer-connection stanza) (setq jabber-chatstates-composing-sent composing-now))) (when 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--restore-thread-on-rollback () "Restore this buffer's thread identity if archive storage rolls back. A renews or retires it alongside durable writes the rollback undoes." (let ((buffer (current-buffer)) (keys jabber-buffer-registry--keys)) (jabber-chat--on-decrypt-rollback (lambda () (when (buffer-live-p buffer) (with-current-buffer buffer (jabber-buffer-registry--remove-current) (setq jabber-buffer-registry--keys keys) (dolist (key keys) (puthash key buffer jabber-buffer-registry--buffers)))))) (jabber-chat--restore-on-rollback 'jabber-message-thread-session-id 'jabber-message-thread-id 'jabber-message-thread-parent-id 'jabber-message-thread--root-reply-id 'jabber-message-thread--root-reply-jid))) (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") (jabber-chatstates-stop-timer) (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) (jabber-chatstates--restore-thread-on-rollback) (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)) (jabber-chatstates-stop-timer) (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.15.1/lisp/jabber-compose.el000066400000000000000000000106521527111033600202750ustar00rootroot00000000000000;;; 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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "To whom? " nil nil nil nil nil jc)))) (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 jc))) "*")))) (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.15.1/lisp/jabber-conn.el000066400000000000000000000504541527111033600175710ustar00rootroot00000000000000;;; 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: (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-conn--cancel-connect (fsm &optional replacement) "Revoke FSM's pending connection attempt and release its resources. Admit REPLACEMENT, or nil for cancellation, before retiring the old attempt." (let ((cancel (get fsm :connect-cancel))) ;; Retire admission before cleanup can run sentinels or buffer hooks. (put fsm :connect-attempt replacement) (put fsm :connect-cancel nil) (when cancel (funcall cancel)))) (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. FSM owns the attempt through its :connect-attempt and :connect-cancel properties until protocol handoff or cancellation." (let* ((proxy (jabber-conn--normalize-proxy proxy)) (attempt (make-symbol "connect-attempt")) errors) ;; ...and connect to them one after another, asynchronously, until ;; connection succeeds. (cl-labels ((active-p () (eq attempt (get fsm :connect-attempt))) (connect (target remaining-targets) (when (active-p) (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) (when (and (active-p) (not 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 attempt)) (fsm-send fsm (list :connected c directtls-p attempt))))) (connection-failed (c status) (when (and (active-p) (not 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) (when (active-p) (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) attempt))))))) (put fsm :connect-cancel (lambda () (setq settled t) (cancel-timeout) (when (processp proc) (set-process-filter proc nil) (set-process-sentinel proc #'ignore)) (jabber-conn--delete-failed-process proc process-buffer))) (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) (when (and (active-p) (not settled) (eq connection proc)) (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 (and (active-p) (not settled) jabber-connection-timeout) (setq timeout-timer (run-at-time jabber-connection-timeout nil (lambda () (connection-failed proc "connection timed out"))))) (unless (active-p) (jabber-conn--delete-failed-process proc process-buffer))) (file-error (connection-failed proc (car (cddr e)))) (error (connection-failed proc (error-message-string e))))))))) ;; Both predecessor cleanup and discovery can yield to stop/replacement. ;; Publish this admission first, then revalidate at each boundary. (jabber-conn--cancel-connect fsm attempt) (when (active-p) (let ((targets (jabber-srv-targets server network-server port proxy))) (when (active-p) (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-conn--tls-element-p (xml-data name) "Return non-nil if XML-DATA is the TLS element NAME." (and (eq (jabber-xml-node-name xml-data) name) (equal (jabber-xml-get-xmlns xml-data) jabber-tls-xmlns))) (defun jabber-conn--starttls-required-p (stream-features) "Return non-nil if STREAM-FEATURES requires STARTTLS." (when-let* ((starttls (cl-find-if (lambda (child) (jabber-conn--tls-element-p child 'starttls)) (jabber-xml-get-children stream-features 'starttls)))) (cl-some (lambda (required) (let ((xmlns (jabber-xml-get-xmlns required))) (or (null xmlns) (equal xmlns jabber-tls-xmlns)))) (jabber-xml-get-children starttls 'required)))) (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 ((jabber-conn--tls-element-p 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))) ((jabber-conn--tls-element-p xml-data 'failure) (error "Command rejected by server")) (t (error "Unexpected STARTTLS response: %s" (jabber-xml-node-name xml-data))))) (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.15.1/lisp/jabber-console.el000066400000000000000000000137651527111033600203020ustar00rootroot00000000000000;;; 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) ;; Chat-buffer support requires the core, which loads the console. (declare-function jabber-chat-buffer--call-with-transcript "jabber-chatbuffer" (function &rest args)) (autoload 'jabber-chat-buffer--call-with-transcript "jabber-chatbuffer") (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 "Approximate number of lines to retain in the console buffer. Keep whole XML entries at the cutoff and always retain the newest entry. Zero disables truncation. The editable draft is never truncated." :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 ;; Keep common commands without inheriting special-mode's typing suppression. :parent (let ((map (copy-keymap jabber-common-keymap))) (set-keymap-parent map sgml-mode-map) map) "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 ((start (point)) (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)))) ;; Own the separator too: EWOC's default wrapper adds it after this guard. (insert "\n") (add-text-properties start (point) '(read-only t front-sticky t rear-nonsticky t)))) (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) (let ((buffer-undo-list t)) (setq jabber-console-ewoc (ewoc-create #'jabber-console-pp "\n" "\n" t)) (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\")." (with-current-buffer (jabber-console-create-buffer jc) (jabber-chat-buffer--call-with-transcript #'ewoc-enter-last jabber-console-ewoc (list direction (jabber-console-sanitize xml-data))) (when (> jabber-console-truncate-lines 0) (let ((jabber-log-lines-to-keep jabber-console-truncate-lines)) (jabber-truncate-top (current-buffer) jabber-console-ewoc))))) (setq jabber-stanza-log-function #'jabber-process-console) (provide 'jabber-console) ;;; jabber-console.el ends here emacs-jabber-0.15.1/lisp/jabber-core.el000066400000000000000000001460411527111033600175620ustar00rootroot00000000000000;;; 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-keepalive-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 jabber-keepalive-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 jabber-keepalive-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)))) ;; fsm 0.2.1 emits the obsolete `cl-gensym' in its constructor. ;; Expand that call to its Emacs 29+ replacement, without changing fsm globally. (cl-macrolet ((jabber--define-state-machine (&rest args) (cl-subst 'gensym 'cl-gensym (macroexpand-1 `(define-state-machine ,@args))))) (jabber--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))))))) (defun jabber-core--close-transport (connection) "Close exact CONNECTION and its buffer without aborting cleanup." (when (processp connection) (let ((buffer (process-buffer connection))) (condition-case err (delete-process connection) ((error quit) (message "Jabber transport cleanup failed: %s" (error-message-string err)))) (when (and (buffer-live-p buffer) (not jabber-debug-keep-process-buffers)) (condition-case err (kill-buffer buffer) ((error quit) (message "Jabber transport buffer cleanup failed: %s" (error-message-string err)))))))) (defun jabber-core--retry-owner-p (fsm state-data) "Return non-nil when FSM owns the retry lease in STATE-DATA." (and (plist-get state-data :nil-entry-token) (null (get fsm :state)) (memq fsm jabber-connections) (not (plist-get state-data :terminalized)) (not (plist-get state-data :disconnection-expected)))) (defun jabber-core--promote-nil-entry-pending (state-data) "Return a copy of STATE-DATA with held work before live pending work." (let ((state-data (copy-sequence state-data))) (setq state-data (plist-put state-data :sm-pending-queue (append (plist-get state-data :nil-entry-pending) (plist-get state-data :sm-pending-queue)))) (plist-put state-data :nil-entry-pending nil))) (defun jabber-core--claim-nil-entry (fsm state-data &optional preserve-pending) "Commit FSM nil entry from STATE-DATA. When PRESERVE-PENDING is non-nil, terminalize held retry work while leaving callback-created current pending entries untouched. Return a plist of captured callback effects and retry authority." (let* ((state-data (copy-sequence state-data)) (connection (plist-get state-data :connection)) (expected (plist-get state-data :disconnection-expected)) (held (plist-get state-data :nil-entry-pending)) (resumable (and (plist-get state-data :sm-enabled) (plist-get state-data :sm-id))) (retrying (and jabber-auto-reconnect (not expected) (not (plist-get state-data :terminalized)) (plist-get state-data :ever-session-established) (memq fsm jabber-connections))) (reset-p (not (and retrying (or resumable (plist-get state-data :sm-fresh-recovery))))) (fresh-loss (and retrying (not resumable) (plist-get state-data :sm-fresh-recovery) (not (plist-get state-data :session-reset-done)))) (reset-claimed (or fresh-loss (and reset-p (or (not (plist-get state-data :session-reset-done)) (plist-get state-data :sm-fresh-recovery))))) (token (make-symbol "nil-entry")) entries) (setq state-data (plist-put state-data :connection nil)) (setq state-data (jabber-sm--stop-r-timer state-data)) (when fresh-loss ;; Establishment reopens the reset claim. Convert a later session's ;; work again, but leave unfinished bind retries in their owned queue. (setq state-data (jabber-sm--handle-failed-resume (jabber-core--promote-nil-entry-pending state-data) '(failed ()))) (setq held nil)) (pcase-let ((`(,detached ,captured) (jabber-sm--take-pending state-data))) (cond ((not reset-p) (setq entries (append held captured)) (setq state-data (plist-put detached :nil-entry-pending entries))) (preserve-pending (setq entries held) (setq state-data (jabber-sm--reset detached)) (setq state-data (plist-put state-data :sm-pending-queue captured)) (setq state-data (plist-put state-data :nil-entry-pending nil))) (t (setq entries (append held captured)) (setq state-data (jabber-sm--reset detached)) (setq state-data (plist-put state-data :nil-entry-pending nil))))) (when reset-claimed (setq state-data (plist-put state-data :session-reset-done t))) (when (and retrying resumable) (setq state-data (plist-put state-data :sm-resuming t))) (setq state-data (plist-put state-data :nil-entry-token token)) (unless retrying (setq state-data (plist-put state-data :terminalized t))) (fsm-stop-timer fsm) (unless retrying (setq jabber-connections (delq fsm jabber-connections))) (put fsm :state-data state-data) (list :state state-data :retrying retrying :retain (not reset-p) :reset reset-claimed :entries entries :connection connection))) (defun jabber-core--settle-nil-entry (fsm state-data &optional suppress-loss preserve-pending) "Settle FSM nil entry from STATE-DATA before arbitrary callbacks. SUPPRESS-LOSS omits repeated loss effects. PRESERVE-PENDING keeps work accepted after an earlier retry claim out of late terminal settlement." (if (plist-get state-data :terminalized) (list (fsm-get-state-data fsm) nil) (let* ((claim (jabber-core--claim-nil-entry fsm state-data preserve-pending)) (claimed (plist-get claim :state)) (token (plist-get claimed :nil-entry-token))) (condition-case err (jabber-conn--cancel-connect fsm) ((error quit) (message "Jabber connection cancellation failed: %s" (error-message-string err)))) (jabber-core--close-transport (plist-get claim :connection)) (when (plist-get claim :reset) (jabber-lifecycle-dispatch-session-reset fsm)) (unless (plist-get claim :retain) (jabber-sm--fail-pending (plist-get claim :entries) "connection closed before transport handoff")) (unless (plist-get claim :retrying) (jabber-lifecycle-dispatch-connection-list-changed)) (unless (or suppress-loss (plist-get claimed :disconnection-expected)) (jabber-lifecycle--dispatch-contained 'jabber-lost-connection-hooks fsm) (message "%s@%s%s: connection lost: `%s'" (plist-get claimed :username) (plist-get claimed :server) (if (plist-get claimed :resource) (concat "/" (plist-get claimed :resource)) "") (plist-get claimed :disconnection-reason))) (let ((current (fsm-get-state-data fsm))) (cond ((or (not (null (get fsm :state))) (not (eq token (plist-get current :nil-entry-token)))) (list current :keep)) ((jabber-core--retry-owner-p fsm current) (when (plist-get claim :retain) (setq current (jabber-core--promote-nil-entry-pending current)) (put fsm :state-data current)) (list current jabber-reconnect-delay)) ((and (plist-get claim :retrying) (not (plist-get current :terminalized))) (jabber-core--settle-nil-entry fsm current t t)) (t (list current nil))))))) (define-enter-state jabber-connection nil (fsm state-data) (jabber-core--settle-nil-entry fsm state-data)) (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 (if (and (timerp (get fsm :timeout)) (jabber-core--retry-owner-p fsm state-data)) (let ((current (jabber-core--promote-nil-entry-pending state-data))) (list :connecting (plist-put current :nil-entry-token nil))) (list nil state-data nil))) (:do-disconnect (let ((current (plist-put (copy-sequence state-data) :disconnection-expected t))) (put fsm :state-data current) (pcase-let ((`(,settled ,timeout) (jabber-core--settle-nil-entry fsm current t))) (list nil settled timeout)))))) (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)) ;; Discovery and process creation can dispatch events. ;; Return their authoritative state, not the entry snapshot; ;; :keep also preserves a reentrant successor's retry timer. (list (fsm-get-state-data fsm) :keep)) (defun jabber-core--connected-state-data (state-data connection directtls-p) "Update STATE-DATA for a new CONNECTION using DIRECTTLS-P." (setq state-data (plist-put state-data :connection connection)) (setq state-data (plist-put state-data :encrypted (and directtls-p t))) (plist-put state-data :disconnection-reason nil)) (define-state jabber-connection :connecting (fsm state-data event _callback) (pcase (or (car-safe event) event) ((and (or :connected :connection-failed) (guard (let ((attempt (if (eq (car event) :connected) (nth 3 event) (nth 2 event)))) (and attempt (not (eq attempt (get fsm :connect-attempt))))))) (list :connecting state-data :keep)) (:connected (let ((connection (cadr event)) (directtls-p (caddr event)) (attempt (get fsm :connect-attempt)) (owner (fsm-get-state-data fsm))) (setq state-data (jabber-core--connected-state-data state-data connection directtls-p)) (if (and (processp connection) (not (process-live-p connection))) (list nil (plist-put state-data :disconnection-reason "Connection closed before protocol handoff")) (when (processp connection) ;; TLS connections leave data in the process buffer, which ;; the XML parser will choke on. Keep the attempt's canceller ;; attached until change hooks finish: stop/replacement ;; must still release this captured transport. (condition-case err (with-current-buffer (process-buffer connection) (erase-buffer)) (error ;; Emacs 29 signals when a change hook kills the ;; buffer. Ignore only a retired handoff's error; ;; a current owner's failure must still propagate. (when (and (eq owner (fsm-get-state-data fsm)) (eq attempt (get fsm :connect-attempt))) (signal (car err) (cdr err)))))) ;; A native change hook may stop or replace this attempt. ;; A nil result leaves the authoritative FSM state and ;; timeout untouched, without reinstalling old handlers. (when (and (eq owner (fsm-get-state-data fsm)) (eq attempt (get fsm :connect-attempt))) (put fsm :connect-attempt nil) (put fsm :connect-cancel nil) (when (processp connection) (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 ;; Nil entry publishes terminal state before cancelling the ;; owned attempt, so cleanup hooks cannot restart its targets. (list nil (plist-put (copy-sequence state-data) :disconnection-expected t))))) (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. (when (eq (cadr event) (plist-get state-data :connection)) (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)))) (defun jabber--sm-protocol-error-transition (fsm state-data err) "Return a closed-stream transition for SM protocol ERR on FSM. STATE-DATA is the connection state to preserve." (let ((reason "Invalid Stream Management acknowledgement")) (when (eq (car err) 'jabber-sm-handled-count-too-high) (let ((h (cadr err)) (sent (caddr err))) (condition-case send-error (jabber-sm--send-count-too-high-error fsm h sent) (error (message "Could not send SM stream error: %s" (error-message-string send-error)))) (setq reason (format "Server acknowledged %d stanzas after %d sent" h sent)))) (list nil (plist-put state-data :disconnection-reason reason)))) (defun jabber-core--active-disconnect-transition (fsm state-data) "Return FSM's terminal transition from STATE-DATA after active close." (let ((current (plist-put (copy-sequence state-data) :disconnection-expected t))) (put fsm :state-data current) (condition-case err (jabber-send-string fsm "") ((error quit) (message "Jabber stream close failed: %s" (error-message-string err)))) (list nil (fsm-get-state-data fsm)))) (define-enter-state jabber-connection :connected (fsm state-data) ;; Publish entry metadata before the send function can ;; dispatch a synchronous stop, reply, or replacement. (put fsm :state-data (plist-put state-data :awaiting-stream-start t)) (jabber-send-stream-header fsm) ;; Next comes the server's start tag. Sending ;; may already have advanced the FSM; preserve its timer too. (list (fsm-get-state-data fsm) :keep)) (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)) (setq state-data (plist-put state-data :awaiting-stream-start nil)) ;; 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 ((plist-get state-data :awaiting-stream-start) (list nil (plist-put state-data :disconnection-reason "Received stanza before the restarted stream header"))) ;; 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 (or (eq (plist-get state-data :connection-type) 'starttls) (jabber-conn--starttls-required-p stanza)) ;; 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-core--active-disconnect-transition fsm state-data)))) (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)) (:stream-start (list nil (plist-put state-data :disconnection-reason "Unexpected stream restart during STARTTLS"))) (: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-core--active-disconnect-transition fsm state-data)))) (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-core--active-disconnect-transition fsm state-data)))) (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-core--active-disconnect-transition fsm state-data)))) (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-core--active-disconnect-transition fsm state-data)))) (defun jabber-core--bind-offered-p (state-data) "Return non-nil for an exact resource-binding offer in STATE-DATA." (cl-some (lambda (node) (equal (jabber-xml-get-xmlns node) jabber-bind-xmlns)) (jabber-xml-get-children (plist-get state-data :stream-features) 'bind))) (defun jabber-core--fresh-bind (jc state-data failed) "Convert retained work on JC before fresh binding after FAILED. Publish STATE-DATA ownership before reset callbacks, then reacquire it." (if (not (jabber-core--bind-offered-p state-data)) (list nil state-data) (let* ((state (get jc :state)) (connection (plist-get state-data :connection)) (converted (jabber-sm--handle-failed-resume state-data failed))) (setq converted (plist-put converted :session-reset-done t)) (put jc :state-data converted) (jabber-lifecycle-dispatch-session-reset jc) (let ((current (fsm-get-state-data jc))) (if (or (not (eq state (get jc :state))) (not (eq connection (plist-get current :connection))) (not (memq jc jabber-connections)) (plist-get current :terminalized)) (list (get jc :state) current :keep) (if (eq state :bind) (progn (jabber--send-bind-request jc current) (list (get jc :state) (fsm-get-state-data jc) :keep)) (list :bind (plist-put current :bind-after-sm-failure 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-core--fresh-bind fsm state-data '(failed ()))) ;; Normal bind flow. ((jabber-core--bind-offered-p state-data) (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-core--active-disconnect-transition fsm state-data)))) (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-core--active-disconnect-transition fsm state-data)))) (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) (condition-case err (list :session-established (jabber-sm--handle-resumed state-data stanza)) (jabber-sm-protocol-error (jabber--sm-protocol-error-transition fsm state-data err)))) ((jabber-sm--failed-p stanza) (condition-case err (jabber-core--fresh-bind fsm state-data stanza) (jabber-sm-protocol-error (jabber--sm-protocol-error-transition fsm state-data err)))) (t (or (jabber-process-stream-error stanza state-data) (list :sm-resume state-data)))))) (:do-disconnect (jabber-core--active-disconnect-transition fsm state-data)))) (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) (setq state-data (copy-sequence state-data)) (setq state-data (plist-put state-data :session-reset-done nil)) (setq state-data (plist-put state-data :nil-entry-token nil)) (setq state-data (plist-put state-data :nil-entry-pending nil)) ;; Establish retry eligibility before callback-capable bootstrap. (setq state-data (plist-put state-data :ever-session-established t)) (put fsm :state-data state-data) (let ((connection (plist-get state-data :connection)) (session (plist-get state-data :session-id))) (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)) (put fsm :state-data state-data) (when (fboundp 'jabber-muc--resume-attempts) (jabber-muc--resume-attempts fsm)) (setq state-data (fsm-get-state-data fsm)) (jabber-lifecycle--dispatch-contained 'jabber-post-resume-hooks fsm)) ;; Normal connect: feature modules fetch initial session data. (jabber-lifecycle-dispatch-session-bootstrap fsm)) (let ((current (fsm-get-state-data fsm))) (if (or (not (eq (get fsm :state) :session-established)) (not (eq connection (plist-get current :connection))) (not (equal session (plist-get current :session-id))) (not (memq fsm jabber-connections))) (list current :keep) ;; Bootstrap may publish fresh state within this session. (jabber-sm--schedule-drain fsm current) (list current 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)) (jabber-sm--schedule-drain fsm state-data) (list :session-established state-data :keep)) (jabber-sm-protocol-error (jabber--sm-protocol-error-transition fsm state-data err)))) (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) ;; Roster hooks can publish a copy and start the SM ;; timer there. Never restore the pre-callback plist. (list (get fsm :state) (fsm-get-state-data fsm) :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 (let ((expected (and (consp event) (cadr event))) (reason (and (consp event) (caddr event)))) (if (or (not (consp event)) (not (eq expected (plist-get state-data :connection)))) (list :session-established state-data :keep) (unless (plist-get state-data :disconnection-reason) (setq state-data (plist-put state-data :disconnection-reason (or reason "Connection process lost")))) (list nil state-data)))) (:do-disconnect (jabber-core--active-disconnect-transition fsm state-data)))) (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) (jabber-clear-roster jc) (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." (when (eq process (plist-get (fsm-get-state-data fsm) :connection)) (with-current-buffer (process-buffer process) ;; Append new data only from the transport that owns this stream. (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.15.1/lisp/jabber-csi.el000066400000000000000000000120321527111033600174000ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-db.el000066400000000000000000003466541527111033600172330ustar00rootroot00000000000000;;; 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, retracted INTEGER NOT NULL DEFAULT 0, origin_id TEXT, room_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 OF body 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.") (defconst jabber-db--archive-message-index-ddl "CREATE INDEX IF NOT EXISTS idx_archive_message_id ON message_archive(message_id)" "Index for exact occurrence reparenting and foreign-owner checks.") (defconst jabber-db--archive-ddl `("CREATE TABLE IF NOT EXISTS mam_progress ( account TEXT NOT NULL, archive TEXT NOT NULL, scope TEXT NOT NULL, uid TEXT, start TEXT, PRIMARY KEY (account, archive, scope))" "CREATE TABLE IF NOT EXISTS message_archive ( account TEXT NOT NULL, archive TEXT NOT NULL, uid TEXT NOT NULL, message_id INTEGER NOT NULL REFERENCES message(id) ON DELETE CASCADE, PRIMARY KEY (account, archive, uid))" ,jabber-db--archive-message-index-ddl) "Archive coverage and occurrence schema; empty scope means all peers. An absent start records an unbounded scan, not an inferred history date.") (defconst jabber-db--identity-index-ddl '("CREATE INDEX IF NOT EXISTS idx_msg_origin_id ON message(account, origin_id) WHERE origin_id IS NOT NULL" "CREATE INDEX IF NOT EXISTS idx_msg_room_id ON message(account, room_id) WHERE room_id IS NOT NULL") "Nonunique identity indexes; collisions must remain visible to admission.") (defun jabber-db--init-schema (db) "Initialize the database schema in DB." (dolist (ddl (append jabber-db--schema-ddl jabber-db--archive-ddl jabber-db--identity-index-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 15 "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))))) (defmacro jabber-db--with-savepoint (db &rest body) "Execute BODY atomically on DB, including on nonlocal exits. Savepoints permit migration inside a caller-owned transaction." (declare (indent 1) (debug t)) (let ((connection (make-symbol "connection")) (complete (make-symbol "complete"))) `(let ((,connection ,db) (,complete nil)) (sqlite-execute ,connection "SAVEPOINT jabber_schema") (unwind-protect (prog1 (progn ,@body) (sqlite-execute ,connection "RELEASE jabber_schema") (setq ,complete t)) (unless ,complete (sqlite-execute ,connection "ROLLBACK TO jabber_schema") (sqlite-execute ,connection "RELEASE jabber_schema")))))) (defun jabber-db--migrate-v1-to-v2 (db) "Migrate DB from schema version 1 to version 2." (jabber-db--with-savepoint db (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." (jabber-db--with-savepoint db (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." (jabber-db--with-savepoint db (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." (jabber-db--with-savepoint db (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." (jabber-db--with-savepoint db (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." (jabber-db--with-savepoint db (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 version 7 to version 8 schema migration to 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 version 8 to version 9 schema migration to 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-v10-to-v11 (db) "Separate retraction state from optional attribution in DB." (jabber-db--with-savepoint db (sqlite-execute db "ALTER TABLE message ADD COLUMN retracted INTEGER NOT NULL DEFAULT 0") (sqlite-execute db "UPDATE message SET retracted = 1 WHERE retracted_by IS NOT NULL") (sqlite-execute db "PRAGMA user_version=11"))) (defun jabber-db--migrate-v11-to-v12 (db) "Preserve identity and archive coverage independently in DB. Never reinterpret historical server IDs or invent historical scan coverage." (jabber-db--with-savepoint db (sqlite-execute db "ALTER TABLE message ADD COLUMN origin_id TEXT") (sqlite-execute db "ALTER TABLE message ADD COLUMN room_id TEXT") (dolist (ddl jabber-db--archive-ddl) (sqlite-execute db ddl)) (sqlite-execute db "PRAGMA user_version=12"))) (defun jabber-db--migrate-v12-to-v13 (db) "Index origin and room duplicate candidates atomically in DB." (jabber-db--with-savepoint db (dolist (ddl jabber-db--identity-index-ddl) (sqlite-execute db ddl)) (sqlite-execute db "PRAGMA user_version=13"))) (defconst jabber-db--split-merge-columns '("occupant_id" "delivered_at" "displayed_at" "retracted_by" "retraction_reason" "reply_to_id" "reply_to_jid" "fallback_start" "fallback_end" "thread_id" "thread_parent_id") "Nullable metadata that may be combined only without conflicting values.") (defun jabber-db--split-reactions-compatible-p (db old live) "Check shared reaction actors on OLD and LIVE in DB for exact agreement. An empty actor snapshot is meaningful; never union conflicting snapshots." (let ((senders (sqlite-select db "SELECT sender FROM message_reaction_actor WHERE message_id = ? UNION SELECT sender FROM message_reaction WHERE message_id = ?" (list old old)))) (cl-every (lambda (entry) (let* ((sender (car entry)) (actors (mapcar (lambda (id) (sqlite-select db "SELECT updated_at FROM message_reaction_actor WHERE message_id = ? AND sender = ?" (list id sender))) (list old live))) (reactions (mapcar (lambda (id) (sqlite-select db "SELECT reaction, updated_at FROM message_reaction WHERE message_id = ? AND sender = ? ORDER BY reaction" (list id sender))) (list old live)))) (or (and (null (cadr actors)) (null (cadr reactions))) (and (equal (car actors) (cadr actors)) (equal (car reactions) (cadr reactions)))))) senders))) (defun jabber-db--split-read-boundaries-compatible-p (db old live) "Reject OLD/LIVE merges crossing an affected thread read boundary in DB. A scalar watermark cannot encode two copies on opposite sides as one row. Check thread membership and non-FK root/read references, even when the watermark points at another message. Remapping OLD's own watermark can also change intervening replies, so reject that case conservatively. Implicit roots use NULL-sensitive stanza/server comparisons; leave those incoming thread pairs untouched rather than changing their unread state." (not (sqlite-select db "SELECT 1 FROM message_thread AS mt JOIN message AS old ON old.id = ? JOIN message AS live ON live.id = ? WHERE mt.account = old.account AND mt.peer = old.peer AND mt.type = old.type AND (mt.thread_id = COALESCE(live.thread_id, old.thread_id) OR mt.root_message_id IN (old.id, live.id) OR mt.read_message_id IN (old.id, live.id)) AND (mt.read_message_id = old.id OR (mt.read_message_id >= MIN(old.id, live.id) AND mt.read_message_id < MAX(old.id, live.id)) OR (old.direction = 'in' AND ((mt.root_message_id = old.id AND live.thread_id = mt.thread_id AND (mt.read_message_id IS NULL OR live.id > mt.read_message_id)) OR (mt.root_message_id = live.id AND old.thread_id = mt.thread_id AND (mt.read_message_id IS NULL OR old.id > mt.read_message_id)) OR (mt.root_message_id IS NULL AND (mt.root_server_id IS NOT NULL OR mt.root_stanza_id IS NOT NULL))))) LIMIT 1" (list old live)))) (defun jabber-db--reconcile-room-split (db old live) "Collapse compatible historical OLD into canonical LIVE in DB. Caller owns the transaction and proves an unambiguous same-account room archive UID equal to LIVE's room ID. OLD has no stanza/server/origin/room IDs. Equal content is a compatibility check, never discovery evidence. Bodies and encryption/edit/retraction states must agree exactly; no ciphertext is decrypted or failed placeholder installed. Nullable metadata conflicts, foreign references and reaction conflicts fail closed. Read boundaries that cannot preserve all affected replies also fail closed. The archived timestamp is authoritative. OOB rows retain every distinct ID, URL and description, including equal URLs with differing descriptions; only their message owner changes, with no attachment deduplication guesses. Reparent all SQL references before deleting OLD; ordinary triggers maintain FTS. Return success." (let* ((columns (append '("account" "peer" "type" "resource" "direction" "body" "encrypted" "edited" "retracted") jabber-db--split-merge-columns)) (sql (format "SELECT %s FROM message WHERE id = ?" (string-join columns ", "))) (a (car (sqlite-select db sql (list old)))) (b (car (sqlite-select db sql (list live))))) (when (and a b (not (sqlite-select db "SELECT 1 FROM message WHERE id = ? AND server_id IS NOT NULL AND server_id != room_id" (list live))) (not (sqlite-select db "SELECT 1 FROM message_archive WHERE message_id IN (?, ?) AND archive = ? AND uid != (SELECT room_id FROM message WHERE id = ?)" (list old live (cadr a) live))) (equal (seq-take a 9) (seq-take b 9)) (cl-every (lambda (pair) (or (null (car pair)) (null (cdr pair)) (equal (car pair) (cdr pair)))) (cl-mapcar #'cons (nthcdr 9 a) (nthcdr 9 b))) (not (sqlite-select db "SELECT 1 FROM message_archive WHERE message_id IN (?, ?) AND (account != ? OR archive != ?) LIMIT 1" (list old live (car a) (cadr a)))) (not (sqlite-select db "SELECT 1 FROM message_thread WHERE (root_message_id IN (?, ?) OR read_message_id IN (?, ?)) AND (account != ? OR peer != ? OR type != 'groupchat') LIMIT 1" (list old live old live (car a) (cadr a)))) (jabber-db--split-read-boundaries-compatible-p db old live) (jabber-db--split-reactions-compatible-p db old live)) (sqlite-execute db (format "UPDATE message SET %s, timestamp = (SELECT timestamp FROM message WHERE id = ?) WHERE id = ?" (mapconcat (lambda (column) (format "%s = COALESCE(%s, (SELECT %s FROM message WHERE id = ?))" column column column)) jabber-db--split-merge-columns ",\n")) (append (make-list (length jabber-db--split-merge-columns) old) (list old live))) ;; Identical shared snapshots have already passed exact comparison. (dolist (table '("message_reaction" "message_reaction_actor")) (sqlite-execute db (format "DELETE FROM %s WHERE message_id = ? AND sender IN (SELECT sender FROM message_reaction_actor WHERE message_id = ? UNION SELECT sender FROM message_reaction WHERE message_id = ?)" table) (list old live live))) (dolist (table '("message_archive" "message_oob" "message_reaction" "message_reaction_actor")) (sqlite-execute db (format "UPDATE %s SET message_id = ? WHERE message_id = ?" table) (list live old))) (dolist (column '("root_message_id" "read_message_id")) (sqlite-execute db (format "UPDATE message_thread SET %s = ? WHERE %s = ?" column column) (list live old))) (sqlite-execute db "DELETE FROM message WHERE id = ?" (list old)) t))) (defun jabber-db--migrate-v13-to-v14 (db) "Repair unambiguous historical room UID splits atomically in DB. Discover only exact archive UID/room ID joins, never timestamp/body scans. Count incompatible candidates too: collisions cannot select a winner. A row participating in more than one pair is left unchanged." (jabber-db--with-savepoint db (sqlite-execute db jabber-db--archive-message-index-ddl) (let ((pairs (and (sqlite-select db "SELECT 1 FROM message_archive LIMIT 1") (sqlite-select db "SELECT DISTINCT old.id, live.id FROM message_archive AS ma JOIN message AS old ON old.id = ma.message_id JOIN message AS live ON live.account = ma.account AND live.room_id = ma.uid AND live.peer = ma.archive AND live.type = 'groupchat' WHERE old.account = ma.account AND old.peer = ma.archive AND old.type = 'groupchat' AND old.id != live.id AND old.stanza_id IS NULL AND old.server_id IS NULL AND old.origin_id IS NULL AND old.room_id IS NULL"))) (counts (make-hash-table :test #'eql))) (dolist (pair pairs) (dolist (id pair) (puthash id (1+ (gethash id counts 0)) counts))) (dolist (pair pairs) (when (cl-every (lambda (id) (= 1 (gethash id counts))) pair) (jabber-db--reconcile-room-split db (car pair) (cadr pair))))) (sqlite-execute db "PRAGMA user_version=14"))) (defconst jabber-db--v15-candidates-query "SELECT m.id, ma.uid FROM message_archive AS ma JOIN message AS m ON m.id = ma.message_id WHERE m.account = ma.account AND m.peer = ma.archive AND m.type = 'groupchat' AND ma.uid != '' AND m.room_id IS NULL AND m.server_id IS NULL AND NOT EXISTS (SELECT 1 FROM message_archive AS dup WHERE dup.message_id = m.id AND dup.account = ma.account AND dup.archive = ma.archive AND dup.uid != ma.uid) AND NOT EXISTS (SELECT 1 FROM message AS other WHERE other.account = m.account AND other.room_id = ma.uid AND other.peer = m.peer) AND NOT EXISTS (SELECT 1 FROM message AS other WHERE other.account = m.account AND other.server_id = ma.uid AND other.peer = m.peer)" "Standalone room archive rows the v15 migration may promote, as (ID UID). Each collision check seeks one identity index; a combined OR would rescan the room's history per candidate.") (defun jabber-db--migrate-v14-to-v15 (db) "Give standalone historical room archive rows their room UID in DB. Older releases kept the room archive UID only in `message_archive' when the forwarded stanza lacked a room stanza ID. Promote it to room and server identity only from the room's own archive, for an ID-less row with exactly one UID there, when no other row in the room uses it. Also narrow the full-text trigger to body changes, which makes this and later identity updates cheap on large histories." (jabber-db--with-savepoint db ;; Identity updates must not rewrite the full-text index of every row. (sqlite-execute db "DROP TRIGGER IF EXISTS message_au") (sqlite-execute db (seq-find (lambda (ddl) (string-match-p "TRIGGER IF NOT EXISTS message_au" ddl)) jabber-db--schema-ddl)) (when (sqlite-select db "SELECT 1 FROM message_archive LIMIT 1") (sqlite-execute db "CREATE TEMP TABLE jabber_v15 (id INTEGER PRIMARY KEY, uid TEXT)") (sqlite-execute db (concat "INSERT INTO jabber_v15 " jabber-db--v15-candidates-query)) (sqlite-execute db "UPDATE message SET room_id = (SELECT uid FROM jabber_v15 WHERE jabber_v15.id = message.id), server_id = (SELECT uid FROM jabber_v15 WHERE jabber_v15.id = message.id) WHERE id IN (SELECT id FROM jabber_v15)") (sqlite-execute db "DROP TABLE jabber_v15")) (sqlite-execute db "PRAGMA user_version=15"))) (defun jabber-db--migrate (db) "Check user_version and apply migrations to DB." (jabber-db--with-savepoint db (let ((version (caar (sqlite-select db "PRAGMA user_version")))) (when (< 0 version jabber-db--schema-version) ;; Large histories can take a while; say so before Emacs pauses. (message "Upgrading Jabber database to schema %d..." jabber-db--schema-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--migrate-v10-to-v11 db) (setq version 11)) (when (= version 11) (jabber-db--migrate-v11-to-v12 db) (setq version 12)) (when (= version 12) (jabber-db--migrate-v12-to-v13 db) (setq version 13)) (when (= version 13) (jabber-db--repair-reaction-actors db) (jabber-db--migrate-v13-to-v14 db) (setq version 14)) (when (= version 14) (jabber-db--migrate-v14-to-v15 db) (setq version 15)) (when (= version 15) (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* ((live (and jabber-db--connection (sqlitep jabber-db--connection))) (db (and live jabber-db--connection)) (complete nil)) (unwind-protect (progn (unless live (when-let* ((dir (file-name-directory jabber-db-path))) (unless (file-directory-p dir) (make-directory dir t))) (setq db (sqlite-open jabber-db-path)) (when (jabber-db--handle-unknown-schema db) (setq db (sqlite-open jabber-db-path))) (sqlite-execute db "PRAGMA journal_mode=WAL") (sqlite-execute db "PRAGMA synchronous=NORMAL") (sqlite-execute db "PRAGMA foreign_keys=ON")) (when (or (not live) (< (caar (sqlite-select db "PRAGMA user_version")) jabber-db--schema-version)) (jabber-db--migrate db)) (setq jabber-db--connection db complete t) db) (unless complete (when (and db (sqlitep db)) (sqlite-close db)) (setq jabber-db--connection nil)))))) (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 shared reply metadata from XML-DATA." (jabber-xml-reply-fields 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 shared reply metadata from XML-DATA." (jabber-xml-reply-fallback-range xml-data)) (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 type direction resource occupant-id) "Return the unambiguous duplicate row id in DB, or nil. ACCOUNT, PEER, TYPE and DIRECTION scope the message. Populated STANZA-ID, SERVER-ID and OCCUPANT-ID must not conflict. A MUC row with all three IDs equal and the same RESOURCE may retain its original direction when nickname-based archive classification drifts. MUC client IDs alone are not unique. Content matching requires one row with equal TIMESTAMP, BODY, RESOURCE and OCCUPANT-ID, and missing IDs. An ID-less outgoing non-MUC row may lack the archive sender's resource. A matching MUC client ID may be upgraded only when the replay supplies a SERVER-ID." (let* ((scope "SELECT id FROM message WHERE account = ? AND peer = ? AND type IS ? AND (direction = ? OR (type = 'groupchat' AND server_id = ? AND stanza_id = ? AND occupant_id = ? AND resource IS ?)) AND (? IS NULL OR stanza_id IS NULL OR stanza_id = ?) AND (? IS NULL OR server_id IS NULL OR server_id = ?) AND (? IS NULL OR occupant_id IS NULL OR occupant_id = ?) AND ") (parameters (list account peer type direction server-id stanza-id occupant-id resource stanza-id stanza-id server-id server-id occupant-id occupant-id)) ;; Separate indexed branches avoid a peer-wide scan for the ID OR. ;; UNION counts one row matching both IDs only once; LIMIT is global. (matches (sqlite-select db (concat scope "server_id = ? UNION " scope "? != 'groupchat' AND stanza_id = ? LIMIT 2") (append parameters (list server-id) parameters (list type stanza-id))))) (if matches (and (null (cdr matches)) (caar matches)) ;; Without an ID, identical messages may be independent sends. ;; Never upgrade every equal-content row or pick an arbitrary one. (when (or stanza-id server-id) (let ((legacy (sqlite-select db "SELECT id FROM message WHERE account = ? AND peer = ? AND type IS ? AND direction = ? AND timestamp = ? AND body = ? AND occupant_id IS ? AND (resource IS ? OR (direction = 'out' AND type != 'groupchat' AND resource IS NULL AND stanza_id IS NULL AND ? IS NOT NULL)) AND server_id IS NULL AND (stanza_id IS NULL OR (? IS NOT NULL AND stanza_id = ?)) LIMIT 2" (list account peer type direction timestamp body occupant-id resource server-id server-id stanza-id)))) (and (null (cdr legacy)) (caar legacy))))))) (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-message (db message-id timestamp body oob-entries) "Update the exact duplicate MESSAGE-ID in DB. Normalize TIMESTAMP when non-nil and replace failed placeholders with BODY. Skip retracted messages to prevent MAM replays from undoing retractions. OOB-ENTRIES replaces the row's OOB metadata when BODY is upgraded." (unless (eql 1 (caar (sqlite-select db "SELECT retracted FROM message WHERE id = ?" (list message-id)))) (when timestamp (sqlite-execute db "UPDATE message SET timestamp = ? WHERE id = ? AND timestamp != ?" (list timestamp message-id timestamp))) (when (and body (not (jabber--decrypt-failure-body-p body)) (jabber--decrypt-failure-body-p (caar (sqlite-select db "SELECT body FROM message WHERE id = ?" (list message-id))))) (sqlite-execute db "UPDATE message SET body = ? WHERE id = ?" (list body message-id)) (sqlite-execute db "DELETE FROM message_oob WHERE message_id = ?" (list message-id)) (dolist (entry oob-entries) (sqlite-execute db "INSERT INTO message_oob (message_id, url, desc) VALUES (?, ?, ?)" (list message-id (car entry) (cdr entry))))))) (defun jabber-db--backfill-message-ids (db message-id stanza-id server-id) "Fill missing STANZA-ID and SERVER-ID on exact MESSAGE-ID in DB. Rows that would keep both values are not rewritten, so exact replays do not fire the full-text update trigger." (when (or stanza-id server-id) (sqlite-execute db "UPDATE message SET stanza_id = COALESCE(stanza_id, ?), server_id = COALESCE(server_id, ?) WHERE id = ? AND ((stanza_id IS NULL AND ? IS NOT NULL) OR (server_id IS NULL AND ? IS NOT NULL))" (list stanza-id server-id message-id stanza-id server-id)))) (defun jabber-db--backfill-reply-fields (db message-id reply) "Fill NULL reply columns in DB for exact MESSAGE-ID using REPLY. Complete rows stored before the outgoing reply elements were attached." (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 id = ? AND reply_to_id IS NULL" (list (plist-get reply :reply-to-id) (plist-get reply :reply-to-jid) fb-start fb-end message-id)))) (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 for THREAD-ID stored in DB 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-mam-progress (account archive with) "Return durable (UID START) for ACCOUNT, exact ARCHIVE and WITH filter. Nil means unknown coverage. A nil START in a recorded row means full scan." (when-let* ((db (jabber-db-ensure-open))) (car (sqlite-select db "SELECT uid, start FROM mam_progress WHERE account = ? AND archive = ? AND scope = ?" (list account archive (or with "")))))) (defun jabber-db--advance-mam-progress (db account archive with expected uid start) "Advance DB's ACCOUNT/ARCHIVE/WITH cursor from EXPECTED to UID. START retains the safe scan lower bound. The caller owns the transaction. Return nil on a stale predecessor; opaque UIDs are never ordered." (if expected (sqlite-execute db "UPDATE mam_progress SET uid = ? WHERE account = ? AND archive = ? AND scope = ? AND uid IS ?" (list uid account archive (or with "") expected)) (sqlite-execute db "INSERT INTO mam_progress (account, archive, scope, uid, start) VALUES (?, ?, ?, ?, ?) ON CONFLICT(account, archive, scope) DO UPDATE SET uid = excluded.uid WHERE mam_progress.uid IS NULL" (list account archive (or with "") uid start))) (= 1 (caar (sqlite-select db "SELECT changes()")))) (defun jabber-db--message-identity (xml &optional archive uid) "Return operation-specific evidence in XML, plus ARCHIVE and UID. Only a stanza ID assigned by the message's room supplies room identity." (let* ((origin (seq-find (lambda (child) (and (eq (jabber-xml-node-name child) 'origin-id) (equal (jabber-xml-get-xmlns child) "urn:xmpp:sid:0"))) (jabber-xml-node-children xml))) (room (and (equal (jabber-xml-get-attribute xml 'type) "groupchat") (jabber-xml-get-attribute xml 'from) (jabber-jid-user (jabber-xml-get-attribute xml 'from)))) (sid (and room (jabber-db--stanza-id-element xml room)))) (list :origin-id (jabber-xml-get-attribute origin 'id) :room-id (jabber-xml-get-attribute sid 'id) :archive archive :archive-id uid))) (defun jabber-db--identity-compatible-p (db id stanza-id server-id origin-id room-id resource occupant-id) "Check ID in DB against supplied operation-specific evidence. STANZA-ID, SERVER-ID, ORIGIN-ID, ROOM-ID and OCCUPANT-ID may fill unknown fields, but never replace conflicts. RESOURCE identifies the sender." (pcase-let ((`(,stanza ,server ,origin ,room ,sender ,occupant ,direction ,type) (car (sqlite-select db "SELECT stanza_id, server_id, origin_id, room_id, resource, occupant_id, direction, type FROM message WHERE id = ?" (list id))))) (and (cl-every (lambda (pair) (or (null (car pair)) (null (cdr pair)) (equal (car pair) (cdr pair)))) (list (cons stanza stanza-id) (cons server server-id) (cons origin origin-id) (cons room room-id) (cons occupant occupant-id))) (or (equal sender resource) (and (equal direction "out") (not (equal type "groupchat")) (null sender)))))) (defun jabber-db--identity-duplicate (db account peer direction type stanza-id server-id resource occupant-id identity legacy) "Resolve IDENTITY to one compatible row in DB, or nil. ACCOUNT, PEER, DIRECTION, TYPE, STANZA-ID, SERVER-ID, RESOURCE and OCCUPANT-ID scope admission. LEGACY is the former detector's candidate, not authority. An archive occurrence conflict signals an error instead of rebinding its UID." (let* ((origin (plist-get identity :origin-id)) (room (plist-get identity :room-id)) (archive (plist-get identity :archive)) (uid (plist-get identity :archive-id)) (occurrence (and archive uid (caar (sqlite-select db "SELECT message_id FROM message_archive WHERE account = ? AND archive = ? AND uid = ?" (list account archive uid))))) (scope "SELECT id FROM message WHERE account = ? AND peer = ? AND type IS ? AND (direction = ? OR (type = 'groupchat' AND room_id = ?)) AND ") (parameters (list account peer type direction room)) ;; Retain incompatible strong candidates for ambiguity/conflict checks. ;; Keep SQL's NULL type semantics in the non-MUC origin branch. (strong (and (or origin room occurrence) (mapcar #'car (sqlite-select db (concat scope "type != 'groupchat' AND origin_id = ? UNION " scope "room_id = ? UNION " scope "id = ?") (append parameters (list origin) parameters (list room) parameters (list occurrence)))))) ;; A populated unknown legacy server_id is not room evidence. ;; A partial live row, however, can acquire its first room ID when ;; the scoped detector also proved an equal transport ID. Body ;; and timestamp alone never authorize this identity upgrade. (candidates (delete-dups (append strong (when (and legacy (or (not (equal type "groupchat")) (caar (sqlite-select db "SELECT id FROM message WHERE id = ? AND (room_id IS NOT NULL OR (server_id IS NULL AND stanza_id = ?))" (list legacy stanza-id))))) (list legacy))))) (matches (seq-filter (lambda (id) (jabber-db--identity-compatible-p db id stanza-id server-id origin room resource occupant-id)) candidates))) (when (and occurrence (not (and (equal matches (list occurrence)) (equal candidates (list occurrence))))) (error "Conflicting archive occurrence")) (and (= (length candidates) 1) (= (length matches) 1) (car matches)))) (defun jabber-db--enrich-message-identity (db id account identity) "Append compatible IDENTITY to exact ID in DB for ACCOUNT. Only a missing origin or room ID rewrites the row." (let ((origin (plist-get identity :origin-id)) (room (plist-get identity :room-id))) (when (or origin room) (sqlite-execute db "UPDATE message SET origin_id = COALESCE(origin_id, ?), room_id = COALESCE(room_id, ?) WHERE id = ? AND ((origin_id IS NULL AND ? IS NOT NULL) OR (room_id IS NULL AND ? IS NOT NULL))" (list origin room id origin room)))) (when-let* ((archive (plist-get identity :archive)) (uid (plist-get identity :archive-id))) (sqlite-execute db "INSERT INTO message_archive (account, archive, uid, message_id) VALUES (?, ?, ?, ?) ON CONFLICT(account, archive, uid) DO NOTHING" (list account archive uid 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 identity) "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 transport message/@id, not the 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'. Optional IDENTITY carries distinct origin, room and scoped archive evidence. Return the canonical message row ID." (when-let* ((db (jabber-db-ensure-open))) (jabber-db--with-savepoint db (let* ((stored-timestamp (or timestamp (floor (float-time)))) (legacy-id (jabber-db--detect-duplicate db account peer stored-timestamp body stanza-id server-id type direction resource occupant-id)) (duplicate-id (if identity (jabber-db--identity-duplicate db account peer direction type stanza-id server-id resource occupant-id identity legacy-id) legacy-id)) (message-id (or duplicate-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)))) (when duplicate-id (jabber-db--update-duplicate-message db duplicate-id timestamp body oob-entries) (jabber-db--backfill-message-ids db duplicate-id stanza-id server-id) (when reply (jabber-db--backfill-reply-fields db duplicate-id reply))) (when identity (jabber-db--enrich-message-identity db message-id account identity)) (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)) message-id)))) (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 &optional ref-id) "Mark delivered outgoing messages through the referenced row as displayed. ACCOUNT and PEER identify the conversation. TIMESTAMP is the time stored in displayed_at. REF-TIMESTAMP is the referenced message's epoch; optional REF-ID is its stanza ID and takes precedence. Resolve exactly one outgoing row, then order by its stored timestamp and primary row ID to break equal-second ties within its message type. Without REF-ID, accept only an unambiguous stored REF-TIMESTAMP. Missing, ambiguous or older boundaries leave every row unchanged. Preserve existing displayed_at values and skip undelivered messages." (when jabber-db--connection (sqlite-execute jabber-db--connection "WITH reference AS (\ SELECT id, timestamp, type FROM message \ WHERE account = ? AND peer = ? AND direction = 'out' \ AND CASE WHEN ? IS NOT NULL THEN stanza_id = ? ELSE timestamp = ? END) \ UPDATE message SET displayed_at = ? \ WHERE account = ? AND peer = ? AND direction = 'out' \ AND (SELECT count(*) FROM reference) = 1 \ AND type = (SELECT type FROM reference) \ AND (timestamp, id) <= (SELECT timestamp, id FROM reference) \ AND delivered_at IS NOT NULL AND displayed_at IS NULL \ AND NOT EXISTS (SELECT 1 FROM message AS newer \ WHERE newer.account = ? AND newer.peer = ? AND newer.direction = 'out' \ AND newer.type = (SELECT type FROM reference) \ AND newer.displayed_at IS NOT NULL \ AND (newer.timestamp, newer.id) > (SELECT timestamp, id FROM reference))" (list account peer ref-id ref-id ref-timestamp timestamp account peer account peer)))) (defun jabber-db-message-retraction-candidates (account peer server-id) "Return stored MUC retraction candidates for SERVER-ID. ACCOUNT and PEER scope the lookup. Each result contains identity and existing retraction state for one exact row." (when-let* ((db (jabber-db-ensure-open))) (mapcar (lambda (row) (seq-let (row-id resource occupant-id retracted-by retraction-reason retracted) row (list :row-id row-id :retracted (eql retracted 1) :from (if resource (concat peer "/" resource) peer) :occupant-id occupant-id :retracted-by retracted-by :retraction-reason retraction-reason))) (sqlite-select db "SELECT id, resource, occupant_id, retracted_by, retraction_reason, retracted \ FROM message \ WHERE account = ? AND peer = ? AND type = 'groupchat' AND server_id = ?" (list account peer server-id))))) (defun jabber-db-retract-message-row (row-id retracted-by &optional reason) "Mark primary message ROW-ID as retracted by RETRACTED-BY. RETRACTED-BY may be nil when attribution is unavailable. Optional REASON is the human-readable retraction reason string. Return non-nil only when this call performed the first retraction." (when-let* ((db (and row-id (jabber-db-ensure-open)))) (sqlite-execute db "UPDATE message SET retracted = 1, retracted_by = ?, retraction_reason = ? \ WHERE id = ? AND retracted = 0" (list retracted-by reason row-id)) (= 1 (caar (sqlite-select db "SELECT changes()"))))) (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 = 1, 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, or nil if anonymous. 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 = 1, 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 = 0" (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--message-reference-candidates (db account peer type target-id) "Return reply/reaction candidates for TARGET-ID in DB. ACCOUNT, PEER and TYPE scope both aliases. Direct messages retain their transport alias after origin enrichment; room references use only room identity, falling back to the historical server field. Archive UIDs never identify action targets. Return all candidates to detect collisions." (when (and account peer type target-id) (let ((scope "SELECT id, body, retracted, direction, resource FROM message WHERE account = ? AND peer = ? AND type = ? AND ") (parameters (list account peer type target-id))) ;; Separate branches seek the identity indexes instead of peer history. ;; UNION returns a row matching both aliases once; distinct rows remain. (sqlite-select db (if (equal type "groupchat") (concat scope "room_id = ? UNION " scope "room_id IS NULL AND server_id = ?") (concat scope "origin_id = ? UNION " scope "stanza_id = ?")) (append parameters parameters))))) (defun jabber-db-reply-target-body (account peer reply-id muc-p &optional sender) "Return the body of the unique message REPLY-ID references, or nil. ACCOUNT and PEER scope the lookup. MUC-P selects room identity; direct chat accepts origin and historical transport aliases. Optional SENDER is the reply's author JID: a full JID limits known resources, a bare JID limits the account or peer. Historical outgoing direct messages may lack resource evidence. Ambiguous and retracted targets return nil." (when-let* ((db (jabber-db-ensure-open))) (let ((rows (seq-filter (lambda (row) (let* ((author (if (or muc-p (equal (nth 3 row) "in")) peer account)) (full (if (nth 4 row) (concat author "/" (nth 4 row)) author))) (or (null sender) (equal sender (if (jabber-jid-resource sender) full author)) (and (not muc-p) (equal (nth 3 row) "out") (null (nth 4 row)) (equal (jabber-jid-user sender) author))))) (jabber-db--message-reference-candidates db account peer (if muc-p "groupchat" "chat") reply-id)))) (when (and (= (length rows) 1) (eql (nth 2 (car rows)) 0)) (nth 1 (car rows)))))) ;;; Reactions (defun jabber-db--message-id-for-reaction-target (db account peer type target-id) "Return the unique DB message id for reaction TARGET-ID, or nil. ACCOUNT, PEER and TYPE scope the lookup. Count all aliases together, including retracted rows, so a collision cannot choose another message." (let ((rows (jabber-db--message-reference-candidates db account peer type target-id))) (when (= (length rows) 1) (caar rows)))) (defun jabber-db-reaction-target-row (account peer type target-id) "Resolve reaction TARGET-ID for ACCOUNT, PEER and TYPE. Return its unique row ID, nil if absent, or `ambiguous' on collision." (when-let* ((db (jabber-db-ensure-open))) (let ((rows (jabber-db--message-reference-candidates db account peer type target-id))) (if (cdr rows) 'ambiguous (caar rows))))) (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. The actor timestamp and snapshot change together: an error or quit leaves both unchanged." (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))))) ;; The actor watermark and its snapshot are one replacement. (jabber-db--with-savepoint db (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, occupant_id, \ reply_to_id, reply_to_jid, fallback_start, fallback_end, \ thread_id, thread_parent_id, retracted, origin_id, room_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 occupant-id reply-to-id reply-to-jid fallback-start fallback-end thread-id thread-parent-id retracted origin-id room-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 (or room-id server-id) :origin-id origin-id :occupant-id occupant-id :from from :body (or body "") :subject nil :timestamp (seconds-to-time timestamp) :delayed t :encrypted (and encrypted (not (zerop encrypted))) :retracted (eql retracted 1) :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, root.retracted, 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 root-retracted 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 (eql root-retracted 1) :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-root-identity (type root-message-id root-stanza-id root-server-id) "Return (COLUMN EXPRESSION VALUE) selecting a thread root, or nil. TYPE, ROOT-MESSAGE-ID, ROOT-STANZA-ID and ROOT-SERVER-ID take the precedence of `jabber-db--message-thread-root-p'. Rows whose COLUMN equals VALUE belong to the thread; EXPRESSION is the row value that predicate compares with VALUE." (cond (root-message-id (list "id" "id" root-message-id)) ((and (equal type "groupchat") root-server-id) (list "server_id" "COALESCE(room_id, server_id)" root-server-id)) (root-stanza-id (list "stanza_id" "stanza_id" root-stanza-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. The newest matching root follows at most COUNT - 1 newest replies; COUNT t returns every reply." (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))))) (pcase-let* ((`(,column ,expression ,root-id) (apply #'jabber-db--thread-root-identity type thread-row)) (limit (or count jabber-backlog-number)) (scope (concat jabber-db--backlog-columns "\ WHERE account = ? AND peer = ? AND type = ? AND timestamp >= ? \ AND (thread_id = ?" (and column (format " OR %s = ?" column)) ")")) (params (append (list account peer type (floor (or start-time 0)) thread-id) (and column (list root-id)))) (root (and column (car (sqlite-select db (format "%s AND %s = ? \ ORDER BY timestamp DESC, id DESC LIMIT 1" scope expression) (append params (list root-id)))))) (replies (sqlite-select db (concat scope " AND id IS NOT ? \ ORDER BY timestamp DESC, id DESC LIMIT ?") (append params (list (car root) (if (eq limit t) -1 (max 0 (1- limit)))))))) (jabber-db--attach-reactions (jabber-db--attach-oob-entries db (mapcar #'jabber-db--row-to-plist (append replies (and root (list root))))))))) (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) jc) (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) (let ((identity (jabber-db--message-identity xml-data))) (when (equal type "groupchat") (plist-put identity :room-id server-id)) identity)))))) (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))) (and (bound-and-true-p jabber-chat--send-hook-stanza) (jabber-db--message-identity 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.15.1/lisp/jabber-disco-menu.el000066400000000000000000000044041527111033600206710ustar00rootroot00000000000000;;; 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) ;; Newer popup revisions generate these launchers at first initialization. (declare-function jabber-info-menu-map-popup "jabber-disco-menu" () t) (declare-function jabber-service-menu-map-popup "jabber-disco-menu" () t) (unless (boundp 'jabber-info-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)) (unless (boundp 'jabber-service-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.15.1/lisp/jabber-disco.el000066400000000000000000001001741527111033600177300ustar00rootroot00000000000000;;; 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) "Globally reusable, verified capabilities keyed by (HASH . VER).") (defvar jabber-caps--pending (make-hash-table :test 'equal) "Pending capabilities requests keyed by (HASH . VER). Each value contains :active, :queue and :timer. Candidates retain a session owner, full JID and advertised node; they are not verified data.") (defun jabber-disco--owner (jc) "Return a session-qualified observation owner for connection JC. Ordinary FSM state copies preserve ownership; a new transport or stream retires it. Never derive an owner from the current buffer." (when jc (let ((state (fsm-get-state-data jc))) (list jc (plist-get state :connection) (plist-get state :session-id) (plist-get state :username) (plist-get state :server))))) (defun jabber-disco--owner-current-p (owner) "Return non-nil if OWNER still identifies a connected session." (and owner (memq (car owner) jabber-connections) (equal owner (jabber-disco--owner (car owner))))) (defun jabber-disco--cache-key (jc jid node) "Return JC's session-qualified observation key for JID and NODE." (list (jabber-disco--owner jc) jid node)) (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 (OWNER JID NODE), where NODE may be nil. ;; 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 (OWNER 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)) (defun jabber-disco--cache-observation (key value cache) "Store observation VALUE under KEY in CACHE, reclaiming retired owners. Before each insertion, prune both observation tables against current session ownership. Thus retired generations cannot accumulate as observations arrive. Leave other live owners and the global verified capabilities cache untouched." (dolist (table (list jabber-disco-info-cache jabber-disco-items-cache)) (maphash (lambda (observation _value) (unless (jabber-disco--owner-current-p (car observation)) (remhash observation table))) table)) (puthash key value cache)) (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 &optional jc) "Get verified capabilities for full JID observed on connection JC. Return (IDENTITIES FEATURES), or nil if no owned observation is known. An omitted JC never selects an ambient account." (when (jabber-disco--owner-current-p (jabber-disco--owner jc)) (let* ((symbol (jabber-jid-symbol jid jc)) (resource (or (jabber-jid-resource jid) "")) (resource-plist (cdr (assoc resource (get symbol 'resources)))) (key (plist-get resource-plist 'caps)) (owner (plist-get resource-plist 'caps-owner))) (when (and key (equal owner (jabber-disco--owner jc))) (gethash key jabber-caps-cache))))) ;;;###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 jc) "Store caps hash KEY for full JID observed on connection JC. KEY is (HASH . VER). Retain the session owner with the resource mapping." (let* ((symbol (jabber-jid-symbol jid jc)) (resource (or (jabber-jid-resource jid) "")) (resource-entry (assoc resource (get symbol 'resources))) (properties (plist-put (plist-put (cdr resource-entry) 'caps key) 'caps-owner (jabber-disco--owner jc)))) (if resource-entry (setcdr resource-entry properties) (push (cons resource properties) (get symbol 'resources))) (remhash (jabber-disco--cache-key jc jid nil) jabber-disco-info-cache))) (defun jabber-caps--query-if-needed (jc jid hash node ver key cache-entry) "Resolve capabilities advertised by JID on JC as HASH, NODE and VER. KEY is (HASH . VER); CACHE-ENTRY contains only verified capabilities. Keep unverified candidates, including their owners, in a separate table." (let* ((owner (jabber-disco--owner jc)) (info (or cache-entry (jabber-db-caps-lookup hash ver)))) (when (jabber-disco--owner-current-p owner) (if info (progn (puthash key info jabber-caps-cache) (jabber-disco--cache-observation (list owner jid nil) info jabber-disco-info-cache)) (let* ((candidate (list owner jid node)) (pending (gethash key jabber-caps--pending))) (if pending (unless (equal candidate (plist-get pending :active)) (cl-pushnew candidate (plist-get pending :queue) :test #'equal)) (setq pending (list :active nil :queue (list candidate) :timer nil)) (puthash key pending jabber-caps--pending) (jabber-caps-try-next key pending))))))) (defun jabber-process-caps-modern (jc jid hash node ver) "Process capabilities advertised by JID on connection JC. HASH, NODE and VER are the XEP-0115 advertisement fields." (when (and (assoc hash jabber-caps-hash-names) (stringp node) (stringp ver) (jabber-disco--owner-current-p (jabber-disco--owner jc))) (let ((key (cons hash ver))) (jabber-caps--store-hash jid key jc) (jabber-caps--query-if-needed jc jid hash node ver key (gethash key jabber-caps-cache))))) (defun jabber-caps--active-p (key pending candidate) "Return non-nil if KEY still owns PENDING and its active CANDIDATE." (and (eq pending (gethash key jabber-caps--pending)) (eq candidate (plist-get pending :active)))) (defun jabber-caps--cancel-attempt (pending) "Retire PENDING's active timer and exact IQ continuations." (when-let* ((timer (plist-get pending :timer))) (cancel-timer timer)) (let ((candidate (plist-get pending :active))) (setq jabber-open-info-queries (cl-delete-if (lambda (query) (let ((callback (nth 1 query))) (and (eq (car-safe callback) #'jabber-process-caps-info-result) (eq (nth 2 callback) pending) (eq (nth 3 callback) candidate)))) jabber-open-info-queries))) (setf (plist-get pending :active) nil (plist-get pending :timer) nil)) (defun jabber-caps--settle (key pending) "Remove the pending request for KEY if it still owns PENDING." (when (eq pending (gethash key jabber-caps--pending)) (jabber-caps--cancel-attempt pending) (remhash key jabber-caps--pending))) (defun jabber-process-caps-info-result (jc xml-data closure-data) "Verify caps XML-DATA received on JC for CLOSURE-DATA. CLOSURE-DATA retains the hash key, pending request and owned candidate." (pcase-let ((`(,key ,pending ,candidate) closure-data)) (when (and (jabber-caps--active-p key pending candidate) (eq jc (caar candidate))) (if (and (jabber-disco--owner-current-p (car candidate)) (equal (cdr key) (jabber-caps-ver-string (jabber-iq-query xml-data) (car key)))) (let ((info (jabber-disco-parse-info xml-data))) (jabber-caps--settle key pending) (puthash key info jabber-caps-cache) (jabber-db-caps-store (car key) (cdr key) (car info) (cadr info))) (jabber-caps-try-next key pending))))) (defun jabber-process-caps-info-error (jc _xml-data closure-data) "Advance the owned caps request in CLOSURE-DATA after an error on JC." (pcase-let ((`(,key ,pending ,candidate) closure-data)) (when (and (jabber-caps--active-p key pending candidate) (eq jc (caar candidate))) (jabber-caps-try-next key pending)))) (defun jabber-caps--timeout (key pending candidate) "Advance KEY's PENDING request only if CANDIDATE still owns its timer." (when (jabber-caps--active-p key pending candidate) (jabber-caps-try-next key pending))) (defun jabber-caps-try-next (key pending) "Query the next live candidate for KEY in the owned PENDING request. Discard retired candidates. Never reuse a failed candidate's connection or advertised node, and expire each attempt after ten seconds." (when (eq pending (gethash key jabber-caps--pending)) (jabber-caps--cancel-attempt pending) (let ((candidate (pop (plist-get pending :queue)))) (while (and candidate (not (jabber-disco--owner-current-p (car candidate)))) (setq candidate (pop (plist-get pending :queue)))) (if (null candidate) (jabber-caps--settle key pending) (setf (plist-get pending :active) candidate (plist-get pending :timer) (run-at-time 10 nil #'jabber-caps--timeout key pending candidate)) (pcase-let ((`(,owner ,jid ,node) candidate)) (condition-case err (jabber-send-iq (car owner) jid "get" `(query ((xmlns . ,jabber-disco-xmlns-info) (node . ,(concat node "#" (cdr key))))) #'jabber-process-caps-info-result (list key pending candidate) #'jabber-process-caps-info-error (list key pending candidate)) (error (when (jabber-caps--active-p key pending candidate) (jabber-caps-try-next key pending)) (message "Capabilities query failed: %s" (error-message-string err))) (quit (when (jabber-caps--active-p key pending candidate) (jabber-caps--settle key pending)) (signal (car err) (cdr err))))))))) (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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Send items disco request to: " nil nil nil 'full t jc) (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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Send info disco request to: " nil nil nil 'full t jc) (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--owned-callback (jc callback) "Return CALLBACK guarded by JC's captured session and receiving owner." (let ((owner (jabber-disco--owner jc))) (lambda (received-jc arg1 arg2) (when (and (eq received-jc jc) (jabber-disco--owner-current-p owner)) (funcall callback jc arg1 arg2))))) (defun jabber-disco--got-error (jc xml-data callback-data) "Deliver the error in XML-DATA on JC to CALLBACK-DATA." (when (car callback-data) (funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data)))) (defun jabber-disco-get-info (jc jid node callback closure-data &optional force response-predicate) "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 only this session's cache and get fresh data. Discard callbacks after JC is removed or its transport or stream changes. RESPONSE-PREDICATE is passed to `jabber-send-iq'; when supplied, bypass the shared cache so that only an admitted wire response supplies the result." (when force (remhash (jabber-disco--cache-key jc jid node) jabber-disco-info-cache)) (let ((result (unless (or force response-predicate) (jabber-disco-get-info-immediately jid node jc)))) (if result (and callback (run-with-timer 0 nil (jabber-disco--owned-callback jc callback) jc closure-data result)) (jabber-send-iq jc jid "get" `(query ((xmlns . ,jabber-disco-xmlns-info) ,@(when node `((node . ,node))))) (jabber-disco--owned-callback jc #'jabber-disco-got-info) (cons callback closure-data) (jabber-disco--owned-callback jc #'jabber-disco--got-error) (cons callback closure-data) nil response-predicate)))) (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))) (jabber-disco--cache-observation (jabber-disco--cache-key jc 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 &optional jc) "Get cached disco info for JID and NODE observed on connection JC. Return nil if no owned info is available; never select an ambient account. Fill the cache with `jabber-disco-get-info'." (when (jabber-disco--owner-current-p (jabber-disco--owner jc)) (or (gethash (jabber-disco--cache-key jc jid node) jabber-disco-info-cache) (and (null node) (jabber-caps-get-cached jid jc))))) (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 only this session's cache and get fresh data. Discard callbacks after JC is removed or its transport or stream changes." (when force (remhash (jabber-disco--cache-key jc jid node) jabber-disco-items-cache)) (let ((result (gethash (jabber-disco--cache-key jc jid node) jabber-disco-items-cache))) (if result (and callback (run-with-timer 0 nil (jabber-disco--owned-callback jc callback) jc closure-data result)) (jabber-send-iq jc jid "get" `(query ((xmlns . ,jabber-disco-xmlns-items) ,@(when node `((node . ,node))))) (jabber-disco--owned-callback jc #'jabber-disco-got-items) (cons callback closure-data) (jabber-disco--owned-callback jc #'jabber-disco--got-error) (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)))) (jabber-disco--cache-observation (jabber-disco--cache-key jc 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.15.1/lisp/jabber-eme.el000066400000000000000000000031131527111033600173700ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-hints.el000066400000000000000000000033751527111033600177610ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-httpupload.el000066400000000000000000000667241527111033600210270ustar00rootroot00000000000000;;; 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. The function and `jabber-chat-encryption' selection are captured before discovery; the function runs with that selection even if the chat is closed or changed. Must return \(TRANSFORMED-FILEPATH . WRAPPED-CALLBACK) to replace both, or nil to upload the original file unchanged. Signal an error to abort the upload when a selected transform fails; nil is not a failure result. 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.") (defvar jabber-httpupload--discoveries nil "Active upload discovery operations, each a list containing its connection. A nil connection marks a retired operation, including for cached callbacks.") (defun jabber-httpupload--finish-discovery (operation) "Retire OPERATION and its pending disco IQs before running other work." (setcar operation nil) (setq jabber-httpupload--discoveries (delq operation jabber-httpupload--discoveries) jabber-open-info-queries (cl-delete-if (lambda (query) ;; Disco stores (CALLBACK . CLOSURE-DATA) in each IQ continuation. (eq (car-safe (cdr-safe (cdr-safe (nth 1 query)))) operation)) jabber-open-info-queries))) (defun jabber-httpupload--session-reset (jc) "Retire upload discovery and cached service metadata belonging to JC." (dolist (operation (copy-sequence jabber-httpupload--discoveries)) (when (eq (car operation) jc) (jabber-httpupload--finish-discovery operation))) (setq jabber-httpupload-support (assq-delete-all jc jabber-httpupload-support) jabber-httpupload-max-file-size (assq-delete-all jc jabber-httpupload-max-file-size))) (defun jabber-httpupload--start-discovery (jc) "Return a new upload discovery operation owned by JC." (let ((operation (list jc))) (push operation jabber-httpupload--discoveries) operation)) (defun jabber-httpupload--query (operation iri items-p callback) "Query IRI for OPERATION and pass its parsed result to CALLBACK. ITEMS-P selects disco items rather than info. Consume the owned IQ before calling CALLBACK, and retire all sibling queries on a nonlocal exit. Always request fresh data: the shared disco cache is not session-qualified." (let ((request (list operation)) (completed nil)) (unwind-protect (progn (funcall (if items-p #'jabber-disco-get-items #'jabber-disco-get-info) (car operation) iri nil (lambda (jc _data result) (when (and (car request) (eq jc (car operation))) (setq jabber-open-info-queries (cl-delete-if (lambda (query) (eq (cdr-safe (cdr-safe (nth 1 query))) request)) jabber-open-info-queries)) (setcar request nil) (let ((returned nil)) (unwind-protect (progn (funcall callback jc result) (setq returned t)) (unless returned (jabber-httpupload--finish-discovery operation)))))) request t) (setq completed t)) (unless completed (jabber-httpupload--finish-discovery operation))))) (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'." (let ((operation (jabber-httpupload--start-discovery jc))) (jabber-httpupload--query operation iri nil (lambda (jc result) (jabber-httpupload--finish-discovery operation) (when (and (not (jabber-httpupload--disco-error-p result)) (member jabber-httpupload-xmlns (nth 1 result))) (jabber-httpupload--record-support jc iri result)))))) (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 ((operation (jabber-httpupload--start-discovery jc)) (node (plist-get (fsm-get-state-data jc) :server))) (jabber-httpupload--query operation node t (lambda (jc result) (unwind-protect (unless (jabber-httpupload--disco-error-p result) (dolist (item result) (when (car operation) (funcall callback jc item)))) (jabber-httpupload--finish-discovery operation)))))) (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)) (when (equal iri (cdr (assq jc 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--discover-from-items (operation upload items) "Inspect ITEMS for OPERATION and call UPLOAD once support is found. Retire the discovery before invoking the fallible upload continuation." (if (or (null items) (jabber-httpupload--disco-error-p items)) (progn (jabber-httpupload--finish-discovery operation) (jabber-httpupload--unsupported-error)) (let ((remaining (length items))) (dolist (item items) (when (car operation) (let ((iri (elt item 1))) (jabber-httpupload--query operation iri nil (lambda (jc result) (if (and (not (jabber-httpupload--disco-error-p result)) (member jabber-httpupload-xmlns (nth 1 result))) (progn (jabber-httpupload--finish-discovery operation) (jabber-httpupload--record-support jc iri result) (funcall upload)) (setq remaining (1- remaining)) (when (zerop remaining) (jabber-httpupload--finish-discovery operation) (jabber-httpupload--unsupported-error))))))))))) (defun jabber-httpupload--discover-and-upload (jc upload) "Discover HTTP Upload support for JC, then call UPLOAD without arguments. Error if the server does not support HTTP Upload." (message "Discovering HTTP Upload support...") (let ((operation (jabber-httpupload--start-discovery jc)) (node (plist-get (fsm-get-state-data jc) :server))) (jabber-httpupload--query operation node t (lambda (_jc result) (jabber-httpupload--discover-from-items operation upload result))))) (defun jabber-httpupload--upload (jc filepath callback) "Upload FILEPATH via HTTP Upload on JC. On success, call (funcall CALLBACK get-url). Capture the transform and encryption selection before asynchronous discovery." (let* ((filepath (expand-file-name filepath)) (transform jabber-httpupload-pre-upload-transform) (encryption jabber-chat-encryption) (upload (lambda () (jabber-httpupload--upload-file jc filepath callback transform encryption)))) (if (jabber-httpupload-server-has-support jc) (funcall upload) (jabber-httpupload--discover-and-upload jc upload)))) (defun jabber-httpupload--upload-file (jc filepath callback transform encryption) "Upload FILEPATH on JC after discovery, passing the URL to CALLBACK. Apply the captured TRANSFORM with the request's ENCRYPTION selection." (let* ((transform (and transform (let ((jabber-chat-encryption encryption)) (funcall 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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Send file to: " nil nil nil 'full t jc) (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) (add-hook 'jabber-lifecycle-session-reset-functions #'jabber-httpupload--session-reset) (provide 'jabber-httpupload) ;;; jabber-httpupload.el ends here emacs-jabber-0.15.1/lisp/jabber-image.el000066400000000000000000000152511527111033600177120ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-info.el000066400000000000000000000165521527111033600175700ustar00rootroot00000000000000;;; 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 &optional jc) "Return full JIDs for connected resources of BARE-JID on JC." (let* ((sym (jabber-jid-symbol bare-jid jc)) (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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Get info for: " nil nil nil 'full t jc)))) (let* ((bare (jabber-jid-user to)) (resource (jabber-jid-resource to)) (full-jids (if resource (list to) (jabber-info--connected-resources bare jc)))) (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.15.1/lisp/jabber-input.el000066400000000000000000000205731527111033600177720ustar00rootroot00000000000000;;; 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 'subr-x) (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.") (defvar-local jabber-chat--input-history nil "Sent chat inputs, newest first.") (defvar-local jabber-chat--input-history-index nil "Current index while navigating `jabber-chat--input-history'.") (defvar-local jabber-chat--input-history-draft "" "Draft restored after moving forward past the newest history entry.") (defun jabber-chat--input-position () "Return the start of the current buffer's composition area." (unless (and (markerp jabber-point-insert) (eq (marker-buffer jabber-point-insert) (current-buffer))) (user-error "No Jabber chat input marker in this buffer")) (marker-position jabber-point-insert)) (defun jabber-chat--point-in-input-p () "Return non-nil when point is in the composition area." (>= (point) (jabber-chat--input-position))) (defun jabber-chat--input-string () "Return the current composition area as a plain string." (buffer-substring-no-properties (jabber-chat--input-position) (point-max))) (defun jabber-chat--replace-input (content) "Replace the current composition area with CONTENT." (let ((position (jabber-chat--input-position))) (delete-region position (point-max)) (goto-char position) (insert content))) (defun jabber-chat--record-input-history (content) "Record non-empty CONTENT in the current buffer's input history." (when (and (stringp content) (not (string-empty-p content))) (let ((text (substring-no-properties content))) (setq jabber-chat--input-history (cons text (delete text jabber-chat--input-history)) jabber-chat--input-history-index nil jabber-chat--input-history-draft "")))) (defun jabber-chat-input-history-previous () "Replace the composition area with the previous sent input." (interactive) (unless (jabber-chat--point-in-input-p) (user-error "Point is outside the Jabber input area")) (unless jabber-chat--input-history (user-error "No Jabber input history")) (when (null jabber-chat--input-history-index) (setq jabber-chat--input-history-draft (jabber-chat--input-string))) (setq jabber-chat--input-history-index (min (1- (length jabber-chat--input-history)) (1+ (or jabber-chat--input-history-index -1)))) (jabber-chat--replace-input (nth jabber-chat--input-history-index jabber-chat--input-history))) (defun jabber-chat-input-history-next () "Replace the composition area with the next sent input or saved draft." (interactive) (unless (jabber-chat--point-in-input-p) (user-error "Point is outside the Jabber input area")) (unless (numberp jabber-chat--input-history-index) (user-error "Already at newest Jabber input")) (setq jabber-chat--input-history-index (and (> jabber-chat--input-history-index 0) (1- jabber-chat--input-history-index))) (jabber-chat--replace-input (if jabber-chat--input-history-index (nth jabber-chat--input-history-index jabber-chat--input-history) jabber-chat--input-history-draft))) (defvar jabber-chat--input-completion nil "Completion function captured by an asynchronous input provider. Call with non-nil on transport handoff, nil on definite failure. The return value on failure says whether the original draft was restored.") (defvar jabber-chat--input-deferred nil "Non-nil when the current input provider owns deferred completion.") (defvar-local jabber-chat--input-submission nil "Identity of the most recent input submission.") (defun jabber-chat--capture-input-owner () "Return a predicate for the current input buffer's exact owner. Track its marker, mode, connection, account and direct or group peer. A live buffer alone does not authorize completion or local publication." (let ((buffer (current-buffer)) (input jabber-point-insert) (mode major-mode) (connection jabber-buffer-connection) (account (and jabber-buffer-connection (jabber-connection-bare-jid jabber-buffer-connection))) (peer (bound-and-true-p jabber-chatting-with)) (group (bound-and-true-p jabber-group))) (lambda () (and (buffer-live-p buffer) (with-current-buffer buffer (and (eq input jabber-point-insert) (or (null input) (and (markerp input) (eq (marker-buffer input) buffer))) (eq mode major-mode) (eq connection jabber-buffer-connection) (equal account (and connection (jabber-connection-bare-jid connection))) (equal peer (bound-and-true-p jabber-chatting-with)) (equal group (bound-and-true-p jabber-group)))))))) (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* ((buffer (current-buffer)) (input jabber-point-insert) (connection jabber-buffer-connection) (owner-p (jabber-chat--capture-input-owner)) (offset (- (point) input)) (undo buffer-undo-list) (token (list t)) (body (delete-and-extract-region input (point-max))) edited (changed (lambda (beg _end _old-length) ;; Transcript writers bind `inhibit-read-only'; their marker ;; shifts do not transfer ownership of the writable tail. (when (and (not inhibit-read-only) (marker-position input) (>= beg input)) (setq edited t)))) (jabber-chat--input-deferred nil) (jabber-chat--input-completion (lambda (success) (when (car token) (setcar token nil) (when (buffer-live-p buffer) (with-current-buffer buffer (remove-hook 'after-change-functions changed t) (when (funcall owner-p) (if success (jabber-chat--record-input-history body) (when (and (eq token jabber-chat--input-submission) (eq (marker-buffer input) buffer) (= input (point-max)) (not edited)) ;; The rejected edit is not an undo transaction. (let ((buffer-undo-list t)) (goto-char input) (insert body)) (setq buffer-undo-list undo) (goto-char (+ input (max 0 (min offset (length body))))) t)))))))) returned) (setq jabber-chat--input-submission token) (add-hook 'after-change-functions changed nil t) (unwind-protect (prog1 (if extra-elements (funcall jabber-send-function connection body extra-elements) (funcall jabber-send-function connection body)) (setq returned t) (unless jabber-chat--input-deferred (funcall jabber-chat--input-completion t))) (unless returned (funcall jabber-chat--input-completion nil)))))) (provide 'jabber-input) ;;; jabber-input.el ends here emacs-jabber-0.15.1/lisp/jabber-iq.el000066400000000000000000000236341527111033600172450ustar00rootroot00000000000000;;; 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")) ;; Admission precedes dispatch AND removal: a rejected reply must not ;; consume the legitimate outstanding request. (when (or (null (nth 3 callback)) (funcall (nth 3 callback) jc xml-data)) (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 response-predicate) "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. RESPONSE-PREDICATE, when non-nil, is called with the receiving connection and stanza before dispatch. A nil return ignores the response without removing the pending query. Omit it to retain legacy response handling. `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) response-predicate) 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.15.1/lisp/jabber-jid.el000066400000000000000000000034101527111033600173700ustar00rootroot00000000000000;;; jabber-jid.el --- Basic JID parsing -*- 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: ;; Dependency-free JID parsing shared by stream management and utilities. ;;; Code: (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-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))) (provide 'jabber-jid) ;;; jabber-jid.el ends here emacs-jabber-0.15.1/lisp/jabber-keepalive.el000066400000000000000000000261271527111033600206010ustar00rootroot00000000000000;;; 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-lifecycle) (require 'jabber-ping) (declare-function sleep-event-state "ext:system-sleep" (event) t) (declare-function system-sleep-enable "ext:system-sleep" ()) (defvar system-sleep-event-functions) ;;;###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 "Outstanding keepalive entries as (CONNECTION . TRANSPORT) pairs.") (defvar jabber-keepalive-round 0 "Identity of the current keepalive round.") (defvar jabber-keepalive-debug nil "Log keepalive traffic when non-nil.") ;; Global reference declarations (defun jabber-keepalive--retire-round () "Retire the current keepalive round without stopping future rounds." (when (timerp jabber-keepalive-timeout-timer) (cancel-timer jabber-keepalive-timeout-timer)) (setq jabber-keepalive-timeout-timer nil jabber-keepalive-pending nil jabber-keepalive-round (1+ jabber-keepalive-round))) (defun jabber-keepalive--active-transports () "Return active connection and exact transport pairs." (let (result) (dolist (jc jabber-connections) (when (jabber-connection-active-p jc) (push (cons jc (plist-get (fsm-get-state-data jc) :connection)) result))) (nreverse result))) ;;;###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)) (setq jabber-keepalive-timer nil) (jabber-keepalive--retire-round)) (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))) (jabber-keepalive--retire-round) (setq jabber-keepalive-pending (jabber-keepalive--active-transports)) (when jabber-keepalive-pending (let ((round jabber-keepalive-round)) (setq jabber-keepalive-timeout-timer (run-with-timer jabber-keepalive-timeout nil #'jabber-keepalive-timeout round)) (dolist (entry (copy-sequence jabber-keepalive-pending)) (let ((c (car entry)) (transport (cdr entry))) (condition-case err ;; Any IQ response proves that the transport is alive. (jabber-ping-send c nil #'jabber-keepalive-got-response (cons round transport) (cons round transport)) (error (setq jabber-keepalive-pending (delq entry jabber-keepalive-pending)) (message "Jabber keepalive send failed: %s" (error-message-string err)) (fsm-send c (list :connection-dead transport "Keepalive send failed"))))))) (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-got-response (jc _xml-data round-transport) "Mark JC answered when ROUND-TRANSPORT matches the current ping. _XML-DATA is the ignored IQ result or error stanza." (when jabber-keepalive-debug (message "%s: got keepalive response from %s" (current-time-string) (plist-get (fsm-get-state-data jc) :server))) (let ((entry (assq jc jabber-keepalive-pending))) (when (and entry (= (car round-transport) jabber-keepalive-round) (eq (cdr round-transport) (cdr entry))) (setq jabber-keepalive-pending (delq entry 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 (round) "Report unanswered transports from current ROUND as lost." (when (= round jabber-keepalive-round) (let ((pending jabber-keepalive-pending)) (setq jabber-keepalive-timeout-timer nil jabber-keepalive-pending nil jabber-keepalive-round (1+ jabber-keepalive-round)) (dolist (entry pending) (let ((c (car entry)) (transport (cdr entry))) (condition-case err (progn (message "%s: keepalive timeout, connection to %s considered lost" (current-time-string) (plist-get (fsm-get-state-data c) :server)) (fsm-send-sync c (list :connection-dead transport "Keepalive timeout"))) (error (message "Jabber keepalive timeout handling failed: %s" (error-message-string err)))))) (unless jabber-connections (jabber-keepalive-stop))))) (defun jabber-keepalive--system-sleep-event (event) "Reconnect active transports after a post-wake sleep EVENT." (condition-case err (when (eq (sleep-event-state event) 'post-wake) (jabber-keepalive--retire-round) (dolist (entry (jabber-keepalive--active-transports)) (condition-case peer-error (fsm-send-sync (car entry) (list :connection-dead (cdr entry) "System wake")) (error (message "Jabber post-wake reconnect failed: %s" (error-message-string peer-error)))))) (error (message "Jabber system sleep handler failed: %s" (error-message-string err))))) (defun jabber-keepalive--enable-system-sleep (_jc) "Enable optional sleep handling for a newly established session JC." (condition-case err (when (require 'system-sleep nil t) (add-hook 'system-sleep-event-functions #'jabber-keepalive--system-sleep-event) (system-sleep-enable)) (error (message "Jabber system sleep support failed: %s" (error-message-string err))))) (add-hook 'jabber-lifecycle-session-bootstrap-functions #'jabber-keepalive--enable-system-sleep) ;;;; Whitespace pings - less traffic, no error checking on our side ;;; ;;; Whitespace pings keep NAT mappings active between response-checked pings. (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 established session as a whitespace ping. Streams still under negotiation are skipped: a space that reaches the server after SASL success, before the restarted stream header, makes that header's XML declaration ill-formed." (dolist (c jabber-connections) (let* ((state-data (fsm-get-state-data c)) (connection (plist-get state-data :connection)) (established (eq (get c :state) :session-established))) (if (and connection (process-live-p connection)) (when established (condition-case err (jabber-send-string c " ") (error (message "jabber-keepalive: whitespace ping failed: %s" err) (fsm-send c (list :connection-dead connection "Whitespace ping failed"))))) ;; 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 established (fsm-send c (list :connection-dead connection "Connection process lost"))))))) (provide 'jabber-keepalive) ;;; jabber-keepalive.el ends here emacs-jabber-0.15.1/lisp/jabber-keymap.el000066400000000000000000000100611527111033600201100ustar00rootroot00000000000000;;; 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) ;; Feature modules depend on these shared maps, so keep their loading lazy. (declare-function jabber-info-menu "jabber-disco-menu" ()) (declare-function jabber-service-menu "jabber-disco-menu" ()) (declare-function jabber-muc-menu "jabber-muc-menu" ()) (declare-function jabber-connect-all "jabber-core" (&optional arg)) (declare-function jabber-disconnect "jabber-core" (&optional arg interactivep)) (declare-function jabber-roster-popup "jabber-roster-menu" ()) (declare-function jabber-chat-with "jabber-chat" (jc jid &optional other-window)) (declare-function jabber-activity-switch-to "jabber-activity" (&optional jid-param)) (declare-function jabber-send-away-presence "jabber-presence" (&optional status jc)) (declare-function jabber-send-default-presence "jabber-presence" (&optional jc)) (declare-function jabber-send-xa-presence "jabber-presence" (&optional status jc)) (declare-function jabber-send-presence "jabber-presence" (show status priority &optional jc)) (declare-function jabber-chat-buffer-switch "jabber-chatbuffer" ()) (declare-function jabber-muc-join "jabber-muc" (jc group nickname &optional popup)) (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'.") (defvar jabber-common-keymap) (defvar jabber-global-keymap) (defun jabber-common-menu () "Show common Jabber commands." (interactive) (keymap-popup jabber-common-keymap)) (defun jabber-global-menu () "Show global Jabber commands." (interactive) (keymap-popup jabber-global-keymap)) (unless (boundp 'jabber-common-keymap) (defvar-keymap jabber-common-keymap :doc "Common Jabber commands." :parent special-mode-map "h" #'jabber-common-menu "TAB" #'forward-button "" #'backward-button "C-c C-i" #'jabber-info-menu "C-c C-m" #'jabber-muc-menu "C-c C-s" #'jabber-service-menu) (keymap-popup-annotate jabber-common-keymap forward-button "Next button" backward-button "Previous button" jabber-info-menu "Info/Discovery" jabber-muc-menu "MUC" jabber-service-menu "Services")) (unless (boundp 'jabber-global-keymap) (defvar jabber-global-keymap (let ((map (make-sparse-keymap))) (keymap-set map "h" #'jabber-global-menu) (dolist (binding jabber-keymap--global-bindings) (keymap-set map (car binding) (caddr binding))) (define-key ctl-x-map "\C-j" map) map) "Global Jabber commands.") (keymap-popup-annotate jabber-global-keymap jabber-connect-all "Connect" jabber-disconnect "Disconnect" jabber-roster-popup "Roster" jabber-chat-with "Chat with" jabber-activity-switch-to "Next unread" jabber-send-away-presence "Away" jabber-send-default-presence "Online" jabber-send-xa-presence "Extended away" jabber-send-presence "Set presence" jabber-chat-buffer-switch "Switch buffer" jabber-muc-join "Join MUC")) (provide 'jabber-keymap) ;;; jabber-keymap.el ends here emacs-jabber-0.15.1/lisp/jabber-lifecycle.el000066400000000000000000000055571527111033600205770ustar00rootroot00000000000000;;; 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--call-contained (function &rest arguments) "Call FUNCTION with ARGUMENTS, containing callback failures." (condition-case err (apply function arguments) ((error quit) (message "Jabber lifecycle callback failed: %s" (error-message-string err)))) nil) (defun jabber-lifecycle--dispatch-contained (hook &rest arguments) "Run HOOK with ARGUMENTS, containing each callback failure." (apply #'run-hook-wrapped hook #'jabber-lifecycle--call-contained arguments)) (defun jabber-lifecycle-dispatch-session-reset (jc) "Dispatch logical session reset effects for JC." (jabber-lifecycle--dispatch-contained 'jabber-lifecycle-session-reset-functions jc)) (defun jabber-lifecycle-dispatch-session-bootstrap (jc) "Dispatch new session bootstrap effects for JC." (jabber-lifecycle--dispatch-contained '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." (jabber-lifecycle--dispatch-contained 'jabber-lifecycle-connection-list-changed-functions)) (provide 'jabber-lifecycle) ;;; jabber-lifecycle.el ends here emacs-jabber-0.15.1/lisp/jabber-link-preview.el000066400000000000000000000462521527111033600212510ustar00rootroot00000000000000;;; jabber-link-preview.el --- local previews for shared links -*- 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. ;;; Commentary: ;; Fetch and parse compact, local-only previews for HTTPS links. Link ;; metadata is derived on demand and is never added to XMPP stanzas. ;;; Code: (require 'dom) (require 'json) (require 'seq) (require 'subr-x) (require 'url-expand) (require 'url-parse) (require 'url-util) (defgroup jabber-link-preview nil "Local previews for links in chat messages." :group 'jabber-chat) (defcustom jabber-link-preview-max-html-bytes (* 256 1024) "Maximum HTML response size accepted for a link preview." :type 'natnum :group 'jabber-link-preview) (defcustom jabber-link-preview-title-length 200 "Maximum number of characters displayed from a preview title." :type 'natnum :group 'jabber-link-preview) (defcustom jabber-link-preview-description-length 500 "Maximum number of characters displayed from a preview description." :type 'natnum :group 'jabber-link-preview) (defcustom jabber-link-preview-program "curl" "Program used to retrieve link preview HTML." :type 'string :group 'jabber-link-preview) (defcustom jabber-link-preview-timeout 8 "Maximum number of seconds allowed for a preview retrieval." :type 'natnum :group 'jabber-link-preview) (defconst jabber-link-preview--response-overhead-bytes (* 64 1024) "Maximum response-header bytes retained before a preview body.") (defconst jabber-link-preview--url-regexp "https://[^ \t\n<>\"]+" "Regexp matching candidate preview URLs.") (defconst jabber-link-preview--image-regexp "\\.\\(?:avif\\|gif\\|jpe?g\\|png\\|svg\\|tiff?\\|webp\\)\\(?:[?#].*\\)?\\'" "Regexp matching URLs that are already handled as inline images.") (defvar jabber-link-preview--cache (make-hash-table :test #'equal) "Session cache mapping URLs to metadata plists or loading tokens.") (defun jabber-link-preview--clean-text (text &optional limit) "Normalize whitespace in TEXT and truncate it to LIMIT characters." (when-let* ((text (and text (string-trim (replace-regexp-in-string "[ \t\n\r]+" " " text)))) ((not (string-empty-p text)))) (if limit (truncate-string-to-width text limit nil nil "…") text))) (defun jabber-link-preview--meta-content (dom attribute value) "Return content of the first meta node in DOM whose ATTRIBUTE is VALUE." (when-let* ((node (seq-find (lambda (candidate) (equal (dom-attr candidate attribute) value)) (dom-by-tag dom 'meta)))) (dom-attr node 'content))) ;; Emacs 29 and 30 have only the older DOM text API. (defalias 'jabber-link-preview--dom-text (symbol-function (if (fboundp 'dom-inner-text) 'dom-inner-text 'dom-texts)) "Return the textual content of a DOM node.") (defun jabber-link-preview--title (dom) "Return the preferred title from DOM." (or (jabber-link-preview--meta-content dom 'property "og:title") (when-let* ((node (car (dom-by-tag dom 'title)))) (jabber-link-preview--dom-text node)))) (defun jabber-link-preview--absolute-url (url base-url) "Resolve URL against BASE-URL, returning nil when URL is empty." (when-let* ((url (jabber-link-preview--clean-text url))) (url-expand-file-name url base-url))) (defun jabber-link-preview-parse-html (html url) "Parse HTML fetched from URL and return a preview metadata plist. Return nil when the document has no usable title." (with-temp-buffer (insert html) (when-let* ((dom (libxml-parse-html-region (point-min) (point-max))) (title (jabber-link-preview--clean-text (jabber-link-preview--title dom) jabber-link-preview-title-length))) (let ((site (jabber-link-preview--clean-text (or (jabber-link-preview--meta-content dom 'property "og:site_name") (url-host (url-generic-parse-url url))))) (description (jabber-link-preview--clean-text (or (jabber-link-preview--meta-content dom 'property "og:description") (jabber-link-preview--meta-content dom 'name "description")) jabber-link-preview-description-length)) (image (jabber-link-preview--absolute-url (jabber-link-preview--meta-content dom 'property "og:image") url)) (image-alt (jabber-link-preview--clean-text (jabber-link-preview--meta-content dom 'property "og:image:alt")))) (append (list :url url :site site :title title) (and description (list :description description)) (and image (list :image image)) (and image-alt (list :image-alt image-alt))))))) (defun jabber-link-preview--parse-result (html url) "Return parsed preview metadata for HTML at URL or an error plist." (if (not (fboundp 'libxml-parse-html-region)) (list :error 'parser-unavailable) (condition-case nil (or (jabber-link-preview-parse-html html url) (list :error 'metadata)) (error (list :error 'parser))))) (defun jabber-link-preview--youtube-oembed-url (url) "Return YouTube's oEmbed endpoint for watch URL, or nil." (let* ((parsed (url-generic-parse-url url)) (host (downcase (or (url-host parsed) "")))) (when (and (member host '("youtube.com" "www.youtube.com")) (string-prefix-p "/watch?" (url-filename parsed))) (format "https://www.youtube.com/oembed?url=%s&format=json" (url-hexify-string url))))) (defun jabber-link-preview--parse-youtube-json (json url) "Return preview metadata parsed from YouTube oEmbed JSON for URL." (condition-case nil (let* ((data (json-parse-string json :object-type 'plist :null-object nil :false-object nil)) (title (plist-get data :title))) (when title (append (list :url url :site (or (plist-get data :provider_name) "YouTube") :title title) (when-let* ((author (plist-get data :author_name))) (list :description author)) (when-let* ((image (plist-get data :thumbnail_url))) (list :image image))))) (error nil))) (defun jabber-link-preview--trim-url (url) "Remove common sentence punctuation from the end of URL." (replace-regexp-in-string "[.,;:!?)}\\]]+\\'" "" url)) (defun jabber-link-preview--private-ipv4-p (address) "Return non-nil when IPv4 ADDRESS vector is not globally routable." (let ((a (aref address 0)) (b (aref address 1))) (or (= a 0) (= a 10) (= a 127) (and (= a 100) (<= 64 b) (<= b 127)) (and (= a 169) (= b 254)) (and (= a 172) (<= 16 b) (<= b 31)) (and (= a 192) (= b 0)) (and (= a 192) (= b 168)) (and (= a 198) (or (= b 18) (= b 19) (= b 51))) (and (= a 203) (= b 0)) (>= a 224)))) (defun jabber-link-preview--public-address-p (address) "Return non-nil when IPv4 ADDRESS vector is globally routable." (and (= (length address) 5) (not (jabber-link-preview--private-ipv4-p address)))) (defun jabber-link-preview-safe-url-p (url &optional resolve) "Return non-nil when URL is an eligible public HTTPS URL. When RESOLVE is non-nil, resolve its host and require every answer to be globally routable." (when-let* ((parsed (url-generic-parse-url url)) ((equal (url-type parsed) "https")) ((memq (url-port parsed) '(nil 443))) (host (url-host parsed)) ((not (string-match-p "\\`\\(?:localhost\\|.*\\.localhost\\)\\'" (downcase host)))) (addresses (or (and resolve (network-lookup-address-info host 'ipv4)) (and (string-match-p "\\`[0-9.]+\\'" host) (network-lookup-address-info host nil 'numeric)) (and (not resolve) '(unchecked))))) (or (eq (car addresses) 'unchecked) (seq-every-p #'jabber-link-preview--public-address-p addresses)))) (defun jabber-link-preview--resolved-address (url) "Return one vetted address string for URL, or nil." (when-let* ((host (url-host (url-generic-parse-url url))) (addresses (network-lookup-address-info host 'ipv4)) ((seq-every-p #'jabber-link-preview--public-address-p addresses))) (format-network-address (car addresses) t))) (defun jabber-link-preview-url (text) "Return the first eligible non-image preview URL in TEXT." (when (stringp text) (let ((start 0) found) (while (and (not found) (string-match jabber-link-preview--url-regexp text start)) (let ((end (match-end 0)) (url (jabber-link-preview--trim-url (match-string 0 text)))) (when (and (jabber-link-preview-safe-url-p url) (not (string-match-p jabber-link-preview--image-regexp (downcase url)))) (setq found url)) (setq start end))) found))) (defun jabber-link-preview-format (metadata) "Return a compact propertized preview card for METADATA." (let* ((url (plist-get metadata :url)) (site (or (plist-get metadata :site) url)) (lines (delq nil (list site (plist-get metadata :title) (plist-get metadata :description)))) (card (concat "\n" (mapconcat (lambda (line) (concat "│ " line)) lines "\n")))) (add-text-properties 1 (length card) (list 'jabber-chat-link-preview-url url 'face 'shadow 'mouse-face 'highlight 'help-echo "RET: open link; w: copy URL") card) card)) (defun jabber-link-preview-get (url) "Return cached preview metadata or state for URL." (gethash url jabber-link-preview--cache)) (defun jabber-link-preview-put (url value) "Cache VALUE for URL and return VALUE." (puthash url value jabber-link-preview--cache) value) (defun jabber-link-preview--curl-command (url address) "Return the curl command for URL pinned to ADDRESS." (let* ((host (url-host (url-generic-parse-url url))) (pin-address (if (string-match-p ":" address) (format "[%s]" address) address))) (list jabber-link-preview-program "--silent" "--show-error" "--proto" "=https" "--noproxy" "*" "--connect-timeout" (number-to-string jabber-link-preview-timeout) "--max-time" (number-to-string jabber-link-preview-timeout) "--resolve" (format "%s:443:%s" host pin-address) "--header" "Accept: text/html" "--header" (format "Range: bytes=0-%d" jabber-link-preview-max-html-bytes) "--include" "--url" url))) (defun jabber-link-preview--abort-oversize (process) "Mark PROCESS oversized and stop it." (process-put process 'jabber-link-preview-too-large t) (when (process-live-p process) (delete-process process))) (defun jabber-link-preview--header-end (process) "Return cached response header end for PROCESS, finding it if needed." (or (process-get process 'jabber-link-preview-header-end) (save-excursion (goto-char (point-min)) (when (re-search-forward "\r?\n\r?\n" nil t) (process-put process 'jabber-link-preview-header-end (point)) (point))))) (defun jabber-link-preview--header-value (name end) "Return response header NAME before END in the current buffer." (save-excursion (goto-char (point-min)) (let ((case-fold-search t)) (when (re-search-forward (format "^%s:[ \t]*\\([^\r\n;]+\\)" (regexp-quote name)) end t) (string-trim (match-string-no-properties 1)))))) (defun jabber-link-preview--process-filter (process chunk) "Insert retrieval CHUNK for PROCESS while enforcing response limits." (when-let* ((buffer (process-buffer process)) ((buffer-live-p buffer))) (with-current-buffer buffer (goto-char (point-max)) (insert chunk) (let ((header-end (jabber-link-preview--header-end process))) (cond ((and (null header-end) (> (buffer-size) jabber-link-preview--response-overhead-bytes)) (delete-region (1+ jabber-link-preview--response-overhead-bytes) (point-max)) (jabber-link-preview--abort-oversize process)) ((and header-end (> header-end jabber-link-preview--response-overhead-bytes)) (delete-region (1+ jabber-link-preview--response-overhead-bytes) (point-max)) (jabber-link-preview--abort-oversize process)) ((and header-end (> (string-bytes (buffer-substring-no-properties header-end (point-max))) jabber-link-preview-max-html-bytes)) (delete-region (min (point-max) (+ header-end jabber-link-preview-max-html-bytes)) (point-max)) (jabber-link-preview--abort-oversize process))))))) (defun jabber-link-preview--buffer-result (process url) "Return preview result from PROCESS buffer for URL." (let ((oversized (process-get process 'jabber-link-preview-too-large))) (cond ((and (not oversized) (not (zerop (process-exit-status process)))) (list :error 'fetch)) (t (with-current-buffer (process-buffer process) (goto-char (point-min)) (if (not (re-search-forward "\r?\n\r?\n" nil t)) (list :error (if oversized 'size 'response)) (let ((body-start (point)) (status (save-excursion (goto-char (point-min)) (and (looking-at "HTTP/[0-9.]+ \\([0-9]+\\)") (string-to-number (match-string 1))))) (content-type (jabber-link-preview--header-value "Content-Type" (point)))) (cond ((not (and status (<= 200 status) (< status 300))) (list :error 'response)) ((not (and content-type (if (eq (process-get process 'jabber-link-preview-kind) 'youtube) (string-equal-ignore-case content-type "application/json") (string-equal-ignore-case content-type "text/html")))) (list :error 'mime)) (t (let* ((body (buffer-substring-no-properties body-start (point-max))) (result (if (eq (process-get process 'jabber-link-preview-kind) 'youtube) (or (jabber-link-preview--parse-youtube-json body url) (list :error 'metadata)) (jabber-link-preview--parse-result body url)))) (if (and oversized (plist-get result :error)) (list :error 'size) result))))))))))) (defun jabber-link-preview--process-sentinel (process _event) "Finish link preview retrieval PROCESS." (when (and (memq (process-status process) '(exit signal)) (not (process-get process 'jabber-link-preview-delivered))) (process-put process 'jabber-link-preview-delivered t) (let ((buffer (process-buffer process)) (callback (process-get process 'jabber-link-preview-callback)) (cbargs (process-get process 'jabber-link-preview-cbargs)) (url (process-get process 'jabber-link-preview-url)) result) (unwind-protect (setq result (condition-case nil (jabber-link-preview--buffer-result process url) (error (list :error 'response)))) (when (buffer-live-p buffer) (kill-buffer buffer))) (apply callback result cbargs)))) (defun jabber-link-preview--start-process (fetch-url source-url kind address callback cbargs) "Fetch FETCH-URL at ADDRESS for SOURCE-URL using KIND parser." (let* ((buffer (generate-new-buffer " *jabber-link-preview*")) process) (with-current-buffer buffer (set-buffer-multibyte nil)) (setq process (make-process :name "jabber-link-preview" :buffer buffer :command (jabber-link-preview--curl-command fetch-url address) :coding 'binary :connection-type 'pipe :filter #'jabber-link-preview--process-filter :sentinel #'jabber-link-preview--process-sentinel :noquery t)) (process-put process 'jabber-link-preview-callback callback) (process-put process 'jabber-link-preview-cbargs cbargs) (process-put process 'jabber-link-preview-url source-url) (process-put process 'jabber-link-preview-kind kind) process)) (defun jabber-link-preview-fetch (url callback &rest cbargs) "Fetch preview metadata for URL and call CALLBACK with it and CBARGS. Retrieval uses a vetted, pinned public address, refuses redirects, sends no cookies or referrer, and aborts when response limits are exceeded." (cond ((not (executable-find jabber-link-preview-program)) (apply callback (list :error 'program-unavailable) cbargs)) ((not (jabber-link-preview-safe-url-p url)) (apply callback (list :error 'unsafe) cbargs)) ((not (fboundp 'libxml-parse-html-region)) (apply callback (list :error 'parser-unavailable) cbargs)) (t (let* ((oembed (jabber-link-preview--youtube-oembed-url url)) (fetch-url (or oembed url)) (kind (and oembed 'youtube))) (if-let* ((address (jabber-link-preview--resolved-address fetch-url))) (jabber-link-preview--start-process fetch-url url kind address callback cbargs) (apply callback (list :error 'unsafe) cbargs)))))) (provide 'jabber-link-preview) ;;; jabber-link-preview.el ends here emacs-jabber-0.15.1/lisp/jabber-mam.el000066400000000000000000001167101527111033600174040ustar00rootroot00000000000000;;; 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-lifecycle) (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 "Legacy initial catch-up window, retained for configuration compatibility. Automatic catch-up now scans unbounded when durable coverage is unknown; using a recent window after migration could silently omit older messages." :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 "Active query plists, including queries waiting for their next page. Each owns its connection/session predicate, archive target, page token, pagination timer and completion callbacks.") (defvar jabber-mam--dirty-peers nil "Peers awaiting refresh after their results, as (ACCOUNT PEER TYPE).") (defvar jabber-mam--redraw-peers nil "Committed peers awaiting a progressive redraw, as (ACCOUNT PEER TYPE).") (defvar jabber-mam--redraw-delay 1.0 "Seconds to coalesce committed pages before redrawing their buffers.") (defvar jabber-mam--redraw-timer nil "Pending timer for `jabber-mam--redraw-committed', or nil.") (defvar jabber-mam--peer-syncing nil "Alist of active automatic peer catch-ups. Each entry has the shape ((JC PEER) . TOKEN).") ;;; 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--signal-peer-syncing (jc peer type syncing-p) "Show whether JC is syncing PEER of TYPE, then run the public hook. SYNCING-P is non-nil when sync starts, nil when it ends. The built-in indicator needs JC to find an account's room buffer, so it is updated here rather than from `jabber-mam-peer-syncing-functions'. Contain failures so a faulty handler cannot strand a catch-up." (jabber-lifecycle--call-contained #'jabber-chat--update-mam-syncing jc peer type syncing-p) (jabber-lifecycle--dispatch-contained 'jabber-mam-peer-syncing-functions peer type syncing-p)) (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) (jabber-mam--signal-peer-syncing jc peer "chat" nil))) (defun jabber-mam--release-page (query) "Release QUERY's page at most once." (plist-put query :page nil) (when-let* ((id (plist-get query :iq-id))) (setq jabber-open-info-queries (delete (assoc id jabber-open-info-queries) jabber-open-info-queries)) (plist-put query :iq-id nil))) (defun jabber-mam--complete-query (query outcome) "Retire QUERY with OUTCOME before releasing resources and calling consumers. OUTCOME is `success', `failed' or `cancelled'; see `jabber-mam--query'. Contain callback errors and quits so other queries can finish cleanup." (when (memq query jabber-mam--syncing) (unless (eq outcome 'success) (plist-put query :failed t)) (setq jabber-mam--syncing (delq query jabber-mam--syncing)) (when-let* ((timer (plist-get query :timer))) (cancel-timer timer) (plist-put query :timer nil)) (unwind-protect (condition-case err (jabber-mam--release-page query) ((error quit) (setq outcome 'failed) (signal (car err) (cdr err)))) (when-let* ((callback (plist-get query :callback))) (jabber-lifecycle--call-contained callback)) (when-let* ((callback (plist-get query :result-callback))) (jabber-lifecycle--call-contained callback outcome))) (jabber-mam--redraw-dirty))) (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) "Return validated MAM fin metadata from XML-DATA, or nil." (let* ((fins (seq-filter (lambda (el) (and (eq (jabber-xml-node-name el) 'fin) (equal (jabber-xml-get-xmlns el) jabber-mam-xmlns))) (jabber-xml-node-children xml-data))) (fin (car fins)) (complete (jabber-xml-get-attribute fin 'complete)) (sets (jabber-xml-get-children fin 'set)) (set (car sets)) (lasts (jabber-xml-get-children set 'last)) (firsts (jabber-xml-get-children set 'first)) (last (car (jabber-xml-node-children (car lasts)))) (first (car (jabber-xml-node-children (car firsts))))) (when (and (= (length fins) 1) (member complete '(nil "true" "false" "1" "0")) (<= (length sets) 1) (or (null set) (equal (jabber-xml-get-xmlns set) jabber-mam-rsm-xmlns)) (<= (length lasts) 1) (<= (length firsts) 1) (or (null lasts) (and (stringp last) (not (string-empty-p last)) (= (length (cddar lasts)) 1))) (or (null firsts) (and (stringp first) (not (string-empty-p first))))) (list :complete (not (null (member complete '("true" "1")))) :first first :last last)))) ;;; 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--session-predicate (jc) "Return a predicate for JC's captured transport, stream and account. Ordinary FSM state copies do not retire this session." (let* ((state (fsm-get-state-data jc)) (connection (plist-get state :connection)) (stream (plist-get state :session-id)) (username (plist-get state :username)) (server (plist-get state :server))) (lambda () (let ((current (fsm-get-state-data jc))) (and (eq connection (plist-get current :connection)) (equal stream (plist-get current :session-id)) (equal username (plist-get current :username)) (equal server (plist-get current :server))))))) (defun jabber-mam--current-query-p (jc query) "Return non-nil when JC still owns the registered QUERY." (and (eq jc (plist-get query :jc)) (memq query jabber-mam--syncing) (funcall (plist-get query :current-p)))) (defun jabber-mam--valid-sender-p (jc from query) "Return non-nil when FROM is QUERY's archive on its owning JC. Require the exact archive JID, never a room occupant or account resource. For compatibility, absent FROM is accepted for an owned personal archive." (and (jabber-mam--current-query-p jc query) (let ((target (plist-get query :to))) (if from (equal from (or target (jabber-connection-bare-jid jc))) (null target))))) (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--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--page-failed (query) "Prevent QUERY's current page from publishing a durable cursor." (plist-put query :failed t)) (defun jabber-mam--process-message (jc xml-data) "Process JC's owned MAM result XML-DATA in its own short transaction. Consume the owned envelope so live handlers never see archived content. Malformed or failing results fail the page instead of being skipped." (let* ((result (jabber-xml-child-with-xmlns xml-data jabber-mam-xmlns)) (qid (jabber-xml-get-attribute result 'queryid)) (query (cl-find qid jabber-mam--syncing :key (lambda (entry) (plist-get entry :id)) :test #'equal))) (when (and query (plist-get query :page) (jabber-mam--valid-sender-p jc (jabber-xml-get-attribute xml-data 'from) query)) (unwind-protect (condition-case err (if (or (not (eq (jabber-xml-node-name result) 'result)) (not (jabber-mam--parse-result xml-data)) (not (stringp (jabber-xml-get-attribute result 'id))) (string-empty-p (jabber-xml-get-attribute result 'id))) (jabber-mam--page-failed query) (plist-put query :received (1+ (or (plist-get query :received) 0))) (jabber-mam--commit-result jc query (copy-tree xml-data))) ((error quit) (jabber-mam--page-failed query) (signal (car err) (cdr err)))) (setcdr (cdr xml-data) nil))))) (defun jabber-mam--commit-result (jc query stanza) "Process QUERY's archived STANZA for JC in one short transaction. Decrypt and store it, run an unwrapped bodyless action through the message chain, then COMMIT. Any error, including one a chain handler raises, aborts the transaction. So does retirement of QUERY meanwhile. Otherwise roll back and restore in-memory state the transaction consumed or changed, so a retry starts again from the restored durable state. Effects deferred with `jabber-chat--on-decrypt-commit' run only after COMMIT." (let ((db (jabber-db-ensure-open)) (jabber-chat--decrypt-undo (list #'ignore)) (jabber-chat--decrypt-commit nil) (committed nil)) (when db (sqlite-execute db "BEGIN")) (unwind-protect (progn (jabber-mam--process-owned-message jc stanza) (when (jabber-xml-get-attribute stanza 'jabber-mam--origin) (jabber-process-input jc stanza (lambda (err) (signal (car err) (cdr err))))) (when (jabber-mam--current-query-p jc query) (when db (sqlite-execute db "COMMIT")) (setq committed t) (dolist (effect (reverse jabber-chat--decrypt-commit)) (jabber-lifecycle--call-contained effect)))) (unless committed (when db (ignore-error sqlite-error (sqlite-execute db "ROLLBACK"))) (mapc #'jabber-lifecycle--call-contained jabber-chat--decrypt-undo))))) (defun jabber-mam--message-identity (jc query inner-msg archive-id) "Return accepted QUERY's identity for INNER-MSG and ARCHIVE-ID on JC. A room archive UID supplies missing room identity only for an owned query whose exact target is the forwarded message's room. The caller must have validated the outer sender. Explicit room stanza IDs take precedence; never promote a personal or foreign archive UID to room identity." (let* ((archive (or (plist-get query :to) (jabber-connection-bare-jid jc))) (identity (jabber-db--message-identity inner-msg archive archive-id))) (when (and (not (plist-get identity :room-id)) (jabber-mam--current-query-p jc query) (equal (jabber-xml-get-attribute inner-msg 'type) "groupchat") (stringp archive-id) (not (string-empty-p archive-id)) (plist-get query :to) (equal (plist-get query :to) (jabber-jid-user (jabber-xml-get-attribute inner-msg 'from)))) (setq identity (plist-put identity :room-id archive-id))) identity)) (defun jabber-mam--process-owned-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)) (query (cl-find qid jabber-mam--syncing :key (lambda (entry) (plist-get entry :id)) :test #'equal)) (page (plist-get query :page)) ((jabber-mam--valid-sender-p jc (jabber-xml-get-attribute xml-data 'from) query)) (parsed (jabber-mam--parse-result xml-data))) (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))) (when (jabber--decrypt-failure-body-p body) (jabber-mam--page-failed query)) (when (and (eq page (plist-get query :page)) (jabber-mam--current-query-p jc query)) (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) (identity (jabber-mam--message-identity jc query inner-msg archive-id))) (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) (if (equal (plist-get fields :type) "groupchat") (plist-get identity :room-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) identity)))) (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 (jabber-lifecycle--dispatch-contained 'jabber-mam-sync-complete-functions peers)))) (defun jabber-mam--redraw-committed () "Refresh open buffers of peers whose pages have committed. Unlike `jabber-mam--redraw-dirty', this does not signal completion, and it skips buffers whose reader is scrolled into history; the completion refresh covers those." (setq jabber-mam--redraw-timer nil) (when-let* ((peers (prog1 jabber-mam--redraw-peers (setq jabber-mam--redraw-peers nil)))) (jabber-lifecycle--call-contained #'jabber-chat--handle-mam-sync-complete peers t))) (defun jabber-mam--schedule-redraw (peers) "Refresh committed PEERS' buffers after `jabber-mam--redraw-delay'. Pages committed while the timer is pending share its redraw, so a long catch-up shows its progress without rebuilding buffers for every page." (dolist (entry peers) (cl-pushnew entry jabber-mam--redraw-peers :test #'equal)) (unless jabber-mam--redraw-timer (setq jabber-mam--redraw-timer (run-with-timer jabber-mam--redraw-delay nil #'jabber-mam--redraw-committed)))) ;;; Page settlement (defun jabber-mam--accept-page (query last-id) "Advance QUERY's forward cursor to LAST-ID after its page's results. Each result has already committed in its own transaction, so this is one autocommitted write; then schedule a redraw of committed peers." (when (plist-get query :forward) (let ((expected (plist-get query :cursor-expected)) (uid (or last-id (plist-get query :cursor-expected)))) (when-let* ((db (jabber-db-ensure-open))) (jabber-db--advance-mam-progress db (plist-get query :account) (plist-get query :archive) (plist-get query :with) expected uid (plist-get query :coverage-start))) (plist-put query :cursor-expected uid))) (when jabber-mam--dirty-peers (jabber-mam--schedule-redraw jabber-mam--dirty-peers))) ;;; Query and pagination (defun jabber-mam--query (jc &optional after-id queryid with start to before-id max callback result-callback) "Start a MAM query on JC, paginating from AFTER-ID. QUERYID correlates results; generate it if nil. WITH and START are filters. TO is nil for the personal archive, or a room bare JID. BEFORE-ID requests one backward page of MAX messages. Call CALLBACK without arguments once on settlement, including failure. Then call RESULT-CALLBACK once with `success', `failed' or `cancelled'. Success means accepted query completion, including a bounded backward page, not complete archive coverage. Each result commits on arrival in its own transaction; a page's fin then advances the forward cursor. Failure means a permanent IQ error, local send error, a result that failed or could not commit, or incomplete forward pagination without cursor progress. Cancellation means retirement of the room, connection or session, or caller quit (which is re-signaled). Intermediate pages and the first stale-cursor retry do not settle the query. Retire ownership before attempting each callback independently; contain their errors and quits without changing the outcome. Callbacks can run before this function returns, including on synchronous send failure. Return the owned query record." (dolist (filter (list with to)) (unless (or (null filter) (and (stringp filter) (not (string-empty-p filter)))) (error "Invalid MAM archive or coverage filter"))) (let* ((account (jabber-connection-bare-jid jc)) (archive (or to account)) (progress (jabber-db-mam-progress account archive with)) (query (list :id (or queryid (jabber-mam--make-queryid)) :jc jc :current-p (jabber-mam--session-predicate jc) :with with :start start :to to :before before-id :max (or max jabber-mam-page-size) :after after-id :callback callback :result-callback result-callback :page nil :timer nil :iq-id nil :retried nil :failed nil :received 0 :account account :archive archive :cursor-expected (car progress) :coverage-start (if progress (cadr progress) start) :forward (and (not before-id) (equal after-id (car progress)) (or (null progress) (equal start (cadr progress))))))) (push query jabber-mam--syncing) (jabber-mam--send-page query) query)) (defun jabber-mam--send-page (query) "Send the next page of QUERY only while its owner remains current." (when (and (memq query jabber-mam--syncing) (not (plist-get query :page))) (plist-put query :timer nil) (if (not (jabber-mam--current-query-p (plist-get query :jc) query)) (jabber-mam--complete-query query 'cancelled) (let ((page (list nil))) (plist-put query :page page) (plist-put query :received 0) (plist-put query :iq-id (jabber-mam--make-queryid)) (condition-case err (progn (jabber-send-iq (plist-get query :jc) (plist-get query :to) "set" (jabber-mam--build-query (plist-get query :id) (plist-get query :with) (plist-get query :start) (plist-get query :after) (plist-get query :max) (plist-get query :before)) #'jabber-mam--handle-fin (cons query page) #'jabber-mam--handle-error (cons query page) (plist-get query :iq-id) (lambda (jc xml) (and (eq page (plist-get query :page)) (jabber-mam--valid-sender-p jc (jabber-xml-get-attribute xml 'from) query))))) ((error quit) (jabber-mam--complete-query query (if (eq (car err) 'quit) 'cancelled 'failed)) (if (eq (car err) 'quit) (signal (car err) (cdr err)) (message "MAM: query failed to send: %s" (error-message-string err))))))))) (defun jabber-mam--reply-query (jc xml-data closure) "Return the active query owned by JC for XML-DATA and CLOSURE." (let ((query (car closure))) (when (and (eq (cdr closure) (plist-get query :page)) (jabber-mam--valid-sender-p jc (jabber-xml-get-attribute xml-data 'from) query)) query))) (defun jabber-mam--handle-fin (jc xml-data closure) "Settle or paginate JC's owned page from XML-DATA and CLOSURE." (when-let* ((query (jabber-mam--reply-query jc xml-data closure))) (condition-case err (let* ((fin (jabber-mam--parse-fin xml-data)) (last-id (plist-get fin :last))) (cond ((or (not fin) (plist-get query :failed) (and (> (or (plist-get query :received) 0) 0) (null last-id)) (and (not (plist-get fin :complete)) (not (plist-get query :before)) (or (null last-id) (equal last-id (plist-get query :after))))) (jabber-mam--complete-query query 'failed)) (t (jabber-mam--accept-page query last-id) (if (or (plist-get fin :complete) (plist-get query :before)) (jabber-mam--complete-query query 'success) (jabber-mam--release-page query) (plist-put query :after last-id) (plist-put query :timer (run-with-timer 0.1 nil #'jabber-mam--send-page query)))))) ((error quit) (jabber-mam--page-failed query) (jabber-mam--complete-query query 'failed) (signal (car err) (cdr err)))))) (defun jabber-mam--handle-error (jc xml-data closure) "Settle JC's failed page from XML-DATA and CLOSURE. Retry a stale forward cursor once without that cursor, preserving filters." (when-let* ((query (jabber-mam--reply-query jc xml-data closure))) (let ((error-el (car (jabber-xml-get-children xml-data 'error)))) (if (and (plist-get query :after) (not (plist-get query :before)) (not (plist-get query :retried)) (car (jabber-xml-get-children error-el 'item-not-found))) (progn (jabber-mam--release-page query) (plist-put query :after nil) (plist-put query :retried t) (jabber-mam--send-page query)) (jabber-mam--complete-query query 'failed) (message "MAM: query failed: %s" (jabber-sexp2xml xml-data)))))) ;;; Post-connect catch-up (defun jabber-mam--initial-start () "Return the configured initial catch-up timestamp, or nil." (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))) (defun jabber-mam--catch-up (jc) "Sync missed messages for JC via MAM." (let* ((account (jabber-connection-bare-jid jc)) (progress (jabber-db-mam-progress account account nil))) (jabber-mam--query jc (car progress) nil nil (cadr progress)))) (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 PEER's archive on JC for automatic catch-up TOKEN." (let* ((account (jabber-connection-bare-jid jc)) (progress (jabber-db-mam-progress account account peer)) (last-id (car progress)) (start (cadr progress))) (jabber-mam--query jc last-id nil peer start nil nil nil (lambda () (jabber-mam--finish-peer-sync jc peer token))))) (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)))) (jabber-mam--signal-peer-syncing jc 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 GROUP's archive on JC, then clear its syncing indicator." (let* ((account (jabber-connection-bare-jid jc)) (progress (jabber-db-mam-progress account group nil)) (last-id (car progress)) (start (cadr progress))) (jabber-mam--query jc last-id nil nil start group nil nil (lambda () (jabber-mam--signal-peer-syncing jc group "groupchat" nil))))) (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 (jabber-mam--signal-peer-syncing jc 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) (jabber-mam--signal-peer-syncing jc group "groupchat" nil)))) (list group)))) (defun jabber-mam-sync-buffer () "Sync recent messages from this buffer's server archive. Fetch at most `jabber-chat-buffer-msg-count' messages. Store new messages and update existing messages through deduplication, including successful re-decryption of placeholders. Never infer deletion from archive absence: a bounded page, even a successful one, is not evidence of remote deletion. Refresh the buffer after settlement." (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)))) (type (if group "groupchat" "chat"))) (jabber-mam--signal-peer-syncing jc peer type t) (jabber-mam--mark-dirty jc peer type) (jabber-mam--query jc nil nil (unless group peer) nil group t count (lambda () (jabber-mam--signal-peer-syncing jc peer type nil))))) ;;; Disconnect cleanup (defun jabber-mam--cleanup-connection (jc) "Retire JC's queries and automatic catch-ups on disconnect." (dolist (query (copy-sequence jabber-mam--syncing)) (when (eq jc (plist-get query :jc)) (jabber-mam--complete-query query 'cancelled))) (dolist (entry (copy-sequence jabber-mam--peer-syncing)) (when (eq (caar entry) jc) (jabber-mam--finish-peer-sync jc (cadar entry) (cdr entry))))) (defun jabber-mam--cleanup-all () "Retire all MAM queries and automatic catch-ups on disconnect." (dolist (query (copy-sequence jabber-mam--syncing)) (jabber-mam--complete-query query 'cancelled)) (dolist (entry (copy-sequence jabber-mam--peer-syncing)) (jabber-mam--finish-peer-sync (caar entry) (cadar entry) (cdr entry)))) ;;; MUC query cancellation (defun jabber-mam--cancel-muc-query (room &optional jc) "Retire MAM queries and pending pagination for ROOM on JC. When JC is nil, intentionally retire this room's queries on all accounts." (dolist (query (copy-sequence jabber-mam--syncing)) (when (and (equal room (plist-get query :to)) (or (null jc) (eq jc (plist-get query :jc)))) (jabber-mam--complete-query query 'cancelled)))) ;;; 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-lifecycle-session-reset-functions #'jabber-mam--cleanup-connection) (add-hook 'jabber-lost-connection-hooks #'jabber-mam--cleanup-connection) (provide 'jabber-mam) ;;; jabber-mam.el ends here emacs-jabber-0.15.1/lisp/jabber-message-correct.el000066400000000000000000000436061527111033600217200ustar00rootroot00000000000000;;; 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 ;; Rejected incoming corrections are routine during archive replay, ;; especially when the original is outside the fetched history. Drop ;; them silently rather than letting remote traffic flood *Messages*. ;; A correction that failed to decrypt must never overwrite the ;; original body with the placeholder (issue #134). ((jabber--decrypt-failure-body-p new-body) nil) ((and scoped-p (/= (length matches) 1)) nil) ((null original-from) nil) ((not (jabber-message-correct--valid-sender-p original-from new-from muc-p original-occupant-id new-occupant-id)) 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) (jabber-chat-buffer--call-with-transcript #'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))))) (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 (car-safe 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* ((owner-p (jabber-chat--capture-input-owner)) (ewoc jabber-chat-ewoc) (new-body (read-string "Correction: " body))) (unless (and (funcall owner-p) (eq ewoc jabber-chat-ewoc) (not (car-safe jabber-message-correct--pending-outgoing))) (user-error "Correction buffer changed")) (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)) (db jabber-db--connection) (db-path jabber-db-path) (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)) (token (list t id)) (view-p (lambda () (and (funcall owner-p) (with-current-buffer buffer (and (eq ewoc jabber-chat-ewoc) (eq token jabber-message-correct--pending-outgoing)))))) (commit (lambda () (when (car token) ;; Retire before SQL or rendering can reenter. Durable ;; success belongs to the captured row, not the live view. (setcar token nil) (condition-case err (progn (when (and row-id (eq db jabber-db--connection) (equal db-path jabber-db-path)) (jabber-db-correct-message-row row-id new-body)) (when (funcall view-p) (with-current-buffer buffer (setq jabber-message-correct--pending-outgoing nil) (jabber-message-correct--update-outgoing-buffer buffer group id (plist-get msg :from) new-body fb-len)))) ((error quit) (when (funcall view-p) (with-current-buffer buffer (setq jabber-message-correct--pending-outgoing nil))) (message "Correction sent but local update failed: %s" (error-message-string err))))))) (failure (lambda (_reason) (when (car token) (setcar token nil) (when (funcall view-p) (with-current-buffer buffer (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")) (setq jabber-message-correct--pending-outgoing token) (condition-case err (jabber-message-correct--send jabber-buffer-connection group new-body extra commit failure) ((error quit) (funcall failure (error-message-string err)) (signal (car err) (cdr err)))))))))) (provide 'jabber-message-correct) ;;; jabber-message-correct.el ends here emacs-jabber-0.15.1/lisp/jabber-message-reply.el000066400000000000000000000266661527111033600214210ustar00rootroot00000000000000;;; 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) ;; Chat loads this library before defining its shared composition policy. (declare-function jabber-chat--captured-reply-elements "jabber-chat" (body correction-p &optional stanza)) (declare-function jabber-chat--clear-send-context "jabber-chat" ()) (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 if still at the start of NEW-BODY. 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--send-context-captured)) (not (bound-and-true-p jabber-chat--sending-correction))) (prog1 (append (jabber-message-reply--thread-elements) (jabber-chat--captured-reply-elements body nil (bound-and-true-p jabber-chat--send-hook-stanza))) (jabber-chat--clear-send-context)))) (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-buffer-connection))) ((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.15.1/lisp/jabber-message-thread-protocol.el000066400000000000000000000060141527111033600233550ustar00rootroot00000000000000;;; 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 for a core thread element in XML-DATA." (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.15.1/lisp/jabber-message-thread.el000066400000000000000000001002211527111033600215110ustar00rootroot00000000000000;;; 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) ;; Chat loads this library before defining its shared composition policy. (declare-function jabber-chat--captured-reply-elements "jabber-chat" (body correction-p &optional stanza)) (declare-function jabber-chat--clear-send-context "jabber-chat" ()) (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 reply elements for BODY." (unless (bound-and-true-p jabber-chat--send-context-captured) (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) (setq elements (append elements (jabber-chat--captured-reply-elements body nil (bound-and-true-p jabber-chat--send-hook-stanza)))) (jabber-chat--clear-send-context)) 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 jabber-buffer-connection)))) (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) (jabber-chat-ewoc-invalidate 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.15.1/lisp/jabber-modeline.el000066400000000000000000000202361527111033600204230ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-moderation.el000066400000000000000000000510651527111033600207740ustar00rootroot00000000000000;;; jabber-moderation.el --- XEP-0424/0425 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 incoming MUC author retractions from XEP-0424 in rooms with ;; trusted XEP-0421 occupant identifiers, plus moderated retractions from ;; XEP-0425. Accepted retractions replace the original message with a ;; tombstone in storage and live chat buffers. ;;; 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) (require 'seq) (require 'subr-x) (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.") (defconst jabber-moderation-occupant-id-xmlns "urn:xmpp:occupant-id:0" "XML namespace for XEP-0421 MUC occupant identifiers.") (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--children-with-name-and-xmlns (xml-data name xmlns) "Return child elements of XML-DATA with NAME and XMLNS." (cl-remove-if-not (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--single-child-with-name-and-xmlns (xml-data name xmlns) "Return XML-DATA's sole child with NAME and XMLNS, or nil." (let ((children (jabber-moderation--children-with-name-and-xmlns xml-data name xmlns))) (and (null (cdr children)) (car children)))) (defun jabber-moderation--muc-retraction-message-p (xml-data) "Return non-nil for a MUC XEP-0424 retraction in XML-DATA. This intentionally does not require a valid target. XEP-0424 forbids displaying sender-controlled fallback bodies even for unknown targets." (and (string= (or (jabber-xml-get-attribute xml-data 'type) "") "groupchat") (jabber-moderation--child-with-name-and-xmlns xml-data 'retract jabber-moderation-retract-xmlns))) (defun jabber-moderation--history-inhibit-p (_jc xml-data) "Return non-nil when XML-DATA is a MUC retraction action stanza." (jabber-moderation--muc-retraction-message-p xml-data)) (defun jabber-moderation--room-supports-occupant-id-p (room jc) "Return non-nil for cached XEP-0421 support in ROOM on connection JC." (member jabber-moderation-occupant-id-xmlns (nth 1 (jabber-disco-get-info-immediately room nil jc)))) (defun jabber-moderation--single-occupant-id (xml-data) "Return XML-DATA's one valid XEP-0421 occupant ID, or nil." (when-let* ((element (jabber-moderation--single-child-with-name-and-xmlns xml-data 'occupant-id jabber-moderation-occupant-id-xmlns)) (occupant-id (jabber-xml-get-attribute element 'id)) ((not (string-empty-p occupant-id))) ((<= (length occupant-id) 128))) occupant-id)) (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--target-buffers-for-row (jc room row-id) "Return live buffers containing exact message ROW-ID in ROOM on JC." (let ((thread-targets (jabber-message-thread-update-targets-for-row jc room "groupchat" row-id))) (cond ((eq thread-targets 'closed) nil) (thread-targets thread-targets) (t (delq nil (list (jabber-muc-find-buffer room jc))))))) (defun jabber-moderation--author-candidate (candidates occupant-id) "Return the sole occupant-matched retraction target, or nil. CANDIDATES all refer to one conversation-scoped ID. OCCUPANT-ID authorizes the sender." (let ((candidate (and (null (cdr candidates)) (car candidates)))) (when (and candidate (jabber-jid-resource (plist-get candidate :from)) (equal occupant-id (plist-get candidate :occupant-id))) candidate))) (defun jabber-moderation--live-author-candidates (jc room server-id) "Return live message candidates for SERVER-ID in ROOM on JC." (let (candidates) (dolist (buffer (buffer-list) (nreverse candidates)) (when (buffer-live-p buffer) (with-current-buffer buffer (when (and (eq jabber-buffer-connection jc) (equal (bound-and-true-p jabber-group) room) jabber-chat-ewoc) (let ((node (ewoc-nth jabber-chat-ewoc 0))) (while node (let* ((data (ewoc-data node)) (msg (and (memq (car-safe data) '(:muc-local :muc-foreign)) (cadr data)))) (when (and (listp msg) (equal server-id (plist-get msg :server-id))) (push (list :buffer buffer :node node :thread-id (bound-and-true-p jabber-message-thread-id) :from (plist-get msg :from) :occupant-id (plist-get msg :occupant-id) :retracted (plist-get msg :retracted) :retracted-by (plist-get msg :retracted-by) :retraction-reason (plist-get msg :retraction-reason)) candidates))) (setq node (ewoc-next jabber-chat-ewoc node)))))))))) (defun jabber-moderation--live-projection-set-p (candidates) "Return non-nil when CANDIDATES form at most one logical projection set." (and (<= (length candidates) 2) (<= (seq-count (lambda (candidate) (null (plist-get candidate :thread-id))) candidates) 1) (<= (seq-count (lambda (candidate) (plist-get candidate :thread-id)) candidates) 1))) (defun jabber-moderation--live-original (candidates occupant-id) "Return CANDIDATES' one logical target authorized by OCCUPANT-ID." (when (and candidates (jabber-moderation--live-projection-set-p candidates) (seq-every-p (lambda (candidate) (and (jabber-jid-resource (plist-get candidate :from)) (equal occupant-id (plist-get candidate :occupant-id)) (not (plist-get candidate :retracted)) (not (plist-get candidate :retracted-by)))) candidates)) candidates)) (defun jabber-moderation--apply-live-author-retraction (candidates server-id from) "Retract live CANDIDATES identified by SERVER-ID and FROM." (dolist (candidate candidates) (with-current-buffer (plist-get candidate :buffer) (jabber-message-thread--mark-root-retracted server-id) (jabber-moderation--mark-node-retracted (plist-get candidate :node) from nil))) t) (defun jabber-moderation--live-candidates-match-p (candidates original occupant-id) "Return non-nil when CANDIDATES agree with ORIGINAL and OCCUPANT-ID." (and (or (null candidates) (and (jabber-moderation--live-projection-set-p candidates) (seq-every-p (lambda (candidate) (equal occupant-id (plist-get candidate :occupant-id))) candidates))) (seq-every-p (lambda (candidate) (equal (plist-get candidate :from) (plist-get original :from))) candidates))) (defun jabber-moderation--handle-author-retraction (jc xml-data retraction) "Apply an XEP-0424 MUC author RETRACTION from XML-DATA on JC." (when-let* ((from (jabber-xml-get-attribute xml-data 'from)) ((jabber-jid-resource from)) (room (jabber-jid-user from)) ((jabber-moderation--room-supports-occupant-id-p room jc)) (occupant-id (jabber-moderation--single-occupant-id xml-data)) (server-id (jabber-xml-get-attribute retraction 'id)) ((not (string-empty-p server-id))) (account (jabber-connection-bare-jid jc))) (let ((stored-candidates (jabber-db-message-retraction-candidates account room server-id)) (live-candidates (jabber-moderation--live-author-candidates jc room server-id))) (if stored-candidates (when-let* ((candidate (jabber-moderation--author-candidate stored-candidates occupant-id)) ((jabber-moderation--live-candidates-match-p live-candidates candidate occupant-id))) (if (or (plist-get candidate :retracted) (plist-get candidate :retracted-by)) (progn (dolist (buffer (jabber-moderation--target-buffers-for-row jc room (plist-get candidate :row-id))) (with-current-buffer buffer (jabber-moderation--mark-ewoc-retracted server-id (plist-get candidate :retracted-by) (plist-get candidate :retraction-reason) (plist-get candidate :from)))) t) (when (jabber-db-retract-message-row (plist-get candidate :row-id) from) (dolist (buffer (jabber-moderation--target-buffers-for-row jc room (plist-get candidate :row-id))) (with-current-buffer buffer (jabber-moderation--mark-ewoc-retracted server-id from nil (plist-get candidate :from)))) t))) (when-let* ((candidates (jabber-moderation--live-original live-candidates occupant-id))) (jabber-moderation--apply-live-author-retraction candidates server-id from)))))) (defun jabber-moderation--handle-message (jc xml-data) "Handle MUC 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))) (if-let* ((moderated (car (jabber-xml-get-children retraction 'moderated)))) (when-let* ((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))) (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)) (unless (cdr entry) (when-let* ((single-retraction (jabber-moderation--single-child-with-name-and-xmlns xml-data 'retract jabber-moderation-retract-xmlns))) (jabber-moderation--handle-author-retraction jc xml-data single-retraction)))))) (jabber-chain-add 'jabber-message-chain #'jabber-moderation--handle-message) (add-to-list 'jabber-history-inhibit-received-message-functions #'jabber-moderation--history-inhibit-p) ;; 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-node-retracted (node retracted-by reason) "Mark EWOC NODE retracted by RETRACTED-BY for REASON." (when-let* ((data (ewoc-data node)) (msg (cadr data))) (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-ewoc-retracted (server-id retracted-by reason &optional original-from) "Mark the ewoc node with SERVER-ID as retracted in the current buffer. RETRACTED-BY and REASON are stored on the message plist. When ORIGINAL-FROM is non-nil, require that full JID to match." (jabber-message-thread--mark-root-retracted server-id) (when-let* ((node (if original-from (jabber-chat-ewoc-find-by-id-and-sender server-id original-from) (jabber-chat-ewoc-find-by-id server-id))) (data (ewoc-data node)) (msg (cadr data)) ((equal server-id (plist-get msg :server-id)))) (jabber-moderation--mark-node-retracted node retracted-by reason))) (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.15.1/lisp/jabber-muc-menu.el000066400000000000000000000037351527111033600203620ustar00rootroot00000000000000;;; 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) ;; Newer popup revisions generate these launchers at first initialization. (declare-function jabber-muc-menu-map-popup "jabber-muc-menu" () t) (unless (boundp '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.15.1/lisp/jabber-muc-nick-completion.el000066400000000000000000000171541527111033600225110ustar00rootroot00000000000000;;; 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 for the current connection. MUC dispatch binds `jabber-buffer-connection' to the receiving account, including when no room buffer is open." (let ((room (or group jabber-group))) (if jabber-buffer-connection (jabber-muc-nickname room jabber-buffer-connection) (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.15.1/lisp/jabber-muc-protocol.el000066400000000000000000000075731527111033600212630ustar00rootroot00000000000000;;; 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 :test #'equal) "Hash table of connection-owned groupchats and nicknames. Keys are (CONNECTION LOWERCASE-BARE-ROOM-JID) lists; values are nicknames. Remember the last nickname used on that connection, including after failure or departure. Never use contact symbols as room identities.") (defun jabber-muc--pending-key (jc jid) "Return a connection-owned pending room key for JC and JID. Keep the historical lowercase bare-JID matching without contact symbols." (list jc (downcase (jabber-jid-user jid)))) (defun jabber-muc--pending-nickname (jc jid) "Return JC's last join nickname for JID, or nil without an owner. JID may be a bare room JID or a full occupant JID." (and jc jid (gethash (jabber-muc--pending-key jc jid) jabber-pending-groupchats))) ;;;###autoload (defun jabber-muc-message-p (message &optional jc) "Return non-nil if MESSAGE is a groupchat message. That does not include private messages in a groupchat, but does include groupchat invites. JC is the receiving connection; without it, only explicit groupchat types and invitation markers qualify." (let ((from (jabber-xml-get-attribute message 'from)) (type (jabber-xml-get-attribute message 'type))) (or (string= type "groupchat") (and (string= type "error") (jabber-muc--pending-nickname jc from)) (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 &optional jc) "Return non-nil if PRESENCE is presence from groupchat on JC. Without the receiving connection JC, require an explicit MUC marker." (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") (jabber-muc--pending-nickname jc from))))) (provide 'jabber-muc-protocol) ;;; jabber-muc-protocol.el ends here emacs-jabber-0.15.1/lisp/jabber-muc-state.el000066400000000000000000000053751527111033600205400ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-muc.el000066400000000000000000004221201527111033600174110ustar00rootroot00000000000000;;; 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) "Connection-owned room identity records, keyed by (JC GROUP). Each record binds transport, session, account and membership, and holds current occupants, affiliation snapshots and per-affiliation query tokens.") (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. Native creates install an identity-bearing (TAG JC ROOM) permission. Manual non-nil values remain valid. Consumption clears before configuration.") (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 records a passwordless actual join or a rejected password.") (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 Names shared by different connections or rooms cannot be reused while another scope has pending automatic configuration. Use distinct names or retry after its room-creation event consumes that permission. The default %a separates distinct accounts, not connections to one account." :type 'string :group 'jabber-chat) (defcustom jabber-muc-header-line-format '(" " (:eval (propertize (jabber-jid-displayname jabber-group jabber-buffer-connection) '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) jabber-buffer-connection)) " " (: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 success-callback failure-callback)) (declare-function jabber-mam-muc-joined "jabber-mam" (jc group)) (declare-function jabber-mam--cancel-muc-query "jabber-mam" (group &optional jc)) (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-moderation--muc-retraction-message-p "jabber-moderation" (xml-data)) (autoload 'jabber-moderation--muc-retraction-message-p "jabber-moderation") (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 jc)) (cons ?b (jabber-jid-bookmarkname group jc)) (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--foreign-arm-p (arm jc group) "Return non-nil if package ARM belongs to another JC or GROUP." (and (eq (car-safe arm) 'jabber-muc--config-arm) (not (and (eq (nth 1 arm) jc) (equal (nth 2 arm) group))))) (defun jabber-muc--check-buffer-arm (buffer jc group) "Reject BUFFER when its configuration permission is foreign to JC/GROUP." (when (and (buffer-live-p buffer) (jabber-muc--foreign-arm-p (buffer-local-value 'jabber-muc--auto-configure buffer) jc group)) (user-error "MUC buffer has pending configuration for another connection or room; use a distinct groupchat buffer name"))) (defun jabber-muc-create-buffer (jc group) "Prepare a buffer for chatroom GROUP. This function is idempotent. Pending foreign configuration rejects reuse; choose a distinct groupchat buffer name. JC is the Jabber connection." (with-current-buffer (get-buffer-create (jabber-muc-get-buffer group jc)) (jabber-muc--check-buffer-arm (current-buffer) jc group) (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)) ;; Setup can reenter and install a foreign permission. (jabber-muc--check-buffer-arm (current-buffer) jc group) (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 jc)) (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). SUCCESS-CALLBACK and FAILURE-CALLBACK report transport completion, not acceptance into the Stream Management queue." (let ((buffer (current-buffer)) (input jabber-point-insert) (mode major-mode) (context (list :state (jabber-chat--send-context-state (assq 'replace extra-elements)))) (completion (unless (assq 'replace extra-elements) jabber-chat--input-completion)) accepted) (unwind-protect (prog1 (jabber-muc--send jc body extra-elements success-callback failure-callback) (setq accepted t)) (when (and (not accepted) ;; A provider may already have settled failure or lost its ;; composer to a new edit before propagating quit. (or (not completion) (funcall completion nil)) (buffer-live-p buffer)) (with-current-buffer buffer (when (and (eq input jabber-point-insert) (eq mode major-mode) (eq jc jabber-buffer-connection)) (jabber-chat--restore-send-context context))))))) (defun jabber-muc--send (jc body extra-elements success-callback failure-callback) "Dispatch BODY on JC with EXTRA-ELEMENTS using the selected encryption. SUCCESS-CALLBACK and FAILURE-CALLBACK report transport completion." ;; 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 success-callback failure-callback)) (_ (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) (if (or success-callback failure-callback) (jabber-send-sexp jc stanza success-callback failure-callback) (jabber-send-sexp jc stanza)))))) (defun jabber-muc-add-groupchat (group nickname &optional jc) "Remember participating in GROUP under NICKNAME via JC." (jabber-muc-join-set group jc nickname)) (defun jabber-muc-remove-groupchat (group &optional jc request) "Remove GROUP from internal bookkeeping. If JC is given, only remove that connection's entry. REQUEST, when non-nil, guards the terminal caller's remaining effects." (jabber-muc--identity-retire group jc) (jabber-muc-leave-remove group jc) ;; 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--nonanonymous-rooms)) (when (and jc (fboundp 'jabber-message-correct--muc-room-leave)) (jabber-message-correct--muc-room-leave jc group)) (when request (jabber-muc--check-intent request)) (jabber-mam--cancel-muc-query group jc) (when request (jabber-muc--check-intent request))) (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 (and preserve-for-reconnect-p (copy-sequence (gethash bare-jid jabber-muc--rooms-before-disconnect)))) (pending (cl-loop for jc in jabber-connections when (equal bare-jid (jabber-connection-bare-jid jc)) append (cl-loop for (room . attempt) in (plist-get (fsm-get-state-data jc) :muc-room-attempts) when (and (eq (plist-get attempt :status) 'pending) (equal (plist-get attempt :session) (plist-get (fsm-get-state-data jc) :session-id))) collect (list room (plist-get attempt :nick) (gethash (list jc room) jabber-muc--session-passwords)))))) (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 (setq snapshot (assoc-delete-all room snapshot)) (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--identity-retire room (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--nonanonymous-rooms))))) (dolist (entry pending) (setq snapshot (cons entry (assoc-delete-all (car entry) snapshot)))) (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--attempt-current-p (jc room attempt &optional active) "Return non-nil if JC still owns ROOM's ATTEMPT lease. When ACTIVE is non-nil, also require pending or ready membership permission." (let ((state (fsm-get-state-data jc))) (and attempt (or (not active) (memq (plist-get (jabber-sm--room-attempt state room) :status) '(pending ready))) (eq (plist-get attempt :token) (plist-get (jabber-sm--room-attempt state room) :token)) (eq (plist-get attempt :transport) (plist-get state :connection)) (equal (plist-get attempt :session) (plist-get state :session-id))))) (defun jabber-muc--attempt-expired-p (jc attempt) "Return non-nil when ATTEMPT merely expired on JC's current stream. Only a withdrawal keeps fencing room presence: a departure, a kick, a ban or a rejected entry. An ordinary join deadline or send failure does not, because the server may still admit that join afterwards and its self-presence remains the authority on our membership. A record from another transport or session keeps fencing: only a successful resume transfers that authority." (let ((state (fsm-get-state-data jc))) (and attempt (eq (plist-get attempt :status) 'failed) (eq (plist-get attempt :disposition) 'expired) (eq (plist-get attempt :transport) (plist-get state :connection)) (equal (plist-get attempt :session) (plist-get state :session-id))))) (defun jabber-muc--live-attempt (jc group) "Return the attempt record still governing GROUP presence on JC. Return nil when nothing governs it, so late presence takes the ordinary unleased path and `jabber-muc--adopt-membership' leases the admission. An expired ordinary join governs nothing (see `jabber-muc--attempt-expired-p'): XEP-0045 section 7.2 makes the room's self-presence the moment we are joined, with no client deadline, and both Dino and Gajim keep accepting room presence for a room they asked to enter and have not left." (when-let* ((attempt (jabber-sm--room-attempt (fsm-get-state-data jc) group))) (unless (and (not (jabber-muc--attempt-current-p jc group attempt t)) (jabber-muc--attempt-expired-p jc attempt)) attempt))) (defun jabber-muc--withdraw-attempt (jc room) "Retire ROOM's expired attempt record on JC after a withdrawal. A departure, kick, ban or rejected entry withdraws the permission an expired deadline left open, so late self-presence cannot reopen it." (when-let* ((attempt (jabber-sm--room-attempt (fsm-get-state-data jc) room))) (when (eq (plist-get attempt :status) 'failed) (jabber-muc--publish-attempt jc room (plist-put (copy-sequence attempt) :disposition 'retired))))) (defun jabber-muc--adopt-membership (jc room nick) "Lease ROOM on JC as NICK for a membership the server already granted. Every joined room owns a current lease: alias transitions, withdrawal fences, identity transfer across resumption and stream-management handoff all key off one. A deadline ends the join request, so an unleased admission and an expiry that outlived its own request both adopt the membership instead of leaving the room leaseless." (let ((state (fsm-get-state-data jc))) (jabber-muc--publish-attempt jc room (list :token (make-symbol "room") :nick nick :previous nil :status 'ready :transport (plist-get state :connection) :session (plist-get state :session-id))))) (defun jabber-muc--continuation (jc callback &optional room) "Fence CALLBACK by JC's stream and ROOM token, or autojoin generation." (let* ((state (fsm-get-state-data jc)) (transport (plist-get state :connection)) (session (plist-get state :session-id)) (key (if room :token :muc-autojoin-generation)) (owner (plist-get (if room (jabber-sm--room-attempt state room) state) key))) (lambda (&rest args) (let ((current (fsm-get-state-data jc))) (when (and (eq transport (plist-get current :connection)) (equal session (plist-get current :session-id)) (eq owner (plist-get (if room (jabber-sm--room-attempt current room) current) key))) (apply callback args)))))) (defun jabber-muc--publish-attempt (jc room attempt) "Publish ROOM's ATTEMPT in a fresh top-level state on JC." (let* ((state (copy-sequence (fsm-get-state-data jc))) (rooms (assoc-delete-all room (copy-sequence (plist-get state :muc-room-attempts))))) (put jc :state-data (plist-put state :muc-room-attempts (cons (cons room attempt) rooms))))) (defun jabber-muc--start-attempt (jc room nick &optional previous) "Reserve JC's next ROOM attempt for NICK, retaining PREVIOUS membership." (let* ((state (fsm-get-state-data jc)) (old (jabber-sm--room-attempt state room)) (attempt (list :token (make-symbol "room") :nick nick :previous previous :status 'pending :transport (plist-get state :connection) :session (plist-get state :session-id)))) (when (timerp (plist-get old :timer)) (cancel-timer (plist-get old :timer))) (jabber-muc--publish-attempt jc room attempt) (plist-put attempt :timer (run-with-timer jabber-muc-autojoin-timeout nil #'jabber-muc--fail-attempt jc room attempt "Room join timed out")) attempt)) (defun jabber-muc--fail-attempt (jc room attempt reason &optional disposition) "Cancel ROOM work on JC only while ATTEMPT owns it, reporting REASON. DISPOSITION is `retired' when the caller knows the membership is gone: a departure, a kick, a ban or a rejected entry, all of which retire the room themselves. It defaults to `expired', which ends this request only: retained stanzas still fail, but an established membership keeps its lease and a pending one stays admissible, because the server alone withdraws membership." (when (and (jabber-muc--attempt-current-p jc room attempt) ;; The published record is the authority: a captured pending ;; object must never reopen or downgrade a terminal outcome. (memq (plist-get (jabber-sm--room-attempt (fsm-get-state-data jc) room) :status) '(pending ready))) (when (timerp (plist-get attempt :timer)) (cancel-timer (plist-get attempt :timer))) (let ((entries nil) (state (copy-sequence (fsm-get-state-data jc)))) (dolist (slot '(:sm-pending-queue :nil-entry-pending)) (let* ((queue (plist-get state slot)) (owned (cl-remove-if-not (lambda (e) (equal room (jabber-sm--entry-room e))) queue))) (setq entries (append entries owned)) (setq state (plist-put state slot (cl-set-difference queue owned :test #'eq))))) (setq disposition (or disposition 'expired)) (put jc :state-data state) (if (and (eq disposition 'expired) (jabber-muc-joined-p room jc)) ;; The request died, not the membership: keep the room leased ;; under the nickname the server last confirmed. (jabber-muc--adopt-membership jc room (jabber-muc-nickname room jc)) (jabber-muc--publish-attempt jc room (plist-put (plist-put (copy-sequence attempt) :status 'failed) :disposition disposition)) ;; Only a withdrawal retires the room; a deadline must not discard ;; the password and snapshot a late admission or reconnect needs. (when (eq disposition 'retired) (jabber-muc--retire-room jc room))) ;; All captured echoes are disposed before the first callback can retry. (when (fboundp 'jabber-omemo--move-echo) (mapc (lambda (e) (jabber-omemo--move-echo e nil)) entries)) (jabber-sm--fail-pending entries reason) (jabber-sm--schedule-drain jc (fsm-get-state-data jc))))) (defun jabber-muc--resume-identities (jc group old attempt) "Transfer GROUP identities on JC from OLD to resumed ATTEMPT. Only the successful SM resume path may transfer transport authority. Preserve accepted occupants and snapshots, never outstanding query tokens." (let* ((key (list jc group)) (record (gethash key jabber-muc--room-jids)) (membership (assq jc (jabber-muc-room-entries group)))) (when (and record (memq (plist-get old :status) '(pending ready)) (eq (plist-get record :transport) (plist-get old :transport)) (equal (plist-get record :session) (plist-get old :session)) (equal (plist-get record :account) (jabber-connection-bare-jid jc)) (if (plist-get record :membership) (eq membership (plist-get record :membership)) (eq (plist-get record :attempt) (plist-get old :token)))) ;; A new record fences even callbacks retaining the predecessor object. ;; The new stream header has its own ID even when SM resumed the same ;; logical session. Transfer both fences only at this native boundary. (let ((resumed (copy-sequence record))) (plist-put resumed :transport (plist-get attempt :transport)) (plist-put resumed :session (plist-get attempt :session)) (plist-put resumed :attempt (plist-get attempt :token)) (plist-put resumed :queries nil) (puthash key resumed jabber-muc--room-jids))))) (defun jabber-muc--resume-attempts (jc) "Transfer JC's room leases to its resumed transport without new joins." (dolist (cell (plist-get (fsm-get-state-data jc) :muc-room-attempts)) (let* ((old (cdr cell)) (attempt (jabber-muc--start-attempt jc (car cell) (plist-get old :nick) (plist-get old :previous)))) (jabber-muc--resume-identities jc (car cell) old attempt) (unless (eq (plist-get old :status) 'pending) (when (timerp (plist-get attempt :timer)) (cancel-timer (plist-get attempt :timer))) ;; Carry the terminal disposition too: a resumed stream must not ;; turn an expired ordinary join into a governing failed lease. (jabber-muc--publish-attempt jc (car cell) (plist-put (plist-put attempt :status (plist-get old :status)) :disposition (plist-get old :disposition))))))) (defun jabber-muc--session-reset (jc) "Clear room state belonging to the lost logical session on JC." (jabber-muc--invalidate-intent jc) (dolist (key (hash-table-keys jabber-muc--room-jids)) (when (eq jc (car key)) (remhash key jabber-muc--room-jids))) (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) (dolist (cell (plist-get state-data :muc-room-attempts)) (when (timerp (plist-get (cdr cell) :timer)) (cancel-timer (plist-get (cdr cell) :timer)))) (put jc :state-data (plist-put (copy-sequence (fsm-get-state-data jc)) :muc-room-attempts nil)) (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")) (let ((password (jabber-muc--session-password jc room)) (state (fsm-get-state-data jc))) (jabber-muc-remove-groupchat room jc) (when (eq state (fsm-get-state-data jc)) (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 (let* ((state (fsm-get-state-data jc)) (transport (plist-get state :connection)) (session (plist-get state :session-id)) (attempt (jabber-sm--room-attempt state group))) (lambda (c xml data) (when (and (eq transport (plist-get (fsm-get-state-data c) :connection)) (equal session (plist-get (fsm-get-state-data c) :session-id)) (equal nick (jabber-muc-nickname group c)) (eq attempt (jabber-sm--room-attempt (fsm-get-state-data c) group))) (jabber-muc--self-ping-failed c xml data)))) 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 established connections. A reconnecting account keeps its rooms, but must not send IQs while its new stream is still negotiating." (dolist (jc jabber-connections) (when (and jc (eq (get jc :state) :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--invalidate-intent (jc &optional group) "Invalidate native requests and package permissions for JC and GROUP. Without GROUP, invalidate all rooms on JC. Preserve manual permissions." (put jc 'jabber-muc--join-intents (and group (assoc-delete-all group (get jc 'jabber-muc--join-intents)))) (dolist (buffer (if group (list (jabber-muc-find-buffer group jc)) (buffer-list))) (when (buffer-live-p buffer) (with-current-buffer buffer (let ((arm jabber-muc--auto-configure)) (when (and (eq (car-safe arm) 'jabber-muc--config-arm) (eq (nth 1 arm) jc) (or (null group) (equal (nth 2 arm) group))) (setq jabber-muc--auto-configure nil))))))) (defun jabber-muc--reserve-intent (jc group) "Reserve a unique native request for exact JC and GROUP." (jabber-muc--invalidate-intent jc group) (let* ((data (fsm-get-state-data jc)) (request (vector jc group (plist-get data :connection) (plist-get data :session-id) (plist-get data :nil-entry-token) nil nil))) (push (cons group request) (get jc 'jabber-muc--join-intents)) request)) (defun jabber-muc--check-intent (request) "Exit the native continuation if REQUEST is no longer eligible." (let* ((jc (aref request 0)) (data (fsm-get-state-data jc))) (unless (and (eq request (cdr (assoc (aref request 1) (get jc 'jabber-muc--join-intents)))) (jabber-connection-active-p jc) (not (plist-get data :registerp)) (eq (aref request 2) (plist-get data :connection)) (equal (aref request 3) (plist-get data :session-id)) (eq (aref request 4) (plist-get data :nil-entry-token))) (throw 'jabber-muc--cancelled :cancelled)))) (defmacro jabber-muc--with-intent (request &rest body) "Run BODY under REQUEST, retiring only its own state on unwind." (declare (indent 1) (debug (form body))) (let ((result (make-symbol "result")) (owner (make-symbol "owner"))) `(let ((,owner ,request) ,result) (unwind-protect (setq ,result (catch 'jabber-muc--cancelled (jabber-muc--check-intent ,owner) ,@body)) (unless (eq ,result :pending) (let ((jc (aref ,owner 0)) (group (aref ,owner 1))) (when (eq ,owner (cdr (assoc group (get jc 'jabber-muc--join-intents)))) (put jc 'jabber-muc--join-intents (assoc-delete-all group (get jc 'jabber-muc--join-intents))))) (unless (eq ,result t) (when (and (aref ,owner 6) (buffer-live-p (aref ,owner 5))) (with-current-buffer (aref ,owner 5) (when (eq jabber-muc--auto-configure (aref ,owner 6)) (setq jabber-muc--auto-configure nil)))))))))) (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))) (let ((request (jabber-muc--reserve-intent jc group))) (jabber-muc--with-intent request (jabber-muc--autojoin-dequeue jc group) (jabber-muc--check-intent request) (cond ;; Already joined: open buffer, sync and verify membership. ((jabber-muc-joined-p group jc) (when popup (let ((buffer (jabber-muc-create-buffer jc group))) (jabber-muc--check-intent request) (switch-to-buffer buffer))) (jabber-muc--check-intent request) (jabber-mam-muc-joined jc group) (jabber-muc--check-intent request) (jabber-muc--self-ping-one jc group) (jabber-muc--check-intent request) t) ;; 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--check-intent request) (jabber-muc--send-join-presence jc group nickname password popup nil request))) (t (jabber-disco-get-info jc group nil #'jabber-muc--disco-callback (list group nickname popup request)) :pending))))) ;;;###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. Pending foreign configuration in a shared buffer signals `user-error'; use distinct groupchat buffer names or retry after the original creation event consumes its permission. 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 "")))) (let ((request (jabber-muc--reserve-intent jc group))) (jabber-muc--with-intent request (jabber-muc--send-join-presence jc group nickname nil t t request) (jabber-muc--check-intent request) (jabber-bookmarks--publish-one jc group nickname) t))) (defun jabber-muc--room-connection (group &optional jc) "Return an active account joined to GROUP, retaining JC when supplied. Prompt when multiple accounts have joined; never replace a stale JC." (let* ((accounts (mapcar (lambda (entry) (cons (jabber-connection-bare-jid (car entry)) (car entry))) (cl-remove-if-not (lambda (entry) (memq (car entry) jabber-connections)) (jabber-muc-room-entries group)))) (owner (or jc (if (cdr accounts) (cdr (assoc (completing-read "Account: " accounts nil t) accounts)) (cdar accounts))))) (unless (and (memq owner jabber-connections) (jabber-muc-joined-p group owner)) (user-error "Selected account is no longer joined to this room")) owner)) ;;;###autoload (defun jabber-muc-switch-to (group &optional jc) "Switch to the active groupchat buffer for GROUP on JC. Prompt with completion for joined rooms only. When JC is nil, ask which account to use if multiple accounts have joined GROUP." (interactive (list (completing-read "Groupchat: " (jabber-muc-active-rooms) nil t))) (let* ((jc (jabber-muc--room-connection group jc)) (buffer (or (jabber-muc-find-buffer group jc) (jabber-muc-create-buffer jc group)))) (jabber-muc--room-connection group jc) (unless (and (buffer-live-p buffer) (eq (buffer-local-value 'jabber-buffer-connection buffer) jc) (equal (buffer-local-value 'jabber-group buffer) group)) (user-error "Room buffer no longer belongs to selected account")) (switch-to-buffer buffer))) (defun jabber-muc--disco-callback (jc closure result) "Disco callback for MUC join. JC is the Jabber connection. CLOSURE is (GROUP NICKNAME POPUP REQUEST), or the legacy three-element form, which reserves fresh ownership. RESULT is the disco#info result." (pcase-let* ((`(,group ,nickname ,popup . ,tail) closure) (request (or (car tail) (jabber-muc--reserve-intent jc group)))) (jabber-muc--with-intent request (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 jc)))) (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 jc)))) (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 jc))))) (jabber-muc--check-intent request) (when (member "muc_nonanonymous" features) (puthash group t jabber-muc--nonanonymous-rooms)) (jabber-muc--send-join-presence jc group nickname password popup nil request))) t)))) (defalias 'jabber-muc-join-2 #'jabber-muc--disco-callback) (defun jabber-muc--send-join-presence (jc group nickname password popup &optional auto-configure request) "Send MUC join presence for GROUP with NICKNAME on JC. PASSWORD is the room password, or nil. POPUP selects the MUC buffer. AUTO-CONFIGURE arms configuration on room creation. REQUEST carries native ownership; absent REQUEST reserves and retires a fresh owner. Return t after synchronous completion, or :cancelled when superseded." (if (null request) (let ((owner (jabber-muc--reserve-intent jc group))) (jabber-muc--with-intent owner (jabber-muc--send-join-presence jc group nickname password popup auto-configure owner))) (jabber-muc--check-intent request) (let ((stanza `(presence ((to . ,(format "%s/%s" group nickname))) (x ((xmlns . ,jabber-muc-xmlns)) (history ((maxchars . "0"))) ,@(when password `((password () ,password)))) ,@(jabber-presence-children jc))) buffer attempt) (jabber-muc--check-intent request) ;; A create response must already have a registered, armed destination. (when auto-configure (setq buffer (jabber-muc-create-buffer jc group)) (jabber-muc--check-intent request) (unless (and (buffer-live-p buffer) (eq (buffer-local-value 'jabber-buffer-connection buffer) jc) (equal (buffer-local-value 'jabber-group buffer) group)) (throw 'jabber-muc--cancelled :cancelled))) (jabber-muc--check-buffer-arm (or buffer (get-buffer (jabber-muc-get-buffer group jc))) jc group) (jabber-muc--check-intent request) (when buffer (with-current-buffer buffer (unless jabber-muc--auto-configure (aset request 5 buffer) (aset request 6 (list 'jabber-muc--config-arm jc group)) (setq jabber-muc--auto-configure (aref request 6))))) (when (or (jabber-sm--active-recovery-room-p (fsm-get-state-data jc) group) (jabber-sm--room-attempt (fsm-get-state-data jc) group)) (dolist (entry (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (when (and (equal group (jabber-sm--entry-room entry)) (not (plist-member entry :echo-key)) (fboundp 'jabber-omemo--current-echo-key)) (plist-put entry :echo-key (jabber-omemo--current-echo-key jc (jabber-sm--pending-stanza entry)))))) ;; Ordinary joins need the same pending membership lease as recovery. (setq attempt (jabber-muc--start-attempt jc group nickname)) ;; Publish bookkeeping before handoff, but never roll it back afterward. (puthash (list jc group) password jabber-muc--session-passwords) (puthash (jabber-muc--pending-key jc group) nickname jabber-pending-groupchats) (jabber-muc--check-intent request) (if attempt (jabber-send-sexp jc stanza nil (lambda (reason) (jabber-muc--fail-attempt jc group attempt reason))) (jabber-send-sexp jc stanza)) (jabber-muc--check-intent request) (when (and attempt (not (jabber-muc--attempt-current-p jc group attempt))) (throw 'jabber-muc--cancelled :cancelled)) (when popup (unless buffer (setq buffer (jabber-muc-create-buffer jc group))) (jabber-muc--check-intent request) (switch-to-buffer buffer) (jabber-muc--check-intent request)) t))) (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* ((room (and (eq major-mode 'jabber-chat-mode) (bound-and-true-p jabber-group))) (owner (and room jabber-buffer-connection)) (group (or room (completing-read "Groupchat: " (jabber-muc-active-rooms) nil t))) (jc (jabber-muc--room-connection group owner)) (current (jabber-muc-nickname group jc)) (new-nick (read-string (format "New nickname (current: %s): " current) nil nil current))) (jabber-muc--room-connection group jc) (list jc group new-nick))) (when (jabber-sm--active-recovery-room-p (fsm-get-state-data jc) group) (jabber-muc--start-attempt jc group nickname (jabber-muc-nickname group jc))) (jabber-send-sexp jc `(presence ((to . ,(format "%s/%s" group nickname)))))) (defun jabber-muc--retire-room (jc group) "Retire GROUP's ordinary membership and reconnect intent on JC. The caller reserves native continuation authority before this local commit." (jabber-muc--identity-retire group jc) (jabber-muc-leave-remove group jc) (let* ((bare-jid (jabber-connection-bare-jid jc)) (snapshot (cl-remove group (gethash bare-jid jabber-muc--rooms-before-disconnect) :key #'car :test #'equal))) (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) (jabber-muc--autojoin-dequeue jc group)) (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)) (request (jabber-muc--reserve-intent jc group))) (jabber-muc--retire-room jc group) (jabber-muc--withdraw-attempt jc group) (when-let* ((attempt (jabber-sm--room-attempt (fsm-get-state-data jc) group))) (jabber-muc--fail-attempt jc group attempt "Room left" 'retired)) (jabber-muc--with-intent request ;; Address the old membership even though it is already retired. (jabber-send-sexp jc `(presence ((to . ,(format "%s/%s" group nick)) (type . "unavailable")))) (jabber-muc--check-intent request) (when jabber-bookmarks-auto-add (jabber-bookmarks--retract-one jc group)) t))) (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 jabber-buffer-connection))))) (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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Invite whom: " ;; The current room is _not_ a good default for whom to invite. (cl-remove jabber-group (plist-get (fsm-get-state-data jc) :roster) :key #'symbol-name :test #'equal) nil nil nil nil jc) (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 jabber-buffer-connection)) (when inviter (insert " by " (jabber-jid-displayname inviter jabber-buffer-connection))) (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)))) (put jc :state-data (plist-put (copy-sequence (fsm-get-state-data jc)) :muc-autojoin-discovering (remove group (plist-get (fsm-get-state-data jc) :muc-autojoin-discovering)))) ;; Decrement in-flight disco counter. (when-let* ((cell (assq jc jabber-muc--autojoin-disco-count))) (cl-decf (cdr cell))) (unless (jabber-sm--active-recovery-room-p (fsm-get-state-data jc) group) (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--continuation jc #'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))) (unless (jabber-muc--join-active-p jc group) (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--continuation jc #'jabber-muc--autojoin-timeout) jc)))))) (defun jabber-muc--autojoin-queued-p (jc group) "Return non-nil if GROUP has queued or in-flight autojoin work on JC." (or (member group (plist-get (fsm-get-state-data jc) :muc-autojoin-discovering)) (assoc group (cdr (assq jc jabber-muc--autojoin-pending))) (when-let* ((entry (assq jc jabber-muc--autojoin-queue))) (cl-find group (cdr entry) :key #'cadr :test #'string=)))) (defun jabber-muc--join-active-p (jc group) "Return non-nil while JC owns membership or a native join for GROUP. The remembered pending nickname is not a lease: it survives failure." (let ((attempt (jabber-sm--room-attempt (fsm-get-state-data jc) group)) (request (cdr (assoc group (get jc 'jabber-muc--join-intents))))) (or (jabber-muc-joined-p group jc) (jabber-muc--attempt-current-p jc group attempt t) (and request (eq t (catch 'jabber-muc--cancelled (jabber-muc--check-intent request) t)))))) (defun jabber-muc--autojoin-clear (jc) "Remove all autojoin queue entries for JC." (put jc :state-data (plist-put (copy-sequence (fsm-get-state-data jc)) :muc-autojoin-generation (make-symbol "autojoin"))) (put jc :state-data (plist-put (copy-sequence (fsm-get-state-data jc)) :muc-autojoin-discovering nil)) (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)) (current-p (jabber-muc--continuation jc (lambda () t))) (snapshot (gethash bare-jid jabber-muc--rooms-before-disconnect))) (catch 'superseded (dolist (room (delete-dups (delq nil (mapcar #'jabber-sm--entry-room (plist-get (fsm-get-state-data jc) :sm-pending-queue))))) (unless (funcall current-p) (throw 'superseded nil)) (let ((nick (cadr (assoc room snapshot)))) (unless (or (jabber-sm--room-attempt (fsm-get-state-data jc) room) (and (stringp nick) (not (string-empty-p nick)))) (jabber-muc--fail-attempt jc room (jabber-muc--start-attempt jc room nil) "Missing saved room nickname" 'retired)))) (dolist (room-nick-password (gethash bare-jid jabber-muc--rooms-before-disconnect)) (unless (funcall current-p) (throw 'superseded nil)) (pcase-let ((`(,room ,nick ,password) room-nick-password)) (unless (or (jabber-muc-joined-p room jc) (jabber-sm--room-attempt (fsm-get-state-data jc) room) (jabber-muc--autojoin-queued-p jc room)) (jabber-muc--remember-password jc room password) (if (jabber-sm--active-recovery-room-p (fsm-get-state-data jc) room) (jabber-muc--send-join-presence jc room nick password nil) (jabber-muc--autojoin-enqueue-pending jc room nick)))))))) (defun jabber-muc--autojoin-enqueue-pending (jc group nick) "Add (GROUP . NICK) to the pending disco list for JC." (unless (or (jabber-sm--active-recovery-room-p (fsm-get-state-data jc) group) (jabber-muc--join-active-p jc group) (jabber-muc--autojoin-queued-p jc group)) (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)) (put jc :state-data (plist-put (copy-sequence (fsm-get-state-data jc)) :muc-autojoin-discovering (cons group (plist-get (fsm-get-state-data jc) :muc-autojoin-discovering)))) (let ((completed nil)) (jabber-disco-get-items jc group nil (jabber-muc--continuation jc (lambda (account context result) (unless completed (setq completed t) (jabber-muc--autojoin-disco-callback account context result)))) (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) (let ((continue (jabber-muc--continuation jc #'always))) (jabber-muc--rejoin-snapshot jc) (when (funcall continue) (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) (when (funcall continue) (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-buffer-connection) (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)))) (defvar jabber-activity--event-owner) (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)) (let ((title (save-current-buffer (let ((jabber-buffer-connection jc)) (funcall jabber-alert-muc-function nick group alert-buffer body-text))))) (run-hook-wrapped hook (lambda (function) (save-current-buffer ;; Bind the receiver afresh for each hook, even when a ;; previous hook switched buffers or changed its locals. (let ((jabber-buffer-connection jc) (jabber-activity--event-owner jc) (origin (and (buffer-live-p alert-buffer) (eq (buffer-local-value 'jabber-buffer-connection alert-buffer) jc) (equal (buffer-local-value 'jabber-group alert-buffer) group) alert-buffer))) (funcall function nick group origin body-text title))) nil)))))))) (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 jc) (let ((xml-data (jabber-chat--decrypt-if-needed jc xml-data))) (unless (or (jabber-reactions--reaction-only-p xml-data) (jabber-moderation--muc-retraction-message-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* ((attempt (jabber-muc--live-attempt jc group)) (leavingp t) (message (cond ((string= type "error") (cond ;; Nick-change errors don't mean we left the room. ((and (jabber-muc-joined-p group jc) (or (not attempt) (and (jabber-muc--attempt-current-p jc group attempt t) (or (equal (plist-get attempt :previous) (jabber-muc-nickname group jc)) (and (eq (plist-get attempt :status) 'ready) (equal (plist-get attempt :nick) (jabber-muc-nickname group jc)))))) (or (member jabber-muc-status-nick-not-allowed status-codes) (member jabber-muc-status-nick-conflict status-codes) (memq (jabber-error-condition error-node) '(conflict not-acceptable)))) (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")))) (cl-flet ((effects (request) (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 request)) ;; Do not create a buffer just to report a departure. (let ((buffer (get-buffer (jabber-muc-get-buffer group jc)))) (when request (jabber-muc--check-intent request)) (if buffer (with-current-buffer buffer (jabber-chat-buffer-with-scrolltobottom (let ((node (jabber-chat-ewoc-enter (list (if (string= type "error") :muc-error :muc-notice) message :time (current-time))))) (when request (jabber-muc--check-intent request)) (jabber-maybe-print-rare-time node)))) (let ((name (jabber-jid-displayname group jc))) (when request (jabber-muc--check-intent request)) (message "%s: %s" name message)))))) (if leavingp (let ((request (jabber-muc--reserve-intent jc group))) (jabber-muc--with-intent request (jabber-muc--retire-room jc group) (jabber-muc--withdraw-attempt jc group) (when attempt (jabber-muc--fail-attempt jc group attempt message 'retired)) (jabber-muc--check-intent request) (effects request) t)) (when (and attempt (plist-get attempt :previous)) (when (timerp (plist-get attempt :timer)) (cancel-timer (plist-get attempt :timer))) (jabber-muc--publish-attempt jc group (plist-put (plist-put (copy-sequence attempt) :status 'ready) :nick (plist-get attempt :previous))) (jabber-sm--schedule-drain jc (fsm-get-state-data jc))) (effects nil))) ;; This account wakeup is independent of the retired room's lease. ;; Cancellation by a successor must not strand unrelated queued rooms. (when (string= type "error") (run-with-timer 0 nil (jabber-muc--continuation jc #'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. Announce nothing for a NICKNAME that was never an occupant: Prosody lists absent affiliated members with reserved nicknames as unavailable presence." (let* ((present (assoc nickname (cdr (assoc group jabber-muc-participants)))) (plist (cdr present)) (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--identity-occupant jc group nickname nil) (jabber-muc-remove-participant group nickname) (when-let* ((buffer (and present (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 (jc group nickname status-codes) "Insert extra ewoc notices for STATUS-CODES into the current MUC buffer. JC and GROUP identify the originating event; NICKNAME is its 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 (and jabber-muc--auto-configure (not (jabber-muc--foreign-arm-p jabber-muc--auto-configure jc group))) (progn (setq jabber-muc--auto-configure nil) (jabber-muc-get-config jc group)) (jabber-muc--insert-notice (jabber-muc--room-created-message))))) (defun jabber-muc--identity-record (jc group &optional create) "Return JC's current identity record for GROUP. With CREATE, allocate a record for joined or pending native membership. A state-plist copy is not a new session. The membership cons, unlike its nickname, identifies one joined lifetime; pending occupants use the native room attempt until self-presence publishes that membership." (when jc (let* ((state (fsm-get-state-data jc)) (membership (assq jc (jabber-muc-room-entries group))) (attempt (jabber-sm--room-attempt state group)) (pending (and (jabber-muc--attempt-current-p jc group attempt t) (plist-get attempt :token))) (key (list jc group)) (record (gethash key jabber-muc--room-jids))) (unless (and record (eq (plist-get record :transport) (plist-get state :connection)) (equal (plist-get record :session) (plist-get state :session-id)) (equal (plist-get record :account) (jabber-connection-bare-jid jc)) (if (plist-get record :membership) (eq membership (plist-get record :membership)) (and pending (eq pending (plist-get record :attempt))))) (setq record nil)) (when (and (not record) create (or membership (and pending (eq (plist-get attempt :status) 'pending)))) (setq record (list :transport (plist-get state :connection) :session (plist-get state :session-id) :account (jabber-connection-bare-jid jc) :membership membership :attempt pending :occupants nil :snapshots nil :queries nil)) (puthash key record jabber-muc--room-jids)) (when (and record membership (not (plist-get record :membership))) (plist-put record :membership membership)) record))) (defun jabber-muc--identity-occupant (jc group nick properties) "Record current NICK's PROPERTIES in GROUP on JC. Nil PROPERTIES removes the occupant. Affiliation replies never create occupants: offline members belong only to their authoritative snapshot." (when-let* ((record (jabber-muc--identity-record jc group (and properties t)))) (plist-put record :occupants (if properties (cons (cons nick properties) (assoc-delete-all nick (plist-get record :occupants))) (assoc-delete-all nick (plist-get record :occupants)))))) (defun jabber-muc--identity-retire (group &optional jc) "Remove GROUP's identity records, restricted to JC when non-nil." (dolist (key (hash-table-keys jabber-muc--room-jids)) (when (and (equal group (cadr key)) (or (not jc) (eq jc (car key)))) (remhash key jabber-muc--room-jids)))) (defun jabber-muc--identity-jids (jc group) "Return current occupant and offline affiliation JIDs in GROUP on JC." (when (jabber-muc-joined-p group jc) (when-let* ((record (jabber-muc--identity-record jc group))) (delete-dups (append (delq nil (mapcar (lambda (entry) (when-let* ((jid (plist-get (cdr entry) 'jid))) (jabber-jid-user jid))) (plist-get record :occupants))) (apply #'append (mapcar (lambda (snapshot) (mapcar #'car (cdr snapshot))) (plist-get record :snapshots)))))))) (defun jabber-muc--affiliation-response-p (owner group receiver xml) "Admit XML on RECEIVER only for OWNER's affiliation request to GROUP." (and (eq receiver owner) (equal (jabber-xml-get-attribute xml 'from) group) (or (equal (jabber-xml-get-attribute xml 'type) "error") (let ((query (jabber-iq-query xml))) (and (eq (car-safe query) 'query) (equal (jabber-xml-get-attribute query 'xmlns) jabber-muc-xmlns-admin)))))) (defun jabber-muc--query-affiliations (jc group) "On JC, query member, admin, and owner affiliation lists for GROUP. Each result replaces only its requested category. Bind the response to this connection, membership lifetime and the latest query for that category." (when (jabber-muc-joined-p group jc) (when-let* ((record (jabber-muc--identity-record jc group t))) (dolist (affiliation '("member" "admin" "owner")) (let* ((token (make-symbol "affiliation")) (request (list jc group record affiliation token))) (setf (alist-get affiliation (plist-get record :queries) nil nil #'equal) token) (jabber-send-iq jc group "get" `(query ((xmlns . ,jabber-muc-xmlns-admin)) (item ((affiliation . ,affiliation)))) #'jabber-muc--affiliation-result request #'jabber-muc--affiliation-error request nil (apply-partially #'jabber-muc--affiliation-response-p jc group))))))) (defun jabber-muc--affiliation-result (jc xml-data request) "Apply XML-DATA on JC only while its affiliation REQUEST still owns it." (pcase-let ((`(,owner ,group ,record ,affiliation ,token) request)) (when (and (eq jc owner) (jabber-muc-joined-p group jc) (eq record (jabber-muc--identity-record jc group)) (eq token (alist-get affiliation (plist-get record :queries) nil nil #'equal))) (let ((items (jabber-xml-get-children (jabber-iq-query xml-data) 'item))) (setf (alist-get affiliation (plist-get record :snapshots) nil nil #'equal) (cl-loop for item in items for jid = (jabber-xml-get-attribute item 'jid) when (and (stringp jid) (not (string-empty-p jid)) (equal affiliation (jabber-xml-get-attribute item 'affiliation))) collect (cons (jabber-jid-user jid) (jabber-xml-get-attribute item 'nick)))) ;; Direct duplicate delivery must not reinstate a consumed snapshot. (setf (alist-get affiliation (plist-get record :queries) nil nil #'equal) nil))))) (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 unused. STATUS-CODES, X-MUC, ACTOR, REASON and OUR-NICKNAME come from the stanza." (let* ((attempt (jabber-muc--live-attempt jc group)) (our-nickname (if attempt (plist-get attempt :nick) our-nickname))) (when (or (not attempt) (jabber-muc--attempt-current-p jc group attempt t)) (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 (and (or (not attempt) (jabber-muc--attempt-current-p jc group attempt t)) (or (member jabber-muc-status-self-presence status-codes) (and (or (not attempt) (not (member "210" status-codes))) (string= nickname our-nickname)))) (let ((was-joined (jabber-muc-joined-p group jc)) (previous (jabber-muc-nickname group jc)) (recovery-p (cl-some (lambda (entry) (equal group (jabber-sm--entry-room entry))) (plist-get (fsm-get-state-data jc) :sm-pending-queue)))) (when (and previous (not (equal previous nickname))) (jabber-muc--identity-occupant jc group previous nil)) (jabber-muc-add-groupchat group nickname jc) (puthash (jabber-muc--pending-key jc group) nickname jabber-pending-groupchats) (unless attempt (jabber-muc--adopt-membership jc group nickname)) (when attempt (when (timerp (plist-get attempt :timer)) (cancel-timer (plist-get attempt :timer))) (dolist (entry (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (when (and (equal group (jabber-sm--entry-room entry)) (fboundp 'jabber-omemo--move-echo)) (jabber-omemo--move-echo entry nickname))) (jabber-muc--publish-attempt jc group (plist-put (plist-put (copy-sequence attempt) :nick nickname) :status 'ready)) (jabber-sm--schedule-drain jc (fsm-get-state-data jc))) ;; Trigger MUC MAM catch-up on initial join (not nick change) (unless was-joined (jabber-mam-muc-joined jc group) (when (or (not attempt) (jabber-muc--attempt-current-p jc group attempt t)) (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. ;; A join lease is not recovery ownership: ordinary joins have one too. ;; Keep rooms with retained SM work on the recovery drain path. (unless recovery-p (run-with-timer 0 nil (jabber-muc--continuation jc #'jabber-muc--autojoin-next) jc))))) (when (or (not attempt) (jabber-muc--attempt-current-p jc group attempt t)) (let* ((self-p (or (member jabber-muc-status-self-presence status-codes) (and (or (not attempt) (not (member "210" status-codes))) (string= nickname our-nickname)))) (old-plist (jabber-muc-participant-plist group nickname)) (new-plist (jabber-muc-parse-affiliation x-muc))) (jabber-muc--identity-occupant jc group nickname new-plist) (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 jc group nickname status-codes) (when (and (or (not attempt) (jabber-muc--attempt-current-p jc group attempt t)) (eq jabber-chat-encryption 'omemo) (fboundp 'jabber-omemo--prefetch-muc-sessions)) (jabber-omemo--prefetch-muc-sessions jc group)) (when (and (or (not attempt) (jabber-muc--attempt-current-p jc group attempt t)) (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 &optional jc) "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. Use receiving connection JC to determine our remembered 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 jc)) (our-nickname (jabber-muc--pending-nickname jc group)) (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 jc)) (type (plist-get p :type)) (group (plist-get p :group)) (nickname (plist-get p :nickname)) (symbol (plist-get p :symbol)) (attempt (jabber-muc--live-attempt jc group)) (our-nickname (if attempt (plist-get attempt :nick) (or (jabber-muc-nickname group jc) (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 ;; Every governed transition, not just available presence, needs ;; permission. An expired ordinary join governs nothing. ((and attempt (not (jabber-muc--attempt-current-p jc group attempt t))) nil) ;; The bare room JID is never an occupant. Prosody lists absent ;; affiliated members to admins and owners as unavailable presence ;; from it; our own departure always comes from our occupant JID. ((and (null nickname) (not (equal type "error"))) nil) ;; Self 303 retires only the alias, not the membership or pending lease. ;; Foreign 303 must take the ordinary occupant-removal path even while ;; our own nickname change is pending. Never adopt its target nickname. ((and attempt (equal type "unavailable") (or (member jabber-muc-status-self-presence status-codes) (equal nickname our-nickname) (equal nickname (plist-get attempt :previous))) (member "303" status-codes)) (jabber-muc--identity-occupant jc group nickname nil)) ((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.15.1/lisp/jabber-notifications.el000066400000000000000000000124151527111033600215000ustar00rootroot00000000000000;;; 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; nil suppresses the notification." (when title (letrec ((body (or (jabber-escape-xml text) " ")) (avatar-hash (when-let* (((buffer-live-p buffer)) (jc (buffer-local-value 'jabber-buffer-connection buffer))) (get (jabber-jid-symbol from jc) '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.15.1/lisp/jabber-omemo-store.el000066400000000000000000000340121527111033600210720ustar00rootroot00000000000000;;; 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)) (defsubst jabber-omemo-store--as-blob (value) "Return a binary-coded copy of string VALUE for SQLite BLOB binding." (propertize value 'coding-system 'binary)) ;;; 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 (jabber-omemo-store--as-blob 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 (jabber-omemo-store--as-blob 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 (jabber-omemo-store--as-blob 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 (jabber-omemo-store--as-blob blob))))) (defun jabber-omemo-store--session-transaction (operation) "Call OPERATION inside an OMEMO session savepoint." (when-let* ((db (jabber-db-ensure-open))) (sqlite-execute db "SAVEPOINT omemo_session_migration") (condition-case err (prog1 (funcall operation) (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-save-session-and-clear-legacy-keys (account jid device-id blob) "Save session BLOB for ACCOUNT, JID, DEVICE-ID and remove legacy keys." (jabber-omemo-store--session-transaction (lambda () (jabber-omemo-store-save-session account jid device-id blob) (jabber-omemo-store-delete-skipped-keys account jid device-id)))) (defun jabber-omemo-store-delete-session-state (account jid device-id) "Delete session and legacy skipped keys for ACCOUNT, JID, DEVICE-ID." (jabber-omemo-store--session-transaction (lambda () (jabber-omemo-store-delete-session account jid device-id) (jabber-omemo-store-delete-skipped-keys account jid device-id)))) (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.15.1/lisp/jabber-omemo-trust.el000066400000000000000000000436731527111033600211340ustar00rootroot00000000000000;;; 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)) ;; Newer dependency revisions generate this launcher inside the conditional ;; initializer below. Its definition is macro-generated, not a source defun. (declare-function jabber-omemo-trust-mode-map-popup "jabber-omemo-trust" () t) ;; The dependency floor supports dynamic captions in `keymap-popup-define', ;; but not in `keymap-popup-annotate'. Initialize once through that API, then ;; install guarded help before exposing the map. Retain both user bindings ;; and their descriptions on reevaluation. (unless (boundp 'jabber-omemo-trust-mode-map) (keymap-popup-define jabber-omemo-trust-mode-map "OMEMO trust commands." :popup-key "h" :description #'jabber-omemo-trust--menu-description "t" ("Verify" jabber-omemo-trust-set-verified) "u" ("Untrust" jabber-omemo-trust-set-untrusted) "r" ("Reset session" jabber-omemo-reset-session) "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) (keymap-popup-annotate jabber-omemo-trust-mode-map :description #'jabber-omemo-trust--menu-description :group "Trust" jabber-omemo-trust-set-verified "Verify" jabber-omemo-trust-set-untrusted "Untrust" jabber-omemo-reset-session "Reset session" jabber-omemo-trust-delete "Delete" jabber-omemo-trust-copy-fingerprint "Copy fingerprint" revert-buffer "Refresh" jabber-omemo-trust-refresh "Re-fetch from server")) (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-reset-session] Reset the encrypted session. \\[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"))) ;;;###autoload (defun jabber-omemo-reset-session () "Reset and rebuild the OMEMO session for the device at point. Preserve the device's trust decision and fingerprint." (interactive) (let ((stored-jc jabber-omemo-trust--jc) (peer jabber-omemo-trust--peer)) (unless (and stored-jc peer) (user-error "Not in an OMEMO trust buffer")) (let ((jc (or (and (jabber-connection-active-p stored-jc) stored-jc) (jabber-find-active-connection stored-jc)))) (unless jc (user-error "The Jabber connection is no longer active")) (let ((did (jabber-omemo-trust--device-at-point))) (message "OMEMO: resetting session for %s device %d" peer did) (jabber-omemo--reset-session jc peer did (lambda (session) (message (if session "OMEMO: rebuilt session for %s device %d" "OMEMO: could not rebuild session for %s device %d") peer did))))))) (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--delete-session jabber-omemo-trust--account jabber-omemo-trust--peer did t) (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--delete-session jabber-omemo-trust--account jabber-omemo-trust--peer did t) (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.15.1/lisp/jabber-omemo.el000066400000000000000000003246671527111033600177620ustar00rootroot00000000000000;;; 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 'seq) (require 'jabber-blocking) (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--identity-record "jabber-muc" (jc group &optional create)) (declare-function jabber-muc--identity-jids "jabber-muc" (jc group)) (declare-function jabber-muc-create-buffer "jabber-muc" (jc group)) (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-muc--rooms-before-disconnect) ; jabber-muc requires jabber-core. (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. A module ;; that exists but cannot be loaded (missing shared library, ABI ;; mismatch) disables OMEMO instead of aborting the load of this file. (unless (or jabber-omemo--available (not jabber-omemo-enable)) (condition-case err (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")) (error (setq jabber-omemo--available 'unavailable) (display-warning 'jabber (format "OMEMO native module failed to load, encryption disabled: %s" (error-message-string err)))))) (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. ;; FILEONLY is needed because check-declare cannot parse module exports. ;; The declaration gate requires a built module and checks its actual exports. (declare-function jabber-omemo--setup-store "jabber-omemo-core" t t) (declare-function jabber-omemo--deserialize-store "jabber-omemo-core" t t) (declare-function jabber-omemo--serialize-store "jabber-omemo-core" t t) (declare-function jabber-omemo--get-bundle "jabber-omemo-core" t t) (declare-function jabber-omemo--rotate-signed-pre-key "jabber-omemo-core" t t) (declare-function jabber-omemo--refill-pre-keys "jabber-omemo-core" t t) (declare-function jabber-omemo--remove-pre-key "jabber-omemo-core" t t) (declare-function jabber-omemo--used-pre-key-id "jabber-omemo-core" t t) (declare-function jabber-omemo--encrypt-message "jabber-omemo-core" t t) (declare-function jabber-omemo--decrypt-message "jabber-omemo-core" t t) (declare-function jabber-omemo--make-session "jabber-omemo-core" t t) (declare-function jabber-omemo--initiate-session "jabber-omemo-core" t t) (declare-function jabber-omemo--serialize-session "jabber-omemo-core" t t) (declare-function jabber-omemo--deserialize-session "jabber-omemo-core" t t) (declare-function jabber-omemo--legacy-session-blob-p "jabber-omemo-core" t t) (declare-function jabber-omemo--encrypt-key "jabber-omemo-core" t t) (declare-function jabber-omemo--decrypt-key "jabber-omemo-core" t t) (declare-function jabber-omemo--session-remote-identity "jabber-omemo-core" t t) (declare-function jabber-omemo--session-skipped-keys "jabber-omemo-core" t t) (declare-function jabber-omemo--session-set-skipped-keys "jabber-omemo-core" t t) (declare-function jabber-omemo--heartbeat "jabber-omemo-core" t t) (declare-function jabber-omemo--aesgcm-decrypt "jabber-omemo-core" t t) (declare-function jabber-omemo--aesgcm-encrypt "jabber-omemo-core" t t) ;;; 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) (define-error 'jabber-omemo-identity-changed "OMEMO sender device identity changed" '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-chat--on-decrypt-rollback (lambda () (remhash account jabber-omemo--stores))) (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) (jabber-chat--on-decrypt-rollback (lambda () (remhash account jabber-omemo--device-ids))) 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))) (defun jabber-omemo--delete-session (account jid device-id &optional delete-trust) "Delete durable and cached session state for ACCOUNT, JID and DEVICE-ID. When DELETE-TRUST is non-nil, delete trust in the same transaction. Do not rebuild the session. Leave the cache unchanged on storage failure." (jabber-omemo-store--session-transaction (lambda () (jabber-omemo-store-delete-session account jid device-id) (jabber-omemo-store-delete-skipped-keys account jid device-id) (when delete-trust (jabber-omemo-store-delete-trust account jid device-id)))) (remhash (jabber-omemo--session-key account jid device-id) jabber-omemo--sessions)) (defun jabber-omemo--reset-session (jc jid device-id callback) "Reset and rebuild JID's DEVICE-ID session via JC. Delete the durable and cached session without changing device trust. Call CALLBACK with the rebuilt session, or nil when the device is no longer active or its bundle could not be fetched." (let* ((account (jabber-connection-bare-jid jc)) (bare-jid (jabber-jid-user jid))) (jabber-omemo--delete-session account bare-jid device-id) (jabber-omemo--ensure-sessions jc bare-jid (lambda (sessions) (when callback (funcall callback (nth 3 (assoc device-id 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--request-peer (jc jid node success failure callback) "Request NODE from JID on JC unless the peer is known blocked. Pass ordinary responses to SUCCESS or FAILURE. A blocked peer, or a retired peer connection, settles CALLBACK with nil, the existing failure value. Check again on response before parsing, persistence or further requests." (let* ((state (fsm-get-state-data jc)) (current-p (jabber-blocking--session-predicate jc)) (own-p (equal (jabber-jid-user jid) (concat (plist-get state :username) "@" (plist-get state :server)))) (allowed-p (lambda () ;; Preserve the existing own-device publication lifecycle. (or own-p (and (funcall current-p) (jabber-blocking-ready-p jc jid) (not (jabber-blocking-blocked-p jc jid)))))) (cancel (lambda () (when callback (funcall callback nil))))) (if (not (funcall allowed-p)) (funcall cancel) (jabber-pubsub-request jc jid node (lambda (&rest args) (if (funcall allowed-p) (apply success args) (funcall cancel))) (lambda (&rest args) (if (funcall allowed-p) (apply failure args) (funcall cancel))))))) (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-omemo--request-peer 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))) callback)) (defun jabber-omemo--own-list-element-p (node namespace inherited) "Return non-nil if NODE has element-only content in NAMESPACE. Use INHERITED when NODE has no explicit namespace. Ignore XML whitespace." (and (equal (or (jabber-xml-get-attribute node 'xmlns) inherited) namespace) (cl-every (lambda (child) (or (consp child) (and (stringp child) (string-match-p "\\`[ \t\r\n]*\\'" child)))) (jabber-xml-node-children node)))) (defun jabber-omemo--own-device-list-result (xml) "Return (t . IDS) for a complete own device-list result in XML. Return nil for an uncertain or malformed result, not an empty snapshot." (let* ((pubsubs (jabber-xml-get-children xml 'pubsub)) (pubsub (car pubsubs)) (items-nodes (jabber-xml-get-children pubsub 'items)) (items-node (car items-nodes)) (items (seq-filter #'consp (jabber-xml-node-children items-node))) (lists (jabber-xml-get-children (car items) 'list)) (list-node (car lists)) (devices (seq-filter #'consp (jabber-xml-node-children list-node)))) (when (and (eq (jabber-xml-node-name xml) 'iq) (equal (jabber-xml-get-attribute xml 'type) "result") (not (jabber-iq-error xml)) (jabber-omemo--own-list-element-p xml (jabber-xml-get-attribute xml 'xmlns) nil) (= (length pubsubs) 1) (= (length (seq-filter #'consp (jabber-xml-node-children xml))) 1) (jabber-omemo--own-list-element-p pubsub jabber-pubsub-xmlns (jabber-xml-get-attribute xml 'xmlns)) (= (length items-nodes) 1) (= (length (seq-filter #'consp (jabber-xml-node-children pubsub))) 1) (jabber-omemo--own-list-element-p items-node jabber-pubsub-xmlns jabber-pubsub-xmlns) (equal (jabber-xml-get-attribute items-node 'node) jabber-omemo-devicelist-node) (or (null items) (and (= (length items) 1) (eq (jabber-xml-node-name (car items)) 'item) (jabber-omemo--own-list-element-p (car items) jabber-pubsub-xmlns jabber-pubsub-xmlns) (= (length lists) 1) (= (length (seq-filter #'consp (jabber-xml-node-children (car items)))) 1) (jabber-omemo--own-list-element-p list-node jabber-omemo-xmlns jabber-pubsub-xmlns) (cl-every (lambda (device) (let ((id (jabber-xml-get-attribute device 'id))) (and (eq (jabber-xml-node-name device) 'device) (jabber-omemo--own-list-element-p device jabber-omemo-xmlns jabber-omemo-xmlns) (not (seq-some #'consp (jabber-xml-node-children device))) (stringp id) (string-match-p "\\`[0-9]+\\'" id) (< 0 (string-to-number id) (ash 1 31))))) devices)))) (cons t (jabber-omemo--parse-device-list items))))) (defun jabber-omemo--fetch-own-device-list (jc callback) "Fetch an authoritative own device list via JC, then call CALLBACK with IDs. A successful empty result or standard `item-not-found' error supplies nil IDs. Other failures, cancellation, malformed or retired replies do not call CALLBACK or modify the cache or database. Preserve the legacy peer callback contract of `jabber-omemo--fetch-device-list' separately." (let* ((account (jabber-connection-bare-jid jc)) (current-p (jabber-blocking--session-predicate jc)) (settled nil) (admitted-p (lambda (received-jc xml) (and (eq received-jc jc) (funcall current-p) (let ((from (jabber-xml-get-attribute xml 'from))) (or (null from) (equal from account)))))) (accept (lambda (ids) (puthash (jabber-omemo--device-list-key account account) ids jabber-omemo--device-lists) (dolist (id ids) (jabber-omemo-store-save-device account account id)) (jabber-omemo--deactivate-stale-devices account account ids) (funcall callback ids)))) (condition-case err (jabber-omemo--request-peer jc account jabber-omemo-devicelist-node (lambda (received-jc xml _closure) (unless settled (setq settled t) (when (funcall admitted-p received-jc xml) (if-let* ((result (jabber-omemo--own-device-list-result xml))) (funcall accept (cdr result)) (message "OMEMO: refusing malformed own device list"))))) (lambda (received-jc xml _closure) (unless settled (setq settled t) (when (funcall admitted-p received-jc xml) (if (and (equal (jabber-xml-get-attribute xml 'type) "error") (= (length (jabber-xml-get-children xml 'error)) 1) (equal (mapcar #'jabber-xml-node-name (seq-filter (lambda (child) (and (equal (jabber-xml-get-attribute child 'xmlns) jabber-stanzas-xmlns) (not (eq (jabber-xml-node-name child) 'text)))) (jabber-xml-node-children (jabber-iq-error xml)))) '(item-not-found))) ;; XEP-0060 6.5.9.11: a nonexistent node, not a failed snapshot. (funcall accept nil) (message "OMEMO: own device-list fetch failed; leaving server state unchanged"))))) (lambda (_result) (setq settled t))) ((error quit) ;; A synchronous unwind can leave callbacks retained by the transport. (setq settled t) (signal (car err) (cdr err)))))) (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. Leave server state unchanged if the fetch fails." (let ((our-id (jabber-omemo--get-device-id jc))) (jabber-omemo--fetch-own-device-list 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. Ignore bundle replies from a retired connection or session." (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)) (current-p (jabber-blocking--session-predicate 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 (and (zerop remaining) (funcall current-p)) (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. Leave the list and bundles unchanged if the fetch fails." (when stale-ids (message "OMEMO: removing %d stale device(s): %s" (length stale-ids) stale-ids) (jabber-omemo--fetch-own-device-list 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. Leave server state unchanged and do not call CALLBACK if the fetch fails." (jabber-omemo--fetch-own-device-list 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)))))))) (cl-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." (unless (and (jabber-blocking-ready-p jc from) (not (jabber-blocking-blocked-p jc from))) (cl-return-from jabber-omemo--handle-device-list nil)) (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. Return nil if a required key or signature is missing or empty. Signal an error for malformed base64 or pre-key text." (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 (cl-every (lambda (text) (and (stringp text) (not (string-empty-p text)))) (list spk-text sig-text 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)))) (unless (and (stringp pk-text) (not (string-empty-p pk-text))) (error "OMEMO: malformed pre-key data")) (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-omemo--request-peer jc jid node (lambda (_jc xml-data _closure) (let ((parsed (condition-case err (let* ((pubsub (car (jabber-xml-get-children xml-data 'pubsub))) (items (car (jabber-xml-get-children pubsub 'items))) (item (car (jabber-xml-get-children items 'item))) (bundle (car (jabber-xml-get-children item 'bundle)))) (when bundle (jabber-omemo--parse-bundle-xml bundle))) (error (message "OMEMO: invalid bundle for %s device %d: %s" jid device-id (error-message-string err)) nil)))) ;; Callback errors are not parse errors: never call it twice. (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)) callback))) (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) (unless (memql id (gethash account jabber-omemo--pending-prekey-removals)) (push id (gethash account jabber-omemo--pending-prekey-removals)) (jabber-chat--on-decrypt-rollback (lambda () (cl-callf2 delete 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'. Select a random pre-key, reject changed known identities, initiate and save the session, and record new devices as undecided without changing an existing trust decision." (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* ((account (jabber-connection-bare-jid jc)) (known-trust (jabber-omemo-store-load-trust account jid device-id))) (when (and known-trust (not (string= identity-key (plist-get known-trust :identity-key)))) (user-error "OMEMO: device %d for %s changed identity key" device-id jid)) (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)))) (jabber-omemo--save-session jc jid device-id session-ptr) (jabber-omemo-store-ensure-trust account jid device-id identity-key) 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)))) (cl-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 ACCOUNT JID SESSION-PTR) for all active devices. Blocked peers and pending blocking discovery return nil, like other failures." (unless (and (jabber-blocking-ready-p jc jid) (not (jabber-blocking-blocked-p jc jid))) (cl-return-from jabber-omemo--ensure-sessions (funcall callback nil))) (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 ACCOUNT JID SESSION-PTR)." (let ((our-id (jabber-omemo--get-device-id jc)) (account (jabber-connection-bare-jid jc)) results missing) (dolist (did device-ids) (unless (and (equal jid account) (= did our-id)) (if-let* ((existing (jabber-omemo--get-session jc jid did))) (push (list did account jid existing) results) (push did missing)))) (let ((pending (length missing))) (if (zerop pending) (funcall callback results) (dolist (did missing) (jabber-omemo--fetch-bundle jc jid did (lambda (bundle) (condition-case err (when (and bundle (not (jabber-blocking-blocked-p jc jid))) (let ((session (jabber-omemo--establish-session jc jid did bundle))) (push (list did account jid session) results))) (error (message "OMEMO: could not establish session for %s device %d: %s" jid did (error-message-string err)))) (cl-decf pending) (when (zerop pending) (funcall callback (unless (jabber-blocking-blocked-p jc jid) 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 ACCOUNT JID SESSION-PTR). Returns the filtered list, dropping any device with trust = -1." (let ((account (jabber-connection-bare-jid jc))) (cl-remove-if (lambda (entry) (pcase-let ((`(,did ,owner ,jid ,_session) entry)) (unless (equal owner account) (user-error "OMEMO: session belongs to another account")) (let ((trust-rec (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 ACCOUNT JID 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")) ;; A deletion or reset may have retired a session while other bundles ;; were in flight. Do not ratchet or persist a captured stale pointer. (dolist (entry sessions) (pcase-let ((`(,did ,account ,jid ,session) entry)) (unless (eq session (gethash (jabber-omemo--session-key account jid did) jabber-omemo--sessions)) (user-error "OMEMO: session for %s device %d was retired" jid did)))) (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)) (jid (nth 2 entry)) (session-ptr (nth 3 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 jid 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))))) ;;; 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 &optional jc) "Return an affiliation JID for current NICK in GROUP on JC. Use only this membership's snapshots and occupants. Do not persist guesses in presence state: replacing a snapshot must also revoke its inferred map." (let ((jc (or jc jabber-buffer-connection))) (when (and jc (jabber-muc-joined-p group jc)) (when-let* ((record (jabber-muc--identity-record jc group)) (participants (plist-get record :occupants)) (current (assoc nick participants))) (let* ((members (apply #'append (mapcar #'cdr (plist-get record :snapshots)))) (named (delete-dups (mapcar #'car (cl-remove-if-not (lambda (entry) (equal nick (cdr entry))) members)))) (assigned (delq nil (mapcar (lambda (entry) (when-let* ((jid (plist-get (cdr entry) 'jid))) (jabber-jid-user jid))) participants))) (unassigned (cl-set-difference (delete-dups (mapcar #'car members)) assigned :test #'equal))) (cond ((length= named 1) (car named)) ((and (null named) (length= unassigned 1)) (car unassigned)))))))) (defun jabber-omemo--resolve-sender-jid (xml-data &optional jc) "Return the real bare sender JID of XML-DATA on JC. Direct messages use the from attribute. MUC messages require a current occupant on this connection, using presence or current affiliation data." (let* ((from (jabber-xml-get-attribute xml-data 'from)) (msg-type (jabber-xml-get-attribute xml-data 'type)) (jc (or jc jabber-buffer-connection))) (if (not (equal msg-type "groupchat")) (and from (jabber-jid-user from)) (require 'jabber-muc) (let* ((group (jabber-jid-user from)) (nick (jabber-jid-resource from)) (record (and jc (jabber-muc-joined-p group jc) (jabber-muc--identity-record jc group))) (plist (cdr (assoc nick (plist-get record :occupants)))) (real-jid (plist-get plist 'jid))) (or (and real-jid (jabber-jid-user real-jid)) (jabber-omemo--match-jid-by-affiliation group nick jc)))))) (defun jabber-omemo--admit-inbound-session (jc sender-jid sender-did session) "Check SESSION against JC's known identity for SENDER-JID and SENDER-DID. Use only the native authenticated remote identity, never an unauthenticated wire key. Preserve unknown-device policy and all existing trust levels." (let* ((identity (jabber-omemo--session-remote-identity session)) (known (jabber-omemo-store-load-trust (jabber-connection-bare-jid jc) sender-jid sender-did))) (unless (and (stringp identity) (not (multibyte-string-p identity)) (= (length identity) 33) (= (aref identity 0) 5)) (signal 'jabber-omemo-error '("Missing authenticated session identity"))) (when (and known (not (equal identity (plist-get known :identity-key)))) (signal 'jabber-omemo-identity-changed (list sender-jid sender-did))))) (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', `jabber-omemo-prekey-failed', or `jabber-omemo-identity-changed'. Fresh sessions must match any known device identity before their key is returned, regardless of trust level." (when (and pre-key-p (not (fboundp 'jabber-omemo--session-remote-identity))) (signal 'jabber-omemo-error '("Rebuild the OMEMO native module: session identity export missing"))) (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)) (key (condition-case err (jabber-omemo-decrypt-key fresh store-ptr t key-data) (jabber-omemo-error (signal 'jabber-omemo-prekey-failed (list sender-jid sender-did (error-message-string err))))))) ;; Admission is outside the recoverable authentication handler: ;; changed identities must never delete or rebuild accepted state. (jabber-omemo--admit-inbound-session jc sender-jid sender-did fresh) (list fresh key t)))))))) (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 jc))) (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) ;; A rolled-back MAM page restores the durable session; forget ;; the consumed copy so its retry decrypts from that state. (jabber-chat--on-decrypt-rollback (lambda () (remhash (jabber-omemo--session-key account sender-jid sender-did) jabber-omemo--sessions) (remhash account jabber-omemo--stores))) (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))) (let ((hb (jabber-omemo-heartbeat session-ptr store-ptr))) (jabber-omemo--save-session jc sender-jid sender-did session-ptr) (when hb ;; Rollback reloads the unadvanced sending chain: never put ;; a step on the wire that durable state may not keep. (jabber-chat--on-decrypt-commit (lambda () (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--current-echo-key (jc stanza) "Return JC's exact existing echo key for encrypted STANZA." (when (and jc (equal (jabber-xml-get-attribute stanza 'type) "groupchat") (eq (car-safe (jabber-xml-child-with-xmlns stanza jabber-omemo-xmlns)) 'encrypted)) (let* ((room (jabber-xml-get-attribute stanza 'to)) (nick (or (jabber-muc-nickname room jc) (cadr (assoc room (gethash (jabber-connection-bare-jid jc) jabber-muc--rooms-before-disconnect))))) (key (and nick (jabber-omemo--muc-echo-key jc room (concat room "/" nick) (jabber-xml-get-attribute stanza 'id))))) (cl-find key (hash-table-keys jabber-omemo--sent-muc-plaintexts) :test #'equal)))) (defun jabber-omemo--move-echo (entry nick) "Move ENTRY's current echo to NICK, or dispose it when NICK is nil." (when-let* ((key (plist-get entry :echo-key)) (body (gethash key jabber-omemo--sent-muc-plaintexts))) (remhash key jabber-omemo--sent-muc-plaintexts) (when nick (setcar (nthcdr 2 key) (concat (nth 1 key) "/" nick)) (puthash key body jabber-omemo--sent-muc-plaintexts)))) (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." (message "OMEMO: rebuilding session for %s device %s" sender-jid sender-did) (jabber-omemo--reset-session jc sender-jid sender-did #'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) ;; Our own ciphertext omits our device: keep the only plaintext. (jabber-chat--on-decrypt-rollback (lambda () (puthash echo-key cached 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 &optional jc) "Return current occupant and offline-member JIDs for GROUP on JC. Ignore the legacy room-only _PARTICIPANTS argument. JC defaults to the current buffer's connection, never to another account joined to the room." (require 'jabber-muc) (jabber-muc--identity-jids (or jc jabber-buffer-connection) group)) (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 ACCOUNT JID 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 (unless (cl-some (lambda (peer) (jabber-blocking-blocked-p jc peer)) jids) 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))) (let ((ewoc jabber-chat-ewoc) (owner-p (jabber-chat--capture-input-owner))) (run-hook-with-args 'jabber-chat-local-message-functions (cadr (ewoc-data node))) (list :buffer target :node node :ewoc ewoc :owner-p owner-p))))))))) (defun jabber-omemo--node-owned-p (buffer node ewoc) "Return non-nil if BUFFER still owns NODE in the captured EWOC." (and node ewoc (buffer-live-p buffer) (with-current-buffer buffer (and (eq ewoc jabber-chat-ewoc) ;; A removed node can retain its ID and marker. Traverse only ;; the live EWOC, never the potentially retired node's links. (let ((current (ewoc-nth ewoc 0))) (while (and current (not (eq current node))) (setq current (ewoc-next ewoc current))) (eq current node)))))) (defun jabber-omemo--send-failed (buffer node body reason &optional node-buffer node-ewoc) "Mark NODE as :undelivered and restore non-nil BODY to input area. BUFFER is the composition buffer. REASON is shown via `message'. NODE-BUFFER and NODE-EWOC identify the original transcript. Deferred input completion owns restoration when BODY is nil." (let* ((target (or node-buffer buffer)) (ewoc (or node-ewoc (and (buffer-live-p target) (buffer-local-value 'jabber-chat-ewoc target))))) (when (jabber-omemo--node-owned-p target node ewoc) (with-current-buffer target (plist-put (cadr (ewoc-data node)) :status :undelivered) (jabber-chat-ewoc-invalidate node)))) (when (and body (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)) (owner-p (jabber-chat--capture-input-owner)) (completion (unless is-correction jabber-chat--input-completion)) (id (format "emacs-msg-%.6f" (float-time))) (send-context (progn (when completion (setq jabber-chat--input-deferred t)) (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)) (node-ewoc (plist-get pending :ewoc)) (node-owner-p (plist-get pending :owner-p)) (raw-failed (lambda (reason) (let ((restore (if completion (funcall completion nil) t))) (when (and restore (funcall owner-p)) (with-current-buffer buffer (jabber-chat--restore-send-context send-context))) (unless is-correction (jabber-omemo--send-failed buffer (and (or (null node-owner-p) (funcall node-owner-p)) node) (and (not completion) restore (funcall owner-p) body) reason node-buffer node-ewoc))) (when failure-callback (funcall failure-callback reason)))) (operation (jabber-omemo--send-operation-register jc (lambda () (when completion (funcall completion t)) (when success-callback (funcall 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)) (check (lambda () (unless (and (jabber-omemo--send-operation-active-p operation) (funcall owner-p)) (error "OMEMO: send buffer changed"))))) (plist-put operation :transport-success succeeded) (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 node-ewoc check node-owner-p) ((error quit) (funcall failed (error-message-string send-error)) (when (eq (car send-error) 'quit) (signal (car send-error) (cdr send-error)))))))) ((error quit) (funcall failed (error-message-string own-error)) (when (eq (car own-error) 'quit) (signal (car own-error) (cdr own-error))))))))) ((error quit) (funcall failed (error-message-string err)) (when (eq (car err) 'quit) (signal (car err) (cdr err))))))) (defun jabber-omemo--check-blocking (jc jid &optional muc) "Reject sending on JC to blocked JID or, with MUC, its real recipients." (let ((recipients (cons jid (when muc (jabber-omemo--muc-participant-jids jid nil jc))))) (when (cl-some (lambda (peer) (jabber-blocking-blocked-p jc peer)) recipients) (user-error "Cannot send OMEMO messages to blocked recipients")))) (defun jabber-omemo--send-encrypted (jc body chat-with all-sessions &optional buffer node id extra-elements success-callback failure-callback node-buffer node-ewoc check node-owner-p) "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 ACCOUNT JID 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 and NODE-EWOC identify the original transcript owning NODE. CHECK validates the captured send owner around hooks and before publication or transport handoff. NODE-OWNER-P validates the node's independently routed view." (jabber-omemo--check-blocking jc (or chat-with jabber-chatting-with)) (let* ((chat-with (or chat-with jabber-chatting-with)) (id (or id (format "emacs-msg-%.6f" (float-time)))) (is-correction (assq 'replace extra-elements)) (buffer (or buffer (unless is-correction (current-buffer)))) (plaintext (encode-coding-string body 'utf-8)) (enc-result (jabber-omemo-encrypt-message plaintext)) (encrypted-xml (jabber-omemo--build-encrypted-xml jc all-sessions enc-result)) (stanza `(message ((to . ,chat-with) (type . "chat") (id . ,id)) (body () ,jabber-omemo-fallback-body) ,encrypted-xml ,(jabber-hints-store) ,(jabber-eme-encryption jabber-omemo-xmlns "OMEMO") ,@extra-elements))) (when check (funcall check)) (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 (jabber-chat--run-send-hooks stanza body id (and check t) check) (cond (node (let* ((target (or node-buffer buffer)) (ewoc (or node-ewoc (and (buffer-live-p target) (buffer-local-value 'jabber-chat-ewoc target))))) (when (and (or (null node-owner-p) (funcall node-owner-p)) (jabber-omemo--node-owned-p target node ewoc)) (with-current-buffer target (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)))))) (when check (funcall check)) (jabber-omemo--check-blocking jc chat-with) (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." (require 'jabber-muc) (let* ((group jabber-group) (is-correction (assq 'replace extra-elements)) (buffer (current-buffer)) (owner-p (jabber-chat--capture-input-owner)) (completion (unless is-correction jabber-chat--input-completion)) (id (format "emacs-msg-%.6f" (float-time))) (send-context (progn (when completion (setq jabber-chat--input-deferred t)) (jabber-chat--capture-send-context body extra-elements))) (extra-elements (plist-get send-context :extra-elements)) (bare-jids (jabber-omemo--muc-participant-jids group nil jc)) (membership (jabber-muc--identity-record jc group)) (raw-failed (lambda (reason) (let ((restore (if completion (funcall completion nil) t))) (when (and restore (funcall owner-p)) (with-current-buffer buffer (jabber-chat--restore-send-context send-context))) (unless is-correction (jabber-omemo--send-failed buffer nil (and (not completion) restore (funcall owner-p) body) reason))) (when failure-callback (funcall failure-callback reason)))) (operation (jabber-omemo--send-operation-register jc (lambda () (when completion (funcall completion t)) (when success-callback (funcall 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)) (check (lambda () (unless (and (jabber-omemo--send-operation-active-p operation) (funcall owner-p) (eq membership (jabber-muc--identity-record jc group)) (equal (sort (copy-sequence bare-jids) #'string<) (sort (jabber-omemo--muc-participant-jids group nil jc) #'string<))) (error "OMEMO: send buffer or room membership changed"))))) (plist-put operation :transport-success succeeded) (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 check) ((error quit) (funcall failed (error-message-string send-error)) (when (eq (car send-error) 'quit) (signal (car send-error) (cdr send-error)))))))) ((error quit) (funcall failed (error-message-string own-error)) (when (eq (car own-error) 'quit) (signal (car own-error) (cdr own-error))))))))) ((error quit) (funcall failed (error-message-string err)) (when (eq (car err) 'quit) (signal (car err) (cdr err)))))))) (defun jabber-omemo--send-encrypted-muc (jc body group all-sessions &optional buffer id extra-elements success-callback failure-callback check) "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 ACCOUNT JID 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. CHECK validates the captured send owner around hooks and before handoff. No local echo: the MUC server mirrors the message back." (when check (funcall check)) (jabber-omemo--check-blocking jc group t) (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 (or (jabber-muc-nickname group jc) (plist-get (jabber-sm--room-attempt (fsm-get-state-data jc) group) :nick))) (echo-key (and nick (jabber-omemo--muc-echo-key jc group (concat group "/" nick) id))) (jabber-omemo--sending-echo-key echo-key) (_ (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)) (jabber-omemo--sending-stanza stanza)) (condition-case err (progn (when check (funcall check)) (when (buffer-live-p buffer) (with-current-buffer buffer (jabber-chat--run-send-hooks stanza body id (and check t) check))) (when check (funcall check)) (jabber-omemo--check-blocking jc group t) (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 ((bare-jids (jabber-omemo--muc-participant-jids group nil jc))) (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 OMEMO work not owned by JC's fresh recovery queue." (let* ((state-data (fsm-get-state-data jc)) (entries (and (plist-get state-data :sm-fresh-recovery) (append (plist-get state-data :nil-entry-pending) (plist-get state-data :sm-pending-queue)))) (callbacks (delq nil (mapcar (lambda (entry) (and (keywordp (car-safe entry)) (plist-get entry :success))) entries))) (operations (copy-sequence (gethash jc jabber-omemo--pending-send-operations))) (discarded-echoes (cl-remove-if-not (lambda (key) (and (eq jc (car key)) (not (cl-some (lambda (entry) (equal key (if (and (keywordp (car-safe entry)) (plist-member entry :echo-key)) (plist-get entry :echo-key) (jabber-omemo--current-echo-key jc (jabber-sm--pending-stanza entry))))) entries)))) (hash-table-keys jabber-omemo--sent-muc-plaintexts)))) ;; Claim old echo disposal before callbacks can create successor work. (dolist (key discarded-echoes) (remhash key jabber-omemo--sent-muc-plaintexts)) (dolist (operation operations) (unless (memq (plist-get operation :transport-success) callbacks) (jabber-omemo--send-operation-finish operation 'failure "OMEMO: connection reset before the message was sent"))))) ;;; 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. Return (ENCRYPTED-PATH . WRAPPED-CALLBACK), or nil if OMEMO is not selected. Signal encryption or file errors so the caller cannot upload plaintext." (when (eq jabber-chat-encryption 'omemo) (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)))) (condition-case err ;; Keep opaque ciphertext literal even for compressed file suffixes. (let ((jka-compr-inhibit t) (coding-system-for-write 'no-conversion)) (write-region ciphertext nil tmp nil 'silent)) ((error quit) (ignore-errors (delete-file tmp)) (signal (car err) (cdr err)))) (cons tmp (lambda (get-url) (ignore-errors (delete-file tmp)) (funcall callback (jabber-omemo--build-aesgcm-url get-url iv key))))))) (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-blocking-ready-hook #'jabber-omemo--prefetch-open-chats) (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.15.1/lisp/jabber-openpgp-legacy.el000066400000000000000000000365541527111033600215530ustar00rootroot00000000000000;;; 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 ;;; 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 (jabber-jid-symbol bare jc) '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 success-callback failure-callback) "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. SUCCESS-CALLBACK and FAILURE-CALLBACK report actual transport handoff or failure, not Stream Management queue admission." (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))) (if (or success-callback failure-callback) (jabber-send-sexp jc stanza success-callback failure-callback) (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 success-callback failure-callback) "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. SUCCESS-CALLBACK and FAILURE-CALLBACK report actual transport handoff or failure, not Stream Management queue admission." (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) (if (or success-callback failure-callback) (jabber-send-sexp jc stanza success-callback failure-callback) (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.15.1/lisp/jabber-openpgp.el000066400000000000000000000750071527111033600203050ustar00rootroot00000000000000;;; 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 'iso8601) (require 'jabber-pubsub) (require 'jabber-xml) (require 'jabber-hints) (require 'jabber-eme) (require 'jabber-chat) (require 'jabber-disco) (eval-when-compile (require 'pcase) (require 'rx)) (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 and return plaintext with verification evidence. The result is (PLAINTEXT . SIGNATURES). Successful decryption does not authenticate a sender; callers must check SIGNATURES." (let* ((context (epg-make-context 'OpenPGP)) (plaintext (epg-decrypt-string context ciphertext))) (cons (decode-coding-string plaintext 'utf-8) (epg-context-result-for context 'verify)))) ;;; 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 completion (defun jabber-openpgp--send (jc recipients body extra-elements sender success failure) "Resolve RECIPIENTS and invoke SENDER once for BODY on JC. Capture EXTRA-ELEMENTS before discovery. SENDER receives the captured extensions, two transport callbacks and an ownership check. SUCCESS and FAILURE report completion, not queue admission." (let* ((buffer (current-buffer)) (owner-p (jabber-chat--capture-input-owner)) (context (jabber-chat--capture-send-context body extra-elements)) (completion (unless (assq 'replace extra-elements) jabber-chat--input-completion)) (state 'discovering) (failed (lambda (reason) (unless (eq state 'done) ;; Retire every retained continuation before calling consumers. (setq state 'done) (let ((restore (if completion (funcall completion nil) t))) (when (and restore (funcall owner-p)) (with-current-buffer buffer (jabber-chat--restore-send-context context)))) (if failure (funcall failure reason) (message "%s" reason))))) (sent (lambda () (when (eq state 'sending) (setq state 'done) (when completion (funcall completion t)) (when success (funcall success)) ;; Completion can run user code and replace the buffer owner. ;; Settlement survives replacement; publication does not. (funcall owner-p)))) returned) (when completion (setq jabber-chat--input-deferred t)) (unwind-protect (prog1 (jabber-openpgp--ensure-recipient-keys jc recipients (lambda () (when (eq state 'discovering) (setq state 'sending) (condition-case err (if (not (funcall owner-p)) (funcall failed "OpenPGP: send buffer changed") (with-current-buffer buffer (funcall sender (plist-get context :extra-elements) sent failed (lambda () (unless (and (eq state 'sending) (funcall owner-p)) (error "OpenPGP: send buffer changed")))))) ((error quit) (funcall failed (error-message-string err)) (when (eq (car err) 'quit) (signal (car err) (cdr err))))))) failed) (setq returned t)) (unless returned (funcall failed "OpenPGP: send cancelled"))))) ;;; 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) (id (format "emacs-msg-%.6f" (float-time)))) (jabber-openpgp--send jc (list recipient) body extra-elements (lambda (extra success failure check) (jabber-openpgp--send-chat-1 jc body recipient chat-with id extra success failure check)) success-callback failure-callback))) (defun jabber-openpgp--send-chat-1 (jc body recipient chat-with id &optional extra-elements success failure check) "Encrypt and send BODY to RECIPIENT at CHAT-WITH via JC with ID. EXTRA-ELEMENTS are outside the encryption envelope. SUCCESS and FAILURE report transport completion. CHECK validates ownership before handoff." (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))) (when check (funcall check)) (jabber-chat--run-send-hooks stanza body id t check) (when check (funcall check)) (let ((buffer (current-buffer))) (jabber-send-sexp jc stanza (lambda () (when (and (if success (funcall success) t) (buffer-live-p buffer) (not (assq 'replace extra-elements))) (with-current-buffer buffer (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))))) failure)))) ;;; 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 jabber-group)) (id (format "emacs-msg-%.6f" (float-time)))) (jabber-openpgp--send jc all-jids body extra-elements (lambda (extra success failure check) (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))) (funcall check) (jabber-chat--run-send-hooks stanza body id t check) (funcall check) (jabber-send-sexp jc stanza success failure))) success-callback failure-callback))) ;;; 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--children (node namespace name) "Return NODE's children with expanded NAME in NAMESPACE." (cl-remove-if-not (lambda (child) (and (consp child) (equal (car child) (cons namespace name)))) (cddr node))) (defun jabber-openpgp--recipient-p (recipient outer) "Return non-nil if inner RECIPIENT corresponds to OUTER's JID. A bare inner JID admits any resource; a full inner JID admits only that resource. As elsewhere in Jabber, JIDs are expected prepared." (and (stringp recipient) (not (string-empty-p recipient)) (stringp outer) (not (string-empty-p outer)) (equal (jabber-jid-user recipient) (jabber-jid-user outer)) (or (null (jabber-jid-resource recipient)) (equal (jabber-jid-resource recipient) (jabber-jid-resource outer))))) (defun jabber-openpgp--xmpp-uid-p (key sender) "Return non-nil if KEY has a non-revoked exact XMPP UID for SENDER. Read GnuPG's colon format directly: EasyPG versions using the Lisp reader for UID escapes misread `\\\\x3aalice' as one hexadecimal escape." (let* ((context (epg-make-context 'OpenPGP)) (home (epg-context-home-directory context))) (with-temp-buffer (set-buffer-multibyte nil) (let ((coding-system-for-read 'binary)) (unless (zerop (apply #'call-process (epg-context-program context) nil (list t nil) nil (append (when home (list "--homedir" home)) (list "--batch" "--with-colons" "--list-keys" (jabber-openpgp--key-fingerprint key))))) (error "OpenPGP: could not inspect sender key"))) (cl-some (lambda (line) (let ((fields (split-string line ":"))) (and (equal (car fields) "uid") (not (member (nth 1 fields) '("r" "e" "d" "i"))) (equal (decode-coding-string (replace-regexp-in-string (rx "\\x" (= 2 xdigit)) (lambda (escape) (unibyte-string (string-to-number (substring escape 2) 16))) (nth 9 fields) t t) 'utf-8) (concat "xmpp:" sender))))) (split-string (buffer-string) "\n" t))))) (defun jabber-openpgp--verify-sender (signatures from) "Require SIGNATURES to authenticate the sender FROM. Honor the configured sender key and require an exact XMPP User ID. Signing subkeys are matched against that key's complete subkey list." (let* ((sender (and (stringp from) (jabber-jid-user from))) (key (and sender (jabber-openpgp--recipient-key sender)))) (unless (and signatures key (jabber-openpgp--xmpp-uid-p key sender) (cl-every (lambda (signature) (and (eq (epg-signature-status signature) 'good) (not (eq (epg-signature-validity signature) 'never)) (cl-some (lambda (subkey) (and (epg-signature-fingerprint signature) (equal (epg-signature-fingerprint signature) (epg-sub-key-fingerprint subkey)))) (epg-key-sub-key-list key)))) signatures)) (error "OpenPGP: sender signature or XMPP key identity is invalid")))) (defun jabber-openpgp--timestamp-p (stamp) "Return non-nil if STAMP has the XEP-0082 DateTime form. Check the calendar date, but do not impose a freshness window on archives." (and (stringp stamp) (string-match-p (rx string-start (= 4 digit) "-" (= 2 digit) "-" (= 2 digit) "T" (or (seq (any "01") digit) (seq "2" (any "0123"))) ":" (any "012345") digit ":" (any "012345") digit (optional "." (+ digit)) (or "Z" (seq (any "+-") (or (seq (any "01") digit) (seq "2" (any "0123"))) ":" (any "012345") digit)) string-end) stamp) (condition-case nil (let* ((date (cl-subseq (iso8601-parse stamp) 3 6)) (time (encode-time 0 0 0 (nth 0 date) (nth 1 date) (nth 2 date) t))) (equal date (cl-subseq (decode-time time t) 3 6))) (error nil)))) (defun jabber-openpgp--validate-content (inner signatures xml-data) "Validate INNER and SIGNATURES against the outer XML-DATA. Return the sole payload element, without changing XML-DATA." (let* ((name (car inner)) (signcrypt (equal name (cons jabber-openpgp-xmlns "signcrypt"))) (times (jabber-openpgp--children inner jabber-openpgp-xmlns "time")) (payloads (jabber-openpgp--children inner jabber-openpgp-xmlns "payload")) (recipients (jabber-openpgp--children inner jabber-openpgp-xmlns "to")) (stamp (cdr (assoc '("" . "stamp") (cadar times))))) (unless (or signcrypt (equal name (cons jabber-openpgp-xmlns "crypt"))) (error "OpenPGP: unexpected content element")) (unless (and (= (length times) 1) (= (length payloads) 1) (jabber-openpgp--timestamp-p stamp)) (error "OpenPGP: invalid time or payload structure")) ;; XEP-0373 0.6+ makes `to' optional for crypt, not signcrypt. (when (or signcrypt recipients) (unless (and recipients (cl-every (lambda (to) (let ((jid (cdr (assoc '("" . "jid") (cadr to))))) (and (stringp jid) (not (string-empty-p jid))))) recipients) (cl-some (lambda (to) (jabber-openpgp--recipient-p (cdr (assoc '("" . "jid") (cadr to))) (jabber-xml-get-attribute xml-data 'to))) recipients)) (error "OpenPGP: intended recipient does not match stanza"))) (if signcrypt (jabber-openpgp--verify-sender signatures (jabber-xml-get-attribute xml-data 'from)) (when signatures (error "OpenPGP: crypt content must not be signed"))) (car payloads))) (defun jabber-openpgp--decrypt-stanza (_jc xml-data openpgp-el) "Authenticate OPENPGP-EL before replacing the body in XML-DATA. Signcrypt requires a valid sender signature; crypt is encryption-only. Reject invalid envelopes without publishing any decrypted content." (let* ((b64 (car (jabber-xml-node-children openpgp-el))) (result (jabber-openpgp--decrypt (base64-decode-string b64))) (roots (with-temp-buffer (insert (car result)) ;; Expanded QNames preserve inherited and prefixed namespaces. (xml-parse-region (point-min) (point-max) nil nil t))) (_ (unless (= (length roots) 1) (error "OpenPGP: expected exactly one content element"))) (payload (jabber-openpgp--validate-content (car roots) (cdr result) xml-data)) (body (car (jabber-openpgp--children payload "jabber:client" "body")))) (unless (cl-every #'stringp (cddr body)) (error "OpenPGP: invalid body content")) (jabber-chat--set-body xml-data (if body (mapconcat #'identity (cddr body) "") "[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.15.1/lisp/jabber-ping.el000066400000000000000000000055231527111033600175660ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-presence-display.el000066400000000000000000000030721527111033600220750ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-presence-events.el000066400000000000000000000050731527111033600217370ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-presence.el000066400000000000000000000601761527111033600204420ustar00rootroot00000000000000;;; 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 &optional jc) "Process a single roster ITEM element. ROSTER is the current roster list. INITIALP non-nil means initial fetch. JC selects the connection-owned contact namespace. Return (CATEGORY . JID-SYMBOL) where CATEGORY is `new', `changed', or `deleted'." (let* ((jid (jabber-jid-symbol (jabber-xml-get-attribute item 'jid) jc)) (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 (and jc (list 'jabber--jid-owner jc)))) (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 jc) (`(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 jc) (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 jc))) (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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Send directed presence to: " nil nil nil nil nil jc) (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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "to: " nil nil nil nil nil jc) (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--read-edit (jc jid) "Read the name and groups for JID on JC, returning a two-element list. JID is a roster symbol. Empty group entries are removed." (let* ((name (get jid 'name)) (groups (get jid 'groups)) (all-groups (apply #'append (mapcar (lambda (contact) (get contact 'groups)) (plist-get (fsm-get-state-data jc) :roster)))) (new-name (jabber-read-with-input-method (format "Name: (default `%s') " name) nil nil name))) (unless (memq jc jabber-connections) (user-error "Selected Jabber account is no longer connected")) (list new-name (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))))) (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* ((jc (jabber-read-account)) (jid (jabber-jid-symbol (jabber-read-jid-completing "Add/change JID: " nil nil nil nil nil jc) jc)) (values (jabber-roster--read-edit jc jid))) (unless (memq jc jabber-connections) (user-error "Selected Jabber account is no longer connected")) (append (list jc jid) values))) ;; 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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Delete from roster: " nil nil nil nil nil jc)))) (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.15.1/lisp/jabber-private.el000066400000000000000000000051451527111033600203030ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-pubsub.el000066400000000000000000000152411527111033600201270ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-reactions.el000066400000000000000000000553601527111033600206240ustar00rootroot00000000000000;;; 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) ;; Chat loads reactions, so the account-qualified lookup is a reverse call. (declare-function jabber-chat--find-buffer-on-connection "jabber-chat" (jc from)) (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 &optional jc) "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 on JC, then SENDER itself." (or (jabber-jid-resource sender) (jabber-jid-displayname sender jc) sender)) (defun jabber-reactions--entry-help-echo (entry &optional jc) "Return help-echo text naming who sent reaction ENTRY, or nil. JC selects the contact owner. 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 (lambda (sender) (jabber-reactions--sender-name sender jc)) 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-chat--find-buffer-on-connection jc 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)))) (when (eq (jabber-db-reaction-target-row (jabber-connection-bare-jid jabber-buffer-connection) (jabber-jid-user to) type target-id) 'ambiguous) (user-error "Reaction target is ambiguous")) (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--find-target-node (target-id muc-p &optional row-id) "Return the unique visible reaction TARGET-ID node, or nil. MUC-P selects room IDs only. Direct chat accepts origin and transport aliases. When known, ROW-ID also limits restored database nodes." (let ((node (and jabber-chat-ewoc (ewoc-nth jabber-chat-ewoc 0))) matches) (while node (let ((msg (cadr (ewoc-data node)))) (when (and (listp msg) (or (equal target-id (jabber-reactions--target-id msg muc-p)) (and (not muc-p) (equal target-id (plist-get msg :id)))) (or (null row-id) (null (plist-get msg :db-id)) (equal row-id (plist-get msg :db-id)))) (push node matches))) (setq node (ewoc-next jabber-chat-ewoc node))) (when (= (length matches) 1) (car matches)))) (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* ((row (jabber-db-reaction-target-row (jabber-connection-bare-jid jc) peer type (car parsed))) (thread-targets (cond ((eq row 'ambiguous) 'closed) (row (jabber-message-thread-update-targets-for-row jc peer type row)) (t (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-reactions--find-target-node (car parsed) (string= type "groupchat") row))) (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.15.1/lisp/jabber-receipts.el000066400000000000000000000452061527111033600204510ustar00rootroot00000000000000;;; 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 jc)) ((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) jc)) (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--displayed-after-p (node) "Return non-nil if an outgoing message after NODE is already displayed." (let ((next (ewoc-next jabber-chat-ewoc node)) found) (while (and next (not found)) (setq found (and (eq (car (ewoc-data next)) :local) (eq (plist-get (cadr (ewoc-data next)) :status) :displayed)) next (ewoc-next jabber-chat-ewoc next))) found)) (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 (float-time msg-ts))) (displayed-p (string= column "displayed_at")) (forward-p (or (not displayed-p) (and (or (not msg-epoch) (>= msg-epoch jabber-receipts--latest-displayed-ts)) (not (jabber-receipts--displayed-after-p node))))) (inhibit-read-only t)) (when (and forward-p (or (null current-status) (jabber-receipts--status-upgrades-p current-status status))) (jabber-receipts--restore-on-rollback node) (jabber-chat--restore-on-rollback 'jabber-receipts--latest-displayed-ts 'jabber-chat-receipt-message) (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--restore-on-rollback (node) "Restore NODE's current status if archive storage rolls back. Otherwise a retry sees the status as current and skips the durable write." (let ((buffer (current-buffer)) (msg (cadr (ewoc-data node))) (status (plist-get (cadr (ewoc-data node)) :status))) (jabber-chat--on-decrypt-rollback (lambda () (when (buffer-live-p buffer) (with-current-buffer buffer (plist-put msg :status status) (let ((inhibit-read-only t)) (jabber-chat-ewoc-invalidate node)))))))) (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 ref-id)))) (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)) (jabber-receipts--restore-on-rollback prev) (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.15.1/lisp/jabber-register.el000066400000000000000000000277771527111033600204740ustar00rootroot00000000000000;;; 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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Register with: " nil nil nil nil nil jc)))) (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.15.1/lisp/jabber-roster-menu.el000066400000000000000000000535051527111033600211140ustar00rootroot00000000000000;;; 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." (when jabber-roster--scoped-connection (jabber-roster--check-connection jabber-roster--scoped-connection)) (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))) ;; Newer popup revisions generate these launchers at first initialization. (declare-function jabber-roster-presence-map-popup "jabber-roster-menu" () t) (declare-function jabber-roster-discovery-map-popup "jabber-roster-menu" () t) (declare-function jabber-roster-contact-action-map-popup "jabber-roster-menu" () t) (declare-function jabber-roster-popup-map-popup "jabber-roster-menu" () t) (declare-function jabber-roster-account-action-map-popup "jabber-roster-menu" () t) (unless (boundp 'jabber-roster-presence-map) (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))) (unless (boundp 'jabber-roster-discovery-map) (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 "Selected JID, with its owning connection in the `jabber-account' property. The action submenu retains this owner even when roster scope changes.") (unless (boundp 'jabber-roster-contact-action-map) (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))) (unless (boundp 'jabber-roster-popup-map) (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* ((scope jabber-roster--scoped-connection) (online (cl-remove-if-not (lambda (buddy) (get buddy 'connected)) (jabber-roster--contacts))) (jid (progn (unless online (user-error "No online contacts in this roster")) (jabber-read-jid-completing "Chat with (online): " online t)))) (when jid (let ((jc (jabber-roster--jc-for-jid jid scope))) (jabber-chat-with jc jid))))) (defun jabber-roster-chat-any () "Select any contact and show action submenu." (interactive) (let* ((scope jabber-roster--scoped-connection) (contacts (jabber-roster--contacts))) (unless contacts (user-error "No contacts in this roster")) (when-let* ((jid (jabber-read-jid-completing "Contact: " contacts t)) (jc (jabber-roster--jc-for-jid jid scope))) (setq jabber-roster--selected-jid (propertize jid 'jabber-account jc)) (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* ((candidates (mapcar (lambda (entry) (cons (format "%s (%s)" (jabber-activity--jid entry) (if-let* ((owner (jabber-activity--owner entry))) (jabber-connection-bare-jid owner) "disconnected")) entry)) jabber-activity-jids)) (choice (completing-read "Unread: " candidates nil t))) (when-let* ((entry (cdr (assoc choice candidates)))) (jabber-activity-switch-to entry))))) (defun jabber-roster--muc-room-name (room) "Return cached bookmark name for ROOM, respecting roster scope." (when-let* ((jc (or jabber-roster--scoped-connection (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)." (when jabber-roster--scoped-connection (jabber-roster--check-connection jabber-roster--scoped-connection)) (mapcar (lambda (room) (cons room (jabber-roster--muc-room-name room))) (cl-remove-if-not (lambda (room) (jabber-muc-joined-p room jabber-roster--scoped-connection)) (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* ((scope jabber-roster--scoped-connection) (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 scope)))) ;;; Account management (defvar jabber-roster--selected-account nil "Connection selected in the accounts menu.") (unless (boundp 'jabber-roster-account-action-map) (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--check-connection (jc) "Return JC if still connected, otherwise reject the stale selection." (unless (memq jc jabber-connections) (user-error "Selected Jabber account is no longer connected")) jc) (cl-defun jabber-roster--jc-for-jid (jid &optional (scope jabber-roster--scoped-connection)) "Return the selected owner of JID, respecting captured SCOPE. Ask explicitly when an unscoped contact belongs to multiple accounts. A retained owner must never fall back to a different account." (let* ((owner (or (get-text-property 0 'jabber-account jid) scope)) (accounts (mapcar (lambda (jc) (cons (jabber-connection-bare-jid jc) jc)) (cl-remove-if-not (lambda (jc) (jabber-roster-contact-p jc jid)) (if owner (list (jabber-roster--check-connection owner)) jabber-connections)))) (jc (cond ((null accounts) (user-error "Contact is no longer in roster")) ((null (cdr accounts)) (cdar accounts)) (t (cdr (assoc (completing-read "Account: " accounts nil t) accounts)))))) (jabber-roster--check-connection jc) (unless (jabber-roster-contact-p jc jid) (user-error "Contact is no longer in selected roster")) jc)) (defun jabber-roster--action-chat () "Open chat with the selected contact." (interactive) (when-let* ((jid jabber-roster--selected-jid) (jc (jabber-roster--jc-for-jid jid))) (jabber-chat-with jc jid))) (defun jabber-roster--action-info () "Get info for the selected contact." (interactive) (when-let* ((jid jabber-roster--selected-jid) (jc (jabber-roster--jc-for-jid jid))) (jabber-get-info jc jid))) (defun jabber-roster--action-edit () "Edit name and groups of the selected contact." (interactive) (when-let* ((jid jabber-roster--selected-jid) (jc (jabber-roster--jc-for-jid jid))) (let ((values (jabber-roster--read-edit jc (jabber-jid-symbol jid jc)))) (jabber-roster--jc-for-jid jid jc) (apply #'jabber-roster-change jc (jabber-jid-symbol jid jc) values)))) (defun jabber-roster--action-delete () "Delete the selected contact from roster." (interactive) (when-let* ((jid jabber-roster--selected-jid) (jc (jabber-roster--jc-for-jid jid))) (when (yes-or-no-p (format "Delete %s from roster? " jid)) (jabber-roster--jc-for-jid jid jc) (jabber-roster-delete jc jid)))) (defun jabber-roster--action-block () "Block the selected contact." (interactive) (when-let* ((jid jabber-roster--selected-jid) (jc (jabber-roster--jc-for-jid jid))) (jabber-blocking-block-jid jc jid))) (provide 'jabber-roster-menu) ;;; jabber-roster-menu.el ends here emacs-jabber-0.15.1/lisp/jabber-roster.el000066400000000000000000000174351527111033600201540ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-rtt.el000066400000000000000000000306011527111033600174350ustar00rootroot00000000000000;;; 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: (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 jc))) (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 (and jabber-rtt-outgoing-events (jabber-connection-active-p jabber-buffer-connection)) (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.15.1/lisp/jabber-sasl.el000066400000000000000000000156601527111033600175760ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-search.el000066400000000000000000000076741527111033600201070ustar00rootroot00000000000000;;; 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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Search what database: " nil nil nil nil nil jc)))) (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.15.1/lisp/jabber-sm-runtime.el000066400000000000000000000253641527111033600207360ustar00rootroot00000000000000;;; 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 'cl-lib) (require 'fsm) (require 'jabber-sm) (require 'jabber-stanza) (defun jabber-sm--take-pending (state-data) "Return STATE-DATA and its pending entries with queue ownership detached." (let ((entries (plist-get state-data :sm-pending-queue))) (list (plist-put state-data :sm-pending-queue nil) entries))) (defun jabber-sm--fail-pending (entries reason) "Fail ENTRIES independently with REASON." (dolist (entry entries) (when (keywordp (car-safe entry)) (when (fboundp 'jabber-omemo--move-echo) (jabber-omemo--move-echo entry nil)) (when (functionp (plist-get entry :failure)) (jabber-sm--run-pending-callback (plist-get entry :failure) reason))))) (defun jabber-sm--discard-pending (state-data reason) "Detach and fail pending entries in STATE-DATA with REASON." (pcase-let ((`(,detached ,entries) (jabber-sm--take-pending state-data))) (jabber-sm--fail-pending entries reason) detached)) (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-owner-p (jc state-data) "Return non-nil when JC still owns active STATE-DATA." (and (eq (get jc :state) :session-established) (eq (fsm-get-state-data jc) state-data) (memq jc jabber-connections) (plist-get state-data :connection) (not (plist-get state-data :terminalized)) (not (plist-get state-data :disconnection-expected)))) (defun jabber-sm--prepare-drain-state (state-data) "Return a copy of STATE-DATA with ordinary pending work stably sorted." (let ((state-data (copy-sequence state-data))) (plist-put state-data :sm-pending-queue (if (plist-get state-data :sm-fresh-recovery) (plist-get state-data :sm-pending-queue) (cl-stable-sort (copy-sequence (plist-get state-data :sm-pending-queue)) (lambda (a b) (< (jabber-sm--pending-priority a) (jabber-sm--pending-priority b)))))))) (defun jabber-sm--next-drain-entry (state-data) "Return the next drain entry descriptor from STATE-DATA." (let ((recovered (plist-get state-data :sm-recovered-queue)) (pending (cl-remove-if (lambda (entry) (jabber-sm--entry-blocked-p state-data entry)) (plist-get state-data :sm-pending-queue)))) (cond (recovered (let ((entry (car recovered))) (list :sm-recovered-queue entry (if (keywordp (car-safe entry)) (jabber-sm--pending-stanza entry) entry) nil))) ((and pending (or (not (plist-get state-data :sm-enabled)) (null jabber-sm-max-in-flight) (< (jabber-sm--in-flight-count state-data) jabber-sm-max-in-flight))) (let ((entry (car pending))) (list :sm-pending-queue entry (jabber-sm--pending-stanza entry) (and (keywordp (car-safe entry)) (plist-get entry :success)))))))) (defun jabber-sm--commit-drain-entry (jc state-data queue-key entry sexp) "Commit one sent ENTRY from QUEUE-KEY when JC still owns STATE-DATA." (when (and (jabber-sm--drain-owner-p jc state-data) (memq entry (plist-get state-data queue-key))) (let ((next (copy-sequence state-data))) (setq next (plist-put next queue-key (cl-delete entry (copy-sequence (plist-get state-data queue-key)) :test #'eq :count 1))) (setq next (plist-put next :sm-outbound-queue (copy-sequence (plist-get state-data :sm-outbound-queue)))) (setq next (jabber-sm--count-outbound next sexp (and (keywordp (car-safe entry)) entry))) (put jc :state-data next) next))) (defun jabber-sm--drain-pending (jc state-data) "Drain work owned by JC under the exact STATE-DATA lease." (when (jabber-sm--drain-owner-p jc state-data) (setq state-data (jabber-sm--prepare-drain-state state-data)) (put jc :state-data state-data) (let ((continue t)) (while (and continue (jabber-sm--drain-owner-p jc state-data)) (if-let* ((descriptor (jabber-sm--next-drain-entry state-data))) (pcase-let ((`(,queue-key ,entry ,sexp ,success) descriptor) (connection (plist-get state-data :connection))) (condition-case nil (progn (jabber-send-sexp--raw jc sexp) (if-let* ((next (jabber-sm--commit-drain-entry jc state-data queue-key entry sexp))) (progn (setq state-data next) (jabber-sm--run-pending-callback success) (unless (jabber-sm--drain-owner-p jc state-data) (setq continue nil))) (setq continue nil))) ((error quit) (message "SM: queue drain write failed") (setq continue nil) (when (and (jabber-sm--drain-owner-p jc state-data) (eq connection (plist-get state-data :connection))) (fsm-send jc (list :connection-dead connection "Stream Management replay write failed")))))) (setq continue nil)))))) (defun jabber-sm--schedule-drain (jc state-data) "Schedule a top-level queue drain for JC and exact STATE-DATA." (run-at-time 0 nil #'jabber-sm--drain-pending jc state-data)) (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 (list :connection-dead connection "Stream Management acknowledgement timeout"))))) (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-owner-p (jc timer connection) "Return non-nil if JC still owns TIMER on active SM CONNECTION." (let ((state-data (fsm-get-state-data jc))) (and timer (eq timer (plist-get state-data :sm-r-timer)) (eq connection (plist-get state-data :connection)) (plist-get state-data :sm-enabled) (jabber-sm--drain-owner-p jc state-data)))) (defun jabber-sm--r-timer-function (jc timer connection) "Request an acknowledgement from JC for owned TIMER and CONNECTION." (if (not (jabber-sm--r-timer-owner-p jc timer connection)) (cancel-timer timer) (condition-case err (progn (jabber-sm--request-ack jc) (when (jabber-sm--r-timer-owner-p jc timer connection) (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 JC's acknowledgement timer and return updated STATE-DATA." (setq state-data (jabber-sm--stop-r-timer state-data)) (let ((timer (run-with-timer jabber-sm-request-interval jabber-sm-request-interval #'ignore))) (timer-set-function timer #'jabber-sm--r-timer-function (list jc timer (plist-get state-data :connection))) (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 (and (plist-get state-data :sm-enabled) (jabber-sm--drain-owner-p jc state-data)) (put jc :state-data (jabber-sm--start-r-timer jc state-data))))) (provide 'jabber-sm-runtime) ;;; jabber-sm-runtime.el ends here emacs-jabber-0.15.1/lisp/jabber-sm.el000066400000000000000000000552011527111033600172460ustar00rootroot00000000000000;;; 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-jid) (require 'jabber-state) (require 'jabber-xml) (require 'rx) (require 'subr-x) (require 'fsm) (defconst jabber-sm-xmlns "urn:xmpp:sm:3" "XEP-0198 Stream Management namespace (version 3).") (declare-function jabber-omemo--current-echo-key "jabber-omemo" (jc stanza)) (defvar jabber-omemo--sending-echo-key nil) (defvar jabber-omemo--sending-stanza nil) (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-protocol-error "Invalid Stream Management acknowledgement") (define-error 'jabber-sm-handled-count-too-high "Server acknowledged more stanzas than were sent" 'jabber-sm-protocol-error) (define-error 'jabber-sm-invalid-acknowledgement "Invalid Stream Management acknowledgement" 'jabber-sm-protocol-error) ;;; 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))) (defun jabber-sm--parse-handled-count (stanza &optional optional) "Return STANZA's unsignedInt h value. When OPTIONAL is non-nil, return nil if h is absent." (let* ((raw (jabber-xml-get-attribute stanza 'h)) (text (and raw (string-trim raw)))) (cond ((and optional (null raw)) nil) ((not (and text (string-match-p (rx string-start (? "+") (+ (in "0-9")) string-end) text))) (signal 'jabber-sm-invalid-acknowledgement (list raw))) (t (let ((h (string-to-number text))) (if (< h jabber-sm--counter-max) h (signal 'jabber-sm-invalid-acknowledgement (list raw)))))))) (defun jabber-sm--handled-count-status (state-data h) "Classify H against STATE-DATA as :current, :forward, or :stale. Signal `jabber-sm-handled-count-too-high' for a forward over-ack." (let* ((last (plist-get state-data :sm-last-acked)) (sent (plist-get state-data :sm-outbound-count)) (handled-delta (jabber-sm--counter-delta h last)) (in-flight (jabber-sm--counter-delta sent last))) (cond ((zerop handled-delta) :current) ((<= handled-delta in-flight) :forward) ((jabber-sm--counter-<= h last) :stale) (t (signal 'jabber-sm-handled-count-too-high (list h sent)))))) (defun jabber-sm--apply-handled-count (state-data h &optional reject-stale) "Apply validated handled count H to STATE-DATA. When REJECT-STALE is non-nil, stale evidence is a protocol error." (pcase (jabber-sm--handled-count-status state-data h) (:current state-data) (:stale (if reject-stale (signal 'jabber-sm-invalid-acknowledgement (list h)) state-data)) (:forward (let ((queue (jabber-sm--prune-queue (plist-get state-data :sm-outbound-queue) h))) (setq state-data (plist-put state-data :sm-last-acked h)) (setq state-data (plist-put state-data :sm-outbound-queue queue)) (plist-put state-data :sm-stall-since nil))))) ;;; 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-fresh-recovery nil :sm-id nil :sm-resume-max nil :sm-outbound-count 0 :sm-inbound-count 0 :sm-outbound-queue nil :sm-recovered-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 &optional entry) "Increment outbound counter and queue SEXP if SM is enabled. Return updated STATE-DATA. ENTRY supplies exact replay echo ownership; transport callbacks are never retained after handoff." (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 (if (equal (jabber-xml-get-attribute sexp 'type) "groupchat") (jabber-sm--pending-entry sexp nil nil (list :echo-key (if entry (plist-get entry :echo-key) (and (eq sexp jabber-omemo--sending-stanza) jabber-omemo--sending-echo-key)))) 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--entry-room (entry) "Return the retained room JID owned by ENTRY, or nil." (and (keywordp (car-safe entry)) (plist-get entry :retained-room))) (defun jabber-sm--room-attempt (state-data room) "Return the current room-attempt record for ROOM in STATE-DATA." (cdr (assoc room (plist-get state-data :muc-room-attempts)))) (defun jabber-sm--room-ready-p (state-data room) "Return non-nil when ROOM in STATE-DATA currently permits handoff." (let ((attempt (jabber-sm--room-attempt state-data room))) (and attempt (eq (plist-get attempt :status) 'ready) (eq (plist-get attempt :transport) (plist-get state-data :connection)) (equal (plist-get attempt :session) (plist-get state-data :session-id))))) (defun jabber-sm--entry-blocked-p (state-data entry) "Return non-nil when ENTRY's room is not ready in STATE-DATA." (let ((room (jabber-sm--entry-room entry))) (and room (not (jabber-sm--room-ready-p state-data room))))) (defun jabber-sm--active-recovery-room-p (state-data room) "Return non-nil if ROOM has recovery work or an attempt in STATE-DATA." (or (cl-some (lambda (entry) (equal (jabber-sm--entry-room entry) room)) (plist-get state-data :sm-pending-queue)) (let ((attempt (jabber-sm--room-attempt state-data room))) (and attempt (memq (plist-get attempt :status) '(pending ready)))))) (defun jabber-sm--recovery-join-p (state-data sexp) "Return non-nil if SEXP is join/nick presence needed to unblock STATE-DATA." (and (eq (jabber-xml-node-name sexp) 'presence) ;; Broadcast availability has no recipient and cannot recover a room. (jabber-xml-get-attribute sexp 'to) (or (jabber-xml-child-with-xmlns sexp "http://jabber.org/protocol/muc") (let* ((to (jabber-xml-get-attribute sexp 'to)) (attempt (jabber-sm--room-attempt state-data (jabber-jid-user to)))) (and (null (jabber-xml-get-attribute sexp 'type)) (eq (plist-get attempt :status) 'pending) (plist-get attempt :previous) (equal (jabber-jid-resource to) (plist-get attempt :nick))))) (jabber-sm--active-recovery-room-p state-data (jabber-jid-user (jabber-xml-get-attribute sexp 'to))))) (defun jabber-sm--blocked-room-p (state-data sexp) "Return non-nil when SEXP targets an active recovery room in STATE-DATA." (and (equal (jabber-xml-get-attribute sexp 'type) "groupchat") (jabber-sm--active-recovery-room-p state-data (jabber-xml-get-attribute sexp 'to)))) (defun jabber-sm--should-queue-p (state-data sexp) "Return non-nil if SEXP must wait for owned work in STATE-DATA. Eligible pending work precedes new stanzas of equal or lower priority. IQ bypasses ordinary back-pressure to permit bootstrap progress. Fresh recovery allows bootstrap IQ and presence past blocked rooms. Required join presence bypasses a full SM window. Successful resumption preserves all recovered wire order." (and (jabber-sm--stanza-p sexp) (not (jabber-sm--recovery-join-p state-data sexp)) (or (and (not (eq (jabber-xml-node-name sexp) 'iq)) (cl-some (lambda (entry) (and (not (jabber-sm--entry-blocked-p state-data entry)) (<= (jabber-sm--pending-priority entry) (jabber-sm--stanza-priority sexp)))) (plist-get state-data :sm-pending-queue))) (and (plist-get state-data :sm-fresh-recovery) (eq (jabber-xml-node-name sexp) 'message) (plist-get state-data :sm-pending-queue)) (and (jabber-sm--blocked-room-p state-data sexp) (not (jabber-sm--room-ready-p state-data (jabber-xml-get-attribute sexp 'to)))) (and (plist-get state-data :sm-enabled) (or (and (not (plist-get state-data :sm-resuming)) (plist-get state-data :sm-recovered-queue)) (and jabber-sm-max-in-flight (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--pending-entry (stanza &optional success-callback failure-callback extra) "Return a pending queue entry for STANZA. SUCCESS-CALLBACK and FAILURE-CALLBACK are optional. EXTRA plists are merged after the common fields." (append (list :priority (jabber-sm--stanza-priority stanza) :stanza stanza :success success-callback :failure failure-callback) extra)) (defun jabber-sm--annotate-retained-entry (entry state-data &optional retain) "Return ENTRY with room and echo ownership from STATE-DATA. When RETAIN is non-nil, associate any groupchat with its room." (let ((stanza (jabber-sm--pending-stanza entry))) (if (not (equal (jabber-xml-get-attribute stanza 'type) "groupchat")) entry (let ((annotated (if (keywordp (car-safe entry)) (copy-sequence entry) (jabber-sm--pending-entry stanza)))) (when (and (not (plist-get annotated :retained-room)) (or retain (jabber-sm--blocked-room-p state-data stanza))) (setq annotated (plist-put annotated :retained-room (jabber-xml-get-attribute stanza 'to)))) (unless (plist-member annotated :echo-key) (setq annotated (plist-put annotated :echo-key (or (and (eq stanza jabber-omemo--sending-stanza) jabber-omemo--sending-echo-key) (when (fboundp 'jabber-omemo--current-echo-key) (jabber-omemo--current-echo-key (cl-find-if (lambda (jc) (eq (fsm-get-state-data jc) state-data)) jabber-connections) stanza)))))) annotated)))) (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 (jabber-sm--annotate-retained-entry (if (or success-callback failure-callback (jabber-sm--blocked-room-p state-data sexp)) (jabber-sm--pending-entry sexp success-callback failure-callback) (cons (jabber-sm--stanza-priority sexp) sexp)) state-data))))) (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-protocol-error' for malformed or impossible acknowledgements. Return updated STATE-DATA." (jabber-sm--apply-handled-count state-data (jabber-sm--parse-handled-count stanza))) ;;; 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 (jabber-escape-xml 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. Move unacknowledged stanzas into the recovered partition in wire order. Return updated state data." (unless (and (jabber-xml-get-attribute stanza 'previd) (equal (jabber-xml-get-attribute stanza 'previd) (plist-get state-data :sm-id))) (signal 'jabber-sm-invalid-acknowledgement (list (jabber-xml-get-attribute stanza 'previd)))) (let* ((state-data (copy-sequence state-data)) (h (jabber-sm--parse-handled-count stanza)) (state-data (jabber-sm--apply-handled-count state-data h t)) (recovered (append (mapcar #'cdr (plist-get state-data :sm-outbound-queue)) (plist-get state-data :sm-recovered-queue)))) (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-recovered-queue recovered)) (setq state-data (plist-put state-data :sm-resumed t)) (setq state-data (plist-put state-data :sm-resuming nil)) state-data)) (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-sm--parse-handled-count stanza t))) (when h (setq state-data (jabber-sm--apply-handled-count state-data h)))) (let* ((stanzas (append (mapcar #'cdr (plist-get state-data :sm-outbound-queue)) (plist-get state-data :sm-recovered-queue))) (entries (append (mapcar (lambda (stanza) (if (keywordp (car-safe stanza)) stanza (cons (jabber-sm--stanza-priority stanza) stanza))) stanzas) (plist-get state-data :sm-pending-queue))) (retained (mapcar (lambda (entry) (jabber-sm--annotate-retained-entry entry state-data t)) entries)) (state-data (jabber-sm--reset (copy-sequence state-data)))) (setq state-data (plist-put state-data :sm-fresh-recovery t)) (plist-put state-data :sm-pending-queue retained))) ;;; 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.15.1/lisp/jabber-srv.el000066400000000000000000000163621527111033600174460ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-stanza.el000066400000000000000000000176161527111033600201370ustar00rootroot00000000000000;;; 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." (let* ((state-data (fsm-get-state-data jc)) (connection (plist-get state-data :connection)) (send-function (plist-get state-data :send-function))) (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)) (sm-countable (and (plist-get state-data :sm-enabled) (jabber-sm--stanza-p sexp))) (wire (if sm-countable (concat xml (jabber-sm--make-request-xml)) xml))) ;; Logging and serialization can run Lisp which replaces the stream. ;; Never acquire a successor transport for this already selected stanza. (unless (and connection (eq state-data (fsm-get-state-data jc)) (eq connection (plist-get state-data :connection)) (eq send-function (plist-get state-data :send-function))) (error "Connection changed before stanza handoff")) (funcall send-function connection wire)))) (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 quit) (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)))))) (declare-function jabber-sm--schedule-drain "jabber-sm-runtime" (jc state-data)) (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 (and (plist-get state-data :sm-fresh-recovery) (eq (get jc :state) :session-established)) (jabber-sm--schedule-drain jc state-data)) (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 (defvar jabber-stanza-error-handler nil "Handler installed during stanza dispatch to record a downstream failure. Bound per dispatch; call it without arguments on an error or quit.") (defun jabber-process-input (jc xml-data &optional error-handler) "Dispatch XML-DATA received on JC through its stanza handler chain. Handler errors are contained. When ERROR-HANDLER is non-nil, first call it with each error or quit condition; it may signal to stop dispatch." (let* ((jabber-xml-data xml-data) (jabber-stanza-error-handler nil) (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) ;; Interpreted closures are conses before Emacs 30; only a ;; numeric car marks a (DEPTH . HANDLER) entry. (let ((handler (if (numberp (car-safe entry)) (cdr entry) entry))) (condition-case err (funcall handler jc xml-data) ((debug error quit) (when error-handler (funcall error-handler err)) (when jabber-stanza-error-handler (funcall jabber-stanza-error-handler)) (when (eq (car err) 'quit) (signal (car err) (cdr err))) (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.15.1/lisp/jabber-state.el000066400000000000000000000054011527111033600177440ustar00rootroot00000000000000;;; 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) "Legacy accountless JID namespace; connected contacts are private to each FSM.") (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 (numberp (car-safe item)) (car item) 0))) (entry-function (lambda (item) (if (numberp (car-safe 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 (&optional jc) "Clear contact metadata belonging to JC. Without JC, clear every currently registered connection and legacy state. Retain scoped symbol identities and their owner for existing hook arguments." (if jc (when-let* ((table (get jc 'jabber--jid-obarray))) (mapatoms (lambda (jid) (setplist jid (list 'jabber--jid-owner jc))) table)) (mapc #'jabber-clear-roster jabber-connections) (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.15.1/lisp/jabber-styling.el000066400000000000000000000507321527111033600203240ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-subscription.el000066400000000000000000000102501527111033600213460ustar00rootroot00000000000000;;; 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 'seq) (require 'jabber-alert) (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 jc) nil "subscribe" presence-status (funcall jabber-alert-presence-message-function (jabber-jid-symbol from jc) 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 subscription request nodes from FROM's chat on live connection JC." (when-let* ((live (memq jc jabber-connections)) (buffer (seq-find (lambda (candidate) (and (eq (buffer-local-value 'jabber-buffer-connection candidate) jc) (jabber-chat--buffer-peer-p candidate from nil))) (buffer-list)))) (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.15.1/lisp/jabber-time.el000066400000000000000000000222031527111033600175610ustar00rootroot00000000000000;;; 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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Request time of: " nil nil nil 'full t jc)))) (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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Request time of: " nil nil nil 'full t jc)))) (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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Get last online for: " nil nil nil 'bare-or-muc nil jc)))) (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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Get idle time for: " nil nil nil 'full t jc)))) (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.15.1/lisp/jabber-truncate.el000066400000000000000000000071051527111033600204540ustar00rootroot00000000000000;;; 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") (declare-function jabber-chat-buffer--call-with-transcript "jabber-chatbuffer" (function &rest args)) (autoload 'jabber-chat-buffer--call-with-transcript "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) (with-current-buffer buffer (save-restriction (widen) (jabber-chat-buffer--call-with-transcript (lambda () (let* ((work-ewoc (or ewoc jabber-chat-ewoc)) (delete-before ;; Keep whole nodes, including the one crossing the cutoff. (ewoc-prev work-ewoc (ewoc-locate work-ewoc (save-excursion (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.15.1/lisp/jabber-uri.el000066400000000000000000000051401527111033600174230ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-util.el000066400000000000000000001103461527111033600176060ustar00rootroot00000000000000;;; 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-jid) (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 jc) (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--roster-full-jids (roster) "Return full-JID completion symbols for scoped contacts in ROSTER. Preserve resource spelling and the contact owner without interning full JIDs." (apply #'append (mapcar (lambda (jid) (mapcar (lambda (resource) (let ((full (make-symbol (format "%s/%s" jid (car resource))))) (setplist full (copy-sequence (symbol-plist jid))) full)) (get jid 'resources))) roster))) (defun jabber-concat-rosters-full () "Concatenate the rosters of all connected accounts with resources." (jabber--roster-full-jids (jabber-concat-rosters))) (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." (let ((bare (jabber-jid-user jid))) (when (string-match "\\(.*\\)@" bare) (match-string 1 bare)))) (defun jabber-jid-server (jid) "Return the server portion of JID." (let ((bare (jabber-jid-user jid))) (when (string-match "\\`\\(?:.*@\\)?\\([^@]+\\)\\'" bare) (match-string 1 bare)))) (defun jabber-jid-rostername (user &optional jc) "Return USER's roster name on JC, or nil. Without JC, use only a supplied symbol or legacy accountless metadata." (let* ((user (jabber-jid-symbol user jc)) (name (get user 'name))) (and name (> (length name) 0) name))) (defun jabber-jid-displayname (jid &optional jc) "Return JID's roster name on JC, or its bare JID. Without JC, never borrow metadata from a connected account." (or (jabber-jid-rostername jid jc) (jabber-jid-user (if (symbolp jid) (symbol-name jid) jid)))) (defvar jabber-bookmarks) (defun jabber-jid-bookmarkname (jid &optional jc) "Return JID's conference bookmark name on JC, or its display name. A supplied scoped symbol retains its owner when JC is omitted." (require 'jabber-bookmarks) (let* ((owner (or jc (jabber-jid-owner jid))) (bare (jabber-jid-user (if (symbolp jid) (symbol-name jid) jid))) (bookmarks (and owner (gethash (jabber-connection-bare-jid owner) jabber-bookmarks))) (bookmark (and (listp bookmarks) (cl-find bare bookmarks :key (lambda (bm) (plist-get bm :jid)) :test #'equal)))) (or (plist-get bookmark :name) (jabber-jid-displayname jid owner)))) (defun jabber-jid-owner (jid) "Return the connection owning supplied JID symbol, or nil." (and (symbolp jid) (get jid 'jabber--jid-owner))) (defvar jabber-jid-obarray) (defun jabber-jid-symbol (jid &optional jc) "Return the contact symbol for JID, a symbol or string, on JC. Explicit JC always resolves JID in that connection's private namespace, even if JID is a foreign symbol. Without JC, retain supplied symbols or use the legacy accountless namespace. Never infer an account. The namespace survives FSM state replacement and stream resumption." (if (and (symbolp jid) (null jc)) jid (let* ((table (if jc (or (get jc 'jabber--jid-obarray) (put jc 'jabber--jid-obarray (make-vector 127 0))) jabber-jid-obarray)) (symbol (intern (downcase (jabber-jid-user (if (symbolp jid) (symbol-name jid) jid))) table))) (when jc (put symbol 'jabber--jid-owner jc)) symbol))) (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. Full-JID candidates include their exact JID even in name mode, so resources remain independently selectable. Unnamed contacts show as 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. Return an alist of (CANDIDATE . SYMBOL) pairs following `jabber-jid-completion-display'. Named full JIDs include both name and JID." (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) (if (jabber-jid-resource jid) (format "%s <%s>" name jid) 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 (or (assoc-string a table) (assoc-string a table t))))) (rank-b (jabber--presence-rank (cdr (or (assoc-string b table) (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 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 (or (assoc-string candidate table) (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 (downcase 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) (cl-loop for alt being the hash-keys of alt-to-candidate thereis (string-equal-ignore-case string alt)))) (t (complete-with-action action table string pred)))))) (defun jabber-read-jid-completing (prompt &optional subset require-match default resource fulljids jc) "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. Optional JC restricts lookup and completion to that owner, even if empty." (let* ((roster-items (cond ((and jc subset) (mapcar (lambda (jid) (let ((contact (jabber-jid-symbol jid jc)) (text (if (symbolp jid) (symbol-name jid) jid))) (if (jabber-jid-resource text) (let ((full (make-symbol text))) (setplist full (copy-sequence (symbol-plist contact))) full) contact))) subset)) (jc (let ((items (plist-get (fsm-get-state-data jc) :roster))) (if fulljids (jabber--roster-full-jids items) items))) (subset subset) (fulljids (jabber-concat-rosters-full)) (t (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 (and jid (get (jabber-jid-symbol jid jc) '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)) (when-let* ((entry (cl-find jid-at-point jid-completion-table :key (lambda (entry) (symbol-name (cdr entry))) :test #'equal))) (setq jid-at-point (car entry)))) ;; If the default is not in the allowed subset, it's not a good default. (when (and (or subset jc) (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))) ;; Resourceparts are case-sensitive. Prefer the exact selection even ;; when completion itself matches names and JIDs case-insensitively. (let ((entry (or (assoc-string input jid-completion-table) (assoc-string input jid-completion-table t)))) (setq chosen (if entry (symbol-name (cdr entry)) (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* ((matches (cl-remove-if-not (lambda (entry) (equal chosen (symbol-name (cdr entry)))) jid-completion-table)) (contact (if jc (jabber-jid-symbol chosen jc) (if (= (length matches) 1) (cdar matches) (jabber-jid-symbol chosen)))) (highest-resource (get contact '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 jc) 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 0)))) (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.15.1/lisp/jabber-vcard-avatars.el000066400000000000000000000140041527111033600213610ustar00rootroot00000000000000;;; 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 jc))) (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 jc)) ((string= sha1-hash (get (jabber-jid-symbol from jc) 'avatar-hash)) ;; Same avatar as before; do nothing ) ((jabber-avatar-find-cached sha1-hash) ;; Avatar is cached (jabber-avatar-set from sha1-hash jc)) (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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Fetch whose vCard avatar: " nil nil nil nil nil jc) 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. JC is the receiving connection. 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 jc) sha1-hash (jabber-avatar-sha1-sum avatar)))) (jabber-avatar-cache avatar) (jabber-avatar-set from avatar jc)) (jabber-avatar-set from nil jc)))) (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.15.1/lisp/jabber-vcard.el000066400000000000000000000507771527111033600177430ustar00rootroot00000000000000;;; 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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Request vcard from: " nil nil nil 'bare-or-muc nil jc)))) (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)) (defvar jabber-vcard-edit-mode-map) ;; Newer popup revisions generate these launchers at first initialization. (declare-function jabber-vcard-edit-mode-map-popup "jabber-vcard" () t) (unless (boundp 'jabber-vcard-edit-mode-map) (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.15.1/lisp/jabber-version.el000066400000000000000000000075351527111033600203230ustar00rootroot00000000000000;;; 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 (let ((jc (jabber-read-account))) (list jc (jabber-read-jid-completing "Request version of: " nil nil nil 'full t jc)))) (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.15.1/lisp/jabber-widget.el000066400000000000000000000124171527111033600201140ustar00rootroot00000000000000;;; 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 (widget-get widget :jabber-connection)))) (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* ((jc (widget-get widget :jabber-connection)) (roster (if jc (plist-get (fsm-get-state-data jc) :roster) jabber-roster-list)) (prefix (buffer-substring-no-properties (funcall (symbol-function 'widget-field-start) widget) (point))) (candidates (append (mapcar #'symbol-name roster) (cl-loop for item in roster 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.15.1/lisp/jabber-xdata-form.el000066400000000000000000000445101527111033600206720ustar00rootroot00000000000000;;; 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 for pending edits to the current form." (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.15.1/lisp/jabber-xdata.el000066400000000000000000000230101527111033600177210ustar00rootroot00000000000000;;; 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.15.1/lisp/jabber-xml.el000066400000000000000000000342431527111033600174320ustar00rootroot00000000000000;;; 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) (require 'seq) (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 (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-reply-fallback-range (xml-data) "Return the XEP-0428 reply fallback range in XML-DATA. Use the first exact in urn:xmpp:fallback:0 whose `for' is urn:xmpp:reply:0, and its first child. Return `all' when that child is absent or has neither offset. Partial or nonnumeric offsets yield nil; two non-negative decimal offsets yield (START END). Do not validate ordering or body bounds here: consumers must check those before using these code-point offsets to modify body text." (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)))) (let* ((body (car (jabber-xml-get-children fallback 'body))) (start (jabber-xml-get-attribute body 'start)) (end (jabber-xml-get-attribute body 'end))) (if (or start end) (and (stringp start) (stringp end) (string-match-p "\\`[0-9]+\\'" start) (string-match-p "\\`[0-9]+\\'" end) (list (string-to-number start) (string-to-number end))) 'all)))) (defun jabber-xml-reply-fields (xml-data) "Return XEP-0461 reply fields in XML-DATA as a plist, or nil. Require the exact name and urn:xmpp:reply:0 namespace. Use the first matching child, even when its ID is absent or empty; later duplicates do not replace it. Preserve absent attributes as nil and empty attributes as empty strings without validating JIDs. Return :reply-to-id, :reply-to-jid and :fallback-range, where the range is nil, `all', or (START END); see `jabber-xml-reply-fallback-range'. Do not modify XML-DATA, encode SQL values, or strip body text." (when-let* ((reply (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 'id) :reply-to-jid (jabber-xml-get-attribute reply 'to) :fallback-range (jabber-xml-reply-fallback-range xml-data)))) (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.15.1/lisp/jabber.el000066400000000000000000000200701527111033600166250ustar00rootroot00000000000000;;; 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.15.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.15.1/src/000077500000000000000000000000001527111033600146775ustar00rootroot00000000000000emacs-jabber-0.15.1/src/Makefile000066400000000000000000000067711527111033600163520ustar00rootroot00000000000000CC ?= cc 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 # OpenBSD's compiler driver omits libc when linking shared libraries. ifeq ($(UNAME),OpenBSD) LDLIBS += -lc endif MBED_MIN_VERSION = 3.0.0 MBED_CHECK = pkg-config --atleast-version=$(MBED_MIN_VERSION) mbedcrypto 2>/dev/null # MBED_STATIC=1 links libmbedcrypto.a into the module, leaving only # libc as a runtime dependency. Use it when the build environment's # library directory is not available to the Emacs that loads the # module, e.g. a Nix development shell whose store paths can be # garbage-collected, or an Emacs built against a different libc. ifneq ($(MBED_STATIC),) MBED_ARCHIVE = $(shell pkg-config --variable=libdir mbedcrypto 2>/dev/null)/libmbedcrypto.a ifneq ($(UNAME),Darwin) # Keep the archive's symbols private to the module. MBED_HIDE = -Wl,--exclude-libs,libmbedcrypto.a endif MBED_FLAGS ?= $(shell test -f $(MBED_ARCHIVE) && $(MBED_CHECK) \ && pkg-config --cflags mbedcrypto 2>/dev/null && echo $(MBED_ARCHIVE) $(MBED_HIDE)) endif 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$(if $(MBED_STATIC), (MBED_STATIC needs libmbedcrypto.a)). Install libmbedtls-dev or set MBED_FLAGS manually) endif $(CC) $(CFLAGS) $(LDFLAGS) -o $@ $(SRCS) $(MBED_FLAGS) $(LDLIBS) $(INSTALL_DIR)/$(TARGET): $(TARGET) cp $< $@ # Standalone fault injection; never linked into the Emacs module. TEST_TARGET = omemo-c-test # Rename only the backend call, not the real implementation in libmbedcrypto. # This uses the C preprocessor instead of GNU ld's nonportable --wrap option. CBC_TEST_OBJECT = omemo-c-test-mbedtls.o $(CBC_TEST_OBJECT): picomemo/mbedtls.c picomemo/omemo.h picomemo/driver.h $(CC) $(CFLAGS) -UNDEBUG $(TEST_CFLAGS) $(MBED_FLAGS) \ -Dmbedtls_aes_crypt_cbc=__wrap_mbedtls_aes_crypt_cbc -c -o $@ $< $(TEST_TARGET): ../tests/omemo-c-test.c $(filter-out jabber-omemo-core.c picomemo/mbedtls.c,$(SRCS)) $(CBC_TEST_OBJECT) picomemo/omemo.h picomemo/driver.h $(CC) $(CFLAGS) -UNDEBUG $(TEST_CFLAGS) \ -D__real_mbedtls_aes_crypt_cbc=mbedtls_aes_crypt_cbc -o $@ $< \ $(filter-out jabber-omemo-core.c picomemo/mbedtls.c,$(SRCS)) \ $(CBC_TEST_OBJECT) $(MBED_FLAGS) $(LDLIBS) RANDOM_TESTS = omemo-random-test omemo-random-openbsd-test # Linux headers can simulate Android's syscall macro, not its native ABI. ifeq ($(UNAME),Linux) RANDOM_TESTS += omemo-random-android-test endif $(RANDOM_TESTS): ../tests/omemo-random-test.c $(SRCS) picomemo/omemo.h picomemo/driver.h $(CC) $(CFLAGS) -UNDEBUG $(TEST_CFLAGS) \ $(if $(filter omemo-random-openbsd-test,$@),-DTEST_OPENBSD) \ $(if $(filter omemo-random-android-test,$@),-DTEST_ANDROID) \ -o $@ $< $(filter-out jabber-omemo-core.c,$(SRCS)) $(MBED_FLAGS) check-random: $(RANDOM_TESTS) @set -e; for test in $(RANDOM_TESTS); do ./$$test; done check: $(TEST_TARGET) check-random ./$(TEST_TARGET) encrypt ./$(TEST_TARGET) store .PHONY: check check-random clean: rm -f $(TARGET) $(INSTALL_DIR)/$(TARGET) $(TEST_TARGET) $(CBC_TEST_OBJECT) $(RANDOM_TESTS) .PHONY: all clean emacs-jabber-0.15.1/src/jabber-omemo-core.c000066400000000000000000001524021527111033600203340ustar00rootroot00000000000000/* * 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 #if defined(__ANDROID__) #include #include #define getrandom(buf,buflen,flags) syscall(SYS_getrandom,buf,buflen,flags) #elif !defined(__OpenBSD__) #include #endif #include #include "picomemo/omemo.h" int plugin_is_GPL_compatible; /* picomemo callbacks */ int omemoRandom(void *p, size_t n) { #if defined(__OpenBSD__) /* arc4random_buf fills any size and has no error return. */ arc4random_buf(p, n); return 0; #else return getrandom(p, n, 0) != (ssize_t)n; #endif } /* 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); } /* Neomacs currently rejects non-ASCII unibyte strings in its module copy_string_contents implementation. Read their byte-valued characters through the Lisp/vector API instead; never transcode cryptographic data. GNU Emacs and multibyte strings retain the native API's UTF-8 semantics. */ static bool unibyte_copy_workaround; static bool copy_string_contents(emacs_env *env, emacs_value arg, char *buf, ptrdiff_t *len) { if (env->non_local_exit_check(env)) return false; if (!unibyte_copy_workaround) return env->copy_string_contents(env, arg, buf, len); emacs_value stringp = env->funcall(env, env->intern(env, "stringp"), 1, &arg); if (env->non_local_exit_check(env)) return false; if (!env->is_not_nil(env, stringp)) return env->copy_string_contents(env, arg, buf, len); emacs_value multibyte = env->funcall(env, env->intern(env, "multibyte-string-p"), 1, &arg); if (env->non_local_exit_check(env)) return false; if (env->is_not_nil(env, multibyte)) return env->copy_string_contents(env, arg, buf, len); emacs_value size = env->funcall(env, env->intern(env, "length"), 1, &arg); if (env->non_local_exit_check(env)) return false; intmax_t n = env->extract_integer(env, size); if (env->non_local_exit_check(env)) return false; if (n < 0 || n >= PTRDIFF_MAX) { signal_error(env, OMEMO_EPARAM, "string is too large to copy"); return false; } ptrdiff_t required = (ptrdiff_t)n + 1; if (!buf) { *len = required; return true; } if (*len < required) { emacs_value sizes[] = { env->make_integer(env, *len), env->make_integer(env, required) }; *len = required; emacs_value data = env->funcall(env, env->intern(env, "list"), 2, sizes); if (!env->non_local_exit_check(env)) env->non_local_exit_signal(env, env->intern(env, "memory-buffer-too-small"), data); return false; } emacs_value bytes = env->funcall(env, env->intern(env, "vconcat"), 1, &arg); if (env->non_local_exit_check(env)) return false; for (ptrdiff_t i = 0; i < (ptrdiff_t)n; i++) { emacs_value value = env->vec_get(env, bytes, i); if (env->non_local_exit_check(env)) return false; intmax_t byte = env->extract_integer(env, value); if (env->non_local_exit_check(env)) return false; if (byte < 0 || byte > UINT8_MAX) { signal_error(env, OMEMO_EPARAM, "invalid unibyte character"); return false; } buf[i] = (char)(uint8_t)byte; } buf[n] = '\0'; *len = required; return true; } 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 (!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; 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) { skipped_clear(ptr, sizeof(struct omemoStore)); 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) { skipped_clear(&store, sizeof store); signal_error(env, -1, "malloc failed"); return Qnil_v; } omemoSerializeStore(buf, &store); emacs_value result = make_unibyte(env, buf, sz); skipped_clear(buf, sz); skipped_clear(&store, sizeof store); 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; 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; } copy_string_contents(env, args[0], (char *)blob, &bloblen); if (env->non_local_exit_check(env)) { skipped_clear(blob, (size_t)bloblen); 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) { skipped_clear(blob, datalen); free(blob); signal_error(env, -1, "calloc failed"); return Qnil_v; } int rc = omemoDeserializeStore(blob, datalen, store); skipped_clear(blob, datalen); free(blob); if (rc) { skipped_clear(store, sizeof *store); 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); skipped_clear(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"); /* 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; 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; } 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; 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; } 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--session-remote-identity */ static emacs_value F_session_remote_identity(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { (void)nargs; (void)data; const struct native_session *native = extract_session(env, args[0]); if (env->non_local_exit_check(env)) return Qnil_v; /* picomemo uses zero for SESSION_UNINIT. Failed decryption restores the whole session, including its identity and initialization state. */ if (!native->session.init) return Qnil_v; omemoSerializedKey identity; omemoSerializeKey(identity, native->session.remoteidentity); return make_unibyte(env, identity, sizeof identity); } /* 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; 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; } 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; 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 (!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; 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; } 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; 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; } 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; 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; } 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 (omemoRandom(key, sizeof(key))) { free(ptbuf); signal_error(env, -1, "getrandom failed for key"); return Qnil_v; } if (omemoRandom(iv, 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); /* Require only the newest interface used here (make_unibyte_string, Emacs 28), not the possibly newer emacs-module.h this file was compiled against, so one build loads into any Emacs >= 28. */ if (env->size < sizeof(struct emacs_env_28)) 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 /* Detect the binary-copy limitation, not the editor's name. Neomacs does not provide its `neomacs' feature in batch mode. Clear only the known unicode-string-p rejection of a valid unibyte probe. */ emacs_value wrong_type = env->intern(env, "wrong-type-argument"); emacs_value unicode_string = env->intern(env, "unicode-string-p"); emacs_value car = env->intern(env, "car"); emacs_value probe = env->make_unibyte_string(env, "\200", 1); if (env->non_local_exit_check(env)) return 3; ptrdiff_t probe_size = 0; if (!env->copy_string_contents(env, probe, NULL, &probe_size)) { emacs_value symbol, data; if (env->non_local_exit_get(env, &symbol, &data) != emacs_funcall_exit_signal) return 3; env->non_local_exit_clear(env); emacs_value predicate = env->funcall(env, car, 1, &data); if (env->non_local_exit_check(env)) return 3; if (!env->eq(env, symbol, wrong_type) || !env->eq(env, predicate, unicode_string)) { env->non_local_exit_signal(env, symbol, data); return 3; } unibyte_copy_workaround = true; } /* 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--session-remote-identity", F_session_remote_identity, 1, 1, "Return SESSION-PTR's remote public identity key without mutation.\n" "Return nil for an uninitialized session. Otherwise return a fresh\n" "33-byte unibyte string (0x05 followed by the 32 public key bytes),\n" "in the same format as the bundle's :identity-key.\n" "The identity comes from verified bundle initiation or successful\n" "pre-key decryption, or is restored from serialized session state.\n" "This does not establish user trust; callers must check pinned keys.\n" "Signal jabber-omemo-error for another native pointer kind, or\n" "wrong-type-argument for a non-pointer."); 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.15.1/src/picomemo/000077500000000000000000000000001527111033600165075ustar00rootroot00000000000000emacs-jabber-0.15.1/src/picomemo/LICENSE000066400000000000000000000013411527111033600175130ustar00rootroot00000000000000ISC 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.15.1/src/picomemo/README000066400000000000000000000005471527111033600173750ustar00rootroot00000000000000picomemo 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.15.1/src/picomemo/driver.h000066400000000000000000000043031527111033600201530ustar00rootroot00000000000000/** * 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.15.1/src/picomemo/hacl.c000066400000000000000000010405611527111033600175710ustar00rootroot00000000000000#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.15.1/src/picomemo/mbedtls.c000066400000000000000000000062051527111033600203100ustar00rootroot00000000000000/** * 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) { int r; mbedtls_aes_context aes; mbedtls_aes_init(&aes); if (!(r = mbedtls_aes_setkey_enc(&aes, k, 256))) r = mbedtls_aes_crypt_cbc(&aes, MBEDTLS_AES_ENCRYPT, n, iv, s, d); mbedtls_aes_free(&aes); TRY(r); return 0; } int omemoDriverAesDecrypt(omemoKey k, size_t n, uint8_t iv[static 16], const uint8_t *s, uint8_t *d) { int r; mbedtls_aes_context aes; mbedtls_aes_init(&aes); if (!(r = mbedtls_aes_setkey_dec(&aes, k, 256))) r = mbedtls_aes_crypt_cbc(&aes, MBEDTLS_AES_DECRYPT, n, iv, s, d); mbedtls_aes_free(&aes); TRY(r); 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.15.1/src/picomemo/omemo.c000066400000000000000000001247301527111033600177760ustar00rootroot00000000000000/** * 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_REPEATED (1 << 4) #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; uint32_t fixed[16]; ASSERT(nfields <= 16); // Preserve schema constraints separately from parsed repeated values. for (int i = 0; i < nfields; i++) fixed[i] = fields[i].v; 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; // Repeated entries may vary in length; other duplicate checks stay intact. uint32_t expected = (fields[id].type & PB_REPEATED) ? fixed[id] : fields[id].v; if (expected && v != expected) 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)); int encrypted = Encrypt(msg->p + msg->n, key, keyn, kdfout->cipher, kdfout->iv); if (encrypted < 0) return encrypted; msg->n += encrypted; #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_REPEATED | 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.15.1/src/picomemo/omemo.h000066400000000000000000000241471527111033600200040ustar00rootroot00000000000000/** * 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.15.1/tests/000077500000000000000000000000001527111033600152525ustar00rootroot00000000000000emacs-jabber-0.15.1/tests/fixtures/000077500000000000000000000000001527111033600171235ustar00rootroot00000000000000emacs-jabber-0.15.1/tests/fixtures/archive-schema-v11.eld000066400000000000000000000120551527111033600231000ustar00rootroot00000000000000;; Literal v11 DDL from 0b93b7612a1742cddf992ed63f1989be5bb3eb74. ("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, retracted INTEGER NOT NULL DEFAULT 0)" "CREATE INDEX IF NOT EXISTS idx_msg_peer_ts ON message(account, peer, timestamp)" "CREATE INDEX IF NOT EXISTS idx_msg_stanza_id ON message(account, stanza_id) WHERE stanza_id IS NOT NULL" "CREATE INDEX IF NOT EXISTS idx_msg_server_id ON message(account, server_id) WHERE server_id IS NOT NULL" "CREATE INDEX IF NOT EXISTS idx_msg_occupant_id ON message(account, peer, occupant_id) WHERE occupant_id IS NOT NULL" "CREATE 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))") emacs-jabber-0.15.1/tests/jabber-archive-test-helpers.el000066400000000000000000000102111527111033600230500ustar00rootroot00000000000000;;; jabber-archive-test-helpers.el --- Archive fixtures -*- lexical-binding: t; -*- ;;; Commentary: ;; Shared fixtures contain no ERT definitions, so ordinary suites compose. ;;; 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-moderation) (require 'jabber-omemo-store) (require 'jabber-message-reply) (require 'jabber-reactions) (defun jabber-test-archive--contain-errors (dispatch &rest args) "Call DISPATCH with ARGS without entering the debugger on contained errors." (let ((debug-on-error nil)) (apply dispatch args))) ;; Stanza dispatch contains handler errors with a `debug' condition. ;; ERT before Emacs 30 runs tests with `debug-on-error' and fails on any ;; debugger entry, so injected faults that dispatch contains would fail. (when (< emacs-major-version 30) (advice-add 'jabber-process-input :around #'jabber-test-archive--contain-errors)) (defun jabber-test-mam--native-connection (&optional username) "Return a disposable established native FSM for USERNAME, defaulting to me." (let ((jc (make-symbol "mam-native"))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data (jabber-sm--reset (list :username (or username "me") :server "example.com" :connection (list 'transport) :session-id "stream" :send-function #'ignore))) jc)) (defmacro jabber-test-archive--with-file (&rest body) "Run BODY with a disposable native file database and MAM state." (declare (indent 0) (debug t)) `(let* ((directory (make-temp-file "jabber-archive-" t)) (jabber-db-path (expand-file-name "history.sqlite" directory)) (jabber-db--connection nil) (jabber-mam--syncing nil) (jabber-mam--dirty-peers nil) (jabber-mam--redraw-peers nil) (jabber-mam--redraw-timer nil) (jabber-open-info-queries nil) (jabber-db-message-thread-stored-functions nil) (jabber-history-inhibit-received-message-functions nil) (jabber-mam-sync-complete-functions nil) (jc (jabber-test-mam--native-connection))) (unwind-protect (cl-letf (((symbol-function 'jabber-send-sexp) #'ignore)) (jabber-db-ensure-open) ,@body) (jabber-mam--cleanup-all) (when jabber-mam--redraw-timer (cancel-timer jabber-mam--redraw-timer)) (jabber-db-close) (delete-directory directory t)))) (defun jabber-test-archive--result (query uid inner) "Wrap INNER in QUERY's result with UID." `(message ((from . ,(or (plist-get query :to) "me@example.com"))) (result ((xmlns . "urn:xmpp:mam:2") (queryid . ,(plist-get query :id)) (id . ,uid)) (forwarded ((xmlns . "urn:xmpp:forward:0")) (delay ((xmlns . "urn:xmpp:delay") (stamp . "2025-01-01T00:00:00Z"))) ,inner)))) (defun jabber-test-archive--fin (jc query uid) "Complete QUERY on JC with UID." (jabber-mam--handle-fin jc `(iq ((from . ,(or (plist-get query :to) "me@example.com"))) (fin ((xmlns . "urn:xmpp:mam:2") (complete . "true")) (set ((xmlns . "http://jabber.org/protocol/rsm")) ,@(when uid `((last () ,uid)))))) (cons query (plist-get query :page)))) (defun jabber-test-archive--idle-p () "Return non-nil when no SQLite transaction is open on the database. MAM must never hold a transaction while it waits for the network." (condition-case nil (progn (sqlite-execute jabber-db--connection "BEGIN") (sqlite-execute jabber-db--connection "ROLLBACK") t) (sqlite-error nil))) (defun jabber-test-archive--progress (&optional account archive with) "Read native progress for ACCOUNT, ARCHIVE and WITH." (jabber-db-mam-progress (or account "me@example.com") (or archive "me@example.com") with)) (provide 'jabber-archive-test-helpers) ;;; jabber-archive-test-helpers.el ends here emacs-jabber-0.15.1/tests/jabber-disco-test-helpers.el000066400000000000000000000050171527111033600225400ustar00rootroot00000000000000;;; jabber-disco-test-helpers.el --- Discovery fixtures -*- lexical-binding: t; -*- ;;; Commentary: ;; Share native connection and wire fixtures without importing another suite. ;;; Code: (require 'ert) (require 'jabber-disco) (require 'jabber-moderation) (defun jabber-test-disco-owner--connection (name) "Return a disposable connected FSM named NAME." (let ((jc (make-symbol name))) (put jc :state 'session-established) (put jc :state-data (list :connection (make-symbol "transport") :session-id "stream" :username name :server "example.org")) jc)) (defmacro jabber-test-disco-owner--with-state (&rest body) "Run BODY with isolated native discovery state and captured wire writes." (declare (indent 0) (debug t)) `(let* ((a (jabber-test-disco-owner--connection "a")) (b (jabber-test-disco-owner--connection "b")) (c (jabber-test-disco-owner--connection "c")) (jabber-connections (list a b c)) (jabber-db-path nil) (jabber-jid-obarray (make-vector 127 0)) (jabber-caps-cache (make-hash-table :test #'equal)) (jabber-caps--pending (make-hash-table :test #'equal)) (jabber-disco-info-cache (make-hash-table :test #'equal)) (jabber-disco-items-cache (make-hash-table :test #'equal)) (jabber-open-info-queries nil) (wire nil)) (unwind-protect (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (jc xml &rest _ignored) (push (cons jc xml) wire)))) ,@body) (maphash (lambda (key pending) (jabber-caps--settle key pending)) jabber-caps--pending)))) (defun jabber-test-disco-owner--reply (sent children &optional error-p) "Deliver a reply to SENT with query CHILDREN, or an error if ERROR-P." (let* ((jc (car sent)) (iq (cdr sent)) (query (jabber-iq-query iq))) (jabber-process-iq jc `(iq ((from . ,(jabber-xml-get-attribute iq 'to)) (id . ,(jabber-xml-get-attribute iq 'id)) (type . ,(if error-p "error" "result"))) ,(if error-p '(error ((type . "cancel")) (item-not-found ())) `(query ,(cadr query) ,@children)))))) (defun jabber-test-disco-owner--expire (pending) "Run PENDING's real timeout function without waiting ten seconds." (let ((timer (plist-get pending :timer))) (apply (timer--function timer) (timer--args timer)))) (provide 'jabber-disco-test-helpers) ;;; jabber-disco-test-helpers.el ends here emacs-jabber-0.15.1/tests/jabber-test-action-storage.el000066400000000000000000000553051527111033600227230ustar00rootroot00000000000000;;; jabber-test-action-storage.el --- Reaction and reference storage -*- lexical-binding: t; -*- ;;; Commentary: ;; Atomic reaction snapshots and indexed reply/reaction target candidates, ;; exercised through native dispatch, real SQLite faults and reopened files. ;;; Code: (require 'jabber-archive-test-helpers) ;;;; Reaction snapshots (defconst jabber-test-action-storage--sender "friend@example.com" "Reaction actor used by direct-chat fixtures.") (defun jabber-test-action-storage--state () "Return reaction actor and snapshot rows from an independent SQLite reader." (let ((reader (sqlite-open jabber-db-path))) (unwind-protect (list (sqlite-select reader "SELECT message_id, sender, updated_at FROM message_reaction_actor ORDER BY message_id, sender") (sqlite-select reader "SELECT message_id, sender, reaction, updated_at FROM message_reaction ORDER BY message_id, sender, reaction")) (sqlite-close reader)))) (defun jabber-test-action-storage--seed (jc) "Store a direct target on JC with an older two-reaction snapshot. Return the independently read state." (jabber-db--message-handler jc '(message ((from . "friend@example.com/phone") (type . "chat") (id . "target")) (body () "target"))) (should (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "target" jabber-test-action-storage--sender '("old" "older") 100)) (jabber-test-action-storage--state)) (defun jabber-test-action-storage--replace (reactions) "Replace the fixture actor's target REACTIONS at source time 200." (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "target" jabber-test-action-storage--sender reactions 200)) (defun jabber-test-action-storage--assert-retry (before reactions) "Assert BEFORE survives reopen and a same-source retry applies REACTIONS." (jabber-db-close) (jabber-db-ensure-open) (should (equal before (jabber-test-action-storage--state))) (should (jabber-test-action-storage--replace reactions)) (should (equal (list (list (list 1 jabber-test-action-storage--sender 200)) (mapcar (lambda (reaction) (list 1 jabber-test-action-storage--sender reaction 200)) (sort (copy-sequence reactions) #'string<))) (jabber-test-action-storage--state)))) (ert-deftest jabber-test-action-storage-reaction-sqlite-faults-roll-back () "A SQLite abort at any snapshot write preserves the prior watermark and rows." (dolist (case '((actor "BEFORE UPDATE ON message_reaction_actor" ("new1" "new2")) (delete "BEFORE DELETE ON message_reaction" ("new1" "new2")) (empty "BEFORE DELETE ON message_reaction" nil) (first "BEFORE INSERT ON message_reaction WHEN NEW.reaction = 'new1'" ("new1" "new2")) (second "BEFORE INSERT ON message_reaction WHEN NEW.reaction = 'new2'" ("new1" "new2")))) (pcase-let ((`(,name ,trigger ,reactions) case)) (ert-info ((symbol-name name) :prefix "Boundary: ") (jabber-test-archive--with-file (let ((before (jabber-test-action-storage--seed jc))) (sqlite-execute jabber-db--connection (format "CREATE TRIGGER snapshot_fault %s BEGIN SELECT RAISE(ABORT, 'injected snapshot fault'); END" trigger)) (should-error (jabber-test-action-storage--replace reactions) :type 'sqlite-error) (should (equal before (jabber-test-action-storage--state))) (sqlite-execute jabber-db--connection "DROP TRIGGER snapshot_fault") (jabber-test-action-storage--assert-retry before reactions))))))) (ert-deftest jabber-test-action-storage-reaction-error-and-quit-roll-back () "Error and quit after each completed snapshot write leave no partial state." (dolist (failure '(error quit)) (dotimes (boundary 3) (ert-info ((format "%s after write %d" failure boundary) :prefix "Fault: ") (jabber-test-archive--with-file (let ((before (jabber-test-action-storage--seed jc)) (execute (symbol-function 'sqlite-execute)) (writes 0)) (should (eq failure (condition-case err (cl-letf (((symbol-function 'sqlite-execute) (lambda (db sql &rest args) (prog1 (apply execute db sql args) (when (and (string-match-p "\\`\\(?:INSERT INTO\\|DELETE FROM\\) message_reaction" sql) (= boundary (prog1 writes (cl-incf writes)))) (signal failure '("Injected snapshot fault"))))))) (jabber-test-action-storage--replace '("new1" "new2")) nil) ((error quit) (car err))))) (should (equal before (jabber-test-action-storage--state))) (jabber-test-action-storage--assert-retry before '("new1" "new2")))))))) (defconst jabber-test-action-storage--mam-chain (list #'jabber-mam--process-message #'jabber-reactions--handle-message) "Native message chain for archived reaction results.") (defun jabber-test-action-storage--reaction-stanza () "Return a delayed two-reaction update for the direct fixture target." '(message ((from . "friend@example.com/phone") (type . "chat")) (delay ((xmlns . "urn:xmpp:delay") (stamp . "2025-01-02T00:00:00Z"))) (reactions ((xmlns . "urn:xmpp:reactions:0") (id . "target")) (reaction () "good") (reaction () "bad")))) (defun jabber-test-action-storage--dispatch (jc query uid) "Dispatch the reaction update natively on JC, through QUERY page UID if any." (let ((jabber-message-chain (if query jabber-test-action-storage--mam-chain (list #'jabber-reactions--handle-message))) (inner (jabber-test-action-storage--reaction-stanza))) (jabber-process-input jc (if query (jabber-test-archive--result query uid inner) inner)) (when query (jabber-test-archive--fin jc query uid)))) (ert-deftest jabber-test-action-storage-reaction-native-live-and-mam-retry () "Native live and MAM faults keep prior state; the same source then applies." (dolist (mode '(live mam)) (ert-info ((symbol-name mode) :prefix "Input: ") (jabber-test-archive--with-file (let ((before (jabber-test-action-storage--seed jc)) (applied '(((1 "friend@example.com" 1735776000)) ((1 "friend@example.com" "bad" 1735776000) (1 "friend@example.com" "good" 1735776000))))) (sqlite-execute jabber-db--connection "CREATE TRIGGER snapshot_fault BEFORE INSERT ON message_reaction WHEN NEW.reaction = 'bad' BEGIN SELECT RAISE(ABORT, 'injected snapshot fault'); END") ;; Native dispatch contains the error; MAM records page failure. (jabber-test-action-storage--dispatch jc (and (eq mode 'mam) (jabber-mam--query jc)) "failed-uid") (should (equal before (jabber-test-action-storage--state))) (should-not (jabber-test-archive--progress)) (sqlite-execute jabber-db--connection "DROP TRIGGER snapshot_fault") (jabber-db-close) (jabber-db-ensure-open) (should (equal before (jabber-test-action-storage--state))) (jabber-test-action-storage--dispatch jc (and (eq mode 'mam) (jabber-mam--query jc)) "retry-uid") (should (equal applied (jabber-test-action-storage--state))) (should (equal (and (eq mode 'mam) '("retry-uid" nil)) (jabber-test-archive--progress)))))))) (ert-deftest jabber-test-action-storage-reaction-fault-keeps-concurrent-mam-page () "A failed snapshot inside a shared MAM transaction keeps other accepted pages." (jabber-test-archive--with-file (let* ((before (jabber-test-action-storage--seed jc)) (failing (jabber-mam--query jc nil nil "friend@example.com")) (accepted (jabber-mam--query jc nil nil "other@example.com"))) (sqlite-execute jabber-db--connection "CREATE TRIGGER snapshot_fault BEFORE INSERT ON message_reaction WHEN NEW.reaction = 'bad' BEGIN SELECT RAISE(ABORT, 'injected snapshot fault'); END") (let ((jabber-message-chain jabber-test-action-storage--mam-chain)) (jabber-process-input jc (jabber-test-archive--result accepted "accepted-uid" '(message ((from . "other@example.com/desk") (type . "chat") (id . "kept")) (body () "kept")))) (jabber-process-input jc (jabber-test-archive--result failing "failed-uid" (jabber-test-action-storage--reaction-stanza)))) (jabber-test-archive--fin jc failing "failed-uid") (jabber-test-archive--fin jc accepted "accepted-uid") (sqlite-execute jabber-db--connection "DROP TRIGGER snapshot_fault") (jabber-db-close) (jabber-db-ensure-open) (should (equal before (jabber-test-action-storage--state))) (should-not (jabber-test-archive--progress nil nil "friend@example.com")) (should (equal '("accepted-uid" nil) (jabber-test-archive--progress nil nil "other@example.com"))) (should (equal '(("kept")) (sqlite-select jabber-db--connection "SELECT body FROM message WHERE peer = 'other@example.com'")))))) (ert-deftest jabber-test-action-storage-reaction-physical-rollback-control () "A transaction-wide SQLite rollback in a result fails its page closed. Earlier results committed in their own transactions and stay durable." (jabber-test-archive--with-file (let ((before (jabber-test-action-storage--seed jc))) ;; Install outside the page transaction, which the fault discards. (sqlite-execute jabber-db--connection "CREATE TRIGGER snapshot_fault BEFORE INSERT ON message_reaction WHEN NEW.reaction = 'bad' BEGIN SELECT RAISE(ROLLBACK, 'injected transaction loss'); END") (let* ((outcome nil) (query (jabber-mam--query jc nil nil nil nil nil nil nil nil (lambda (value) (setq outcome value)))) (jabber-message-chain jabber-test-action-storage--mam-chain)) (jabber-process-input jc (jabber-test-archive--result query "body-uid" '(message ((from . "friend@example.com/phone") (type . "chat") (id . "kept")) (body () "kept")))) (jabber-process-input jc (jabber-test-archive--result query "reaction-uid" (jabber-test-action-storage--reaction-stanza))) (should (jabber-test-archive--idle-p)) (jabber-test-archive--fin jc query "reaction-uid") (should (eq outcome 'failed))) (sqlite-execute jabber-db--connection "DROP TRIGGER snapshot_fault") (jabber-db-close) (jabber-db-ensure-open) (should (equal before (jabber-test-action-storage--state))) (should-not (jabber-test-archive--progress)) (should (sqlite-select jabber-db--connection "SELECT id FROM message WHERE body = 'kept'"))))) ;;;; Reference candidates (defconst jabber-test-action-storage--rows ;; (ACCOUNT PEER TYPE ROOM SERVER ORIGIN STANZA RETRACTED RESOURCE) '(("me@example.com" "room@example.com" "groupchat" "uid-1" "uid-1" nil nil 0 "nick") ("me@example.com" "room@example.com" "groupchat" nil "legacy" nil nil 0 "nick") ("me@example.com" "room@example.com" "groupchat" "shadow" "uid-2" nil nil 0 "nick") ("me@example.com" "room@example.com" "groupchat" "uid-2" nil nil nil 0 "nick") ("me@example.com" "room@example.com" "groupchat" "dup" "dup" nil nil 0 "nick") ("me@example.com" "room@example.com" "groupchat" "dup" nil nil nil 1 "other") ("me@example.com" "room@example.com" "groupchat" nil "dup" nil nil 0 "third") ("other@example.com" "room@example.com" "groupchat" "uid-1" "uid-1" nil nil 0 "nick") ("me@example.com" "elsewhere@example.com" "groupchat" "uid-1" "uid-1" nil nil 0 "nick") ("me@example.com" "room@example.com" "chat" "uid-1" "uid-1" "uid-1" "uid-1" 0 "nick") ("me@example.com" "friend@example.com" "chat" nil nil "o-1" "s-1" 0 "phone") ("me@example.com" "friend@example.com" "chat" nil nil "same" "same" 0 "phone") ("me@example.com" "friend@example.com" "chat" nil nil "x-1" "s-2" 0 "phone") ("me@example.com" "friend@example.com" "chat" nil nil nil "x-1" 1 "phone") ("me@example.com" "friend@example.com" "chat" "o-3" "o-3" nil nil 0 "phone") ("me@example.com" "friend@example.com" "groupchat" nil nil "o-1" "o-1" 0 "phone")) "Reference identity rows covering shadowing, fallback, aliases and scope.") (defun jabber-test-action-storage--insert-rows (db) "Insert reference fixture rows into DB." (dolist (row jabber-test-action-storage--rows) (pcase-let ((`(,account ,peer ,type ,room ,server ,origin ,stanza ,retracted ,resource) row)) (sqlite-execute db "INSERT INTO message (account, peer, direction, type, body, timestamp, resource, room_id, server_id, origin_id, stanza_id, retracted) VALUES (?, ?, 'in', ?, 'body', 1, ?, ?, ?, ?, ?, ?)" (list account peer type resource room server origin stanza retracted))))) (defun jabber-test-action-storage--oracle (db account peer type target) "Return the previous unindexed candidate rows for TARGET in DB, sorted." (sqlite-select db (format "SELECT id, body, retracted, direction, resource FROM message WHERE account = ? AND peer = ? AND type = ? AND %s ORDER BY id" (if (equal type "groupchat") "COALESCE(room_id, server_id) = ?" "(origin_id = ? OR stanza_id = ?)")) (append (list account peer type target) (unless (equal type "groupchat") (list target))))) (ert-deftest jabber-test-action-storage-reference-candidates-equivalent () "Indexed candidates equal the room-precedence and alias contracts exactly." (jabber-test-archive--with-file (ignore jc) (let ((db jabber-db--connection) (targets '("uid-1" "uid-2" "shadow" "legacy" "dup" "o-1" "s-1" "same" "x-1" "s-2" "o-3" "absent"))) (jabber-test-action-storage--insert-rows db) (dolist (scope '(("me@example.com" "room@example.com" "groupchat") ("me@example.com" "room@example.com" "chat") ("me@example.com" "friend@example.com" "chat") ("me@example.com" "friend@example.com" "groupchat") ("other@example.com" "room@example.com" "groupchat") ("me@example.com" "elsewhere@example.com" "groupchat"))) (dolist (target targets) (ert-info ((format "%S %s" scope target) :prefix "Lookup: ") (should (equal (apply #'jabber-test-action-storage--oracle db (append scope (list target))) (sort (apply #'jabber-db--message-reference-candidates db (append scope (list target))) (lambda (a b) (< (car a) (car b)))))))))) ;; Spot-check the contracts the oracle encodes. (let ((ids (lambda (target) (mapcar #'car (jabber-db--message-reference-candidates jabber-db--connection "me@example.com" "room@example.com" "groupchat" target))))) (should (equal '(4) (funcall ids "uid-2"))) (should (equal '(2) (funcall ids "legacy"))) (should (equal '(5 6 7) (sort (funcall ids "dup") #'<)))))) (defun jabber-test-action-storage--plan (db type target) "Return native plan details of the production candidate SQL for TYPE TARGET." (let ((select (symbol-function 'sqlite-select)) captured) (cl-letf (((symbol-function 'sqlite-select) (lambda (connection sql &optional values &rest rest) (unless captured (setq captured (list sql values))) (apply select connection sql values rest)))) (jabber-db--message-reference-candidates db "me@example.com" (if (equal type "groupchat") "room@example.com" "friend@example.com") type target)) (mapcar (lambda (row) (nth 3 row)) (funcall select db (concat "EXPLAIN QUERY PLAN " (car captured)) (cadr captured))))) (ert-deftest jabber-test-action-storage-reference-candidates-seek-identity-indexes () "Room and direct candidates seek identity indexes, never peer history." (jabber-test-archive--with-file (ignore jc) (let ((db jabber-db--connection)) (dotimes (i 500) (sqlite-execute db "INSERT INTO message (account, peer, direction, type, body, timestamp, room_id, server_id, origin_id, stanza_id) VALUES ('me@example.com', ?, 'in', ?, 'history', ?, ?, ?, ?, ?)" (if (cl-evenp i) (list "room@example.com" "groupchat" i (format "r-%d" i) (format "r-%d" i) nil nil) (list "friend@example.com" "chat" i nil nil (format "o-%d" i) (format "s-%d" i))))) (dolist (analyzed '(nil t)) (when analyzed (sqlite-execute db "ANALYZE")) (pcase-dolist (`(,type ,target ,indexes) '(("groupchat" "r-2" ("idx_msg_room_id" "idx_msg_server_id")) ("chat" "o-1" ("idx_msg_origin_id" "idx_msg_stanza_id")))) (ert-info ((format "%s analyzed=%s" type analyzed) :prefix "Plan: ") (let* ((plan (jabber-test-action-storage--plan db type target)) (searches (seq-filter (lambda (detail) (string-match-p "\\`\\(?:SEARCH\\|SCAN\\)" detail)) plan))) (should (= 2 (length searches))) (dolist (detail searches) (should (string-prefix-p "SEARCH message USING INDEX" detail))) (dolist (index indexes) (should (seq-some (lambda (detail) (string-search (concat index " ") detail)) searches)))))))))) (ert-deftest jabber-test-action-storage-reference-consumers-native () "Native room/direct history serves reply previews and reactions with scope checks." (jabber-test-archive--with-file (let ((query (jabber-mam--query jc nil nil nil nil "room@example.com")) (other (jabber-test-mam--native-connection "other"))) ;; Room archive row with an explicit room stanza ID. (let ((jabber-message-chain jabber-test-action-storage--mam-chain)) (jabber-process-input jc (jabber-test-archive--result query "room-uid" '(message ((from . "room@example.com/alice") (type . "groupchat")) (body () "room target") (stanza-id ((xmlns . "urn:xmpp:sid:0") (by . "room@example.com") (id . "room-uid"))))))) (jabber-test-archive--fin jc query "room-uid") ;; Historical null-room row and a row whose room ID shadows its server ID. (sqlite-execute jabber-db--connection "INSERT INTO message (account, peer, direction, type, body, timestamp, resource, room_id, server_id) VALUES ('me@example.com', 'room@example.com', 'in', 'groupchat', 'legacy target', 1, 'bob', NULL, 'legacy-uid'), ('me@example.com', 'room@example.com', 'in', 'groupchat', 'shadowing', 2, 'bob', 'own-room', 'shadowed-uid')") ;; Direct row with origin and transport aliases. (let ((jabber-message-chain (list #'jabber-db--message-handler))) (jabber-process-input jc '(message ((from . "friend@example.com/phone") (type . "chat") (id . "transport")) (body () "direct target") (origin-id ((xmlns . "urn:xmpp:sid:0") (id . "origin")))))) (jabber-db-close) (let ((snippet (lambda (peer muc-p id from) (with-temp-buffer (setq-local jabber-buffer-connection jc) (if muc-p (setq-local jabber-group peer) (setq-local jabber-chatting-with peer)) (jabber-chat--reply-context-snippet (list :reply-to-id id :reply-to-jid from)))))) (should (equal "room target" (funcall snippet "room@example.com" t "room-uid" "room@example.com/alice"))) (should-not (funcall snippet "room@example.com" t "room-uid" "room@example.com/mallory")) (should (equal "legacy target" (funcall snippet "room@example.com" t "legacy-uid" "room@example.com/bob"))) (should-not (funcall snippet "room@example.com" t "shadowed-uid" "room@example.com/bob")) (should (equal "shadowing" (funcall snippet "room@example.com" t "own-room" "room@example.com/bob"))) (dolist (alias '("origin" "transport")) (should (equal "direct target" (funcall snippet "friend@example.com" nil alias "friend@example.com/phone"))) (should-not (funcall snippet "friend@example.com" nil alias "friend@example.com/laptop"))) (should-not (funcall snippet "room@example.com" nil "room-uid" "room@example.com/alice"))) ;; Native reactions resolve the same candidates and respect account scope. (let ((react (lambda (connection from type target) (let ((jabber-message-chain (list #'jabber-reactions--handle-message))) (jabber-process-input connection `(message ((from . ,from) (type . ,type)) (reactions ((xmlns . "urn:xmpp:reactions:0") (id . ,target)) (reaction () "👍")))))))) (funcall react jc "room@example.com/carol" "groupchat" "room-uid") (funcall react jc "room@example.com/carol" "groupchat" "legacy-uid") (funcall react jc "room@example.com/carol" "groupchat" "shadowed-uid") (funcall react jc "friend@example.com/phone" "chat" "origin") (funcall react other "room@example.com/carol" "groupchat" "room-uid") (should (equal '(("direct target" "friend@example.com") ("legacy target" "room@example.com/carol") ("room target" "room@example.com/carol")) (sqlite-select jabber-db--connection "SELECT body, sender FROM message_reaction JOIN message ON message.id = message_reaction.message_id ORDER BY body"))))))) (provide 'jabber-test-action-storage) ;;; jabber-test-action-storage.el ends here emacs-jabber-0.15.1/tests/jabber-test-activity-owners.el000066400000000000000000000631321527111033600231500ustar00rootroot00000000000000;;; jabber-test-activity-owners.el --- Owned activity regressions -*- lexical-binding: t; -*- ;;; Commentary: ;; Exercise real dispatch, buffers, EWOCs, visibility, and navigation without I/O. ;;; Code: (require 'ert) (require 'cl-lib) (require 'jabber-activity) (require 'jabber-subscription) (require 'jabber-presence) (require 'jabber-mam) (require 'jabber-roster-menu) (require 'jabber-message-thread) (require 'jabber-keymap) (defun jabber-test-activity-owners--connection (name) "Return a disposable connection named NAME." (let ((jc (make-symbol name))) (put jc :state-data (list :username name :server "example.test")) jc)) (defmacro jabber-test-activity-owners--with-state (&rest body) "Run BODY with isolated activity, connection, and buffer state." (declare (indent 0) (debug t)) `(let* ((a (jabber-test-activity-owners--connection "a")) (b (jabber-test-activity-owners--connection "b")) (jabber-connections (list a b)) (jabber-db-path nil) (jabber-mam-enable nil) (jabber-activity-jids nil) (jabber-activity-personal-jids nil) (jabber-activity-name-alist nil) (jabber-activity-mode-string "") (jabber-activity-count-string "0") (jabber-activity-last-buffer nil) (jabber-activity--shortened-names (make-hash-table :test #'equal)) (jabber-activity-update-hook nil) (jabber-activity-show-p #'jabber-activity-show-p-default) (jabber-activity-make-string #'identity) (jabber-activity-make-strings #'jabber-activity-make-strings-default) (jabber-activity--event-owner nil) (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) (jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-chat-buffer-format " *activity-%a-%j*") (jabber-groupchat-buffer-format " *activity-%a-%n*") (jabber-muc-private-buffer-format " *activity-%a-%g-%n*") (jabber-chat-default-encryption 'plaintext) (jabber-chat-mode-hook nil) (jabber-message-hooks '(jabber-activity-add)) (jabber-alert-message-hooks nil) (jabber-muc-hooks '(jabber-activity-add-muc)) (jabber-alert-muc-hooks nil) (jabber-presence-hooks '(jabber-activity-presence)) (jabber-alert-presence-hooks nil) (jabber-alert-message-function (lambda (&rest _) "Message")) (jabber-alert-muc-function (lambda (&rest _) "Room")) (jabber-alert-presence-message-function (lambda (&rest _) "Presence")) (before (buffer-list))) (unwind-protect (save-window-excursion (with-temp-buffer ,@body)) (dolist (buffer (seq-difference (buffer-list) before)) (when (buffer-live-p buffer) (kill-buffer buffer)))))) (defun jabber-test-activity-owners--message (jc buffer) "Deliver an incoming direct message on JC into BUFFER." (jabber-chat--display-message jc '(message nil) buffer nil "peer@example.test" (list :from "peer@example.test" :body "hello" :timestamp (current-time)))) (ert-deftest jabber-test-activity-owners-direct-visibility () "Visible A never suppresses B; actual dispatch retains the background owner." (jabber-test-activity-owners--with-state (let ((ab (jabber-chat-create-buffer a "peer@example.test")) (bb (jabber-chat-create-buffer b "peer@example.test"))) (setq-local jabber-buffer-connection a) (jabber-test-activity-owners--message a ab) (jabber-test-activity-owners--message b bb) (should (= 2 (length jabber-activity-jids))) (should (= 2 (length jabber-activity-personal-jids))) (set-window-buffer (selected-window) ab) (jabber-activity-clean) (should (equal jabber-activity-jids (list (cons b "peer@example.test")))) (jabber-test-activity-owners--message b bb) (should (= 1 (length jabber-activity-jids))) (jabber-activity-switch-to) (should (eq (current-buffer) bb)) (should-not jabber-activity-jids)))) (ert-deftest jabber-test-activity-owners-killed-and-retired () "Killed B is recreated on B, but a retired B is never redirected to A." (jabber-test-activity-owners--with-state (let* ((bb (jabber-chat-create-buffer b "peer@example.test")) (entry (cons b "peer@example.test"))) (jabber-test-activity-owners--message b bb) (kill-buffer bb) (jabber-activity-switch-to entry) (should (eq jabber-buffer-connection b)) (should (equal jabber-chatting-with "peer@example.test")) (kill-buffer (current-buffer)) (setq jabber-connections (list a) jabber-activity-jids (list entry)) (let ((before (current-buffer))) (jabber-activity-switch-to entry) (should (eq (current-buffer) before))) (should-not jabber-activity-jids)))) (ert-deftest jabber-test-activity-owners-closed-muc-dispatch () "Closed-room events retain owner and mention policy across earlier hooks." (jabber-test-activity-owners--with-state (jabber-muc-join-set "room@example.test" a "alice") (jabber-muc-join-set "room@example.test" b "bob") (setq-local jabber-buffer-connection a) (let ((foreign (current-buffer)) (jabber-muc-hooks (list (lambda (&rest _) (set-buffer (get-buffer-create " *activity-hook*"))) #'jabber-activity-add-muc))) (jabber-muc--display-message b '(message nil) "room@example.test" "sender" :muc-foreign '(:from "room@example.test/sender" :body "bob: hello")) (should (eq (current-buffer) foreign))) (jabber-muc--display-message a '(message nil) "room@example.test" "sender" :muc-foreign '(:from "room@example.test/sender" :body "bob: hello")) (should (= 2 (length jabber-activity-jids))) (should (equal jabber-activity-personal-jids (list (cons b "room@example.test")))) (jabber-activity-switch-to (cons b "room@example.test")) (should (eq jabber-buffer-connection b)) (should (equal jabber-group "room@example.test")) (should (equal jabber-activity-jids (list (cons a "room@example.test")))))) (ert-deftest jabber-test-activity-owners-muc-visible-and-killed () "Room visibility and killed-buffer navigation are account qualified." (jabber-test-activity-owners--with-state (jabber-muc-join-set "room@example.test" a "alice") (jabber-muc-join-set "room@example.test" b "bob") (let ((ab (jabber-muc-create-buffer a "room@example.test")) (bb (jabber-muc-create-buffer b "room@example.test"))) (set-window-buffer (selected-window) ab) (jabber-muc--display-message b '(message nil) "room@example.test" "sender" :muc-foreign '(:from "room@example.test/sender" :body "bob: hello")) (jabber-activity-clean) (should (equal jabber-activity-jids (list (cons b "room@example.test")))) (kill-buffer bb) (jabber-activity-switch-to) (should (eq jabber-buffer-connection b)) (should-not (eq (current-buffer) ab))))) (ert-deftest jabber-test-activity-owners-private-muc-killed () "A private MUC entry reconstructs only its original account's buffer." (jabber-test-activity-owners--with-state (jabber-muc-join-set "room@example.test" a "alice") (jabber-muc-join-set "room@example.test" b "bob") (let* ((jid "room@example.test/sender") (bb (jabber-muc-private-create-buffer b "room@example.test" "sender"))) (jabber-activity-add jid bb "hello" "Message") (kill-buffer bb) (jabber-activity-switch-to) (should (eq jabber-buffer-connection b)) (should (equal jabber-chatting-with jid))))) (ert-deftest jabber-test-activity-owners-formatters-and-mouse () "Fixed-arity string formatters retain separate cache keys and mouse owners." (jabber-test-activity-owners--with-state (let ((ab (jabber-chat-create-buffer a "peer@example.test")) (bb (jabber-chat-create-buffer b "peer@example.test")) (jabber-activity-show-p (lambda (jid) (stringp jid))) (jabber-activity-make-string (lambda (jid) (concat "name:" jid))) (jabber-activity-make-strings (lambda (jids) (should (seq-every-p #'stringp jids)) (jabber-activity-make-strings-shorten jids)))) (jabber-activity-add "peer@example.test" ab "hi" "Message") (jabber-activity-add "peer@example.test" bb "hi" "Message") (should (= 2 (length jabber-activity-name-alist))) (should (= 2 (hash-table-count jabber-activity--shortened-names))) (let* ((entry (jabber-activity-lookup-name (cons b "peer@example.test"))) (text (jabber-activity--propertize-entry entry)) (map (get-text-property 0 'local-map text))) (call-interactively (lookup-key map [mode-line mouse-1])) (should (eq (current-buffer) bb)))))) (ert-deftest jabber-test-activity-owners-ambiguous-legacy () "An accountless action never uses the selected or first active account." (jabber-test-activity-owners--with-state (setq-local jabber-buffer-connection a) (let ((before (current-buffer))) (jabber-activity-switch-to "peer@example.test") (should (eq (current-buffer) before))) (should (equal (jabber-activity-make-string-default "peer@example.test") "peer")))) (ert-deftest jabber-test-activity-owners-disconnect () "Disconnecting A preserves B's activity and personal state." (jabber-test-activity-owners--with-state (setq jabber-activity-jids (list (cons a "peer@example.test") (cons b "peer@example.test")) jabber-activity-personal-jids (copy-sequence jabber-activity-jids) jabber-connections (list b)) (jabber-activity--on-disconnect) (should (equal jabber-activity-jids (list (cons b "peer@example.test")))) (should (equal jabber-activity-jids jabber-activity-personal-jids)))) (ert-deftest jabber-test-activity-owners-roster-unread () "Unread completion keeps B's identity across the interactive reader." (jabber-test-activity-owners--with-state (let ((bb (jabber-chat-create-buffer b "peer@example.test"))) (setq jabber-activity-jids (list (cons a "peer@example.test") (cons b "peer@example.test"))) (cl-letf (((symbol-function 'completing-read) (lambda (_prompt candidates &rest _) (should (= 2 (length candidates))) (car (nth 1 candidates))))) (call-interactively #'jabber-roster-chat-unread)) (should (eq (current-buffer) bb))))) (ert-deftest jabber-test-activity-owners-subscription-who () "Native subscription delivery uses scoped WHO despite background context." (jabber-test-activity-owners--with-state (setq-local jabber-buffer-connection a) (jabber-presence-events-dispatch-subscription-request a "peer@example.test" "first") (jabber-presence-events-dispatch-subscription-request b "peer@example.test" "second") (should (= 2 (length jabber-activity-jids))) (should (member (cons a "peer@example.test") jabber-activity-jids)) (should (member (cons b "peer@example.test") jabber-activity-jids)))) (ert-deftest jabber-test-activity-owners-subscription-cleanup () "Native ordinary presence removes only exact-owner EWOC request nodes." (jabber-test-activity-owners--with-state (dolist (order '(forward reverse)) (let* ((ab (jabber-chat-create-buffer a "peer@example.test")) (bb (jabber-chat-create-buffer b "peer@example.test"))) (dolist (buffer (if (eq order 'forward) (list ab bb) (list bb ab))) (with-current-buffer buffer (jabber-buffer-registry-register 'chat "peer@example.test") (jabber-chat-ewoc-enter '(:subscription-request "allow")) (jabber-chat-ewoc-enter '(:notice "keep")))) (with-current-buffer bb (jabber-process-presence a '(presence ((from . "peer@example.test/phone"))))) (with-current-buffer ab (should (equal (ewoc-collect jabber-chat-ewoc #'identity) '((:notice "keep"))))) (with-current-buffer bb (should (equal (ewoc-collect jabber-chat-ewoc #'identity) '((:subscription-request "allow") (:notice "keep"))))) (kill-buffer ab) (jabber-process-presence a '(presence ((from . "peer@example.test/phone")))) (setq jabber-connections (list a)) (jabber-process-presence b '(presence ((from . "peer@example.test/phone")))) (with-current-buffer bb (should (= 2 (length (ewoc-collect jabber-chat-ewoc #'identity))))) (kill-buffer bb) (setq jabber-connections (list a b)))))) (ert-deftest jabber-test-activity-owners-subscription-reply () "Reply uses the request buffer's connection and removes just its prompt." (jabber-test-activity-owners--with-state (let ((bb (jabber-chat-create-buffer b "peer@example.test")) sent) (with-current-buffer bb (let ((node (jabber-chat-ewoc-enter '(:subscription-request "allow")))) (goto-char (ewoc-location node)) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (jc stanza) (push (cons jc stanza) sent)))) (jabber-subscription-reply "subscribed")) (should (eq (caar sent) b)) (should-not (ewoc-collect jabber-chat-ewoc #'identity))))))) (ert-deftest jabber-test-activity-owners-closed-direct-dispatch () "A closed direct-message event retains its receiver across earlier hooks." (jabber-test-activity-owners--with-state (setq-local jabber-buffer-connection a) (let ((jabber-message-hooks (list (lambda (&rest _) (set-buffer (get-buffer-create " *activity-hook*"))) #'jabber-activity-add))) (jabber-test-activity-owners--message b nil)) (should (equal jabber-activity-jids (list (cons b "peer@example.test")))))) (ert-deftest jabber-test-activity-owners-reconstruction-name-collision () "Reconstructing B cannot adopt A's buffer with an accountless format." (jabber-test-activity-owners--with-state (let* ((jabber-chat-buffer-format " *activity-collision-%j*") (ab (jabber-chat-create-buffer a "peer@example.test"))) (jabber-activity-switch-to (cons b "peer@example.test")) (should (eq jabber-buffer-connection b)) (should-not (eq (current-buffer) ab)) (should (eq (buffer-local-value 'jabber-buffer-connection ab) a))))) (ert-deftest jabber-test-activity-owners-names () "Default naming and shortening use each entry's scoped contact metadata." (jabber-test-activity-owners--with-state (put (jabber-jid-symbol "peer@example.test" a) 'name "Alice") (put (jabber-jid-symbol "peer@example.test" b) 'name "Bob") (let ((jabber-activity-make-string #'jabber-activity-make-string-default)) (setq jabber-activity-jids (list (cons a "peer@example.test") (cons b "peer@example.test"))) (jabber-activity-make-name-alist) (should (equal (cdr (jabber-activity-lookup-name (cons a "peer@example.test"))) "Alice")) (should (equal (cdr (jabber-activity-lookup-name (cons b "peer@example.test"))) "Bob")) (should (equal (jabber-activity-make-string-default "peer@example.test") "peer"))))) (ert-deftest jabber-test-activity-owners-unowned-and-killed-buffer () "A legacy event without an explicit owner never inherits the current chat." (jabber-test-activity-owners--with-state (setq-local jabber-buffer-connection a) (jabber-activity-add "peer@example.test" nil "hello" "Message") (let ((buffer (generate-new-buffer " *activity-killed*"))) (with-current-buffer buffer (setq-local jabber-buffer-connection b)) (kill-buffer buffer) (jabber-activity-add "peer@example.test" buffer "hello" "Message")) (should-not jabber-activity-jids))) (ert-deftest jabber-test-activity-owners-roster-reader-retirement () "Retiring B during unread completion cannot redirect the action to A." (jabber-test-activity-owners--with-state (setq jabber-activity-jids (list (cons b "peer@example.test"))) (let ((before (current-buffer))) (cl-letf (((symbol-function 'completing-read) (lambda (_prompt candidates &rest _) (setq jabber-connections (list a)) (caar candidates)))) (call-interactively #'jabber-roster-chat-unread)) (should (eq (current-buffer) before)) (should-not jabber-activity-jids)))) (defun jabber-test-activity-owners--parent (jc peer type) "Create the parent for JC, PEER and TYPE." (if (equal type "groupchat") (progn (jabber-muc-join-set peer jc "reader") (jabber-muc-create-buffer jc peer)) (jabber-chat-create-buffer jc peer))) (defun jabber-test-activity-owners--deliver (jc peer type body &optional thread) "Dispatch BODY from PEER on JC as TYPE, optionally in THREAD." (funcall (if (equal type "groupchat") #'jabber-muc-process-message #'jabber-process-chat) jc `(message ((from . ,(if (equal type "groupchat") (concat peer "/sender") peer)) (type . ,type)) (body nil ,body) ,@(when thread `((thread nil ,thread)))))) (defmacro jabber-test-activity-owners--with-threads (type reverse &rest body) "Run BODY with real parent/thread views of TYPE in REVERSE account order." (declare (indent 2) (debug (form form body))) `(jabber-test-activity-owners--with-state (let* ((peer "peer@example.test") (kind ,type) (jabber-connections (if ,reverse (list b a) (list a b))) (parents (mapcar (lambda (jc) (cons jc (jabber-test-activity-owners--parent jc peer kind))) jabber-connections)) (ab (cdr (assq a parents))) (bb (cdr (assq b parents))) (threads (mapcar (lambda (jc) (cons jc (jabber-message-thread-create-buffer jc peer kind "topic" nil (cdr (assq jc parents))))) jabber-connections)) (thread (cdr (assq b threads))) (entry (cons b peer))) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (&rest _) (error "Unexpected wire send")))) ,@body)))) (ert-deftest jabber-test-activity-owners-parent-thread-visibility () "A visible dedicated thread never hides unthreaded parent activity." (dolist (type '("chat" "groupchat")) (dolist (reverse '(nil t)) (jabber-test-activity-owners--with-threads type reverse (switch-to-buffer thread) (jabber-test-activity-owners--deliver a peer kind "foreign parent") (jabber-test-activity-owners--deliver b peer kind "own parent") (should (get-buffer-window thread)) (should-not (get-buffer-window ab)) (should-not (get-buffer-window bb)) (with-current-buffer bb (should (string-match-p "own parent" (buffer-string)))) (with-current-buffer thread (should-not (string-match-p "own parent" (buffer-string)))) (should (member entry jabber-activity-jids)) (should (member (cons a peer) jabber-activity-jids)) (jabber-activity-clean) (should (member entry jabber-activity-jids)) (switch-to-buffer bb) (jabber-activity-clean) (should-not (member entry jabber-activity-jids)) (should (equal jabber-activity-jids (list (cons a peer)))))))) (ert-deftest jabber-test-activity-owners-parent-thread-navigation () "Native activity actions select parents across renaming and recreation." (dolist (type '("chat" "groupchat")) (dolist (reverse '(nil t)) (dolist (lifetime '(original renamed closed)) (dolist (action '(keyboard mouse unread)) (jabber-test-activity-owners--with-threads type reverse (switch-to-buffer (get-buffer-create " *activity-origin*")) (jabber-test-activity-owners--deliver a peer kind "foreign parent") (jabber-test-activity-owners--deliver b peer kind "own parent") (pcase lifetime ('renamed (let ((old-name (buffer-name bb))) (with-current-buffer bb (rename-buffer " *activity-renamed*" t)) (with-current-buffer (get-buffer-create old-name) (insert "Unrelated replacement")))) ('closed (kill-buffer bb))) ;; Make the wrong view the most recently selected matching buffer. (switch-to-buffer thread) (switch-to-buffer (get-buffer-create " *activity-origin*")) (pcase action ('keyboard (should (eq (key-binding (kbd "C-x C-j C-l")) #'jabber-activity-switch-to)) (execute-kbd-macro (kbd "C-x C-j C-l"))) ('mouse (let* ((text (jabber-activity--propertize-entry (jabber-activity-lookup-name entry))) (map (get-text-property 0 'local-map text))) (call-interactively (lookup-key map [mode-line mouse-1])))) ('unread ;; Supply only the human choice, never lookup or navigation. (cl-letf (((symbol-function 'completing-read) (lambda (_prompt candidates &rest _) (car (rassoc entry candidates))))) (call-interactively #'jabber-roster-chat-unread)))) (should (eq jabber-buffer-connection b)) (should-not jabber-message-thread-id) (should-not (eq (current-buffer) ab)) (unless (eq lifetime 'closed) (should (eq (current-buffer) bb))) (should (equal (or jabber-group jabber-chatting-with) peer)) (should-not (member entry jabber-activity-jids)) (should (equal jabber-activity-jids (list (cons a peer)))) (should (buffer-live-p thread)) (should (equal (buffer-local-value 'jabber-message-thread-id thread) "topic")))))))) (ert-deftest jabber-test-activity-owners-parent-thread-actions () "Opening and renaming a real thread preserves parent activity routing." (dolist (type '("chat" "groupchat")) (jabber-test-activity-owners--with-state (let* ((dir (make-temp-file "jabber-activity-thread-" t)) (jabber-db-path (expand-file-name "test.sqlite" dir)) (jabber-db--connection nil) (peer "peer@example.test") (parent (jabber-test-activity-owners--parent b peer type))) (unwind-protect (progn (switch-to-buffer parent) (jabber-message-thread-open (list :id "root" :server-id "server-root" :thread-id "topic" :from (concat peer "/sender") :body "Thread root" :timestamp (current-time))) (let ((thread (current-buffer))) (should-not (eq parent thread)) (should (equal jabber-message-thread-id "topic")) (jabber-message-thread-set-title "Renamed thread") (should (string-match-p "Renamed thread" (buffer-name))) ;; Keep only the thread visible after native pop-to-buffer. (delete-other-windows) (jabber-test-activity-owners--deliver b peer type "Thread reply" "topic") (with-current-buffer thread (should (string-match-p "Thread reply" (buffer-string)))) (with-current-buffer parent (should-not (string-match-p "Thread reply" (buffer-string)))) (jabber-test-activity-owners--deliver b peer type "Parent message") (should (member (cons b peer) jabber-activity-jids)) (jabber-activity-clean) (should (member (cons b peer) jabber-activity-jids)) (call-interactively #'jabber-activity-switch-to) (should (eq (current-buffer) parent)) (should-not jabber-activity-jids) (should (buffer-live-p thread)))) (jabber-db-close) (delete-directory dir t)))))) (ert-deftest jabber-test-activity-owners-parent-thread-private-muc () "Private MUC activity keeps the exact occupant and excludes thread views." (dolist (reverse '(nil t)) (jabber-test-activity-owners--with-state (let* ((room "room@example.test") (peer (concat room "/sender")) (jabber-connections (if reverse (list b a) (list a b))) (parents (mapcar (lambda (jc) (jabber-muc-join-set room jc "reader") (cons jc (jabber-muc-private-create-buffer jc room "sender"))) jabber-connections)) (parent (cdr (assq b parents))) (other (jabber-muc-private-create-buffer b room "other")) (thread (jabber-message-thread-create-buffer b peer "chat" "private-topic" nil parent))) (switch-to-buffer thread) (jabber-process-chat b `(message ((from . ,peer) (type . "chat")) (body nil "Private message"))) (with-current-buffer parent (should (string-match-p "Private message" (buffer-string)))) (jabber-activity-clean) (should (equal jabber-activity-jids (list (cons b peer)))) (call-interactively #'jabber-activity-switch-to) (should (eq (current-buffer) parent)) (should jabber-muc-private-p) (should-not jabber-message-thread-id) (should-not (eq (current-buffer) other)) (should-not jabber-activity-jids))))) (provide 'jabber-test-activity-owners) ;;; jabber-test-activity-owners.el ends here emacs-jabber-0.15.1/tests/jabber-test-activity.el000066400000000000000000000313041527111033600216310ustar00rootroot00000000000000;;; 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-connections '(test-connection)) (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-create-buffer) (lambda (actual-jc actual-jid) (should (eq actual-jc 'test-connection)) (setq switched actual-jid) 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.15.1/tests/jabber-test-ahc.el000066400000000000000000000264041527111033600205350ustar00rootroot00000000000000;;; 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.15.1/tests/jabber-test-alert.el000066400000000000000000000227271527111033600211150ustar00rootroot00000000000000;;; jabber-test-alert.el --- Alert routing tests -*- lexical-binding: t; -*- ;;; Commentary: ;; Exercise real alert and send modules with isolated buffers and wire capture. ;;; Code: (require 'ert) (require 'cl-lib) (require 'jabber-chat) (require 'jabber-muc) (require 'jabber-alert) (require 'jabber-notifications) (require 'jabber-activity) (defun jabber-test-alert--connection (name) "Return a disposable connection named NAME." (let ((jc (make-symbol name))) (put jc :state-data (list :username name :server "example.test")) jc)) (ert-deftest jabber-test-alert-autoanswer-origin () "A closed-thread alert replies through its parent, never the current chat." (let* ((a (jabber-test-alert--connection "a")) (b (jabber-test-alert--connection "b")) (jabber-connections (list a b)) (origin (generate-new-buffer " *jabber-alert-origin*")) (jabber-autoanswer-alist '(("ping" . "reply"))) (jabber-message-hooks nil) (jabber-alert-message-hooks '(jabber-autoanswer-answer)) (jabber-alert-message-function (lambda (&rest _) "Peer")) sent) (unwind-protect (progn (with-current-buffer origin (setq-local jabber-buffer-connection a jabber-chatting-with "peer@example.test" jabber-send-function #'jabber-chat-send jabber-chat-encryption 'plaintext)) (with-temp-buffer (setq-local jabber-buffer-connection b jabber-chatting-with "other@example.test") (cl-letf (((symbol-function 'jabber-chat--find-buffer-on-connection) (lambda (&rest _) origin)) ((symbol-function 'jabber-chat--run-send-hooks) #'ignore) ((symbol-function 'jabber-chat--display-local-message) #'ignore) ((symbol-function 'jabber-send-sexp) (lambda (jc stanza &optional success _failure) (push (list jc stanza) sent) (when success (funcall success))))) (jabber-chat--display-message a nil nil nil "peer@example.test/resource" '(:body "ping" :thread-id "closed"))) (should (= (length sent) 1)) (should (eq (caar sent) a)) (should (equal (jabber-xml-get-attribute (cadar sent) 'to) "peer@example.test")))) (kill-buffer origin)))) (ert-deftest jabber-test-alert-autoanswer-stale-origin () "Killed, disconnected, and retargeted origins never send a reply." (let* ((a (jabber-test-alert--connection "a")) (jabber-connections (list a)) (jabber-autoanswer-alist '(("ping" . "reply"))) (jabber-alert-chat-send-function (lambda (&rest _) (ert-fail "Sent")))) (with-temp-buffer (setq-local jabber-buffer-connection a jabber-chatting-with "other@example.test") (jabber-autoanswer-answer "peer@example.test" (current-buffer) "ping" "Peer") (setq-local jabber-chatting-with "peer@example.test") (let ((jabber-connections nil)) (jabber-autoanswer-answer "peer@example.test" (current-buffer) "ping" "Peer"))) (let ((dead (generate-new-buffer " *jabber-alert-dead*"))) (kill-buffer dead) (jabber-autoanswer-answer "peer@example.test" dead "ping" "Peer")))) (ert-deftest jabber-test-alert-autoanswer-muc-origin () "MUC autoanswers use the room's groupchat sender and owning account." (let* ((a (jabber-test-alert--connection "a")) (b (jabber-test-alert--connection "b")) (jabber-connections (list a b)) (jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-autoanswer-alist '(("ping" . "reply"))) (origin (generate-new-buffer " *jabber-alert-room*")) sent) (unwind-protect (progn (jabber-muc-join-set "room@example.test" a "alice") (with-current-buffer origin (setq-local jabber-buffer-connection a jabber-group "room@example.test" jabber-send-function #'jabber-muc-send jabber-chat-encryption 'plaintext)) (with-temp-buffer (setq-local jabber-buffer-connection b jabber-chatting-with "unrelated@example.test") (cl-letf (((symbol-function 'jabber-chat--run-send-hooks) #'ignore) ((symbol-function 'jabber-chat--display-local-message) #'ignore) ((symbol-function 'jabber-send-sexp) (lambda (jc stanza) (push (list jc stanza) sent)))) (jabber-autoanswer-answer-muc "bob" "room@example.test" origin "ping" "Room")) (should (= (length sent) 1)) (should (eq (caar sent) a)) (should (equal (jabber-xml-get-attribute (cadar sent) 'to) "room@example.test")) (should (equal (jabber-xml-get-attribute (cadar sent) 'type) "groupchat")))) (kill-buffer origin)))) (ert-deftest jabber-test-alert-muc-background-mentions () "Closed rooms retain the receiving account through notification hooks." (let* ((a (jabber-test-alert--connection "a")) (b (jabber-test-alert--connection "b")) (jabber-connections (list a b)) (jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc-hooks nil) (jabber-alert-muc-hooks '(jabber-muc-notifications)) (jabber-alert-muc-function (lambda (&rest _) "Room")) (jabber-notifications-muc 'mentions) sent) (jabber-muc-join-set "room@example.test" a "alice") (jabber-muc-join-set "room@example.test" b "bob") (with-temp-buffer (setq-local jabber-buffer-connection b) (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (&rest _) nil)) ((symbol-function 'notifications-notify) (lambda (&rest args) (push args sent)))) (jabber-muc--display-message a '(message nil) "room@example.test" "sender" :muc-foreign '(:body "alice: hello")) (should (= (length sent) 1)) (jabber-muc--display-message a '(message nil) "room@example.test" "sender" :muc-foreign '(:body "bob: hello")) (should (= (length sent) 1)))))) (ert-deftest jabber-test-alert-muc-nick-retains-owner () "Interactive nickname changes use the room buffer's account." (let* ((a (jabber-test-alert--connection "a")) (b (jabber-test-alert--connection "b")) (jabber-connections (list a b)) (jabber-muc--rooms (make-hash-table :test #'equal)) sent) (jabber-muc-join-set "room@example.test" a "alice") (jabber-muc-join-set "room@example.test" b "bob") (with-temp-buffer (setq major-mode 'jabber-chat-mode) (setq-local jabber-buffer-connection a jabber-group "room@example.test") (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "new-alice")) ((symbol-function 'jabber-send-sexp) (lambda (jc stanza) (push (list jc stanza) sent)))) (call-interactively #'jabber-muc-nick)) (should (eq (caar sent) a)) (should (equal (jabber-xml-get-attribute (cadar sent) 'to) "room@example.test/new-alice")) (should (equal (jabber-muc-nickname "room@example.test" b) "bob")) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) (setq jabber-connections (list b)) "stale")) ((symbol-function 'jabber-send-sexp) (lambda (&rest args) (push args sent)))) (should-error (call-interactively #'jabber-muc-nick) :type 'user-error)) (should (= (length sent) 1))))) (ert-deftest jabber-test-alert-muc-hooks-retain-receiver () "Buffer-changing hooks cannot steal subsequent mention detection." (let* ((a (jabber-test-alert--connection "a")) (b (jabber-test-alert--connection "b")) (jabber-connections (list a b)) (jabber-muc--rooms (make-hash-table :test #'equal)) (foreign (generate-new-buffer " *jabber-foreign*")) (jabber-alert-muc-function (lambda (&rest _) "Room")) (jabber-notifications-muc 'mentions) (jabber-activity-jids nil) (jabber-activity-personal-jids nil) (jabber-activity-show-p (lambda (&rest _) t)) (jabber-muc-hooks (list (lambda (&rest _) (set-buffer foreign)) #'jabber-activity-add-muc)) (jabber-alert-muc-hooks '(jabber-muc-notifications)) calls) (unwind-protect (progn (jabber-muc-join-set "room@example.test" a "alice") (jabber-muc-join-set "room@example.test" b "bob") (with-current-buffer foreign (setq-local jabber-buffer-connection b)) (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (&rest _) nil)) ((symbol-function 'jabber-activity-mode-line-update) #'ignore) ((symbol-function 'notifications-notify) (lambda (&rest args) (push args calls)))) (jabber-muc--display-message a '(message nil) "room@example.test" "sender" :muc-foreign '(:body "alice: hello"))) (should (= (length calls) 1)) (should (equal jabber-activity-personal-jids (list (cons a "room@example.test"))))) (kill-buffer foreign)))) (provide 'jabber-test-alert) ;;; jabber-test-alert.el ends here emacs-jabber-0.15.1/tests/jabber-test-archive-identity.el000066400000000000000000000403731527111033600232530ustar00rootroot00000000000000;;; jabber-test-archive-identity.el --- Persistent action identities -*- lexical-binding: t; -*- ;;; Commentary: ;; Exercise native ingestion, actions, SQLite readers and cold replay together. ;;; Code: (require 'jabber-archive-test-helpers) (defun jabber-test-archive-identity--direct (&optional origin) "Return a direct message, optionally carrying ORIGIN." `(message ((from . "friend@example.com/phone") (type . "chat") (id . "transport")) (body () "retained") ,@(when origin `((origin-id ((xmlns . "urn:xmpp:sid:0") (id . ,origin))))))) (defun jabber-test-archive-identity--replay (jc inner archive uid) "Replay INNER on JC from ARCHIVE with UID through a complete MAM page." (let ((query (jabber-mam--query jc nil nil nil nil archive t 10))) (jabber-mam--process-message jc (jabber-test-archive--result query uid inner)) (jabber-test-archive--fin jc query uid))) (ert-deftest jabber-test-archive-identity-reaction-action-reopen () "Select from cold history, send the real action, receive and reject stale updates." (jabber-test-archive--with-file (let ((xml (jabber-test-archive-identity--direct "origin")) (other (jabber-test-mam--native-connection "other"))) (jabber-db--message-handler jc xml) (jabber-db--message-handler other xml) (jabber-db-close) (let ((stored (car (jabber-db-backlog "me@example.com" "friend@example.com"))) sent) (with-temp-buffer (setq-local jabber-buffer-connection jc) (setq-local jabber-chatting-with "friend@example.com") (setq-local jabber-chat-ewoc (ewoc-create (lambda (_) (insert "message\n")))) (let ((node (ewoc-enter-last jabber-chat-ewoc (list :foreign stored)))) (setq-local jabber-point-insert (copy-marker (point-max))) (goto-char (ewoc-location node)) (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) "👍")) ((symbol-function 'jabber-send-sexp) (lambda (_jc xml &rest _) (setq sent xml)))) (call-interactively #'jabber-reactions-react-at-point-or-insert)) (should (equal "origin" (jabber-xml-get-attribute (car (jabber-xml-get-children sent 'reactions)) 'id))))) (let ((reader (sqlite-open jabber-db-path))) (unwind-protect (should (equal '(("me@example.com" "👍")) (sqlite-select reader "SELECT m.account,r.reaction FROM message m JOIN message_reaction r ON r.message_id=m.id"))) (sqlite-close reader)))) ;; Inbound source time and actor lookup use the same origin/alias policy. (dolist (entry '(("2025-01-02T00:00:00Z" "origin" "🔥") ("2025-01-01T00:00:00Z" "transport" "stale"))) (jabber-reactions--handle-message jc `(message ((from . "friend@example.com/laptop") (type . "chat")) (delay ((xmlns . "urn:xmpp:delay") (stamp . ,(car entry)))) (reactions ((xmlns . "urn:xmpp:reactions:0") (id . ,(cadr entry))) (reaction () ,(nth 2 entry)))))) (should (jabber-db-reaction-stale-p "me@example.com" "friend@example.com" "chat" "origin" "friend@example.com" 1)) (should (jabber-db-reaction-stale-p "me@example.com" "friend@example.com" "chat" "transport" "friend@example.com" 1)) (jabber-db-close) (let ((reactions (plist-get (car (jabber-db-backlog "me@example.com" "friend@example.com")) :reactions))) (should (equal '("👍") (cdr (assoc "me@example.com" reactions)))) (should (equal '("🔥") (cdr (assoc "friend@example.com" reactions))))) (should-not (plist-get (car (jabber-db-backlog "other@example.com" "friend@example.com")) :reactions))))) (ert-deftest jabber-test-archive-identity-historical-reply-enrichment () "Retain transport references after replay adds origin; new replies prefer origin." (jabber-test-archive--with-file (jabber-db--message-handler jc (jabber-test-archive-identity--direct)) (jabber-db--message-handler jc '(message ((from . "friend@example.com/phone") (type . "chat") (id . "reply")) (body () "response") (reply ((xmlns . "urn:xmpp:reply:0") (id . "transport") (to . "friend@example.com/phone"))))) (should (equal "retained" (jabber-db-reply-target-body "me@example.com" "friend@example.com" "transport" nil))) (jabber-db-close) (jabber-test-archive-identity--replay jc (jabber-test-archive-identity--direct "origin") nil "archive-uid") (jabber-db-close) (let* ((rows (jabber-db-backlog "me@example.com" "friend@example.com")) (reply (seq-find (lambda (row) (plist-get row :reply-to-id)) rows)) (target (seq-find (lambda (row) (equal "transport" (plist-get row :id))) rows))) (should (= (length rows) 2)) (should (equal "transport" (plist-get reply :reply-to-id))) (should (equal "origin" (jabber-message-reply--select-id target nil))) (with-temp-buffer (setq-local jabber-buffer-connection jc) (setq-local jabber-chatting-with "friend@example.com") (should (equal "retained" (jabber-chat--reply-context-snippet reply)))) (should-not (jabber-db-reply-target-body "me@example.com" "friend@example.com" "archive-uid" nil))))) (ert-deftest jabber-test-archive-identity-reference-collisions () "Count origin/transport collisions across senders, not accounts or message kinds." (jabber-test-archive--with-file (jabber-db--message-handler jc (jabber-test-archive-identity--direct "origin")) ;; A distinct sender's transport equals the first sender's origin. (jabber-db--message-handler jc '(message ((from . "friend@example.com/other") (type . "chat") (id . "origin")) (body () "collision") (origin-id ((xmlns . "urn:xmpp:sid:0") (id . "other-origin"))))) (jabber-db-close) (should-not (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "origin" "actor" '("bad"))) (should-not (jabber-db-reply-target-body "me@example.com" "friend@example.com" "origin" nil)) (should (equal "retained" (jabber-db-reply-target-body "me@example.com" "friend@example.com" "origin" nil "friend@example.com/phone"))) (should-not (jabber-db-reply-target-body "me@example.com" "friend@example.com" "origin" nil "wrong@example.com")) (should-not (jabber-db-reply-target-body "me@example.com" "friend@example.com" "origin" nil "friend@example.com")) (should-not (sqlite-select jabber-db--connection "SELECT * FROM message_reaction_actor")) ;; A visible subset must not override ambiguity found in durable history. (with-temp-buffer (setq-local jabber-buffer-connection jc) (setq-local jabber-chatting-with "friend@example.com") (setq-local jabber-chat-ewoc (ewoc-create (lambda (_) (insert "message\n")))) (let* ((stored (seq-find (lambda (msg) (equal "transport" (plist-get msg :id))) (jabber-db-backlog "me@example.com" "friend@example.com"))) (node (ewoc-enter-last jabber-chat-ewoc (list :foreign stored))) sent) (setq-local jabber-point-insert (copy-marker (point-max))) (goto-char (ewoc-location node)) (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) "bad")) ((symbol-function 'jabber-send-sexp) (lambda (&rest _) (setq sent t)))) (should-error (call-interactively #'jabber-reactions-react-at-point-or-insert) :type 'user-error)) (should-not sent) (jabber-reactions--handle-message jc '(message ((from . "friend@example.com/phone") (type . "chat")) (reactions ((xmlns . "urn:xmpp:reactions:0") (id . "origin")) (reaction () "bad")))) (should-not (plist-get (cadr (ewoc-data node)) :reactions)))) ;; Tombstones participate in ambiguity rather than selecting the survivor. (sqlite-execute jabber-db--connection "UPDATE message SET retracted=1 WHERE stanza_id='origin'") (should-not (jabber-db-reply-target-body "me@example.com" "friend@example.com" "origin" nil)) (should-not (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "origin" "actor" '("bad"))) ;; One row matching both aliases is not two candidates. (jabber-db--message-handler jc '(message ((from . "friend@example.com/phone") (type . "chat") (id . "same")) (body () "one") (origin-id ((xmlns . "urn:xmpp:sid:0") (id . "same"))))) (should (jabber-db-replace-reactions "me@example.com" "friend@example.com" "chat" "same" "actor" '("ok"))))) (defun jabber-test-archive-identity--room () "Return a partial live room stanza with sender and transport evidence." '(message ((from . "room@example.com/nick") (type . "groupchat") (id . "transport")) (body () "retained") (delay ((xmlns . "urn:xmpp:delay") (stamp . "2025-01-01T00:00:00Z"))) (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "actor"))))) (ert-deftest jabber-test-archive-identity-partial-room-replay () "Enrich one live partial room row, replay two archives and preserve its tombstone." (jabber-test-archive--with-file (let ((jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--generation 0) (inner (jabber-test-archive-identity--room))) (jabber-muc-join-set "room@example.com" jc "me") (jabber-db--message-handler jc inner) (let ((id (caar (sqlite-select jabber-db--connection "SELECT id FROM message"))) (full (append inner '((stanza-id ((xmlns . "urn:xmpp:sid:0") (by . "room@example.com") (id . "room-id"))))))) (jabber-db-close) (jabber-test-archive-identity--replay jc full "room@example.com" "room-uid") (let ((reader (sqlite-open jabber-db-path))) (unwind-protect (should (equal (list (list id "transport" "room-id" "room-id")) (sqlite-select reader "SELECT id,stanza_id,server_id,room_id FROM message"))) (sqlite-close reader))) (jabber-db-retract-message-row id nil) (dotimes (_ 2) (jabber-db-close) (jabber-test-archive-identity--replay jc full nil "personal-uid") (jabber-test-archive-identity--replay jc full "room@example.com" "room-uid")) (jabber-db-close) (should (equal (list (list id 1 "retained")) (sqlite-select (jabber-db-ensure-open) "SELECT id,retracted,body FROM message"))) (should (equal '(("me@example.com" "personal-uid") ("room@example.com" "room-uid")) (sqlite-select jabber-db--connection "SELECT archive,uid FROM message_archive ORDER BY archive"))))))) (ert-deftest jabber-test-archive-identity-partial-room-conflicts () "Reject sender, kind, occupant, transport, origin, legacy-server and weak matches." (dolist (conflict '(sender type occupant transport origin server weak ambiguous)) (jabber-test-archive--with-file (let ((jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--generation 0) (inner (jabber-test-archive-identity--room))) (jabber-muc-join-set "room@example.com" jc "me") (jabber-db--message-handler jc inner) (pcase conflict ('sender (sqlite-execute jabber-db--connection "UPDATE message SET resource='other'")) ('type (sqlite-execute jabber-db--connection "UPDATE message SET type='chat'")) ('occupant (sqlite-execute jabber-db--connection "UPDATE message SET occupant_id='other'")) ('transport (sqlite-execute jabber-db--connection "UPDATE message SET stanza_id='other'")) ('origin (sqlite-execute jabber-db--connection "UPDATE message SET origin_id='other'")) ('server (sqlite-execute jabber-db--connection "UPDATE message SET server_id='room-id'")) ('weak (sqlite-execute jabber-db--connection "UPDATE message SET stanza_id=NULL")) ('ambiguous (sqlite-execute jabber-db--connection "INSERT INTO message (account,peer,resource,occupant_id,direction,type,body,timestamp,stanza_id) SELECT account,peer,resource,occupant_id,direction,type,body,timestamp,stanza_id FROM message"))) (let ((before (sqlite-select jabber-db--connection "SELECT * FROM message ORDER BY id"))) (jabber-db-close) (jabber-test-archive-identity--replay jc (append inner '((stanza-id ((xmlns . "urn:xmpp:sid:0") (by . "room@example.com") (id . "room-id"))) (origin-id ((xmlns . "urn:xmpp:sid:0") (id . "origin"))))) "room@example.com" "room-uid") (jabber-db-close) (should (equal before (seq-take (sqlite-select (jabber-db-ensure-open) "SELECT * FROM message ORDER BY id") (length before)))) (should (= (1+ (length before)) (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message"))))))))) (ert-deftest jabber-test-archive-identity-thread-reaction-routing () "Route a restored origin reaction to its native dedicated thread view." (jabber-test-archive--with-file (let ((jabber-buffer-registry--buffers (make-hash-table :test #'equal)) (jabber-message-thread-use-buffers t)) (jabber-db--message-handler jc (append (jabber-test-archive-identity--direct "origin") '((thread () "thread")))) (jabber-db-register-message-thread "me@example.com" "friend@example.com" "chat" "thread" nil "transport" nil 1) (jabber-db-close) (let ((stored (car (jabber-db-backlog "me@example.com" "friend@example.com" nil nil nil nil t)))) (with-temp-buffer (setq-local jabber-buffer-connection jc) (setq-local jabber-chatting-with "friend@example.com") (setq-local jabber-chat-ewoc (ewoc-create (lambda (_) (insert "message\n")))) (let ((node (ewoc-enter-last jabber-chat-ewoc (list :foreign stored)))) (jabber-buffer-registry-register 'thread '("me@example.com" "friend@example.com" "chat" "thread")) (jabber-reactions--handle-message jc '(message ((from . "friend@example.com/phone") (type . "chat")) (reactions ((xmlns . "urn:xmpp:reactions:0") (id . "origin")) (reaction () "👍")))) (should (equal '(("friend@example.com" "👍")) (plist-get (cadr (ewoc-data node)) :reactions))))))))) (ert-deftest jabber-test-archive-identity-visible-reaction-collisions () "Do not let a cached generic ID or two visible aliases choose a wrong target." (with-temp-buffer (setq-local jabber-chat-ewoc (ewoc-create #'ignore)) (setq-local jabber-chat--msg-nodes (make-hash-table :test #'equal)) (let* ((first (ewoc-enter-last jabber-chat-ewoc '(:foreign (:id "transport" :origin-id "origin" :server-id "archive")))) (second (ewoc-enter-last jabber-chat-ewoc '(:foreign (:id "origin" :origin-id "other" :server-id "room"))))) (puthash "origin" first jabber-chat--msg-nodes) (should-not (jabber-reactions--find-target-node "origin" nil)) (should-not (jabber-reactions--find-target-node "archive" nil)) (should-not (jabber-reactions--find-target-node "origin" t)) (should (eq second (jabber-reactions--find-target-node "room" t))) (should (eq first (jabber-reactions--find-target-node "transport" nil)))))) (provide 'jabber-test-archive-identity) ;;; jabber-test-archive-identity.el ends here emacs-jabber-0.15.1/tests/jabber-test-archive-migration.el000066400000000000000000000320461527111033600234110ustar00rootroot00000000000000;;; jabber-test-archive-migration.el --- Archive schema migration proof -*- lexical-binding: t; -*- (require 'ert) (require 'cl-lib) (require 'jabber-db) (defconst jabber-test-archive-migration--fixture (expand-file-name "fixtures/archive-schema-v11.eld" (file-name-directory (or load-file-name buffer-file-name))) "Literal historical schema, never synthesized from the candidate schema.") (defun jabber-test-archive-migration--populate (db) "Create literal v11 tables and representative retained state in DB." (with-temp-buffer (insert-file-contents jabber-test-archive-migration--fixture) (dolist (ddl (read (current-buffer))) (sqlite-execute db ddl))) (dolist (sql '("PRAGMA user_version=11" "INSERT INTO message (id, account, peer, direction, type, stanza_id, server_id, body, timestamp, thread_id, retracted, retracted_by) VALUES (1,'me','peer','in','chat','transport','unknown-legacy','retained',1,'thread',1,'actor')" "INSERT INTO message_oob (message_id,url,desc) VALUES (1,'https://example.org/file','file')" "INSERT INTO message_reaction VALUES (1,'actor','λ',9)" "INSERT INTO message_reaction_actor VALUES (1,'actor',11)" "INSERT INTO message_thread (account,peer,type,thread_id,root_message_id,created_at,read_message_id,dedicated,title) VALUES ('me','peer','chat','thread',1,1,1,1,'local title')" "INSERT INTO chat_settings VALUES ('me','peer','omemo','thread')" "INSERT INTO omemo_store VALUES ('me',x'000102',123)" "INSERT INTO omemo_sessions VALUES ('me','peer',7,x'030405')" "INSERT INTO omemo_trust VALUES ('me','peer',7,x'0607',1,4)" "INSERT INTO omemo_skipped_keys VALUES ('me','peer',7,x'0809',3,x'1011',12)" "INSERT INTO omemo_devices VALUES ('me','peer',7,1,12)" "INSERT INTO omemo_device_id VALUES ('me',7)" "INSERT INTO caps_cache VALUES ('sha-1','ver','identities','features')")) (sqlite-execute db sql))) (defun jabber-test-archive-migration--data (db &optional columns) "Snapshot DB's application data, using historical COLUMNS when supplied." (mapcar (lambda (row) (let* ((table (car row)) (names (or (cadr (assoc table columns)) (mapcar #'cadr (sqlite-select db (format "PRAGMA table_info(%s)" table)))))) (list table names (sqlite-select db (format "SELECT %s FROM %s ORDER BY rowid" (mapconcat #'identity names ",") table))))) (sqlite-select db "SELECT name FROM sqlite_master WHERE type='table' AND name NOT LIKE 'message_fts%' AND name NOT LIKE 'sqlite_%' AND name NOT IN ('mam_progress','message_archive') ORDER BY name"))) (defun jabber-test-archive-migration--schema (db) "Return DB's complete schema and version for rollback comparisons." (list (sqlite-select db "PRAGMA user_version") (sqlite-select db "SELECT type,name,tbl_name,sql FROM sqlite_master ORDER BY type,name"))) (ert-deftest jabber-test-archive-migration-populated-upgrade-and-fresh () "Preserve all retained state; fresh and migrated tables have equal columns." (let ((db (sqlite-open)) (fresh (sqlite-open))) (unwind-protect (progn (jabber-test-archive-migration--populate db) (let ((before (jabber-test-archive-migration--data db))) (jabber-db--migrate db) (should (equal before (jabber-test-archive-migration--data db before))) (should (equal '((nil nil "unknown-legacy")) (sqlite-select db "SELECT origin_id,room_id,server_id FROM message"))) (should-not (sqlite-select db "SELECT * FROM mam_progress")) (should-not (sqlite-select db "SELECT * FROM message_archive")) (should (equal '((1)) (sqlite-select db "SELECT rowid FROM message_fts WHERE message_fts MATCH 'retained'"))) (should (equal '(("ok")) (sqlite-select db "PRAGMA integrity_check"))) (should-not (sqlite-select db "PRAGMA foreign_key_check"))) (jabber-db--migrate fresh) (should (equal (list (list jabber-db--schema-version)) (sqlite-select db "PRAGMA user_version"))) (should (equal (sqlite-select db "SELECT type,name FROM sqlite_master ORDER BY type,name") (sqlite-select fresh "SELECT type,name FROM sqlite_master ORDER BY type,name"))) (dolist (table (sqlite-select db "SELECT name FROM sqlite_master WHERE type='table'")) (let ((sql (format "PRAGMA table_info(%s)" (car table)))) (should (equal (sqlite-select db sql) (sqlite-select fresh sql)))))) (sqlite-close db) (sqlite-close fresh)))) (ert-deftest jabber-test-archive-migration-faults-reopen-retry () "Roll back each DDL/version boundary on error/quit, close, reopen and retry." (dolist (failure '(error quit)) (dotimes (boundary 5) (let* ((dir (make-temp-file "jabber-migration-" t)) (jabber-db-path (expand-file-name "history.sqlite" dir)) (jabber-db--connection nil) (raw (sqlite-open jabber-db-path)) (execute (symbol-function 'sqlite-execute)) (count 0) before schema) (unwind-protect (progn (jabber-test-archive-migration--populate raw) (setq before (jabber-test-archive-migration--data raw) schema (jabber-test-archive-migration--schema raw)) (sqlite-close raw) (cl-letf (((symbol-function 'sqlite-execute) (lambda (db sql &rest args) (prog1 (apply execute db sql args) (when (or (string-prefix-p "ALTER TABLE message ADD COLUMN" sql) (string-prefix-p "CREATE TABLE IF NOT EXISTS mam_progress" sql) (string-prefix-p "CREATE TABLE IF NOT EXISTS message_archive" sql) (equal sql "PRAGMA user_version=12")) (when (= (prog1 count (cl-incf count)) boundary) (signal failure '("Migration fault")))))))) (should (eq failure (condition-case err (progn (jabber-db-ensure-open) nil) ((error quit) (car err)))))) (should-not jabber-db--connection) (setq raw (sqlite-open jabber-db-path)) (should (equal schema (jabber-test-archive-migration--schema raw))) (should (equal before (jabber-test-archive-migration--data raw))) (sqlite-close raw) (jabber-db-ensure-open) (should (equal before (jabber-test-archive-migration--data jabber-db--connection before))) (jabber-db-close) (jabber-db-ensure-open) (should (equal (list (list jabber-db--schema-version)) (sqlite-select jabber-db--connection "PRAGMA user_version")))) (jabber-db-close) (ignore-errors (sqlite-close raw)) (delete-directory dir t)))))) (ert-deftest jabber-test-archive-migration-nonlocal-exit-preserves-owner () "A nonlocal exit inside a caller transaction preserves its earlier work." (let ((db (sqlite-open)) (execute (symbol-function 'sqlite-execute))) (unwind-protect (progn (jabber-test-archive-migration--populate db) (sqlite-execute db "BEGIN") (sqlite-execute db "UPDATE message SET body='owner work' WHERE id=1") (should (eq 'stopped (catch 'stop (cl-letf (((symbol-function 'sqlite-execute) (lambda (connection sql &rest args) (prog1 (apply execute connection sql args) (when (equal sql "PRAGMA user_version=13") (throw 'stop 'stopped)))))) (jabber-db--migrate db))))) (should (equal '((11)) (sqlite-select db "PRAGMA user_version"))) (should (equal '(("owner work")) (sqlite-select db "SELECT body FROM message"))) (sqlite-execute db "COMMIT") (jabber-db--migrate db) (should (equal (list (list jabber-db--schema-version)) (sqlite-select db "PRAGMA user_version")))) (sqlite-close db)))) (defun jabber-test-archive-migration--v12 (db) "Populate historical v12 data in DB, including identities and archive state." (jabber-test-archive-migration--populate db) (jabber-db--migrate-v11-to-v12 db) (sqlite-execute db "UPDATE message SET origin_id='origin',room_id='room'") (sqlite-execute db "INSERT INTO message_archive VALUES ('me','archive','uid',1)") (sqlite-execute db "INSERT INTO mam_progress VALUES ('me','archive','','uid',NULL)")) (ert-deftest jabber-test-archive-migration-v13-preserves-data-and-indexes () "Add the same nonunique indexes as fresh schema without changing any data." (let ((db (sqlite-open)) (fresh (sqlite-open))) (unwind-protect (progn (jabber-test-archive-migration--v12 db) (let ((before (jabber-test-archive-migration--data db)) (archive (sqlite-select db "SELECT * FROM message_archive")) (progress (sqlite-select db "SELECT * FROM mam_progress"))) (jabber-db--migrate db) (should (equal before (jabber-test-archive-migration--data db))) (should (equal archive (sqlite-select db "SELECT * FROM message_archive"))) (should (equal progress (sqlite-select db "SELECT * FROM mam_progress")))) (jabber-db--migrate fresh) (dolist (name '("idx_msg_origin_id" "idx_msg_room_id")) (let ((sql "SELECT sql FROM sqlite_master WHERE name=?")) (should (equal (sqlite-select db sql (list name)) (sqlite-select fresh sql (list name)))))) ;; Identity collisions remain stored, never suppressed by a UNIQUE index. (sqlite-execute db "INSERT INTO message (account,peer,direction,type,body,timestamp,origin_id,room_id) VALUES ('me','peer','in','chat','collision',2,'origin','room')") (should (equal '((2)) (sqlite-select db "SELECT count(*) FROM message WHERE origin_id='origin'"))) (should (equal '(("ok")) (sqlite-select db "PRAGMA integrity_check"))) (should-not (sqlite-select db "PRAGMA foreign_key_check"))) (sqlite-close db) (sqlite-close fresh)))) (ert-deftest jabber-test-archive-migration-v13-faults-reopen-retry () "Roll back both indexes/version on error or quit, reopen and retry safely." (dolist (failure '(error quit)) (dotimes (boundary 3) (let* ((dir (make-temp-file "jabber-v13-" t)) (jabber-db-path (expand-file-name "history.sqlite" dir)) (jabber-db--connection nil) (raw (sqlite-open jabber-db-path)) (execute (symbol-function 'sqlite-execute)) (count 0) before schema archive progress) (unwind-protect (progn (jabber-test-archive-migration--v12 raw) (setq before (jabber-test-archive-migration--data raw) schema (jabber-test-archive-migration--schema raw) archive (sqlite-select raw "SELECT * FROM message_archive") progress (sqlite-select raw "SELECT * FROM mam_progress")) (sqlite-close raw) (cl-letf (((symbol-function 'sqlite-execute) (lambda (db sql &rest args) (prog1 (apply execute db sql args) (when (or (member sql jabber-db--identity-index-ddl) (equal sql "PRAGMA user_version=13")) (when (= (prog1 count (cl-incf count)) boundary) (signal failure '("Index migration fault")))))))) (should (eq failure (condition-case err (progn (jabber-db-ensure-open) nil) ((error quit) (car err)))))) (should-not jabber-db--connection) (setq raw (sqlite-open jabber-db-path)) (should (equal schema (jabber-test-archive-migration--schema raw))) (should (equal before (jabber-test-archive-migration--data raw))) (should (equal archive (sqlite-select raw "SELECT * FROM message_archive"))) (should (equal progress (sqlite-select raw "SELECT * FROM mam_progress"))) (sqlite-close raw) (jabber-db-ensure-open) (should (equal before (jabber-test-archive-migration--data jabber-db--connection))) (should (equal (list (list jabber-db--schema-version)) (sqlite-select jabber-db--connection "PRAGMA user_version")))) (jabber-db-close) (ignore-errors (sqlite-close raw)) (delete-directory dir t)))))) (provide 'jabber-test-archive-migration) ;;; jabber-test-archive-migration.el ends here emacs-jabber-0.15.1/tests/jabber-test-archive-persistence.el000066400000000000000000000635111527111033600237450ustar00rootroot00000000000000;;; jabber-test-archive-persistence.el --- Durable archive proof -*- lexical-binding: t; -*- (require 'ert) (require 'jabber-archive-test-helpers) (require 'jabber-message-reply) (require 'jabber-reactions) (ert-deftest jabber-test-archive-origin-transport-reopen () "Preserve distinct origin and transport IDs through real incoming storage." (jabber-test-archive--with-file (let ((xml '(message ((from . "friend@example.com/mobile") (type . "chat") (id . "transport")) (body () "original") (origin-id ((xmlns . "urn:xmpp:sid:0") (id . "origin")))))) (jabber-db--message-handler jc xml) (jabber-db-close) (let ((stored (car (jabber-db-backlog "me@example.com" "friend@example.com")))) (should (equal (plist-get stored :id) "transport")) (should (equal (jabber-message-reply--select-id stored nil) "origin")) (should (equal "original" (jabber-db-reply-target-body "me@example.com" "friend@example.com" "origin" nil))) (should (equal "original" (jabber-db-reply-target-body "me@example.com" "friend@example.com" "transport" nil))))))) (ert-deftest jabber-test-archive-room-personal-replay () "Keep trusted room action identity across two archive authorities." (jabber-test-archive--with-file (let ((inner '(message ((from . "room@example.com/nick") (to . "me@example.com") (type . "groupchat") (id . "transport")) (body () "room message") (stanza-id ((xmlns . "urn:xmpp:sid:0") (by . "room@example.com") (id . "room-id")))))) (dolist (archive '(nil "room@example.com")) (let ((query (jabber-mam--query jc nil nil nil nil archive))) (jabber-mam--process-message jc (jabber-test-archive--result query (if archive "room-uid" "personal-uid") inner)) (jabber-test-archive--fin jc query (if archive "room-uid" "personal-uid")))) (jabber-db-close) (let ((rows (jabber-db-backlog "me@example.com" "room@example.com" nil nil nil "groupchat"))) (should (= 1 (length rows))) (should (equal "room-id" (jabber-message-reply--select-id (car rows) t))))))) (ert-deftest jabber-test-archive-bodyless-fin-progress () "Advance a bodyless page without borrowing a message row's identity." (jabber-test-archive--with-file (let ((query (jabber-mam--query jc))) (jabber-mam--process-message jc (jabber-test-archive--result query "bodyless" '(message ((from . "friend@example.com") (to . "me@example.com"))))) (jabber-test-archive--fin jc query "bodyless")) (jabber-db-close) (let (request) (cl-letf (((symbol-function 'jabber-mam--query) (lambda (&rest args) (setq request args)))) (jabber-mam--catch-up jc)) (should (equal (cadr request) "bodyless"))))) (ert-deftest jabber-test-archive-commit-is-the-receipt () "Independent SQLite readers see each result at its commit, progress at fin. Each page settles independently of other pending pages." (jabber-test-archive--with-file (let* ((first (jabber-mam--query jc)) (second (jabber-mam--query jc nil nil nil nil "room@example.com")) (reader (sqlite-open jabber-db-path))) (unwind-protect (progn (jabber-mam--process-message jc (jabber-test-archive--result first "uid" '(message ((from . "friend@example.com/phone") (type . "chat") (id . "one")) (body () "visible at commit")))) (should (equal '(("visible at commit")) (sqlite-select reader "SELECT body FROM message"))) (should-not (sqlite-select reader "SELECT uid FROM mam_progress")) (jabber-test-archive--fin jc first "uid") (should (equal '(("uid")) (sqlite-select reader "SELECT uid FROM mam_progress"))) (jabber-test-archive--fin jc second "room-uid") (should (equal '(("uid") ("room-uid")) (sqlite-select reader "SELECT uid FROM mam_progress ORDER BY archive")))) (sqlite-close reader))))) (ert-deftest jabber-test-archive-predecessor-cas-and-backfill () "Late same-scope completion and backward history cannot regress progress." (jabber-test-archive--with-file (let ((older (jabber-mam--query jc)) (newer (jabber-mam--query jc))) (jabber-test-archive--fin jc newer "newer") (jabber-test-archive--fin jc older "older")) (should (equal '("newer" nil) (jabber-test-archive--progress))) (let ((backfill (jabber-mam--query jc nil nil nil nil nil t 10))) (jabber-mam--process-message jc (jabber-test-archive--result backfill "old-history" '(message ((from . "friend@example.com/phone") (type . "chat") (id . "old")) (body () "older")))) (jabber-test-archive--fin jc backfill "old-history")) (jabber-db-store-message "me@example.com" "room@example.com" "in" "groupchat" "live" 1 "someone" "live-id" "unrelated-room") ;; Arrival order and equal/archive timestamps have no cursor authority. (dolist (entry '((42 "tie-a") (42 "tie-b") (2 "late-old"))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" (cadr entry) (car entry) "phone" (cadr entry) (cadr entry))) (jabber-db-close) (should (equal '("newer" nil) (jabber-test-archive--progress))))) (ert-deftest jabber-test-archive-scopes-and-wire-cursors () "Keep two accounts, personal/two room archives and peer filters distinct." (jabber-test-archive--with-file (let ((other (jabber-test-mam--native-connection "other"))) (dolist (connection (list jc other)) (dolist (archive '(nil "room@example.com" "second@example.com")) (dolist (with '(nil "friend@example.com")) (let* ((account (jabber-connection-bare-jid connection)) (uid (format "%s/%s/%s" account archive with)) (query (jabber-mam--query connection nil nil with nil archive))) (jabber-mam--handle-fin connection `(iq ((from . ,(or archive account))) (fin ((xmlns . "urn:xmpp:mam:2") (complete . "true")) (set ((xmlns . "http://jabber.org/protocol/rsm")) (last () ,uid)))) (cons query (plist-get query :page))))))) (jabber-db-close) (dolist (connection (list jc other)) (dolist (kind '(global peer room second)) (let* ((account (jabber-connection-bare-jid connection)) (archive (pcase kind ('room "room@example.com") ('second "second@example.com"))) (with (and (eq kind 'peer) "friend@example.com")) sent) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (_jc xml &rest _) (setq sent xml)))) (pcase kind ('global (jabber-mam--catch-up connection)) ('peer (jabber-mam--chat-catch-up connection with nil)) (_ (jabber-mam--muc-catch-up connection archive)))) (let* ((query (car (jabber-xml-get-children sent 'query))) (set (car (jabber-xml-get-children query 'set))) (form (car (jabber-xml-get-children query 'x))) (field (seq-find (lambda (el) (equal "with" (jabber-xml-get-attribute el 'var))) (jabber-xml-get-children form 'field)))) (should (equal archive (jabber-xml-get-attribute sent 'to))) (should (equal with (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value)))))) (should (equal (format "%s/%s/%s" account archive with) (car (jabber-xml-node-children (car (jabber-xml-get-children set 'after))))))) (jabber-mam--cleanup-connection connection))))))) (ert-deftest jabber-test-archive-correction-duplicate-and-empty-pages () "Progress correction-only, duplicate-only and empty pages without new rows." (jabber-test-archive--with-file (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "before" 1 "phone" "original" "initial") (let ((query (jabber-mam--query jc))) (jabber-mam--process-message jc (jabber-test-archive--result query "edit-uid" '(message ((from . "friend@example.com/phone") (type . "chat") (id . "edit")) (body () "after") (replace ((xmlns . "urn:xmpp:message-correct:0") (id . "original")))))) (jabber-test-archive--fin jc query "edit-uid")) (should (equal '(("after")) (sqlite-select jabber-db--connection "SELECT body FROM message"))) (should (equal '("edit-uid" nil) (jabber-test-archive--progress))) (let ((query (jabber-mam--query jc "edit-uid"))) (jabber-mam--process-message jc (jabber-test-archive--result query "initial" '(message ((from . "friend@example.com/phone") (type . "chat") (id . "original")) (body () "before")))) (jabber-test-archive--fin jc query "duplicate-page")) (let ((query (jabber-mam--query jc "duplicate-page"))) (jabber-test-archive--fin jc query nil)) (jabber-db-close) (should (equal '("duplicate-page" nil) (jabber-test-archive--progress))) (should (equal '(("after")) (sqlite-select jabber-db--connection "SELECT body FROM message"))))) (ert-deftest jabber-test-archive-stale-uid-preserves-coverage () "Stale UID recovery keeps the durable lower bound despite a long absence." (jabber-test-archive--with-file (let ((query (jabber-mam--query jc nil nil nil "2001-01-01T00:00:00Z"))) (jabber-test-archive--fin jc query "gone")) (jabber-db-close) (let ((jabber-mam-catch-up-days 1) sent) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (_jc xml &rest _) (push xml sent)))) (let* ((query (jabber-mam--catch-up jc)) (closure (cons query (plist-get query :page)))) (jabber-mam--handle-error jc '(iq () (error () (item-not-found ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))) closure) (should-not (plist-get query :after)) (should (equal "2001-01-01T00:00:00Z" (plist-get query :start))) (should (= 2 (length sent))) (jabber-test-archive--fin jc query "recovered")))) (should (equal '("recovered" "2001-01-01T00:00:00Z") (jabber-test-archive--progress))) ;; A different, unknown archive never borrows history or recent-days policy. (let ((query (jabber-mam--query jc nil nil nil nil "new-room@example.com"))) (should-not (plist-get query :start))))) (ert-deftest jabber-test-archive-commit-fault-rolls-back () "A native COMMIT failure rolls back the result and fails its page, then retries." (jabber-test-archive--with-file (let ((query (jabber-mam--query jc)) outcome (execute (symbol-function 'sqlite-execute))) (plist-put query :result-callback (lambda (value) (setq outcome value))) (cl-letf (((symbol-function 'sqlite-execute) (lambda (db sql &rest args) (if (equal sql "COMMIT") (error "Commit fault") (apply execute db sql args))))) (should-error (jabber-mam--process-message jc (jabber-test-archive--result query "failed" '(message ((from . "friend@example.com/phone") (type . "chat") (id . "one")) (body () "uncommitted")))))) (should (jabber-test-archive--idle-p)) (jabber-test-archive--fin jc query "failed") (should (eq outcome 'failed))) (jabber-db-close) (should-not (jabber-test-archive--progress)) (should-not (sqlite-select jabber-db--connection "SELECT id FROM message")) (let ((query (jabber-mam--query jc))) (jabber-test-archive--fin jc query "retry")) (should (equal '("retry" nil) (jabber-test-archive--progress))))) (ert-deftest jabber-test-archive-failed-or-retired-pages-do-not-progress () "Reject malformed fin, store/decrypt/downstream faults and retired owners." (dolist (failure '(cancel stale store decrypt downstream malformed)) (jabber-test-archive--with-file (let* ((query (jabber-mam--query jc)) (xml (jabber-test-archive--result query "bad" '(message ((from . "friend@example.com/phone") (type . "chat") (id . "one")) (body () "body"))))) (pcase failure ('cancel (jabber-mam--cleanup-connection jc)) ('stale (plist-put (fsm-get-state-data jc) :connection (list 'replacement))) ('store (cl-letf (((symbol-function 'jabber-db-store-message) (lambda (&rest _) (error "Store fault")))) (should-error (jabber-mam--process-message jc xml)))) ('decrypt (cl-letf (((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (&rest _) (error "Decrypt fault")))) (should-error (jabber-mam--process-message jc xml)))) ('downstream (let ((called 0)) (let ((debug-on-error nil) (jabber-message-chain (list #'jabber-mam--process-message (cons 0 (lambda (_jc xml) (when (jabber-xml-get-attribute xml 'jabber-mam--origin) (cl-incf called) (error "Downstream fault"))))))) (jabber-process-input jc (jabber-test-archive--result query "bad" '(message ((from . "friend@example.com")))))) (should (= called 1)))) ('malformed (jabber-mam--handle-fin jc '(iq () (wrong ((xmlns . "urn:xmpp:mam:2") (complete . "true")))) (cons query (plist-get query :page))))) (jabber-test-archive--fin jc query "bad") (jabber-mam--cleanup-connection jc)) (jabber-db-close) (should-not (jabber-test-archive--progress))))) (ert-deftest jabber-test-archive-completed-room-retirement-before-commit () "Room leave before fin revokes that room's progress only." (jabber-test-archive--with-file (let ((room (jabber-mam--query jc nil nil nil nil "room@example.com")) (personal (jabber-mam--query jc))) (jabber-mam--cancel-muc-query "room@example.com" jc) (jabber-test-archive--fin jc room "retired") (jabber-test-archive--fin jc personal "personal")) (jabber-db-close) (should-not (jabber-test-archive--progress nil "room@example.com")) (should (equal '("personal" nil) (jabber-test-archive--progress))))) (ert-deftest jabber-test-archive-live-room-actions-and-tombstone-replay () "Retain room reply/reaction/retraction identity through live and two archives." (jabber-test-archive--with-file (let ((jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--generation 0) (inner '(message ((from . "room@example.com/nick") (to . "me@example.com") (type . "groupchat") (id . "transport")) (body () "retained") (thread () "thread") (origin-id ((xmlns . "urn:xmpp:sid:0") (id . "origin"))) (stanza-id ((xmlns . "urn:xmpp:sid:0") (by . "room@example.com") (id . "room-id")))))) (jabber-muc-join-set "room@example.com" jc "me") (jabber-db--message-handler jc inner) (dolist (archive '(nil "room@example.com")) (let ((query (jabber-mam--query jc nil nil nil nil archive t 10))) (jabber-mam--process-message jc (jabber-test-archive--result query (if archive "room-uid" "personal-uid") inner)) (jabber-test-archive--fin jc query (if archive "room-uid" "personal-uid")))) (jabber-db-close) (let* ((rows (jabber-db-backlog "me@example.com" "room@example.com" nil nil nil "groupchat")) (stored (car rows))) (should (= 1 (length rows))) (should (equal "room-id" (jabber-message-reply--select-id stored t))) (should (equal "room-id" (jabber-reactions--target-id stored t))) (should (equal "origin" (plist-get stored :origin-id))) (should (equal "transport" (plist-get stored :id))) (should (= 1 (length (jabber-db-message-retraction-candidates "me@example.com" "room@example.com" "room-id")))) (should-not (jabber-db-message-retraction-candidates "me@example.com" "room@example.com" "personal-uid")) (should (equal '(("me@example.com" "personal-uid") ("room@example.com" "room-uid")) (sqlite-select jabber-db--connection "SELECT archive,uid FROM message_archive ORDER BY archive"))) (jabber-db-retract-message-row (plist-get stored :db-id) nil) (let ((query (jabber-mam--query jc nil nil nil nil nil t 10))) (jabber-mam--process-message jc (jabber-test-archive--result query "personal-uid" inner)) (jabber-test-archive--fin jc query "personal-uid")) (jabber-db-close) (let ((after (car (jabber-db-backlog "me@example.com" "room@example.com" nil nil nil "groupchat")))) (should (plist-get after :retracted)) (should (equal "thread" (plist-get after :thread-id))) (should (equal "retained" (plist-get after :body)))))))) (ert-deftest jabber-test-archive-occurrence-conflicts-preserve-row () "Never enrich a different sender, type or ID under an existing archive UID." (dolist (conflict '(sender type transport origin)) (jabber-test-archive--with-file (let ((inner '(message ((from . "friend@example.com/phone") (to . "me@example.com") (type . "chat") (id . "transport")) (body () "retained") (origin-id ((xmlns . "urn:xmpp:sid:0") (id . "origin")))))) (let ((query (jabber-mam--query jc))) (jabber-mam--process-message jc (jabber-test-archive--result query "uid" inner)) (jabber-test-archive--fin jc query "uid")) (let* ((changed (copy-tree inner)) (query (jabber-mam--query jc nil nil nil nil nil t 10))) (pcase conflict ('sender (setf (alist-get 'from (cadr changed)) "friend@example.com/other")) ('type (setf (alist-get 'type (cadr changed)) "headline")) ('transport (setf (alist-get 'id (cadr changed)) "different")) ('origin (setf (alist-get 'id (cadr (car (jabber-xml-get-children changed 'origin-id)))) "different"))) (should-error (jabber-mam--process-message jc (jabber-test-archive--result query "uid" changed))) (jabber-test-archive--fin jc query "uid")) (jabber-db-close) (should (equal '(("retained" "transport" "origin" "phone")) (sqlite-select (jabber-db-ensure-open) "SELECT body,stanza_id,origin_id,resource FROM message"))))))) (ert-deftest jabber-test-archive-conflicting-origin-does-not-merge () "A reused transport ID cannot replace another origin ID." (jabber-test-archive--with-file (dolist (origin '("first" "second")) (jabber-db--message-handler jc `(message ((from . "friend@example.com/phone") (type . "chat") (id . "transport")) (body () "equal body") (origin-id ((xmlns . "urn:xmpp:sid:0") (id . ,origin)))))) (jabber-db-close) (should (equal '(("first") ("second")) (sqlite-select (jabber-db-ensure-open) "SELECT origin_id FROM message ORDER BY id"))))) (ert-deftest jabber-test-archive-legacy-unknown-evidence () "Keep legacy server semantics and infer neither origins nor archive coverage." (jabber-test-archive--with-file (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "legacy" 1 "phone" "transport" "unknown") (should-not (jabber-test-archive--progress)) (jabber-db--message-handler jc '(message ((from . "friend@example.com/phone") (type . "chat") (id . "transport")) (body () "legacy") (origin-id ((xmlns . "urn:xmpp:sid:0") (id . "proven"))))) (jabber-db-close) (should (equal '(("unknown" "proven" nil)) (sqlite-select (jabber-db-ensure-open) "SELECT server_id,origin_id,room_id FROM message"))) (should-not (sqlite-select jabber-db--connection "SELECT * FROM message_archive")))) (ert-deftest jabber-test-archive-progress-sql-fault-and-retry () "Fail the page when SQLite rejects its cursor; the retry deduplicates." (jabber-test-archive--with-file (sqlite-execute jabber-db--connection "CREATE TRIGGER reject_progress BEFORE INSERT ON mam_progress BEGIN SELECT RAISE(ABORT, 'cursor fault'); END") (let ((query (jabber-mam--query jc))) (jabber-mam--process-message jc (jabber-test-archive--result query "uid" '(message ((from . "friend@example.com/phone") (type . "chat") (id . "one")) (body () "atomic")))) (should-error (jabber-test-archive--fin jc query "uid")) (should-not jabber-mam--syncing)) (jabber-db-close) (should-not (jabber-test-archive--progress)) (should (equal '(("atomic")) (sqlite-select jabber-db--connection "SELECT body FROM message"))) (sqlite-execute jabber-db--connection "DROP TRIGGER reject_progress") (let ((query (jabber-mam--query jc))) (jabber-mam--process-message jc (jabber-test-archive--result query "uid" '(message ((from . "friend@example.com/phone") (type . "chat") (id . "one")) (body () "atomic")))) (jabber-test-archive--fin jc query "uid")) (jabber-db-close) (should (equal '("uid" nil) (jabber-test-archive--progress))) (should (equal '(("atomic")) (sqlite-select jabber-db--connection "SELECT body FROM message"))))) (ert-deftest jabber-test-archive-pagination-send-failure () "A failed next-page send retains only the already committed predecessor." (jabber-test-archive--with-file (let ((query (jabber-mam--query jc))) (jabber-mam--handle-fin jc '(iq ((from . "me@example.com")) (fin ((xmlns . "urn:xmpp:mam:2")) (set ((xmlns . "http://jabber.org/protocol/rsm")) (last () "accepted")))) (cons query (plist-get query :page))) (cancel-timer (plist-get query :timer)) (plist-put query :timer nil) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (&rest _) (error "Send failed")))) (jabber-mam--send-page query)) (should-not jabber-mam--syncing)) (jabber-db-close) (should (equal '("accepted" nil) (jabber-test-archive--progress))))) ;; A live action can reference an archived original of the page still ;; in flight. Each result commits on arrival, so the original exists by ;; the time the live handler looks for it. (ert-deftest jabber-test-archive-live-action-during-page () "A live correction or reaction to an in-flight page's result is kept." (dolist (size '(1 50)) (pcase-dolist (`(,action ,room) '((correction nil) (reaction nil) (reaction t))) (jabber-test-archive--with-file (let* ((peer (if room "room@example.com" "friend@example.com")) (from (concat peer (if room "/alice" "/phone"))) (type (if room "groupchat" "chat")) (jabber-mam-page-size size) (jabber-history-inhibit-received-message-functions '(jabber-message-correct--inhibit jabber-reactions--history-inhibit-p)) (jabber-message-chain (list #'jabber-mam--process-message #'jabber-process-chat #'jabber-muc-process-message #'jabber-reactions--handle-message #'jabber-db--message-handler)) (query (jabber-mam--query jc nil nil nil nil (and room peer)))) (jabber-process-input jc (jabber-test-archive--result query "target" `(message ((from . ,from) (type . ,type) (id . "target")) (body () "original") ,@(when room '((stanza-id ((xmlns . "urn:xmpp:sid:0") (by . "room@example.com") (id . "target")))))))) (jabber-process-input jc (if (eq action 'correction) `(message ((from . ,from) (type . ,type) (id . "edit")) (body () "corrected") (replace ((xmlns . "urn:xmpp:message-correct:0") (id . "target")))) `(message ((from . ,from) (type . ,type)) (reactions ((xmlns . "urn:xmpp:reactions:0") (id . "target")) (reaction () "good"))))) (jabber-test-archive--fin jc query "target") (jabber-db-close) (should (equal (if (eq action 'correction) '(("corrected")) '(("original"))) (sqlite-select (jabber-db-ensure-open) "SELECT body FROM message"))) (should (equal (and (eq action 'reaction) '(("good"))) (sqlite-select jabber-db--connection "SELECT reaction FROM message_reaction"))) (should (equal '("target" nil) (jabber-test-archive--progress nil (and room peer))))))))) (provide 'jabber-test-archive-persistence) ;;; jabber-test-archive-persistence.el ends here emacs-jabber-0.15.1/tests/jabber-test-archive-recovery.el000066400000000000000000000346201527111033600232560ustar00rootroot00000000000000;;; jabber-test-archive-recovery.el --- Native rollback and reply proof -*- lexical-binding: t; -*- (require 'jabber-archive-test-helpers) (require 'jabber-omemo-store) (require 'jabber-chat) ;; A real application writer, not a mocked execute or trigger, hits ;; SQLITE_FULL. It rolls back only itself, never a committed result. (ert-deftest jabber-test-archive-recovery-native-store-full () "A full database rolls back only its own write, never a committed result." (dolist (paginate '(nil t)) (jabber-test-archive--with-file (let ((jabber-mam--peer-syncing nil)) (jabber-test-archive--fin jc (jabber-mam--query jc) "predecessor") (sqlite-execute jabber-db--connection (format "PRAGMA max_page_count=%d" (+ 20 (caar (sqlite-select jabber-db--connection "PRAGMA page_count"))))) (let* ((first (jabber-mam--catch-up jc)) (second (jabber-mam--query jc nil nil "friend@example.com")) (inner '(message ((from . "friend@example.com/phone") (type . "chat") (id . "kept")) (body () "must survive with cursor"))) outcome) (should (equal "predecessor" (plist-get first :after))) (plist-put second :result-callback (lambda (value) (setq outcome value))) (jabber-mam--process-message jc (jabber-test-archive--result first "kept-message-uid" inner)) (let ((err (should-error (jabber-omemo-store-save "me@example.com" (make-string (* 1024 1024) ?x)) :type 'sqlite-error))) (should (string-match-p "full" (error-message-string err)))) (if paginate (jabber-mam--handle-fin jc '(iq () (fin ((xmlns . "urn:xmpp:mam:2")) (set ((xmlns . "http://jabber.org/protocol/rsm")) (last () "kept-message-uid")))) (cons first (plist-get first :page))) (jabber-test-archive--fin jc first "kept-message-uid")) (jabber-test-archive--fin jc second nil) (should (eq outcome 'success)) (should (eq paginate (and (memq first jabber-mam--syncing) t))) (jabber-mam--cleanup-connection jc) (should-not jabber-mam--dirty-peers) (should-not jabber-open-info-queries) (should-not (plist-get first :timer)) (jabber-db-close) (should (equal '("kept-message-uid" nil) (jabber-test-archive--progress))) (should (equal '(("must survive with cursor")) (sqlite-select jabber-db--connection "SELECT body FROM message")))))))) (ert-deftest jabber-test-archive-recovery-own-result-store-full () "A full database rolls back its result and fails the page without a cursor." (jabber-test-archive--with-file (jabber-test-archive--fin jc (jabber-mam--query jc) "predecessor") (sqlite-execute jabber-db--connection (format "PRAGMA max_page_count=%d" (+ 20 (caar (sqlite-select jabber-db--connection "PRAGMA page_count"))))) (let ((query (jabber-mam--catch-up jc)) (inner `(message ((from . "friend@example.com/phone") (type . "chat") (id . "lost")) (body () ,(make-string (* 1024 1024) ?x))))) (let ((err (should-error (jabber-mam--process-message jc (jabber-test-archive--result query "lost-uid" inner)) :type 'sqlite-error))) (should (string-match-p "full" (error-message-string err)))) (should (jabber-test-archive--idle-p)) (jabber-test-archive--fin jc query "lost-uid") (should (plist-get query :failed)) (should-not jabber-mam--syncing)) (jabber-db-close) (should (equal '("predecessor" nil) (jabber-test-archive--progress))) (should-not (sqlite-select jabber-db--connection "SELECT body FROM message")))) (ert-deftest jabber-test-archive-recovery-statement-local-fault () "Keep valid page effects when only another writer's statement aborts." (jabber-test-archive--with-file (sqlite-execute jabber-db--connection "CREATE TABLE unique_control (id INTEGER PRIMARY KEY)") (sqlite-execute jabber-db--connection "INSERT INTO unique_control VALUES (1)") (let ((first (jabber-mam--query jc)) (second (jabber-mam--query jc nil nil "friend@example.com"))) (jabber-mam--process-message jc (jabber-test-archive--result first "retained" '(message ((from . "friend@example.com/phone") (type . "chat") (id . "one")) (body () "statement survives")))) (jabber-test-archive--fin jc first "retained") (should-error (sqlite-execute jabber-db--connection "INSERT INTO unique_control VALUES (1)") :type 'sqlite-error) (jabber-test-archive--fin jc second nil)) (jabber-db-close) (should (equal '("retained" nil) (jabber-test-archive--progress))) (should (equal '(("statement survives")) (sqlite-select jabber-db--connection "SELECT body FROM message"))))) (ert-deftest jabber-test-archive-recovery-statement-full () "An FTS correction SQLITE_FULL can abort only its statement, not the page." (jabber-test-archive--with-file (sqlite-execute jabber-db--connection (format "PRAGMA max_page_count=%d" (+ 20 (caar (sqlite-select jabber-db--connection "PRAGMA page_count"))))) (let ((first (jabber-mam--query jc)) (second (jabber-mam--query jc nil nil "friend@example.com"))) (jabber-mam--process-message jc (jabber-test-archive--result first "retained" '(message ((from . "friend@example.com/phone") (type . "chat") (id . "original")) (body () "retained body")))) (jabber-test-archive--fin jc first "retained") (let ((err (should-error (jabber-mam--process-message jc (jabber-test-archive--result second "fault" `(message ((from . "friend@example.com/phone") (type . "chat") (id . "edit")) (body () ,(make-string (* 1024 1024) ?x)) (replace ((xmlns . "urn:xmpp:message-correct:0") (id . "original")))))) :type 'sqlite-error))) (should (string-match-p "full" (error-message-string err)))) (jabber-test-archive--fin jc second "fault")) (jabber-db-close) (should (equal '("retained" nil) (jabber-test-archive--progress))) (should-not (jabber-test-archive--progress nil nil "friend@example.com")) (should (equal '(("retained body")) (sqlite-select jabber-db--connection "SELECT body FROM message"))))) (ert-deftest jabber-test-archive-recovery-replacement-transaction () "A result never joins, commits or ends another writer's open transaction." (jabber-test-archive--with-file (let ((first (jabber-mam--query jc)) (second (jabber-mam--query jc nil nil "friend@example.com"))) (jabber-test-archive--fin jc first "durable") (sqlite-execute jabber-db--connection "BEGIN") (sqlite-execute jabber-db--connection "INSERT INTO mam_progress (account, archive, scope, uid) VALUES ('me@example.com', 'me@example.com', 'foreign@example.com', 'foreign')") (should-error (jabber-mam--process-message jc (jabber-test-archive--result second "blessed" '(message ((from . "friend@example.com/phone") (type . "chat") (id . "one")) (body () "never blessed")))) :type 'sqlite-error) (should (plist-get second :failed)) ;; The foreign transaction is still open and still owns its write. (should-not (jabber-test-archive--idle-p)) (should (jabber-test-archive--progress nil nil "foreign@example.com")) (sqlite-execute jabber-db--connection "ROLLBACK") (jabber-test-archive--fin jc second "blessed") (should-not jabber-mam--syncing)) (jabber-db-close) (should (equal '("durable" nil) (jabber-test-archive--progress))) (should-not (jabber-test-archive--progress nil nil "friend@example.com")) (should-not (jabber-test-archive--progress nil nil "foreign@example.com")) (should-not (sqlite-select jabber-db--connection "SELECT body FROM message")))) (ert-deftest jabber-test-archive-recovery-native-commit-fault () "A deferred foreign-key failure at native COMMIT rolls back its result." (jabber-test-archive--with-file (sqlite-execute jabber-db--connection "CREATE TABLE control_parent(id INTEGER PRIMARY KEY)") (sqlite-execute jabber-db--connection "CREATE TABLE control_child(parent INTEGER REFERENCES control_parent(id) DEFERRABLE INITIALLY DEFERRED)") (let ((query (jabber-mam--query jc)) outcome (execute (symbol-function 'sqlite-execute))) (plist-put query :result-callback (lambda (value) (setq outcome value))) ;; Violate the deferred constraint inside the result's own transaction. (cl-letf (((symbol-function 'sqlite-execute) (lambda (db sql &rest args) (when (equal sql "COMMIT") (funcall execute db "INSERT INTO control_child VALUES (999)")) (apply execute db sql args)))) (should-error (jabber-mam--process-message jc (jabber-test-archive--result query "uid" '(message ((from . "friend@example.com/phone") (type . "chat") (id . "one")) (body () "atomic")))) :type 'sqlite-error)) (should (jabber-test-archive--idle-p)) (jabber-test-archive--fin jc query "uid") (should (eq 'failed outcome)) (should-not jabber-mam--syncing) (should-not jabber-mam--dirty-peers)) (jabber-db-close) (should-not (jabber-test-archive--progress)) (should-not (sqlite-select jabber-db--connection "SELECT * FROM message")) (should-not (sqlite-select jabber-db--connection "SELECT * FROM control_child")) (jabber-test-archive--fin jc (jabber-mam--query jc) "retry") (should (equal '("retry" nil) (jabber-test-archive--progress))))) (ert-deftest jabber-test-archive-recovery-outgoing-reply-context () "Resolve native outgoing replies before and after archive enrichment." (jabber-test-archive--with-file (with-temp-buffer (setq-local jabber-buffer-connection jc) (setq-local jabber-chatting-with "friend@example.com") (let ((jabber-chat-encryption nil) (jabber-chat--sending-correction nil) (jabber-chat--send-hook-stanza nil)) (jabber-db--outgoing-handler "original outgoing body" "sent-id")) (dolist (enrich '(nil t)) (when enrich (let ((query (jabber-mam--query jc))) (jabber-mam--process-message jc (jabber-test-archive--result query "archive-uid" '(message ((from . "me@example.com/desktop") (to . "friend@example.com") (type . "chat") (id . "sent-id")) (body () "original outgoing body") (origin-id ((xmlns . "urn:xmpp:sid:0") (id . "origin-id")))))) (jabber-test-archive--fin jc query "archive-uid"))) (dolist (sender '("me@example.com" "me@example.com/desktop")) (jabber-db--message-handler jc `(message ((from . "friend@example.com/phone") (type . "chat") (id . ,(concat "reply-" sender))) (body () "answer") (reply ((xmlns . "urn:xmpp:reply:0") (id . "sent-id") (to . ,sender))))) (jabber-db-close) (let* ((rows (jabber-db-backlog "me@example.com" "friend@example.com")) (reply (seq-find (lambda (msg) (equal (plist-get msg :id) (concat "reply-" sender))) rows))) (should (equal "original outgoing body" (jabber-chat--reply-context-snippet reply))))) (when enrich (should (equal "original outgoing body" (jabber-db-reply-target-body "me@example.com" "friend@example.com" "origin-id" nil "me@example.com/desktop"))))) (should (= 1 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message WHERE direction = 'out'"))))))) (ert-deftest jabber-test-archive-recovery-reply-sender-controls () "Unknown outgoing resource must not weaken known conflicts or ambiguity." (jabber-test-archive--with-file (ignore jc) (jabber-db-store-message "me@example.com" "friend@example.com" "out" "chat" "known" 1 "desktop" "known-id") (jabber-db-store-message "me@example.com" "friend@example.com" "out" "chat" "unknown" 2 nil "unknown-id") (dolist (case '(("known-id" "me@example.com/phone") ("unknown-id" "other@example.com/desktop") ("unknown-id" "friend@example.com/phone"))) (should-not (jabber-db-reply-target-body "me@example.com" "friend@example.com" (car case) nil (cadr case)))) (should-not (jabber-db-reply-target-body "other@example.com" "friend@example.com" "unknown-id" nil "me@example.com/desktop")) (should-not (jabber-db-reply-target-body "me@example.com" "other@example.com" "unknown-id" nil "me@example.com/desktop")) (should-not (jabber-db-reply-target-body "me@example.com" "friend@example.com" "unknown-id" t "me@example.com/desktop")) ;; Unknown resources remain strict for inbound/room messages. (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "incoming" 3 nil "incoming-id") (should-not (jabber-db-reply-target-body "me@example.com" "friend@example.com" "incoming-id" nil "friend@example.com/phone")) (jabber-db-store-message "me@example.com" "friend@example.com" "out" "chat" "alias collision" 4 "desktop" "second-id" nil nil nil nil nil nil '(:origin-id "unknown-id")) (jabber-db-close) (should-not (jabber-db-reply-target-body "me@example.com" "friend@example.com" "unknown-id" nil "me@example.com/desktop")) (let ((row (caar (sqlite-select jabber-db--connection "SELECT id FROM message WHERE stanza_id = 'known-id'")))) (jabber-db-retract-message-row row nil)) (jabber-db-close) (should-not (jabber-db-reply-target-body "me@example.com" "friend@example.com" "known-id" nil "me@example.com/desktop")))) (provide 'jabber-test-archive-recovery) ;;; jabber-test-archive-recovery.el ends here emacs-jabber-0.15.1/tests/jabber-test-archive-repair.el000066400000000000000000000655101527111033600227040ustar00rootroot00000000000000;;; jabber-test-archive-repair.el --- Historical room reconciliation -*- lexical-binding: t; -*- ;;; Commentary: ;; Schema 13 split rows must repair on open, without content-based discovery. ;;; Code: (require 'jabber-archive-test-helpers) (defun jabber-test-archive-repair--split (jc) "Return (OLD LIVE) historical split row IDs for JC." (let ((old (jabber-db-store-message "me@example.com" "room@conference.example.com" "in" "groupchat" "A repeatable message" 1735689600 "nick"))) (sqlite-execute jabber-db--connection "INSERT INTO message_archive VALUES (?, ?, ?, ?)" (list "me@example.com" "room@conference.example.com" "room-uid" old)) (list old (jabber-db-store-message (jabber-connection-bare-jid jc) "room@conference.example.com" "in" "groupchat" "A repeatable message" 1735689600 "nick" "transport" "room-uid" nil nil nil nil nil '(:room-id "room-uid"))))) (defun jabber-test-archive-repair--open () "Reopen the fixture as an existing schema 13 database." (sqlite-execute jabber-db--connection "PRAGMA user_version=13") (jabber-db-close) (jabber-db-ensure-open)) (ert-deftest jabber-test-archive-repair-open-replay () "Opening repairs a historical split and replay accepts canonical ownership." (jabber-test-archive--with-file (let* ((ids (jabber-test-archive-repair--split jc)) (live (cadr ids))) (jabber-test-archive-repair--open) (should (equal (sqlite-select jabber-db--connection "SELECT id FROM message") (list (list live)))) (should (equal (sqlite-select jabber-db--connection "SELECT message_id FROM message_archive") (list (list live)))) (let ((query (jabber-mam--query jc nil nil nil nil "room@conference.example.com"))) (jabber-mam--process-message jc (jabber-test-archive--result query "room-uid" '(message ((from . "room@conference.example.com/nick") (type . "groupchat")) (body () "A repeatable message")))) (jabber-test-archive--fin jc query "room-uid")) (should (equal '("room-uid" nil) (jabber-test-archive--progress nil "room@conference.example.com"))) (jabber-db-close) (jabber-db-ensure-open) (should (= jabber-db--schema-version (caar (sqlite-select jabber-db--connection "PRAGMA user_version")))) (should (= 1 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message"))))))) (ert-deftest jabber-test-archive-repair-references () "Preserve metadata, relational references, FTS and unrelated rows." (jabber-test-archive--with-file (pcase-let ((`(,old ,live) (jabber-test-archive-repair--split jc))) (sqlite-execute jabber-db--connection "UPDATE message SET delivered_at=7, thread_id='thread' WHERE id=?" (list old)) (sqlite-execute jabber-db--connection "UPDATE message SET displayed_at=8 WHERE id=?" (list live)) (sqlite-execute jabber-db--connection "INSERT INTO message_oob(message_id,url,desc) VALUES (?, 'url', 'description')" (list old)) (sqlite-execute jabber-db--connection "INSERT INTO message_reaction VALUES (?, 'actor', 'like', 9)" (list old)) (sqlite-execute jabber-db--connection "INSERT INTO message_reaction_actor VALUES (?, 'actor', 9)" (list old)) (sqlite-execute jabber-db--connection "INSERT INTO message_thread(account,peer,type,thread_id,root_message_id,created_at,read_message_id,title) VALUES ('me@example.com','room@conference.example.com','groupchat','thread',?,1,?,'title')" (list old live)) (let ((unrelated (jabber-db-store-message "me@example.com" "room@conference.example.com" "in" "groupchat" "A repeatable message" 1735689600 "nick"))) (jabber-test-archive-repair--open) (should (equal (sqlite-select jabber-db--connection "SELECT id FROM message ORDER BY id") (list (list live) (list unrelated))))) (should (equal '((7 8 "thread")) (sqlite-select jabber-db--connection "SELECT delivered_at,displayed_at,thread_id FROM message WHERE id=?" (list live)))) (dolist (table '("message_archive" "message_oob" "message_reaction" "message_reaction_actor")) (should (equal (list (list live)) (sqlite-select jabber-db--connection (format "SELECT message_id FROM %s" table))))) (should (equal (list (list live live "title")) (sqlite-select jabber-db--connection "SELECT root_message_id,read_message_id,title FROM message_thread"))) (should-not (sqlite-select jabber-db--connection "PRAGMA foreign_key_check")) (should (equal '(("ok")) (sqlite-select jabber-db--connection "PRAGMA integrity_check"))) (sqlite-execute jabber-db--connection "INSERT INTO message_fts(message_fts,rank) VALUES ('integrity-check',1)") (should (= 2 (length (sqlite-select jabber-db--connection "SELECT rowid FROM message_fts WHERE message_fts MATCH 'repeatable'"))))))) (ert-deftest jabber-test-archive-repair-conflicts () "Conflicting content, sender, encryption or metadata fails closed." (dolist (assignment '("body='different'" "resource='other'" "encrypted=1" "occupant_id='other'" "edited=1" "retracted=1" "thread_id='different'" "server_id='conflicting'")) (jabber-test-archive--with-file (pcase-let ((`(,old ,live) (jabber-test-archive-repair--split jc))) (sqlite-execute jabber-db--connection "UPDATE message SET occupant_id='known',thread_id='thread' WHERE id=?" (list old)) (sqlite-execute jabber-db--connection (concat "UPDATE message SET " assignment " WHERE id=?") (list live)) (jabber-test-archive-repair--open) (should (= 2 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message")))) (should (equal (list (list old)) (sqlite-select jabber-db--connection "SELECT message_id FROM message_archive"))))))) (ert-deftest jabber-test-archive-repair-ambiguity () "A room ID collision remains ambiguous even with incompatible content." (jabber-test-archive--with-file (pcase-let ((`(,old ,live) (jabber-test-archive-repair--split jc))) (sqlite-execute jabber-db--connection "INSERT INTO message(account,peer,type,direction,timestamp,resource,body,room_id) SELECT account,peer,type,direction,timestamp,resource,'different',room_id FROM message WHERE id=?" (list live)) (jabber-test-archive-repair--open) (should (= 3 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message")))) (should (equal (list (list old)) (sqlite-select jabber-db--connection "SELECT message_id FROM message_archive")))))) (ert-deftest jabber-test-archive-repair-rollback () "A failure after reparenting restores all rows, references and version." (jabber-test-archive--with-file (let* ((ids (jabber-test-archive-repair--split jc)) (old (car ids))) (sqlite-execute jabber-db--connection "PRAGMA user_version=13") (sqlite-execute jabber-db--connection "CREATE TRIGGER repair_failure BEFORE DELETE ON message BEGIN SELECT RAISE(ABORT, 'injected'); END") (should-error (jabber-db--migrate jabber-db--connection)) (should (= 13 (caar (sqlite-select jabber-db--connection "PRAGMA user_version")))) (should (= 2 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message")))) (should (equal (list (list old)) (sqlite-select jabber-db--connection "SELECT message_id FROM message_archive")))))) (ert-deftest jabber-test-archive-repair-scopes () "Personal archives, foreign accounts and foreign rooms cannot authorize repair." (dolist (assignment '("archive='me@example.com'" "account='other@example.com'" "archive='other@conference.example.com'")) (jabber-test-archive--with-file (jabber-test-archive-repair--split jc) (sqlite-execute jabber-db--connection (concat "UPDATE message_archive SET " assignment)) (jabber-test-archive-repair--open) (should (= 2 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message"))))))) (ert-deftest jabber-test-archive-repair-encrypted-and-timestamp () "Keep identical decrypted text and encrypted state; prefer archive time." (jabber-test-archive--with-file (pcase-let ((`(,old ,live) (jabber-test-archive-repair--split jc))) (sqlite-execute jabber-db--connection "UPDATE message SET encrypted=1") (sqlite-execute jabber-db--connection "UPDATE message SET timestamp=timestamp+2 WHERE id=?" (list live)) (jabber-test-archive-repair--open) (should (equal (list (list live "A repeatable message" 1 1735689600)) (sqlite-select jabber-db--connection "SELECT id,body,encrypted,timestamp FROM message"))) (should-not (sqlite-select jabber-db--connection "SELECT id FROM message WHERE id=?" (list old)))))) (ert-deftest jabber-test-archive-repair-reaction-snapshots () "Equal actor snapshots collapse; differing and empty snapshots fail closed." (dolist (snapshot '(same different empty)) (jabber-test-archive--with-file (pcase-let ((`(,old ,live) (jabber-test-archive-repair--split jc))) (dolist (id (list old live)) (sqlite-execute jabber-db--connection "INSERT INTO message_reaction_actor VALUES (?, 'actor', 9)" (list id))) (sqlite-execute jabber-db--connection "INSERT INTO message_reaction VALUES (?, 'actor', 'like', 9)" (list old)) (unless (eq snapshot 'empty) (sqlite-execute jabber-db--connection "INSERT INTO message_reaction VALUES (?, 'actor', ?, 9)" (list live (if (eq snapshot 'same) "like" "other")))) (jabber-test-archive-repair--open) (should (= (if (eq snapshot 'same) 1 2) (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message")))) (when (eq snapshot 'same) (should (equal (list (list live "actor" "like" 9)) (sqlite-select jabber-db--connection "SELECT * FROM message_reaction"))) (should (equal (list (list live "actor" 9)) (sqlite-select jabber-db--connection "SELECT * FROM message_reaction_actor")))))))) (ert-deftest jabber-test-archive-repair-foreign-references () "References with conflicting ownership and room occurrences remain untouched." (dolist (kind '(thread archive occurrence)) (jabber-test-archive--with-file (let ((old (car (jabber-test-archive-repair--split jc)))) (pcase kind ('thread (sqlite-execute jabber-db--connection "INSERT INTO message_thread(account,peer,type,thread_id,root_message_id,created_at) VALUES ('other','foreign','chat','thread',?,1)" (list old))) ('archive (sqlite-execute jabber-db--connection "INSERT INTO message_archive VALUES ('other','personal','uid',?)" (list old))) ('occurrence (sqlite-execute jabber-db--connection "INSERT INTO message_archive VALUES ('me@example.com','room@conference.example.com','different',?)" (list old)))) (jabber-test-archive-repair--open) (should (= 2 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message")))))))) (ert-deftest jabber-test-archive-repair-v14-faults () "Every write boundary rolls back on error/quit; reopen and retry succeeds." (dolist (failure '(error quit)) (dotimes (boundary 12) (jabber-test-archive--with-file (pcase-let* ((`(,old ,live) (jabber-test-archive-repair--split jc)) (execute (symbol-function 'sqlite-execute)) (count 0)) (sqlite-execute jabber-db--connection "PRAGMA user_version=13") (sqlite-execute jabber-db--connection "DROP INDEX idx_archive_message_id") (let ((schema (sqlite-select jabber-db--connection "SELECT type,name,sql FROM sqlite_master ORDER BY name"))) (cl-letf (((symbol-function 'sqlite-execute) (lambda (db sql &rest args) (prog1 (apply execute db sql args) (unless (string-match-p "\\`\\(?:SAVEPOINT\\|RELEASE\\|ROLLBACK\\)" sql) (when (= (prog1 count (cl-incf count)) boundary) (signal failure '("injected")))))))) (should (eq failure (condition-case err (progn (jabber-db--migrate jabber-db--connection) nil) ((error quit) (car err)))))) (should (equal schema (sqlite-select jabber-db--connection "SELECT type,name,sql FROM sqlite_master ORDER BY name")))) (should (= 13 (caar (sqlite-select jabber-db--connection "PRAGMA user_version")))) (should (= 2 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message")))) (should (equal (list (list old)) (sqlite-select jabber-db--connection "SELECT message_id FROM message_archive"))) (jabber-db-close) (jabber-db-ensure-open) (should (equal (list (list live)) (sqlite-select jabber-db--connection "SELECT id FROM message")))))))) (ert-deftest jabber-test-archive-repair-read-boundaries () "Never cross a read boundary, in either direction or with external watermarks." (dolist (reverse '(nil t)) (dolist (watermark '(old live middle)) (jabber-test-archive--with-file (pcase-let ((`(,old ,live) (jabber-test-archive-repair--split jc))) ;; Reserve an intervening unrelated reply and put the pair around it. (sqlite-execute jabber-db--connection "PRAGMA foreign_keys=OFF") (sqlite-execute jabber-db--connection "UPDATE message SET id=4 WHERE id=?" (list (if reverse old live))) (if reverse (progn (sqlite-execute jabber-db--connection "UPDATE message_archive SET message_id=4") (setq old 4)) (setq live 4)) (sqlite-execute jabber-db--connection "PRAGMA foreign_keys=ON") (sqlite-execute jabber-db--connection "UPDATE message SET thread_id='thread'") (sqlite-execute jabber-db--connection "INSERT INTO message(id,account,peer,type,direction,body,timestamp,thread_id) VALUES (3,'me@example.com','room@conference.example.com','groupchat','in','unrelated reply',1,'thread')") (sqlite-execute jabber-db--connection "INSERT INTO message_thread(account,peer,type,thread_id,created_at,read_message_id,dedicated) VALUES ('me@example.com','room@conference.example.com','groupchat','thread',1,?,1)" (list (pcase watermark ('old old) ('live live) (_ 3)))) (let ((before (sqlite-select jabber-db--connection "SELECT * FROM message ORDER BY id")) (thread (sqlite-select jabber-db--connection "SELECT * FROM message_thread")) (unread (plist-get (jabber-db-message-thread-summary "me@example.com" "room@conference.example.com" "groupchat" "thread") :unread))) (jabber-test-archive-repair--open) ;; A watermark at the higher LIVE is already safe and is not remapped. (unless (and (not reverse) (eq watermark 'live)) (should (equal before (sqlite-select jabber-db--connection "SELECT * FROM message ORDER BY id"))) (should (equal thread (sqlite-select jabber-db--connection "SELECT * FROM message_thread")))) (should (eq unread (plist-get (jabber-db-message-thread-summary "me@example.com" "room@conference.example.com" "groupchat" "thread") :unread))))))))) (ert-deftest jabber-test-archive-repair-both-row-references () "Check ownership and conflicting UIDs on both rows, including non-FK refs." (dolist (which '(old live)) (dolist (kind '(root read foreign-account foreign-archive contradictory-uid)) (jabber-test-archive--with-file (pcase-let* ((`(,old ,live) (jabber-test-archive-repair--split jc)) (id (if (eq which 'old) old live))) (pcase kind ((or 'root 'read) (sqlite-execute jabber-db--connection (format "INSERT INTO message_thread(account,peer,type,thread_id,created_at,%s) VALUES ('other','foreign','chat','thread',1,?)" (if (eq kind 'root) "root_message_id" "read_message_id")) (list id))) ('foreign-account (sqlite-execute jabber-db--connection "INSERT INTO message_archive VALUES ('other','personal','uid',?)" (list id))) ('foreign-archive (sqlite-execute jabber-db--connection "INSERT INTO message_archive VALUES ('me@example.com','foreign','uid',?)" (list id))) ('contradictory-uid (sqlite-execute jabber-db--connection "INSERT INTO message_archive VALUES ('me@example.com','room@conference.example.com','different',?)" (list id)))) (let ((messages (sqlite-select jabber-db--connection "SELECT * FROM message ORDER BY id")) (archives (sqlite-select jabber-db--connection "SELECT * FROM message_archive ORDER BY account,archive,uid")) (threads (sqlite-select jabber-db--connection "SELECT * FROM message_thread"))) (jabber-test-archive-repair--open) (should (equal messages (sqlite-select jabber-db--connection "SELECT * FROM message ORDER BY id"))) (should (equal archives (sqlite-select jabber-db--connection "SELECT * FROM message_archive ORDER BY account,archive,uid"))) (should (equal threads (sqlite-select jabber-db--connection "SELECT * FROM message_thread"))))))))) (ert-deftest jabber-test-archive-repair-oob-lossless () "Preserve attachment IDs, URLs and distinct descriptions without guesses." (jabber-test-archive--with-file (pcase-let ((`(,old ,live) (jabber-test-archive-repair--split jc))) (dolist (entry (list (list old "same-url" "archive description") (list live "same-url" "live description") (list old "same-url" nil) (list live "other-url" "other") (list old "same-url" "live description"))) (sqlite-execute jabber-db--connection "INSERT INTO message_oob(message_id,url,desc) VALUES (?,?,?)" entry)) (let ((before (sqlite-select jabber-db--connection "SELECT id,url,desc FROM message_oob ORDER BY id"))) (jabber-test-archive-repair--open) (should (equal before (sqlite-select jabber-db--connection "SELECT id,url,desc FROM message_oob ORDER BY id"))) (should (equal (list (list live)) (sqlite-select jabber-db--connection "SELECT DISTINCT message_id FROM message_oob"))))))) (ert-deftest jabber-test-archive-repair-root-unread () "Do not erase an unread reply by collapsing it into a thread root." (dolist (root '(old live server stanza)) (jabber-test-archive--with-file (pcase-let ((`(,old ,live) (jabber-test-archive-repair--split jc))) (sqlite-execute jabber-db--connection "UPDATE message SET thread_id='thread'") (sqlite-execute jabber-db--connection "INSERT INTO message_thread(account,peer,type,thread_id,created_at,dedicated,root_message_id,root_server_id,root_stanza_id) VALUES ('me@example.com','room@conference.example.com','groupchat','thread',1,1,?,?,?)" (list (pcase root ('old old) ('live live)) (and (eq root 'server) "room-uid") (and (eq root 'stanza) "transport"))) (let ((before (sqlite-select jabber-db--connection "SELECT * FROM message ORDER BY id")) (summary (jabber-db-message-thread-summary "me@example.com" "room@conference.example.com" "groupchat" "thread"))) (jabber-test-archive-repair--open) (should (equal before (sqlite-select jabber-db--connection "SELECT * FROM message ORDER BY id"))) (should (equal summary (jabber-db-message-thread-summary "me@example.com" "room@conference.example.com" "groupchat" "thread")))))))) (ert-deftest jabber-test-archive-repair-unmatched-implicit-root () "Preserve NULL-sensitive unread state when thread metadata moves to LIVE." (dolist (kind '(server stanza)) (jabber-test-archive--with-file (pcase-let ((`(,old ,_live) (jabber-test-archive-repair--split jc))) (sqlite-execute jabber-db--connection "UPDATE message SET thread_id='thread' WHERE id=?" (list old)) (sqlite-execute jabber-db--connection (format "INSERT INTO message_thread(account,peer,type,thread_id,created_at,dedicated,%s) VALUES ('me@example.com','room@conference.example.com','groupchat','thread',1,1,'unmatched')" (if (eq kind 'server) "root_server_id" "root_stanza_id"))) (let ((before (sqlite-select jabber-db--connection "SELECT * FROM message ORDER BY id")) (summary (jabber-db-message-thread-summary "me@example.com" "room@conference.example.com" "groupchat" "thread"))) (jabber-test-archive-repair--open) (should (equal before (sqlite-select jabber-db--connection "SELECT * FROM message ORDER BY id"))) (should (equal summary (jabber-db-message-thread-summary "me@example.com" "room@conference.example.com" "groupchat" "thread")))))))) ;;; Standalone historical room archive rows (defun jabber-test-archive-repair--standalone (&optional uid archive) "Store an ID-less groupchat row owned by ARCHIVE's UID, return its ID. ARCHIVE defaults to the room's own archive, UID to \"solo-uid\"." (let ((id (jabber-db-store-message "me@example.com" "room@conference.example.com" "in" "groupchat" "An archived message" 1735689600 "nick"))) (sqlite-execute jabber-db--connection "INSERT INTO message_archive VALUES (?, ?, ?, ?)" (list "me@example.com" (or archive "room@conference.example.com") (or uid "solo-uid") id)) id)) (defun jabber-test-archive-repair--v14-reference (id) "Reopen the fixture as schema 14 and return row ID's backlog reference." (sqlite-execute jabber-db--connection "PRAGMA user_version=14") (jabber-db-close) (jabber-db-ensure-open) (should (= jabber-db--schema-version (caar (sqlite-select jabber-db--connection "PRAGMA user_version")))) (plist-get (seq-find (lambda (entry) (eql id (plist-get entry :db-id))) (jabber-db-backlog "me@example.com" "room@conference.example.com")) :server-id)) (ert-deftest jabber-test-archive-repair-standalone-room-uid () "A historical row owned only by its room archive gains the room UID." (jabber-test-archive--with-file (ignore jc) (let ((id (jabber-test-archive-repair--standalone))) (should (equal "solo-uid" (jabber-test-archive-repair--v14-reference id))) (should (equal '(("solo-uid" "solo-uid")) (sqlite-select jabber-db--connection "SELECT room_id, server_id FROM message WHERE id = ?" (list id))))))) (ert-deftest jabber-test-archive-repair-standalone-controls () "Personal archives, collisions, ambiguity and existing IDs stay unchanged." (dolist (kind '(personal collision ambiguous room-id server-id)) (jabber-test-archive--with-file (ignore jc) (let ((id (jabber-test-archive-repair--standalone nil (and (eq kind 'personal) "me@example.com")))) (pcase kind ('collision (jabber-db-store-message "me@example.com" "room@conference.example.com" "in" "groupchat" "Other" 1735689601 "nick" nil "solo-uid" nil nil nil nil nil '(:room-id "solo-uid"))) ('ambiguous (sqlite-execute jabber-db--connection "INSERT INTO message_archive VALUES (?, ?, ?, ?)" (list "me@example.com" "room@conference.example.com" "other-uid" id))) ('room-id (sqlite-execute jabber-db--connection "UPDATE message SET room_id = 'explicit' WHERE id = ?" (list id))) ('server-id (sqlite-execute jabber-db--connection "UPDATE message SET server_id = 'inner' WHERE id = ?" (list id)))) (let ((before (sqlite-select jabber-db--connection "SELECT * FROM message ORDER BY id"))) (should (equal (pcase kind ('room-id "explicit") ('server-id "inner")) (jabber-test-archive-repair--v14-reference id))) (should (equal before (sqlite-select jabber-db--connection "SELECT * FROM message ORDER BY id")))))))) (ert-deftest jabber-test-archive-repair-v15-collision-seeks-identity-index () "The v15 candidate query seeks identity indexes without statistics. Opening a large 0.15.0 database must not rescan a room's history for every candidate row." (let ((db (sqlite-open))) (unwind-protect (progn (jabber-db--init-schema db) (sqlite-execute db "WITH RECURSIVE n(i) AS (VALUES (1) UNION ALL SELECT i + 1 FROM n WHERE i < 4000) INSERT INTO message (id, account, peer, type, direction, body, timestamp) SELECT i, 'me', 'room', 'groupchat', 'in', 'history', i FROM n") (sqlite-execute db "INSERT INTO message_archive SELECT account, peer, CAST(id AS TEXT), id FROM message") (let ((plan (mapconcat (lambda (row) (format "%s" (car (last row)))) (sqlite-select db (concat "EXPLAIN QUERY PLAN " jabber-db--v15-candidates-query)) "\n"))) (should-not (string-match-p "idx_msg_peer_ts" plan)) (should (string-match-p "idx_msg_room_id" plan)) (should (string-match-p "idx_msg_server_id" plan))) (should (= 4000 (length (sqlite-select db jabber-db--v15-candidates-query))))) (sqlite-close db)))) (ert-deftest jabber-test-archive-repair-v15-identity-updates-skip-fts () "After v15, identity updates leave the full-text index alone. Body updates still reindex, so search keeps working." (jabber-test-archive--with-file (ignore jc) (sqlite-execute jabber-db--connection "PRAGMA user_version=14") (jabber-db-close) (jabber-db-ensure-open) (let ((db jabber-db--connection)) (sqlite-execute db "INSERT INTO message (id, account, peer, type, direction, body, timestamp) VALUES (1, 'me', 'room', 'groupchat', 'in', 'hello world', 1)") (let ((changes (lambda () (caar (sqlite-select db "SELECT total_changes()"))))) (let ((before (funcall changes))) (sqlite-execute db "UPDATE message SET room_id = 'r1', server_id = 'r1' WHERE id = 1") (should (= 1 (- (funcall changes) before)))) (sqlite-execute db "UPDATE message SET body = 'goodbye moon' WHERE id = 1") (should (equal '((1)) (sqlite-select db "SELECT rowid FROM message_fts WHERE message_fts MATCH 'moon'"))) (should-not (sqlite-select db "SELECT rowid FROM message_fts WHERE message_fts MATCH 'hello'")))))) (provide 'jabber-test-archive-repair) ;;; jabber-test-archive-repair.el ends here emacs-jabber-0.15.1/tests/jabber-test-autoaway.el000066400000000000000000000043251527111033600216320ustar00rootroot00000000000000;;; 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.15.1/tests/jabber-test-avatar.el000066400000000000000000000033211527111033600212510ustar00rootroot00000000000000;;; -*- 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.15.1/tests/jabber-test-blocking.el000066400000000000000000000717261527111033600216010ustar00rootroot00000000000000;;; jabber-test-blocking.el --- Tests for XEP-0191 blocking -*- lexical-binding: t; -*- ;;; Code: (require 'ert) (require 'cl-lib) (require 'jabber-blocking) (require 'jabber-muc) (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))) (ert-deftest jabber-test-blocking-jid-matching () "Match XEP-0191 scopes without broadening resources or domains." (let ((state (list :username "me" :server "example.org"))) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (jc) (and (eq jc 'account) state)))) (dolist (case '(("peer@example.net" "peer@example.net/Phone" t) ("peer@example.net/Phone" "peer@example.net" nil) ("peer@example.net/Phone" "peer@example.net/phone" nil) ("example.net/Phone" "peer@example.net/Phone" t) ("example.net/Phone" "peer@example.net/Other" nil) ("example.net" "peer@example.net/Phone" t) ("example.net" "peer@sub.example.net" nil) ("example.net" "peer@notexample.net" nil) ("example.org" "me@example.org/Other" nil) ("PEER@EXAMPLE.NET" "peer@example.net" t) ("peer@example.net" "room@conference.example.net/peer" nil))) (plist-put state :blocking-list (list (nth 0 case))) (should (eq (not (null (jabber-blocking-blocked-p 'account (nth 1 case)))) (nth 2 case)))) (should-not (jabber-blocking-blocked-p 'other "peer@example.net"))))) (ert-deftest jabber-test-blocking-malformed-unblock-and-authority () "Malformed unblocks must not clear state; resources cannot push it." (should (equal (jabber-blocking--apply-push '("peer@example.net") '(unblock nil (item nil))) '("peer@example.net"))) (let ((state '(:username "me" :server "example.org" :resource "emacs"))) (should (jabber-blocking--valid-push-p nil state)) (should (jabber-blocking--valid-push-p "me@example.org" state)) (should-not (jabber-blocking--valid-push-p "me@example.org/emacs" state)) (should-not (jabber-blocking--valid-push-p "example.org" state)))) (ert-deftest jabber-test-blocking-startup-snapshot-and-push-race () "Startup subscribes to pushes and never overwrites one with an old snapshot." (let ((state (list :username "me" :server "example.org")) disco requests (jabber-blocking-ready-hook nil)) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_) state)) ((symbol-function 'jabber-disco-get-info) (lambda (_jc _jid _node callback _ctx &optional _force _predicate) (setq disco callback))) ((symbol-function 'jabber-send-iq) (lambda (&rest args) (push args requests)))) (jabber-blocking--on-connect 'account) (should-not (jabber-blocking-ready-p 'account "peer@example.net")) (should (jabber-blocking-ready-p 'account "me@example.org/Other")) (funcall disco 'account nil '(nil ("urn:xmpp:blocking"))) (let ((snapshot (nth 4 (car requests)))) (should-not (nth 1 (car requests))) (jabber-blocking--process-push 'account '(iq ((type . "set") (id . "p")) (block ((xmlns . "urn:xmpp:blocking")) (item ((jid . "peer@example.net")))))) (funcall snapshot 'account '(iq nil (blocklist ((xmlns . "urn:xmpp:blocking")))) nil) (should (jabber-blocking-blocked-p 'account "peer@example.net")) (should-not (jabber-blocking-ready-p 'account "peer@example.net")) (funcall (nth 4 (car requests)) 'account '(iq nil (blocklist ((xmlns . "urn:xmpp:blocking")) (item ((jid . "peer@example.net"))))) nil) (should (jabber-blocking-ready-p 'account "peer@example.net")) (should (jabber-blocking-blocked-p 'account "peer@example.net")))))) (ert-deftest jabber-test-blocking-discovery-unsupported-or-failed () "Unsupported servers permit work; discovery failures do not mean empty." (dolist (info '((nil nil) (error nil))) (let ((state (list :username "me" :server "example.org")) (jabber-blocking-ready-hook nil)) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_) state)) ((symbol-function 'jabber-disco-get-info) (lambda (jc _jid _node callback _ctx &optional _force _predicate) (funcall callback jc nil info))) ((symbol-function 'jabber-send-iq) (lambda (&rest _) (ert-fail "Unexpected blocklist request")))) (jabber-blocking--on-connect 'account) (should (eq (not (null (jabber-blocking-ready-p 'account "peer@example.net"))) (not (eq (car info) 'error)))))))) (ert-deftest jabber-test-blocking-old-session-snapshot () "A snapshot from an old connection generation cannot replace current state." (let ((state (list :username "me" :server "example.org")) response) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_) state)) ((symbol-function 'jabber-send-iq) (lambda (&rest args) (setq response (nth 4 args))))) (jabber-blocking--fetch 'account) (plist-put state :blocking-session (list nil)) (funcall response 'account '(iq nil (blocklist ((xmlns . "urn:xmpp:blocking")) (item ((jid . "peer@example.net"))))) nil) (should-not (plist-member state :blocking-list))))) (require 'jabber-omemo) (require 'jabber-muc) (ert-deftest jabber-test-blocking-omemo-no-requests-or-events () "Known blocks settle fetches without requests, cache changes or warnings." (let ((state (list :username "me" :server "example.org" :blocking-list '("peer@example.net"))) (jabber-omemo--device-lists (make-hash-table :test #'equal)) (calls 0)) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_) state)) ((symbol-function 'jabber-pubsub-request) (lambda (&rest _) (ert-fail "Blocked peer was queried"))) ((symbol-function 'warn) (lambda (&rest _) (ert-fail "Blocked peer produced warning"))) ((symbol-function 'jabber-omemo-store-save-device) (lambda (&rest _) (ert-fail "Blocked event was persisted")))) (let ((done (lambda (result) (should-not result) (cl-incf calls)))) (jabber-omemo--fetch-device-list 'account "peer@example.net" done) (jabber-omemo--fetch-bundle 'account "peer@example.net" 7 done) (jabber-omemo--ensure-sessions 'account "peer@example.net" done)) (jabber-omemo--handle-device-list 'account "peer@example.net" nil nil) (should (= calls 3)) (should (= (hash-table-count jabber-omemo--device-lists) 0))))) (ert-deftest jabber-test-blocking-omemo-inflight-block-and-errors () "Late replies settle after a block; ordinary errors remain visible." (dolist (blocked '(nil t)) (let ((state (list :username "me" :server "example.org")) success failure warned result) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_) state)) ((symbol-function 'jabber-pubsub-request) (lambda (_jc _jid _node ok err) (setq success ok failure err))) ((symbol-function 'warn) (lambda (&rest _) (setq warned t))) ((symbol-function 'jabber-omemo--parse-bundle-xml) (lambda (_) (ert-fail "Blocked reply parsed")))) (jabber-omemo--fetch-bundle 'account "peer@example.net" 7 (lambda (value) (setq result (list value)))) (when blocked (jabber-blocking--set-list state '("peer@example.net")) (funcall success 'account '(iq nil (pubsub nil (items nil (item nil (bundle nil))))) nil) (should (equal result '(nil)))) (funcall failure 'account '(iq nil (error ((type . "cancel")) (service-unavailable ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))) nil) (should (equal result '(nil))) (should (eq warned (not blocked))))))) (ert-deftest jabber-test-blocking-omemo-muc-no-partial-success () "A blocked real recipient fails aggregation rather than silently omitting them." (let ((state (list :username "me" :server "example.org" :blocking-list '("peer@example.net"))) result) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_) state)) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc jid callback) (funcall callback (unless (equal jid "peer@example.net") '((8 . session))))))) (jabber-omemo--ensure-sessions-multi 'account '("peer@example.net" "other@example.net") (lambda (value) (setq result (list value)))) (should (equal result '(nil)))))) (ert-deftest jabber-test-blocking-delayed-command-result () "A delayed block result refreshes state rather than replaying old intent." (let ((state (list :username "me" :server "example.org")) requests (jabber-blocking-ready-hook nil)) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_) state)) ((symbol-function 'jabber-send-iq) (lambda (&rest args) (push args requests)))) (jabber-blocking-block-jid 'account "peer@example.net") (let ((ack (nth 4 (car requests)))) (jabber-blocking--set-list state nil) (funcall ack 'account '(iq ((type . "result"))) nil) (should (equal (nth 2 (car requests)) "get")) (should-not (jabber-blocking-blocked-p 'account "peer@example.net")) (funcall (nth 4 (car requests)) 'account '(iq nil (blocklist ((xmlns . "urn:xmpp:blocking")))) nil) (should-not (jabber-blocking-blocked-p 'account "peer@example.net")) (setq requests nil) (plist-put state :blocking-session (list nil)) (funcall ack 'account '(iq ((type . "result"))) nil) (should-not requests))))) (ert-deftest jabber-test-blocking-open-chat-waits-for-snapshot () "Open-chat prefetch waits for discovery, then resumes only unblocked peers." (let ((state (list :username "me" :server "example.org" :blocking-status 'pending)) (jabber-omemo--device-lists (make-hash-table :test #'equal)) (jabber-blocking-ready-hook '(jabber-omemo--prefetch-open-chats)) requested) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_) state)) ((symbol-function 'jabber-omemo--load-device-list-from-db) (lambda (&rest _) nil)) ((symbol-function 'jabber-omemo--fetch-device-list) (lambda (_jc jid callback) (push jid requested) (funcall callback nil)))) (with-temp-buffer (setq-local major-mode 'jabber-chat-mode jabber-buffer-connection 'account jabber-chat-encryption 'omemo jabber-chatting-with "peer@example.net") (jabber-omemo--prefetch-open-chats 'account) (should-not requested) (jabber-blocking--ready 'account 'ready) (should (equal requested '("peer@example.net"))) (setq requested nil) (jabber-blocking--set-list state '("peer@example.net")) (jabber-blocking--ready 'account 'ready) (should-not requested))))) (ert-deftest jabber-test-blocking-omemo-own-work-proceeds () "Discovery and a domain block do not suppress own-device requests." (let ((state (list :username "me" :server "example.org" :blocking-status 'pending :blocking-list '("example.org"))) targets) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_) state)) ((symbol-function 'jabber-pubsub-request) (lambda (_jc jid &rest _) (push jid targets)))) (jabber-omemo--fetch-bundle 'account "me@example.org" 7 #'ignore) (jabber-omemo--fetch-device-list 'account "me@example.org" #'ignore) (should (equal targets '("me@example.org" "me@example.org")))))) (ert-deftest jabber-test-blocking-inflight-devicelist-no-persistence () "A block arriving before a device-list response prevents cache and DB writes." (let ((state (list :username "me" :server "example.org")) (jabber-omemo--device-lists (make-hash-table :test #'equal)) response result) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_) state)) ((symbol-function 'jabber-pubsub-request) (lambda (_jc _jid _node success _failure) (setq response success))) ((symbol-function 'jabber-omemo-store-save-device) (lambda (&rest _) (ert-fail "Blocked device persisted")))) (jabber-omemo--fetch-device-list 'account "peer@example.net" (lambda (value) (setq result (list value)))) (jabber-blocking--set-list state '("peer@example.net")) (funcall response 'account `(iq nil (pubsub nil (items nil (item nil (list ((xmlns . ,jabber-omemo-xmlns)) (device ((id . "7")))))))) nil) (should (equal result '(nil))) (should (= (hash-table-count jabber-omemo--device-lists) 0))))) (ert-deftest jabber-test-blocking-send-refuses-blocked-recipients () "Direct and room send paths refuse before encryption, not just fetch." (let ((state (list :username "me" :server "example.org" :blocking-list '("peer@example.net"))) (jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--room-jids (make-hash-table :test #'equal))) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_) state)) ((symbol-function 'jabber-omemo-encrypt-message) (lambda (&rest _) (ert-fail "Blocked send reached encryption")))) (jabber-muc-add-groupchat "room@conference.example.org" "me" 'account) (jabber-muc--identity-occupant 'account "room@conference.example.org" "nick" '(jid "peer@example.net/Phone")) (should-error (jabber-omemo--send-encrypted 'account "text" "peer@example.net" nil) :type 'user-error) (should-error (jabber-omemo--send-encrypted-muc 'account "text" "room@conference.example.org" nil) :type 'user-error)))) (ert-deftest jabber-test-blocking-invalid-snapshot-retains-known-state () "Malformed snapshots and failed refreshes never manufacture an empty list." (let ((state (list :username "me" :server "example.org" :blocking-status 'ready :blocking-list '("peer@example.net"))) request (jabber-blocking-ready-hook nil)) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_) state)) ((symbol-function 'jabber-send-iq) (lambda (&rest args) (setq request args)))) (jabber-blocking--fetch 'account) (funcall (nth 4 request) 'account '(iq nil (blocklist ((xmlns . "urn:xmpp:blocking")) (item nil))) nil) (should (jabber-blocking-blocked-p 'account "peer@example.net")) (funcall (nth 6 request) 'account '(iq nil (error ((type . "cancel")) (service-unavailable ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))) nil) (should (jabber-blocking-blocked-p 'account "peer@example.net")) (should (jabber-blocking-ready-p 'account "other@example.net"))))) (ert-deftest jabber-test-blocking-wire-response-admission () "Reject foreign IQ results/errors without consuming the legitimate request." (dolist (kind '(disco snapshot block unblock)) (dolist (type '("result" "error")) (let* ((state (list :username "me" :server "example.org" :blocking-status 'pending :blocking-list '("peer@example.net"))) (other (list :username "other" :server "example.org")) (jabber-connections (list 'account 'other)) (jabber-open-info-queries nil) (jabber-disco-info-cache (make-hash-table :test #'equal)) (ready 0) (jabber-blocking-ready-hook (list (lambda (_) (cl-incf ready)))) sent messages) ;; A cached unsupported answer must not bypass wire admission. (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (jc) (if (eq jc 'account) state other))) ((symbol-function 'jabber-send-sexp) (lambda (_jc xml &rest _) (push xml sent))) ((symbol-function 'message) (lambda (&rest args) (push args messages)))) (puthash (jabber-disco--cache-key 'account "example.org" nil) '(nil nil) jabber-disco-info-cache) (pcase kind ('disco (jabber-blocking--on-connect 'account)) ('snapshot (jabber-blocking--fetch 'account)) (_ (jabber-blocking--change 'account "peer@example.net" kind))) (should (= (length sent) 1)) (let* ((id (jabber-xml-get-attribute (car sent) 'id)) (pending (assoc id jabber-open-info-queries)) (payload (if (equal type "error") '(error ((type . "cancel")) (service-unavailable ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))) (pcase kind ('disco '(query ((xmlns . "http://jabber.org/protocol/disco#info")))) ('snapshot '(blocklist ((xmlns . "urn:xmpp:blocking"))))))) (reply (lambda (from) `(iq ((type . ,type) (id . ,id) ,@(when from `((from . ,from)))) ,payload)))) (should pending) (dolist (attack '((account "attacker@example.net") (other nil) (other "example.org") (account "me@example.org/Other"))) (jabber-process-iq (car attack) (funcall reply (cadr attack))) (should (eq pending (assoc id jabber-open-info-queries))) (should (equal (plist-get state :blocking-list) '("peer@example.net"))) (should (eq (plist-get state :blocking-status) 'pending)) (should (= ready 0)) (should (= (length sent) 1)) (should-not messages)) ;; The real response still settles the original pending request. (jabber-process-iq 'account (funcall reply "example.org")) (should-not (assoc id jabber-open-info-queries)) (cond ((equal type "error") (should (equal (plist-get state :blocking-list) '("peer@example.net"))) (should (= ready 0)) (should (= (length sent) 1)) (if (eq kind 'disco) (should (eq (plist-get state :blocking-status) 'failed)) (should messages))) ((memq kind '(disco snapshot)) (should (= ready 1)) (should-not (plist-get state :blocking-list)) (should (eq (plist-get state :blocking-status) (if (eq kind 'disco) 'unsupported 'ready)))) (t (should (= (length sent) 2)) (should (eq (car (jabber-iq-query (car sent))) 'blocklist)) (should messages))))))))) (ert-deftest jabber-test-blocking-wire-malformed-then-valid-snapshot () "Ignore malformed snapshots while retaining the request for a valid reply." (let ((state (list :username "me" :server "example.org" :blocking-list '("peer@example.net"))) (jabber-open-info-queries nil) (jabber-blocking-ready-hook nil) sent) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_) state)) ((symbol-function 'jabber-send-sexp) (lambda (_jc xml &rest _) (setq sent xml)))) (jabber-blocking--fetch 'account) (let* ((id (jabber-xml-get-attribute sent 'id)) (pending (assoc id jabber-open-info-queries))) (jabber-process-iq 'account `(iq ((type . "result") (id . ,id)) (blocklist ((xmlns . "urn:xmpp:blocking")) (item nil)))) (should (eq pending (assoc id jabber-open-info-queries))) (should (equal (plist-get state :blocking-list) '("peer@example.net"))) (jabber-process-iq 'account `(iq ((type . "result") (from . "me@example.org") (id . ,id)) (blocklist ((xmlns . "urn:xmpp:blocking"))))) (should-not jabber-open-info-queries) (should-not (plist-get state :blocking-list)))))) (require 'jabber-core) (defun jabber-test-blocking--connection () "Return a disposable established FSM with Stream Management state." (let ((jc (make-symbol "blocking-test"))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data (jabber-sm--reset (list :username "me" :server "example.org" :connection (list 'transport) :session-id "stream" :blocking-session (list nil) :blocking-status 'pending))) jc)) (defun jabber-test-blocking--drain (jc) "Run the real SM drain that replaces JC's state between replies." (let ((old (fsm-get-state-data jc))) (jabber-sm--drain-pending jc old) (should-not (eq old (fsm-get-state-data jc))) (should (eq (plist-get old :connection) (plist-get (fsm-get-state-data jc) :connection))))) (ert-deftest jabber-test-blocking-fsm-replaced-state-responses () "Real FSM replies survive the ordinary SM drain's plist replacement." (dolist (kind '(disco snapshot block)) (dolist (failure '(nil t)) (let* ((jc (jabber-test-blocking--connection)) (jabber-connections (list jc)) (jabber-open-info-queries nil) (jabber-blocking-ready-hook nil) (jabber-disco-info-cache (make-hash-table :test #'equal)) sent) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (_jc xml &rest _) (push xml sent)))) (pcase kind ('disco (jabber-blocking--on-connect jc)) ('snapshot (jabber-blocking--fetch jc)) (_ (jabber-blocking--change jc "peer@example.net" kind))) (let* ((old (fsm-get-state-data jc)) (id (jabber-xml-get-attribute (car sent) 'id)) (payload (if failure '(error ((type . "cancel")) (service-unavailable ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))) (pcase kind ('disco '(query ((xmlns . "http://jabber.org/protocol/disco#info")))) ('snapshot '(blocklist ((xmlns . "urn:xmpp:blocking")) (item ((jid . "peer@example.net"))))))))) (jabber-test-blocking--drain jc) (fsm-send-sync jc `(:stanza (iq ((type . ,(if failure "error" "result")) (id . ,id) (from . "example.org")) ,@(when payload (list payload))))) (should-not (assoc id jabber-open-info-queries)) (should (eq (plist-get old :blocking-status) 'pending)) (if (eq kind 'block) (should (= (length sent) (if failure 1 2))) (should (eq (plist-get (fsm-get-state-data jc) :blocking-status) (if failure 'failed (if (eq kind 'disco) 'unsupported 'ready))))) (when (and (eq kind 'snapshot) (not failure)) (should (jabber-blocking-blocked-p jc "peer@example.net"))))))))) (ert-deftest jabber-test-blocking-fsm-retired-response () "Replacement transport, stream, blocking session or account rejects old IQs." (dolist (change '((:connection . new-transport) (:session-id . "new-stream") (:blocking-session . new-session) (:username . "other") (:server . "example.net"))) (let* ((jc (jabber-test-blocking--connection)) (jabber-connections (list jc)) (jabber-open-info-queries nil) (jabber-blocking-ready-hook nil) sent) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (_jc xml &rest _) (setq sent xml)))) (jabber-blocking--fetch jc) (jabber-test-blocking--drain jc) (plist-put (fsm-get-state-data jc) (car change) (cdr change)) (let* ((id (jabber-xml-get-attribute sent 'id)) (pending (assoc id jabber-open-info-queries))) (fsm-send-sync jc `(:stanza (iq ((type . "result") (id . ,id)) (blocklist ((xmlns . "urn:xmpp:blocking")))))) (should (eq pending (assoc id jabber-open-info-queries))) (should (eq (plist-get (fsm-get-state-data jc) :blocking-status) 'pending))))))) (ert-deftest jabber-test-blocking-omemo-replaced-state () "Peer replies survive SM copies but not transport or session replacement." (dolist (change '(nil (:connection . replacement) (:session-id . "replacement") (:blocking-session . replacement) (:blocking-list "peer@example.net"))) (dolist (failure '(nil t)) (let* ((jc (jabber-test-blocking--connection)) (jabber-connections (list jc)) success error-callback result) (plist-put (fsm-get-state-data jc) :blocking-status 'ready) (cl-letf (((symbol-function 'jabber-pubsub-request) (lambda (_jc _jid _node ok err) (setq success ok error-callback err)))) (jabber-omemo--request-peer jc "peer@example.net" "test-node" (lambda (&rest _) (setq result 'success)) (lambda (&rest _) (setq result 'failure)) (lambda (value) (setq result (list value)))) (jabber-test-blocking--drain jc) (when change (plist-put (fsm-get-state-data jc) (car change) (cdr change))) (funcall (if failure error-callback success) jc nil nil) (should (equal result (if change '(nil) (if failure 'failure 'success))))))))) (provide 'jabber-test-blocking) ;;; jabber-test-blocking.el ends here emacs-jabber-0.15.1/tests/jabber-test-bookmarks.el000066400000000000000000001057541527111033600220000ustar00rootroot00000000000000;;; 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.15.1/tests/jabber-test-carbons.el000066400000000000000000000465161527111033600214370ustar00rootroot00000000000000;;; 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.15.1/tests/jabber-test-chat.el000066400000000000000000006415071527111033600207300ustar00rootroot00000000000000;;; jabber-test-chat.el --- Tests for jabber-chat -*- lexical-binding: t; -*- ;;; Commentary: ;; One-to-one chat message parsing and display. ;;; Code: (require 'ert) (require 'xref) (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)) `(save-window-excursion (with-temp-buffer (let* ((history (cons nil nil)) (xref-history-storage (lambda (&optional _new-value) history)) (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-goto-reply-target-history () "Reply jumps preserve exact positions through nested back navigation." (jabber-test-chat--with-reply-ewoc (let* ((reply (point)) (node (jabber-chat-ewoc-enter '(:foreign (:id "r-2" :body "nested reply" :reply-to-id "r-1")))) (origin (+ 3 (ewoc-location node)))) (set-marker jabber-point-insert (point-max)) (goto-char origin) (jabber-chat-goto-reply-target-or-send) (should (= (point) reply)) (jabber-chat-goto-reply-target-or-send) (should (= (point) (point-min))) (xref-go-back) (should (= (point) reply)) (xref-go-back) (should (= (point) origin))))) (ert-deftest jabber-test-chat-goto-reply-target-failure-preserves-history () "Missing replies and targets do not alter point or xref history." (jabber-test-chat--with-reply-ewoc (xref-push-marker-stack) (let ((before (copy-tree (funcall xref-history-storage))) (origin (point))) (setf (plist-get (cadr (ewoc-data (ewoc-locate jabber-chat-ewoc))) :reply-to-id) "missing") (should-error (jabber-chat-goto-reply-target) :type 'user-error) (should (= (point) origin)) (should (equal before (funcall xref-history-storage))) (goto-char (point-min)) (should-error (jabber-chat-goto-reply-target) :type 'user-error) (should (= (point) (point-min))) (should (equal before (funcall xref-history-storage)))))) (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 &optional _sender) (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 (lambda (jid) (jabber-jid-symbol jid jc)) 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-download-aesgcm-preserves-literal-bytes () "Save decrypted bytes unchanged, preserving other filename handlers." (require 'jabber-omemo) (dolist (suffix '(".bin" ".targz" ".gz" ".tgz")) (let* ((dir (make-temp-file "jabber-download-bytes-" t)) (dest (expand-file-name (concat "download" suffix) dir)) (writes 0)) (unwind-protect (let* ((original (unibyte-string 0 1 10 13 127 128 254 255)) (enc (jabber-omemo-aesgcm-encrypt original))) (cl-labels ((handle (operation &rest args) (when (eq operation 'write-region) (cl-incf writes)) (let ((inhibit-file-name-handlers (cons #'handle (and (eq inhibit-file-name-operation operation) inhibit-file-name-handlers))) (inhibit-file-name-operation operation)) (apply operation args)))) (let ((file-name-handler-alist (cons (cons (regexp-quote dest) #'handle) file-name-handler-alist))) ;; Only the network boundary is mocked; use real GCM and I/O. (cl-letf (((symbol-function 'url-queue-retrieve) (lambda (_url callback args &rest _) (with-temp-buffer (set-buffer-multibyte nil) (insert "HTTP/1.1 200 OK\r\n\r\n" (plist-get enc :ciphertext)) (apply callback nil args))))) (jabber-chat--download-aesgcm "https://example.org/file" dest (plist-get enc :key) (plist-get enc :iv))))) (should (> writes 0)) (should (equal original (with-temp-buffer (set-buffer-multibyte nil) (insert-file-contents-literally dest) (buffer-string))))) (delete-directory dir t))))) (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)))))) ;;; Native chat regression journeys (require 'jabber-message-correct) (require 'jabber-receipts) (require 'jabber-console) (defvar jabber-omemo--pending-send-operations) (defun jabber-test-chat--journey-connection (user) "Return an inert established connection for USER." (let ((jc (make-symbol user))) (put jc :state :session-established) (put jc :state-data (list :username user :server "example.org" :resource "test" :connection 'test-transport :send-function #'ignore)) jc)) (defun jabber-test-chat--owned-omemo-room (jc) "Admit a room and peer presence owned by fixture connection JC." (jabber-muc-add-groupchat "room@example.org" "self" jc) (jabber-muc-process-presence jc '(presence ((from . "room@example.org/peer")) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((jid . "peer@example.org/mobile") (role . "participant") (affiliation . "none")))))) (should (equal '("peer@example.org") (jabber-muc--identity-jids jc "room@example.org")))) (defmacro jabber-test-chat--journey (&rest body) "Run BODY in a real rendered chat with an inert transport." (declare (indent 0) (debug t)) `(with-temp-buffer (let ((jabber-db-path nil) (jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-muc--room-jids (make-hash-table :test #'equal)) (jabber-chat-default-encryption 'plaintext) (jabber-chat-display-help-at-point nil) (jabber-chat-display-images nil) (jabber-chat-display-link-previews nil) (jabber-print-rare-time nil) (jabber-chat-mode-hook nil) (jc (jabber-test-chat--journey-connection "me"))) (jabber-chat-mode) (setq-local jabber-chatting-with "peer@example.org") (jabber-chat-mode-setup jc #'jabber-chat-pp) (setq-local jabber-send-function #'jabber-chat-send) (let ((jabber-connections (list jc))) ,@body)))) (ert-deftest jabber-test-chat-journey-send-failure-keeps-reply () "Real transport rejection preserves Unicode input and one-shot metadata." (dolist (outcome '(error quit success)) (jabber-test-chat--journey (setq-local jabber-chat-send-hooks '(jabber-message-reply--send-hook)) (setq-local jabber-message-reply--id "reply") (setq-local jabber-message-reply--jid "peer@example.org") (setq-local jabber-message-reply--thread '(:thread-id "thread")) (setq-local jabber-message-reply--fallback-text "> λ\n") (insert "> λ\nanswer") (backward-char 2) (let ((offset (- (point) jabber-point-insert))) (pcase outcome ('error (plist-put (get jc :state-data) :connection nil)) ('quit (plist-put (get jc :state-data) :send-function (lambda (&rest _) (signal 'quit nil))))) (pcase outcome ('error (should-error (call-interactively (key-binding (kbd "RET"))))) ('quit (should (eq 'quit (condition-case nil (call-interactively (key-binding (kbd "RET"))) (quit 'quit))))) ('success (call-interactively (key-binding (kbd "RET"))))) (if (eq outcome 'success) (progn (should (equal "" (jabber-chat--input-string))) (should (equal jabber-chat--input-history '("> λ\nanswer"))) (should-not jabber-message-reply--id)) (should (equal "> λ\nanswer" (jabber-chat--input-string))) (should (= offset (- (point) jabber-point-insert))) (should-not jabber-chat--input-history) (should (equal "reply" jabber-message-reply--id)) (should (equal '(:thread-id "thread") jabber-message-reply--thread)) (should (equal "> λ\n" jabber-message-reply--fallback-text)) (should-not (ewoc-nth jabber-chat-ewoc 0))))))) (ert-deftest jabber-test-chat-journey-console-ret-failure () "The actual console RET command preserves rejected and cancelled XML." (dolist (outcome '(error quit success)) (let* ((jc (jabber-test-chat--journey-connection "console")) (jabber-db-path nil) (jabber-debug-log-xml nil) (jabber-console-truncate-lines 0) (jabber-console-name-format " *test-console-%s*") (jabber-connections (list jc)) (buffer (jabber-console-create-buffer jc)) (body "λ draft")) (unwind-protect (with-current-buffer buffer (insert body) (cl-letf (((symbol-function 'jabber-send-string) (lambda (_jc text) (should (equal body text)) (pcase outcome ('error (error "Rejected")) ('quit (signal 'quit nil)))))) (pcase outcome ('error (should-error (call-interactively (key-binding (kbd "RET"))))) ('quit (should (eq 'quit (condition-case nil (call-interactively (key-binding (kbd "RET"))) (quit 'quit))))) ('success (call-interactively (key-binding (kbd "RET")))))) (should (equal (jabber-chat--input-string) (if (eq outcome 'success) "" body))) (should (equal jabber-chat--input-history (and (eq outcome 'success) (list body))))) (kill-buffer buffer))))) (ert-deftest jabber-test-chat-journey-correction-draft-undo () "Length-changing corrections preserve the draft, point and undo/redo." (dolist (new-body '("a substantially longer corrected message" "x")) (jabber-test-chat--journey (jabber-chat-ewoc-enter (list :local (list :id "original" :body "original message" :timestamp (current-time)))) (goto-char (point-max)) (buffer-enable-undo) (setq buffer-undo-list nil) (insert "draft λ") (undo-boundary) (backward-char 2) (let ((offset (- (point) jabber-point-insert))) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) new-body))) (call-interactively #'jabber-correct-last-message)) (should (= offset (- (point) jabber-point-insert))) (should (equal "draft λ" (jabber-chat--input-string))) (let ((transcript (buffer-substring-no-properties (point-min) jabber-point-insert))) (let ((last-command nil)) (undo-only 1)) (should (equal "" (jabber-chat--input-string))) (undo-boundary) (undo-redo) (should (equal "draft λ" (jabber-chat--input-string))) (should (equal transcript (buffer-substring-no-properties (point-min) jabber-point-insert)))))))) (ert-deftest jabber-test-chat-journey-correction-storage () "A correction changes SQLite and the rendered message only after handoff." (dolist (outcome '(error quit success)) (jabber-test-chat--journey (jabber-test-chat--with-db (jabber-db-store-message "me@example.org" "peer@example.org" "out" "chat" "original" 100 nil "original") (jabber-chat-ewoc-enter (list :local (list :id "original" :body "original" :timestamp '(0 100)))) (pcase outcome ('error (plist-put (get jc :state-data) :connection nil)) ('quit (plist-put (get jc :state-data) :send-function (lambda (&rest _) (signal 'quit nil))))) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "corrected λ"))) (pcase outcome ('error (should-error (call-interactively #'jabber-correct-last-message))) ('quit (should (eq 'quit (condition-case nil (call-interactively #'jabber-correct-last-message) (quit 'quit))))) ('success (call-interactively #'jabber-correct-last-message)))) (should-not jabber-message-correct--pending-outgoing) (let* ((expected (if (eq outcome 'success) "corrected λ" "original")) (msg (cadr (ewoc-data (jabber-chat-ewoc-find-by-id "original"))))) (should (equal expected (plist-get msg :body))) (should (eq (eq outcome 'success) (plist-get msg :edited))) (should (equal (list (list expected)) (sqlite-select jabber-db--connection "SELECT body FROM message")))))))) (ert-deftest jabber-test-chat-journey-reaction-account-routing () "Direct and received-carbon reactions update only their account, even renamed." (dolist (carbon '(nil t)) (let* ((jabber-db-path nil) (jabber-chat-default-encryption 'plaintext) (jabber-chat-display-help-at-point nil) (jabber-chat-display-images nil) (jabber-chat-display-link-previews nil) (jabber-chat-mode-hook nil) (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) (a-jc (jabber-test-chat--journey-connection "a")) (b-jc (jabber-test-chat--journey-connection "b")) (a (jabber-chat-create-buffer a-jc "peer@example.org")) (b (jabber-chat-create-buffer b-jc "peer@example.org"))) (unwind-protect (progn (dolist (buffer (list a b)) (with-current-buffer buffer (jabber-chat-ewoc-enter (list :foreign (list :id "same-id" :from "peer@example.org" :body "peer message" :timestamp (current-time)))))) (with-current-buffer a (rename-buffer " *renamed-chat-test*" t)) (dolist (id '("same-id" "missing")) (let ((stanza `(message ((from . "peer@example.org/mobile") (type . "chat")) (reactions ((xmlns . "urn:xmpp:reactions:0") (id . ,id)) (reaction nil "👍"))))) (jabber-reactions--handle-message a-jc (if carbon `(message ((from . "a@example.org")) (received ((xmlns . "urn:xmpp:carbons:2")) (forwarded ((xmlns . "urn:xmpp:forward:0")) ,stanza))) stanza)))) (with-current-buffer a (should (equal '(("peer@example.org" "👍")) (plist-get (cadr (ewoc-data (jabber-chat-ewoc-find-by-id "same-id"))) :reactions)))) (with-current-buffer b (should-not (plist-get (cadr (ewoc-data (jabber-chat-ewoc-find-by-id "same-id"))) :reactions)))) (kill-buffer a) (kill-buffer b))))) (ert-deftest jabber-test-chat-journey-receipts-same-second () "Public marker handling advances equal-second display state and SQLite." (dolist (times '(((0 100 100000) (0 100 900000)) ((0 100) (0 100)))) (jabber-test-chat--journey (jabber-test-chat--with-db (let ((jabber-buffer-registry--buffers (make-hash-table :test #'equal))) (rename-buffer (jabber-chat-get-buffer "peer@example.org" jc)) (jabber-buffer-registry-register 'chat "peer@example.org") (cl-loop for id in '("first" "second") for time in times do (jabber-db-store-message "me@example.org" "peer@example.org" "out" "chat" id 100 nil id) (jabber-db-update-receipt "me@example.org" "peer@example.org" id "delivered_at" 101) (jabber-chat-ewoc-enter (list :local (list :id id :body id :status :delivered :timestamp time)))) (dolist (id '("first" "second" "first" "missing" "second")) (jabber-receipts--handle-message jc `(message ((from . "peer@example.org/mobile") (type . "chat")) (displayed ((xmlns . "urn:xmpp:chat-markers:0") (id . ,id)))))) (dolist (id '("first" "second")) (should (eq :displayed (plist-get (cadr (ewoc-data (jabber-chat-ewoc-find-by-id id))) :status)))) (should (= 2 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message WHERE displayed_at IS NOT NULL"))))))))) (ert-deftest jabber-test-chat-journey-explicit-thread-reply () "The native thread hook and global hooks emit one reply with Unicode fallback." (jabber-test-chat--journey (let* ((jabber-message-thread-use-buffers t) (thread (jabber-message-thread-create-buffer jc "peer@example.org" "chat" "thread-1" nil (current-buffer) '(:id "root-link" :from "peer@example.org" :body "root"))) sent) (unwind-protect (with-current-buffer thread (plist-put (get jc :state-data) :send-function (lambda (_connection text) (setq sent text))) (let ((node (jabber-chat-ewoc-enter '(:foreign (:id "explicit" :from "peer@example.org" :body "λ quoted" :thread-id "thread-1"))))) (goto-char (ewoc-location node)) (call-interactively #'jabber-chat-reply)) (goto-char (point-max)) (insert "answer") (let ((fallback jabber-message-reply--fallback-text)) (call-interactively (key-binding (kbd "RET"))) (should-not jabber-message-reply--id) (should-not jabber-message-thread--root-reply-id) (should (equal "" (jabber-chat--input-string))) (with-temp-buffer (insert sent) (let* ((stanza (car (xml-parse-region (point-min) (point-max)))) (replies (jabber-xml-get-children stanza 'reply)) (fb (jabber-xml-child-with-xmlns stanza "urn:xmpp:fallback:0"))) (should (= 1 (length replies))) (should (equal "explicit" (jabber-xml-get-attribute (car replies) 'id))) (should (equal (number-to-string (length fallback)) (jabber-xml-get-attribute (car (jabber-xml-get-children fb 'body)) 'end))))))) (kill-buffer thread))))) (ert-deftest jabber-test-chat-journey-correction-queued-handoff () "A queued correction commits on native SM handoff, not queue acceptance." (require 'jabber-sm-runtime) (dolist (outcome '(success failure retired)) (jabber-test-chat--journey (jabber-test-chat--with-db (jabber-db-store-message "me@example.org" "peer@example.org" "out" "chat" "original" 100 nil "original") (jabber-chat-ewoc-enter (list :local (list :id "original" :body "original" :timestamp '(0 100)))) (put jc :state-data (append (get jc :state-data) (list :sm-enabled t :sm-outbound-count 0 :sm-last-acked 0 :sm-pending-queue nil))) (let ((jabber-sm-max-in-flight 0)) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "queued correction"))) (call-interactively #'jabber-correct-last-message))) (should jabber-message-correct--pending-outgoing) (should (equal '(("original")) (sqlite-select jabber-db--connection "SELECT body FROM message"))) (let* ((entry (car (plist-get (get jc :state-data) :sm-pending-queue))) (callback (plist-get entry :success))) (should (functionp callback)) (pcase outcome ('failure (jabber-sm--discard-pending (get jc :state-data) "discarded")) ('retired (fundamental-mode) (let ((jabber-sm-max-in-flight nil)) (jabber-sm--drain-pending jc (get jc :state-data)))) ('success (let ((jabber-sm-max-in-flight nil)) (jabber-sm--drain-pending jc (get jc :state-data))))) ;; Repeated/stale deliveries must not commit or reapply. (funcall callback) (funcall callback)) (should-not jabber-message-correct--pending-outgoing) (should (equal (list (list (if (eq outcome 'failure) "original" "queued correction"))) (sqlite-select jabber-db--connection "SELECT body FROM message"))))))) (ert-deftest jabber-test-chat-journey-omemo-input-restored-once () "Native OMEMO immediate and delayed session failure restores the draft once." (require 'jabber-omemo) (dolist (outcome '(immediate delayed quit)) (jabber-test-chat--journey (setq-local jabber-chat-encryption 'omemo) (setq-local jabber-message-reply--id "reply") (setq-local jabber-message-reply--jid "peer@example.org") (let ((jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) callback) (insert "encrypted draft λ") (cl-letf (((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc _peer on-result) (pcase outcome ('immediate (funcall on-result nil)) ('delayed (setq callback on-result)) ('quit (signal 'quit nil)))))) (if (eq outcome 'quit) (should (eq 'quit (condition-case nil (call-interactively (key-binding (kbd "RET"))) (quit 'quit)))) (call-interactively (key-binding (kbd "RET"))))) (when callback (should (equal "" (jabber-chat--input-string))) (should-not jabber-message-reply--id) (funcall callback nil) (funcall callback nil)) (should (equal "encrypted draft λ" (jabber-chat--input-string))) (should (equal "reply" jabber-message-reply--id)) (when (eq outcome 'quit) (should-not jabber-chat--input-history)))))) (ert-deftest jabber-test-chat-journey-input-successor-preserved () "A synchronous sender cannot restore its draft over a replacement input." (jabber-test-chat--journey (insert "old draft") (setq-local jabber-send-function (lambda (&rest _) (fundamental-mode) (let ((inhibit-read-only t)) (erase-buffer)) (insert "successor draft") (error "Retired input"))) (should-error (jabber-chat-buffer-send)) (should (equal "successor draft" (buffer-string))) (should-not jabber-chat--input-history))) (ert-deftest jabber-test-chat-journey-alert-origin () "Incoming hook chains cannot retarget automatic replies or current buffer." (dolist (mutation '(unchanged rename account peer mode killed title)) (jabber-test-chat--journey (rename-buffer (jabber-chat-get-buffer "peer@example.org" jc) t) (let* ((origin (current-buffer)) (other (generate-new-buffer " *jabber-alert-other*")) (second (jabber-test-chat--journey-connection "other")) (jabber-connections (list jc second)) (jabber-autoanswer-alist '(("ping" . "pong"))) (jabber-alert-message-function (lambda (&rest _) (when (eq mutation 'title) (with-current-buffer origin (setq-local jabber-buffer-connection second))) "Peer")) (jabber-message-hooks (list (lambda (&rest _) (with-current-buffer origin (pcase mutation ('rename (rename-buffer " *renamed-alert-origin*" t)) ('account (setq-local jabber-buffer-connection second)) ('peer (setq-local jabber-chatting-with "other@example.org")) ('mode (fundamental-mode)) ('killed (kill-buffer origin)))) (set-buffer other) ;; Hook truth values must not stop ordinary hook chains. t))) seen sent (jabber-alert-message-hooks (list (lambda (_from buffer _text _title) (push (list buffer (current-buffer)) seen)) #'jabber-autoanswer-answer))) (unwind-protect (progn (plist-put (get jc :state-data) :send-function (lambda (&rest args) (push args sent))) (plist-put (get second :state-data) :send-function (lambda (&rest args) (push args sent))) (jabber-process-chat jc '(message ((from . "peer@example.org") (type . "chat") (id . "incoming")) (body () "ping"))) (should (= 1 (length seen))) (if (memq mutation '(unchanged rename)) (progn (should (eq origin (caar seen))) (should (eq origin (current-buffer))) (should (= 1 (length sent)))) (should-not (caar seen)) (should-not sent)) (unless (eq mutation 'killed) (should (eq origin (cadar seen))) (should (eq origin (current-buffer))))) (kill-buffer other)))))) (require 'jabber-core) (require 'jabber-openpgp) (require 'jabber-omemo) (require 'jabber-openpgp-legacy) (defun jabber-test-chat--send-key-fixture (function) "Call FUNCTION with an isolated send-capable GnuPG keyring." (unless (and (executable-find "gpg") (executable-find "gpgconf")) (ert-skip "GnuPG and gpgconf are required")) (let* ((home (make-temp-file "jabber-send-gpg-" t)) (epg-gpg-home-directory home) (process-environment (copy-sequence process-environment)) (jabber-openpgp-key-alist nil)) (set-file-modes home #o700) (setenv "GNUPGHOME" home) (unwind-protect (progn (with-temp-file (expand-file-name "gpg.conf" home) (insert "no-auto-key-retrieve\nauto-key-locate clear\n")) (dolist (jid '("me@example.org" "peer@example.org")) (should (zerop (call-process "gpg" nil nil nil "--homedir" home "--batch" "--pinentry-mode" "loopback" "--passphrase" "" "--quick-generate-key" (concat "xmpp:" jid) "ed25519" "sign" "0"))) (let* ((key (car (epg-list-keys (epg-make-context 'OpenPGP) (concat "=xmpp:" jid)))) (fingerprint (jabber-openpgp--key-fingerprint key))) (should (zerop (call-process "gpg" nil nil nil "--homedir" home "--batch" "--pinentry-mode" "loopback" "--passphrase" "" "--quick-add-key" fingerprint "cv25519" "encr" "0"))) (push (cons jid fingerprint) jabber-openpgp-key-alist))) (funcall function)) (call-process "gpgconf" nil nil nil "--homedir" home "--kill" "all") (delete-directory home t)))) (defun jabber-test-chat--correction-wire (wire encryption group) "Check captured WIRE for ENCRYPTION and GROUP, decrypting real ciphertext." (let* ((stanza (with-temp-buffer (insert "" wire "") (car (jabber-xml-get-children (car (xml-parse-region (point-min) (point-max))) 'message)))) (replace (jabber-xml-get-children stanza 'replace))) (should (equal (jabber-xml-get-attribute stanza 'to) (if group "room@example.org" "peer@example.org"))) (should (equal (jabber-xml-get-attribute stanza 'type) (if group "groupchat" "chat"))) (should (= 1 (length replace))) (should (equal "original" (jabber-xml-get-attribute (car replace) 'id))) (pcase encryption ('openpgp (let* ((cipher (base64-decode-string (caddr (jabber-xml-child-with-xmlns stanza jabber-openpgp-xmlns)))) ;; Inspect the wire directly: the receive provider's internal ;; return value also carries authentication evidence. (plain (decode-coding-string (epg-decrypt-string (epg-make-context 'OpenPGP) cipher) 'utf-8)) (inner (with-temp-buffer (insert plain) (car (xml-parse-region (point-min) (point-max))))) (payload (car (jabber-xml-get-children inner 'payload)))) (should (eq (car inner) (if group 'crypt 'signcrypt))) (should (equal "corrected λ" (caddr (car (jabber-xml-get-children payload 'body))))))) ('openpgp-legacy (let ((cipher (jabber-openpgp-legacy--rearmor-message (jabber-openpgp-legacy--detect-encrypted stanza)))) (should (equal "corrected λ" (decode-coding-string (epg-decrypt-string (epg-make-context 'OpenPGP) cipher) 'utf-8))))) (_ (should (equal "corrected λ" (caddr (car (jabber-xml-get-children stanza 'body))))))))) (defun jabber-test-chat--provider-correction (encryption group) "Exercise ENCRYPTION and GROUP correction through native SM and SQLite." (dolist (outcome '(immediate drained discarded error quit)) (ert-info ((format "%S %S %S" encryption group outcome)) (jabber-test-chat--journey (jabber-test-chat--with-db (setq-local jabber-chat-encryption encryption) (when group (setq-local jabber-group "room@example.org")) (let* ((jabber-muc-participants '(("room@example.org" ("peer" jid "peer@example.org/mobile")))) (queued (memq outcome '(drained discarded))) (jabber-sm-max-in-flight (and queued 0)) (peer (if group "room@example.org" "peer@example.org")) (node (jabber-chat-ewoc-enter (list (if group :muc-local :local) (list :id "original" :body "original" :from (if group "room@example.org/me" "me@example.org") :timestamp '(0 100))))) wire) (jabber-db-store-message "me@example.org" peer "out" (if group "groupchat" "chat") "original" 100 (and group "me") "original") (put jc :name 'jabber-connection) (put jc :state-data (append (get jc :state-data) (list :sm-enabled t :sm-outbound-count 0 :sm-last-acked 0 :sm-pending-queue nil))) (plist-put (get jc :state-data) :send-function (lambda (_transport text) (pcase outcome ('error (error "Fixture write failed")) ('quit (signal 'quit nil)) (_ (push text wire))))) (goto-char (point-max)) (insert "successor draft λ") (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "corrected λ"))) (condition-case err (call-interactively #'jabber-correct-last-message) ((error quit) (unless (memq outcome '(error quit)) (signal (car err) (cdr err)))))) (when queued (should jabber-message-correct--pending-outgoing) (should-not wire) (should (equal "original" (plist-get (cadr (ewoc-data node)) :body))) (should (equal '(("original")) (sqlite-select jabber-db--connection "SELECT body FROM message"))) (let* ((entry (car (plist-get (get jc :state-data) :sm-pending-queue))) (success (plist-get entry :success)) (failure (plist-get entry :failure))) (should (functionp success)) (should (functionp failure)) (if (eq outcome 'discarded) (put jc :state-data (jabber-sm--discard-pending (get jc :state-data) "Discarded")) (let ((jabber-sm-max-in-flight nil) (deadline (+ (float-time) 30))) ;; Real FSM acknowledgement publishes state before its native timer. (fsm-send-sync jc `(:stanza (a ((xmlns . ,jabber-sm-xmlns) (h . "0"))))) (while (and jabber-message-correct--pending-outgoing (< (float-time) deadline)) (accept-process-output nil 0.01)))) (should-not jabber-message-correct--pending-outgoing) (should (equal (if (eq outcome 'drained) "corrected λ" "original") (plist-get (cadr (ewoc-data node)) :body))) (funcall success) (funcall failure "Late failure") (funcall success))) (let ((expected (if (memq outcome '(immediate drained)) "corrected λ" "original"))) (should-not jabber-message-correct--pending-outgoing) (should (equal expected (plist-get (cadr (ewoc-data node)) :body))) (should (equal (list (list expected)) (sqlite-select jabber-db--connection "SELECT body FROM message"))) (should (equal "successor draft λ" (jabber-chat--input-string))) (if (memq outcome '(immediate drained)) (progn (should (= 1 (length wire))) (jabber-test-chat--correction-wire (car wire) encryption group)) (should-not wire))))))))) (ert-deftest jabber-test-chat-provider-plaintext-muc-completion () "Plaintext MUC corrections wait for native handoff." (jabber-test-chat--provider-correction 'plaintext t)) (ert-deftest jabber-test-chat-provider-modern-completion () "Real modern OpenPGP direct and MUC corrections wait for native handoff." (jabber-test-chat--send-key-fixture (lambda () (dolist (group '(nil t)) (jabber-test-chat--provider-correction 'openpgp group))))) (ert-deftest jabber-test-chat-provider-legacy-completion () "Real legacy OpenPGP direct and MUC corrections wait for native handoff." (jabber-test-chat--send-key-fixture (lambda () (dolist (group '(nil t)) (jabber-test-chat--provider-correction 'openpgp-legacy group))))) (ert-deftest jabber-test-chat-provider-omemo-quit-retirement () "Retained discovery callbacks cannot resend or duplicate cancelled drafts." (dolist (group '(nil t)) (dolist (own '(nil t)) (jabber-test-chat--journey (setq-local jabber-chat-encryption 'omemo) (when group (setq-local jabber-group "room@example.org") (setq-local jabber-send-function #'jabber-muc-send)) (let ((jabber-muc-participants '(("room@example.org" ("peer" jid "peer@example.org/mobile")))) (jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) callback sent) (when group (jabber-test-chat--owned-omemo-room jc)) (plist-put (get jc :state-data) :send-function (lambda (&rest _) (setq sent t))) (insert "cancelled draft λ") (cl-labels ((discover (_jc peer cb) (if (and own (not (equal peer "me@example.org"))) (funcall cb '((1 . session))) (setq callback cb) (signal 'quit nil)))) (cl-letf (((symbol-function 'jabber-omemo--ensure-sessions) #'discover) ((symbol-function 'jabber-omemo--ensure-sessions-multi) #'discover)) (should (eq 'quit (condition-case nil (call-interactively (key-binding (kbd "RET"))) (quit 'quit)))))) (should callback) (should (equal "cancelled draft λ" (jabber-chat--input-string))) (should-not (gethash jc jabber-omemo--pending-send-operations)) (jabber-chat--replace-input "successor draft") (funcall callback nil) (funcall callback '((1 . session))) (should-not sent) (should (equal "successor draft" (jabber-chat--input-string)))))))) (ert-deftest jabber-test-chat-provider-muc-ret-failure-context () "MUC RET restores consumed reply metadata on synchronous error and quit." (dolist (outcome '(error quit)) (jabber-test-chat--journey (setq-local jabber-group "room@example.org") (setq-local jabber-send-function #'jabber-muc-send) (setq-local jabber-message-reply--id "reply") (setq-local jabber-message-reply--jid "room@example.org/peer") (setq-local jabber-message-reply--fallback-text "> λ\n") (insert "> λ\nanswer") (plist-put (get jc :state-data) :send-function (lambda (&rest _) (signal outcome '("Fixture refused")))) (should (eq outcome (condition-case err (call-interactively (key-binding (kbd "RET"))) ((error quit) (car err))))) (should (equal "> λ\nanswer" (jabber-chat--input-string))) (should (equal "reply" jabber-message-reply--id)) (should (equal "> λ\n" jabber-message-reply--fallback-text)) (should-not jabber-chat--input-history)))) (ert-deftest jabber-test-chat-provider-omemo-correction-failure () "An OMEMO correction failure never inserts correction text into a draft." (dolist (group '(nil t)) (dolist (cancel '(nil t)) (jabber-test-chat--journey (setq-local jabber-chat-encryption 'omemo) (when group (setq-local jabber-group "room@example.org")) (let ((jabber-muc-participants '(("room@example.org" ("peer" jid "peer@example.org/mobile")))) (jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (failures 0) callback) (when group (jabber-test-chat--owned-omemo-room jc)) (insert "successor draft λ") (cl-labels ((discover (_jc _peer cb) (setq callback cb) (when cancel (signal 'quit nil)))) (cl-letf (((symbol-function 'jabber-omemo--ensure-sessions) #'discover) ((symbol-function 'jabber-omemo--ensure-sessions-multi) #'discover)) (condition-case nil (funcall (if group #'jabber-muc-send #'jabber-chat-send) jc "corrected λ" '((replace ((id . "original")))) #'ignore (lambda (_reason) (cl-incf failures))) (quit nil)))) (funcall callback nil) (funcall callback nil) (should (= failures 1)) (should-not (gethash jc jabber-omemo--pending-send-operations)) (should (equal "successor draft λ" (jabber-chat--input-string)))))))) (ert-deftest jabber-test-chat-journey-receipt-inbound-boundaries () "Native markers persist exact equal-second boundaries across reopen." (dolist (reverse '(nil t)) (jabber-test-chat--journey (jabber-test-chat--with-db (rename-buffer (jabber-chat-get-buffer "peer@example.org" jc)) (dolist (entry '(("older" . 99.75) ("first" . 100.125) ("second" . 100.875) ("future" . 100.875))) (jabber-db-store-message "me@example.org" "peer@example.org" "out" "chat" (car entry) (floor (cdr entry)) nil (car entry)) (jabber-db-update-receipt "me@example.org" "peer@example.org" (car entry) "delivered_at" 101) (jabber-chat-ewoc-enter (list :local (list :id (car entry) :body (car entry) :status :delivered :timestamp (seconds-to-time (cdr entry)))))) (dolist (scope '(("other@example.org" "peer@example.org") ("me@example.org" "other@example.org"))) (jabber-db-store-message (car scope) (cadr scope) "out" "chat" "first" 99 nil "first") (jabber-db-update-receipt (car scope) (cadr scope) "first" "delivered_at" 101)) (cl-labels ((marker (id) (jabber-receipts--handle-message jc `(message ((from . "peer@example.org/mobile") (type . "chat")) (displayed ((xmlns . "urn:xmpp:chat-markers:0") (id . ,id)))))) (marked () (sqlite-select jabber-db--connection "SELECT account, peer, stanza_id FROM message WHERE displayed_at IS NOT NULL ORDER BY id"))) (marker "missing") (should-not (marked)) (unless reverse (marker "first") (let ((expected '(("me@example.org" "peer@example.org" "older") ("me@example.org" "peer@example.org" "first")))) (should (equal expected (marked))) (should (eq :delivered (plist-get (cadr (ewoc-data (jabber-chat-ewoc-find-by-id "second"))) :status))) (jabber-db-close) (jabber-db-ensure-open) (should (equal expected (marked))))) (marker "second") (let ((expected '(("me@example.org" "peer@example.org" "older") ("me@example.org" "peer@example.org" "first") ("me@example.org" "peer@example.org" "second"))) (state (sqlite-select jabber-db--connection "SELECT id, delivered_at, displayed_at FROM message ORDER BY id"))) (should (equal expected (marked))) (dolist (id '("first" "second" "older" "missing")) (marker id) (should (equal state (sqlite-select jabber-db--connection "SELECT id, delivered_at, displayed_at FROM message ORDER BY id")))) (jabber-db-close) (jabber-db-ensure-open) (should (equal expected (marked))))))))) (defmacro jabber-test-chat--publication-fixture (&rest body) "Run BODY with native chat/SQLite fixtures and observed correction sends. Expose `publication-node', `publication-attempts', `publication-wire' and `publication-messages'. The journey fixture also binds the inert `jc'." (declare (indent 0) (debug t)) `(jabber-test-chat--journey (jabber-test-chat--with-db (setq-local jabber-chat-send-hooks nil) (let* ((jabber-debug-log-xml nil) (jabber-sm-max-in-flight nil) (original-send (symbol-function 'jabber-message-correct--send)) (publication-attempts nil) (publication-wire nil) (publication-messages nil) (publication-node (jabber-chat-ewoc-enter (list :local (list :id "original" :body "original" :from "me@example.org" :timestamp (list 0 100)))))) (jabber-db-store-message "me@example.org" "peer@example.org" "out" "chat" "original" 100 nil "original") (put jc :name 'jabber-connection) (put jc :state-data (append (get jc :state-data) (list :sm-enabled t :sm-outbound-count 0 :sm-last-acked 0 :sm-pending-queue nil))) (plist-put (get jc :state-data) :send-function (lambda (_transport text) (push text publication-wire))) (goto-char (point-max)) (insert "unrelated draft λ") (cl-letf (((symbol-function 'jabber-message-correct--send) (lambda (connection group text extra &optional success failure) (push (list :token jabber-message-correct--pending-outgoing :success success :failure failure :body text) publication-attempts) (funcall original-send connection group text extra success failure))) ((symbol-function 'message) (lambda (format-string &rest arguments) (let ((text (and format-string (apply #'format format-string arguments)))) (when text (push text publication-messages)) text)))) ,@body))))) (defun jabber-test-chat--publication-correct (body) "Submit a correction with BODY through the interactive command." (cl-letf (((symbol-function 'read-string) (lambda (&rest _) body))) (call-interactively #'jabber-correct-last-message))) (defun jabber-test-chat--publication-drain (jc) "Drain JC through a real FSM acknowledgement and its native timer." (let ((jabber-sm-max-in-flight nil) (deadline (+ (float-time) 30))) (fsm-send-sync jc `(:stanza (a ((xmlns . ,jabber-sm-xmlns) (h . "0"))))) ;; Wait for native queue removal, NOT a pending token a broken commit can ;; strand. Return from accept-process-output also returns from its timer. (while (and (plist-get (get jc :state-data) :sm-pending-queue) (< (float-time) deadline)) (accept-process-output nil 0.01)) (should-not (plist-get (get jc :state-data) :sm-pending-queue)) (should (eq :session-established (get jc :state))))) (defun jabber-test-chat--publication-rows () "Return complete fixture message rows, including edited metadata." (sqlite-select jabber-db--connection "SELECT * FROM message ORDER BY id")) (defun jabber-test-chat--publication-replay (attempt node) "Check late callbacks from ATTEMPT leave NODE and all local state intact." (let ((pending jabber-message-correct--pending-outgoing) (pending-active (car-safe jabber-message-correct--pending-outgoing)) (rows (jabber-test-chat--publication-rows)) (data (copy-tree (ewoc-data node))) (text (buffer-string))) (should (functionp (plist-get attempt :success))) (should (functionp (plist-get attempt :failure))) (funcall (plist-get attempt :success)) (funcall (plist-get attempt :failure) "Late publication failure") (funcall (plist-get attempt :success)) (should (eq pending jabber-message-correct--pending-outgoing)) (should (eq pending-active (car-safe pending))) (should (equal rows (jabber-test-chat--publication-rows))) (should (equal data (ewoc-data node))) (should (equal text (buffer-string))))) (defun jabber-test-chat--publication-check-committed (node body) "Check NODE, rendered text and reopened SQLite agree on BODY." (should-not jabber-message-correct--pending-outgoing) (should (equal body (plist-get (cadr (ewoc-data node)) :body))) (should (plist-get (cadr (ewoc-data node)) :edited)) (should (string-search body (buffer-substring-no-properties (point-min) jabber-point-insert))) (should (equal "unrelated draft λ" (jabber-chat--input-string))) (should (equal (list (list body 1)) (sqlite-select jabber-db--connection "SELECT body, edited FROM message"))) (let ((rows (jabber-test-chat--publication-rows))) (jabber-db-close) (jabber-db-ensure-open) (should (equal rows (jabber-test-chat--publication-rows))))) (defun jabber-test-chat--publication-sqlite-abort (queued) "Exercise a real SQLite abort after handoff, optionally QUEUED." (jabber-test-chat--publication-fixture (let ((rows (jabber-test-chat--publication-rows)) (text (buffer-string))) (sqlite-execute jabber-db--connection "CREATE TRIGGER publication_abort BEFORE UPDATE OF body ON message BEGIN SELECT RAISE(ABORT, 'publication sqlite abort'); END") (let ((jabber-sm-max-in-flight (and queued 0))) (jabber-test-chat--publication-correct "corrected λ")) (let* ((attempt (car publication-attempts)) (token (plist-get attempt :token))) (should token) (when queued (should (eq token jabber-message-correct--pending-outgoing)) (should (car token)) (should-not publication-wire) (should (equal rows (jabber-test-chat--publication-rows))) (should (equal text (buffer-string))) (jabber-test-chat--publication-drain jc)) ;; Establish native handoff and terminal settlement BEFORE any replay. (should (= 1 (length publication-wire))) (should-not (car token)) (should-not jabber-message-correct--pending-outgoing) (should (equal text (buffer-string))) (should (equal "original" (plist-get (cadr (ewoc-data publication-node)) :body))) (should-not (plist-get (cadr (ewoc-data publication-node)) :edited)) (should (equal rows (jabber-test-chat--publication-rows))) (should (cl-some (lambda (text) (string-match-p "publication sqlite abort" text)) publication-messages)) (jabber-db-close) (jabber-db-ensure-open) (should (equal rows (jabber-test-chat--publication-rows))) ;; Remove the failure first: stale success must be inert even when an ;; accidental second publication would now succeed. (sqlite-execute jabber-db--connection "DROP TRIGGER publication_abort") (jabber-test-chat--publication-replay attempt publication-node) (should (= 1 (length publication-wire))) (let ((jabber-sm-max-in-flight 0)) (jabber-test-chat--publication-correct "retry λ")) (let ((retry-token jabber-message-correct--pending-outgoing)) (should retry-token) (should-not (eq token retry-token)) (should (car retry-token)) (should (= 2 (length publication-attempts))) (jabber-test-chat--publication-replay attempt publication-node) (should (= 1 (length publication-wire))) (jabber-test-chat--publication-drain jc) (should-not (car retry-token))) (should (= 2 (length publication-wire))) (jabber-test-chat--publication-check-committed publication-node "retry λ") (jabber-test-chat--publication-replay attempt publication-node) (should (= 2 (length publication-wire))))))) (ert-deftest jabber-test-chat-repair-publication-sqlite-immediate () "Release an immediate handed-off correction after a real SQLite abort." (jabber-test-chat--publication-sqlite-abort nil)) (ert-deftest jabber-test-chat-repair-publication-sqlite-queued () "Release a native FSM-drained correction after a real SQLite abort." (jabber-test-chat--publication-sqlite-abort t)) (defun jabber-test-chat--publication-render-fault (queued fault) "Exercise printer FAULT after handoff, optionally QUEUED." (jabber-test-chat--publication-fixture (let* ((render-calls 0) (pending-at-render 'not-called) (jabber-chat-printers (cons (lambda (msg _who mode) (when (and (eq mode :insert) (equal "corrected λ" (plist-get msg :body))) (cl-incf render-calls) (setq pending-at-render jabber-message-correct--pending-outgoing) (signal fault (and (eq fault 'error) (list "publication render fault"))))) jabber-chat-printers))) (let ((jabber-sm-max-in-flight (and queued 0))) (jabber-test-chat--publication-correct "corrected λ")) (let* ((attempt (car publication-attempts)) (token (plist-get attempt :token))) (when queued (should (eq token jabber-message-correct--pending-outgoing)) (should (car token)) (should-not publication-wire) (should (zerop render-calls)) (should (equal '(("original")) (sqlite-select jabber-db--connection "SELECT body FROM message"))) (jabber-test-chat--publication-drain jc)) (should (= 1 (length publication-wire))) (should (= 1 render-calls)) (should-not pending-at-render) (should-not (car token)) (should-not jabber-message-correct--pending-outgoing) (should (equal "unrelated draft λ" (jabber-chat--input-string))) ;; SQLite precedes rendering: do not demand a fictitious rollback of ;; an already handed-off stanza or of the successful local SQL write. (should (equal '(("corrected λ" 1)) (sqlite-select jabber-db--connection "SELECT body, edited FROM message"))) (should (cl-some (lambda (text) (string-match-p (if (eq fault 'quit) "[Qq]uit" "publication render fault") text)) publication-messages)) (jabber-db-close) (jabber-db-ensure-open) (should (equal '(("corrected λ" 1)) (sqlite-select jabber-db--connection "SELECT body, edited FROM message"))) (jabber-test-chat--publication-replay attempt publication-node) (should (= 1 render-calls)) (should (= 1 (length publication-wire))) (let ((jabber-sm-max-in-flight 0)) (jabber-test-chat--publication-correct "retry λ")) (let ((retry-token jabber-message-correct--pending-outgoing)) (should retry-token) (should (car retry-token)) (should-not (eq token retry-token)) (jabber-test-chat--publication-replay attempt publication-node) (jabber-test-chat--publication-drain jc) (should-not (car retry-token))) (should (= 2 (length publication-attempts))) (should (= 2 (length publication-wire))) (should (= 1 render-calls)) (jabber-test-chat--publication-check-committed publication-node "retry λ"))))) (ert-deftest jabber-test-chat-repair-publication-render-error-immediate () "Settle an immediate correction before a native printer raises error." (jabber-test-chat--publication-render-fault nil 'error)) (ert-deftest jabber-test-chat-repair-publication-render-quit-immediate () "Settle an immediate correction before a native printer raises quit." (jabber-test-chat--publication-render-fault nil 'quit)) (ert-deftest jabber-test-chat-repair-publication-render-error-queued () "Settle a native FSM-drained correction before a printer raises error." (jabber-test-chat--publication-render-fault t 'error)) (ert-deftest jabber-test-chat-repair-publication-render-quit-queued () "Settle a native FSM-drained correction before a printer raises quit." (jabber-test-chat--publication-render-fault t 'quit)) (defun jabber-test-chat--publication-successor (fault) "Preserve a printer-admitted successor through optional publication FAULT." (dolist (queued '(nil t)) (ert-info ((format "queued=%S fault=%S" queued fault)) (jabber-test-chat--publication-fixture (let* ((hook-runs 0) (hook-error nil) (pending-at-hook 'not-called) (successor-token nil) (jabber-chat-printers (cons (lambda (msg _who mode) (when (and (zerop hook-runs) (eq mode :insert) (equal "corrected λ" (plist-get msg :body))) (cl-incf hook-runs) (setq pending-at-hook jabber-message-correct--pending-outgoing) ;; Native rendering is a reentry boundary. Admit a ;; real new correction, not an invented pending list. ;; Queue it so the old renderer resumes while the new ;; occurrence still owns the same buffer's slot. ;; Keep back-pressure active until the surrounding ;; drain returns, or it would immediately consume the ;; new entry too. The caller binds this option, so ;; changing it here cannot escape the test phase. (setq jabber-sm-max-in-flight 0) (condition-case err (let ((jabber-sm-max-in-flight 0)) (jabber-test-chat--publication-correct "successor λ") (setq successor-token jabber-message-correct--pending-outgoing)) ((error quit) (setq hook-error err))) (when fault (signal fault (and (eq fault 'error) (list "publication successor fault")))))) jabber-chat-printers))) (let ((jabber-sm-max-in-flight (and queued 0))) (jabber-test-chat--publication-correct "corrected λ")) (let* ((attempt (car (last publication-attempts))) (token (plist-get attempt :token))) (when queued (should-not publication-wire) ;; This drain intentionally leaves a reentrantly queued successor. ;; Wait for the hook, rather than draining every generation. (let ((jabber-sm-max-in-flight nil) (deadline (+ (float-time) 30))) (fsm-send-sync jc `(:stanza (a ((xmlns . ,jabber-sm-xmlns) (h . "0"))))) (while (and (zerop hook-runs) (< (float-time) deadline)) (accept-process-output nil 0.01)))) ;; Assertions stay outside callbacks production can demote. (should (= 1 hook-runs)) (should-not hook-error) (should-not pending-at-hook) (should-not (car token)) (should successor-token) (should-not (eq token successor-token)) (should (car successor-token)) (should (eq successor-token jabber-message-correct--pending-outgoing)) (should (= 2 (length publication-attempts))) (should (= 1 (length publication-wire))) (should (= 1 (length (plist-get (get jc :state-data) :sm-pending-queue)))) (should (equal "unrelated draft λ" (jabber-chat--input-string))) (should (equal '(("corrected λ" 1)) (sqlite-select jabber-db--connection "SELECT body, edited FROM message"))) (jabber-test-chat--publication-replay attempt publication-node) (should (= 1 (length publication-wire))) (jabber-test-chat--publication-drain jc) (should-not (car successor-token)) (should (= 2 (length publication-wire))) (jabber-test-chat--publication-check-committed publication-node "successor λ") (jabber-test-chat--publication-replay attempt publication-node) (should (= 2 (length publication-wire))))))))) (ert-deftest jabber-test-chat-repair-publication-successor-render-return () "Keep a native printer's new pending correction after old rendering returns." (jabber-test-chat--publication-successor nil)) (ert-deftest jabber-test-chat-repair-publication-successor-render-error () "Keep a native printer's new pending correction after old rendering errors." (jabber-test-chat--publication-successor 'error)) (ert-deftest jabber-test-chat-repair-publication-successor-render-quit () "Keep a native printer's new pending correction after old rendering quits." (jabber-test-chat--publication-successor 'quit)) (defmacro jabber-test-chat--modern-fixture (group &rest body) "Run BODY in a modern OpenPGP chat, with optional GROUP routing." (declare (indent 1) (debug (form body))) `(jabber-test-chat--journey (setq-local jabber-chat-encryption 'openpgp) (setq-local jabber-chat-send-hooks '(jabber-message-reply--send-hook)) (when ,group (setq-local jabber-group "room@example.org") (setq-local jabber-send-function #'jabber-muc-send)) (let ((jabber-muc-participants '(("room@example.org" ("peer" jid "peer@example.org/mobile"))))) ,@body))) (defmacro jabber-test-chat--delayed-keys (&rest body) "Run BODY with native IQ discovery and captured peer-key continuations." (declare (indent 0) (debug t)) `(let ((jabber-open-info-queries nil) (jabber-debug-log-xml nil) (lookup (symbol-function 'jabber-openpgp--recipient-key)) (missing t) continuations request-ids) (cl-letf (((symbol-function 'jabber-openpgp--recipient-key) (lambda (jid) (unless (and missing (equal jid "peer@example.org")) (funcall lookup jid)))) ((symbol-function 'jabber-openpgp--fetch-key) (lambda (connection jid callback) (push callback continuations) (jabber-send-iq connection jid "get" '(query ((xmlns . "test:key"))) (lambda (_jc _xml _closure) (funcall callback (funcall lookup jid))) nil nil nil) (push (caar jabber-open-info-queries) request-ids)))) ,@body))) (defun jabber-test-chat--keyboard (keys) "Dispatch KEYS in the current chat using the actual command loop." (save-window-excursion (switch-to-buffer (current-buffer)) (execute-kbd-macro keys))) (ert-deftest jabber-test-chat-repair-modern-immediate-input () "Real GPG RET preserves rejected input, metadata, point and native undo." (jabber-test-chat--send-key-fixture (lambda () (dolist (group '(nil t)) (dolist (outcome '(transport crypto key quit success queued)) (ert-info ((format "group=%S outcome=%S" group outcome)) (jabber-test-chat--modern-fixture group (setq-local jabber-message-reply--id "reply") (setq-local jabber-message-reply--jid "peer@example.org") (setq-local jabber-message-reply--thread '(:thread-id "thread")) (setq-local jabber-message-reply--fallback-text "> λ\n") (buffer-enable-undo) (setq buffer-undo-list nil) (jabber-test-chat--keyboard "draft λ") (jabber-test-chat--keyboard (kbd "C-b C-b")) (undo-boundary) (let* ((offset (- (point) jabber-point-insert)) (undo buffer-undo-list) (transcript (buffer-substring (point-min) jabber-point-insert)) (encrypt (symbol-function 'epg-encrypt-string)) (jabber-sm-max-in-flight (and (eq outcome 'queued) 0)) wire) (put jc :name 'jabber-connection) (put jc :state-data (append (get jc :state-data) (list :sm-enabled t :sm-outbound-count 0 :sm-last-acked 0))) (plist-put (get jc :state-data) :send-function (lambda (_transport text) (if (eq outcome 'transport) (error "Rejected native wire") (push text wire)))) (cl-letf (((symbol-function 'jabber-openpgp--fetch-key) (lambda (_jc _jid callback) (funcall callback nil))) ((symbol-function 'epg-encrypt-string) (lambda (&rest args) (pcase outcome ('crypto (error "Rejected encryption")) ('quit (signal 'quit nil)) (_ (apply encrypt args)))))) (let ((jabber-openpgp-key-alist (if (eq outcome 'key) (cons '("me@example.org" . "missing-key") jabber-openpgp-key-alist) jabber-openpgp-key-alist))) (condition-case nil (jabber-test-chat--keyboard (kbd "RET")) ((error quit) nil)))) (if (memq outcome '(success queued)) (progn (should (equal "" (jabber-chat--input-string))) (when (eq outcome 'queued) (should-not wire) (should-not jabber-chat--input-history) (jabber-test-chat--publication-drain jc)) (should (= 1 (length wire))) (should (equal '("draft λ") jabber-chat--input-history)) (should-not jabber-message-reply--id)) (should-not wire) (should (equal "draft λ" (jabber-chat--input-string))) (should (= offset (- (point) jabber-point-insert))) (should (equal undo buffer-undo-list)) (should-not jabber-chat--input-history) (should (equal "reply" jabber-message-reply--id)) (should (equal '(:thread-id "thread") jabber-message-reply--thread)) (should (equal "> λ\n" jabber-message-reply--fallback-text)) (should (equal transcript (buffer-substring (point-min) jabber-point-insert))) (jabber-test-chat--keyboard (kbd "C-/")) (should (equal "" (jabber-chat--input-string))) (jabber-test-chat--keyboard (kbd "C-?")) (should (equal "draft λ" (jabber-chat--input-string))) (should (equal transcript (buffer-substring (point-min) jabber-point-insert)))))))))))) (ert-deftest jabber-test-chat-repair-modern-delayed-input () "Native key results settle failed drafts once without stealing successors." (jabber-test-chat--send-key-fixture (lambda () (dolist (group '(nil t)) (dolist (outcome '(error quit missing discard success)) (dolist (successor '(nil t)) (ert-info ((format "group=%S outcome=%S successor=%S" group outcome successor)) (jabber-test-chat--modern-fixture group (setq-local jabber-message-reply--id "reply") (buffer-enable-undo) (setq buffer-undo-list nil) (insert "old draft λ") (backward-char 2) (let ((offset (- (point) jabber-point-insert)) wire) (plist-put (get jc :state-data) :send-function (lambda (_transport text) (push text wire))) (put jc :name 'jabber-connection) (put jc :state-data (append (get jc :state-data) (list :sm-enabled t :sm-outbound-count 0 :sm-last-acked 0))) (jabber-test-chat--delayed-keys (jabber-test-chat--keyboard (kbd "RET")) (should request-ids) (should-not jabber-chat--input-history) (should (equal "" (jabber-chat--input-string))) (setq wire nil missing nil) (when successor (insert "successor λ") (setq-local jabber-message-reply--id "successor-reply")) (plist-put (get jc :state-data) :send-function (lambda (_transport text) (pcase outcome ('error (error "Delayed wire error")) ('quit (signal 'quit nil)) (_ (push text wire))))) (let ((jabber-sm-max-in-flight (and (eq outcome 'discard) 0))) (if (eq outcome 'missing) (funcall (car continuations) nil) (condition-case nil (jabber-process-iq jc `(iq ((type . "result") (id . ,(car request-ids))))) ((error quit) nil)))) (when (eq outcome 'discard) (should (plist-get (get jc :state-data) :sm-pending-queue)) (put jc :state-data (jabber-sm--discard-pending (get jc :state-data) "Queue discarded"))) (should (equal (if successor "successor λ" (if (eq outcome 'success) "" "old draft λ")) (jabber-chat--input-string))) (should (equal (and (eq outcome 'success) '("old draft λ")) jabber-chat--input-history)) (unless (or successor (eq outcome 'success)) (should (= offset (- (point) jabber-point-insert))) (should (equal "reply" jabber-message-reply--id))) (when successor (should (equal "successor-reply" jabber-message-reply--id))) (should (= (if (eq outcome 'success) 1 0) (length wire))) (let ((text (buffer-string)) (history (copy-sequence jabber-chat--input-history))) (funcall (car continuations) nil) (funcall (car continuations) (funcall lookup "peer@example.org")) (should (equal text (buffer-string))) (should (equal history jabber-chat--input-history))) ;; A fresh explicit RET remains usable after a failed operation. (unless (eq outcome 'success) (plist-put (get jc :state-data) :send-function (lambda (_transport text) (push text wire))) (jabber-test-chat--keyboard (kbd "RET")) (should (= 1 (length wire))) (should (equal "" (jabber-chat--input-string)))))))))))))) (ert-deftest jabber-test-chat-repair-modern-delayed-correction-quit () "Native discovery followed by encryption/wire quit releases exact correction." (jabber-test-chat--send-key-fixture (lambda () (dolist (group '(nil t)) (dolist (boundary '(encryption transport)) (jabber-test-chat--modern-fixture group (setq-local jabber-chat-send-hooks nil) (jabber-chat-ewoc-enter (list (if group :muc-local :local) (list :id "original" :body "original" :timestamp '(0 100) :from (if group "room@example.org/me" "me@example.org")))) (insert "successor composer") (let ((encrypt (symbol-function 'epg-encrypt-string)) wire) (plist-put (get jc :state-data) :send-function (lambda (_transport text) (push text wire))) (jabber-test-chat--delayed-keys (jabber-test-chat--publication-correct "corrected λ") (let ((token jabber-message-correct--pending-outgoing)) (should token) (setq missing nil wire nil) (plist-put (get jc :state-data) :send-function (lambda (_transport _text) (signal 'quit nil))) (cl-letf (((symbol-function 'epg-encrypt-string) (lambda (&rest args) (if (eq boundary 'encryption) (signal 'quit nil) (apply encrypt args))))) (should (eq 'quit (condition-case nil (jabber-process-iq jc `(iq ((type . "result") (id . ,(car request-ids))))) (quit 'quit))))) (should-not (car token)) (should-not jabber-message-correct--pending-outgoing) (plist-put (get jc :state-data) :send-function (lambda (_transport text) (push text wire))) (funcall (car continuations) nil) (funcall (car continuations) (funcall lookup "peer@example.org")) (should-not wire) (should (equal "successor composer" (jabber-chat--input-string))) (jabber-test-chat--publication-correct "corrected λ") (should-not jabber-message-correct--pending-outgoing) (should (= 1 (length wire))) (jabber-test-chat--correction-wire (car wire) 'openpgp group)))))))))) (ert-deftest jabber-test-chat-repair-modern-draft-ownership () "Incoming transcript preserves a failed draft; edited or retargeted input does not." (jabber-test-chat--send-key-fixture (lambda () (dolist (change '(incoming empty-successor retarget mode)) (jabber-test-chat--modern-fixture nil (buffer-enable-undo) (setq buffer-undo-list nil) (jabber-test-chat--keyboard "old draft λ") (undo-boundary) (jabber-test-chat--delayed-keys (jabber-test-chat--keyboard (kbd "RET")) (pcase change ('incoming (jabber-chat-ewoc-enter '(:foreign (:id "incoming" :body "Incoming message λ" :from "peer@example.org" :timestamp (0 100))))) ('empty-successor (insert "new draft") (delete-region jabber-point-insert (point-max))) ('retarget (setq-local jabber-chatting-with "other@example.org")) ('mode (fundamental-mode))) (let ((text (buffer-string))) (funcall (car continuations) nil) (if (eq change 'incoming) (progn (should (equal "old draft λ" (jabber-chat--input-string))) (jabber-test-chat--keyboard (kbd "C-/")) (should (equal "" (jabber-chat--input-string))) (should (equal text (buffer-string)))) (should (equal text (buffer-string))))) (should-not jabber-chat--input-history))))))) (ert-deftest jabber-test-chat-repair-modern-encryption-owner () "Revalidate the destination after real encryption without touching a successor." (jabber-test-chat--send-key-fixture (lambda () (dolist (group '(nil t)) (jabber-test-chat--modern-fixture group (insert "old draft") (let ((encrypt (symbol-function 'epg-encrypt-string)) wire) (plist-put (get jc :state-data) :send-function (lambda (_transport text) (push text wire))) (cl-letf (((symbol-function 'epg-encrypt-string) (lambda (&rest args) (prog1 (apply encrypt args) (if group (setq-local jabber-group "other@example.org") (setq-local jabber-chatting-with "other@example.org")) (insert "new owner draft") (setq-local jabber-message-reply--id "new-reply"))))) (jabber-test-chat--keyboard (kbd "RET"))) (should-not wire) (should-not jabber-chat--input-history) (should (equal "new owner draft" (jabber-chat--input-string))) (should (equal "new-reply" jabber-message-reply--id)))))))) (ert-deftest jabber-test-chat-repair-modern-correction-input-isolation () "A nested correction cannot acquire another submission's completion owner." (jabber-test-chat--send-key-fixture (lambda () (jabber-test-chat--modern-fixture nil (jabber-chat-ewoc-enter (list :local (list :id "original" :body "original" :timestamp (list 0 100)))) (let ((calls 0) (jabber-chat--input-deferred nil)) (let ((jabber-chat--input-completion (lambda (&rest _) (cl-incf calls)))) (jabber-test-chat--publication-correct "corrected λ")) (should-not jabber-message-correct--pending-outgoing) (should-not jabber-chat--input-deferred) (should (zerop calls))))))) (defun jabber-test-chat--r2-enable-sm (jc wire) "Enable native SM on JC and use WIRE at its transport boundary." (put jc :name 'jabber-connection) (put jc :state-data (append (get jc :state-data) (list :sm-enabled t :sm-outbound-count 0 :sm-last-acked 0))) (plist-put (get jc :state-data) :send-function wire)) (ert-deftest jabber-test-chat-r2-post-handoff-publication () "Settle real RET before printer or local-message error/quit on either provider." (jabber-test-chat--send-key-fixture (lambda () (dolist (provider '(plaintext openpgp)) (dolist (queued '(nil t)) (dolist (site '(printp insert hook success)) (dolist (fault (if (eq site 'success) '(nil) '(error quit))) (ert-info ((format "%S queued=%S site=%S fault=%S" provider queued site fault)) (jabber-test-chat--modern-fixture nil (setq-local jabber-chat-encryption provider) (setq-local jabber-message-reply--id "r2-reply") (setq-local jabber-message-reply--jid "peer@example.org") (let* (wire reports at-publication (trip (lambda () (push (list (jabber-chat--input-string) (copy-sequence jabber-chat--input-history) jabber-message-reply--id (car jabber-chat--input-submission)) at-publication) (signal fault (and (eq fault 'error) '("R2 publication fault"))))) (jabber-chat-printers (cons (lambda (_msg who mode) (when (and (eq who :local) (eq mode (if (eq site 'insert) :insert :printp)) (memq site '(insert printp))) (funcall trip))) jabber-chat-printers)) (jabber-chat-local-message-functions (and (eq site 'hook) (list (lambda (_msg) (funcall trip)))))) (jabber-test-chat--r2-enable-sm jc (lambda (_transport text) (push text wire))) (insert "r2 sent λ") (cl-letf (((symbol-function 'message) (lambda (format-string &rest args) (when format-string (push (apply #'format format-string args) reports))))) (let ((jabber-sm-max-in-flight (and queued 0))) (jabber-test-chat--keyboard (kbd "RET"))) (let* ((token jabber-chat--input-submission) (entry (car (plist-get (get jc :state-data) :sm-pending-queue)))) (when queued (should (car token)) (should-not wire) (should-not jabber-chat--input-history) (should-not (ewoc-nth jabber-chat-ewoc 0)) (jabber-test-chat--publication-drain jc)) (should (= 1 (length wire))) (should-not (car token)) (should (equal "" (jabber-chat--input-string))) (should (equal '("r2 sent λ") jabber-chat--input-history)) (should-not jabber-message-reply--id) (if fault (progn (should (equal '(("" ("r2 sent λ") nil nil)) at-publication)) (should (cl-some (lambda (report) (string-match-p (if (eq fault 'quit) "[Qq]uit" "R2 publication fault") report)) reports))) (should (equal "r2 sent λ" (plist-get (cadr (ewoc-data (ewoc-nth jabber-chat-ewoc 0))) :body))) (should-not (ewoc-nth jabber-chat-ewoc 1))) ;; No implicit retry, even after the local fault is gone. (let ((jabber-chat-printers (cdr jabber-chat-printers)) (jabber-chat-local-message-functions nil) (before (buffer-string))) (jabber-test-chat--keyboard (kbd "RET")) (when entry (funcall (plist-get entry :success)) (funcall (plist-get entry :failure) "Late failure")) (should (equal before (buffer-string))) (should (= 1 (length wire)))))))))))))))) (defun jabber-test-chat--r2-replace-owner (change) "Apply owner CHANGE using native mode/setup for a replacement lifetime." (pcase change ('account (setq-local jabber-buffer-connection (jabber-test-chat--journey-connection "new-account"))) ('account-data (plist-put (get jabber-buffer-connection :state-data) :username "new-account")) ('peer (setq-local jabber-chatting-with "new-peer@example.org")) ('marker (setq-local jabber-point-insert (copy-marker jabber-point-insert))) ('detached (set-marker jabber-point-insert nil)) ('mode (fundamental-mode)) ('setup (let ((inhibit-read-only t)) (erase-buffer)) (jabber-chat-mode) (setq-local jabber-chatting-with "new-peer@example.org") (jabber-chat-mode-setup (jabber-test-chat--journey-connection "new-account") #'jabber-chat-pp)) ('rename (rename-buffer (generate-new-buffer-name "r2-renamed")))) (goto-char (point-max)) (insert "successor draft λ") (setq-local jabber-chat--input-history (list "successor history"))) (ert-deftest jabber-test-chat-r2-queued-owner () "Fence both providers' queued echoes after all captured owner replacements." (jabber-test-chat--send-key-fixture (lambda () (dolist (provider '(plaintext openpgp)) (dolist (change '(account account-data peer marker detached mode setup rename)) (ert-info ((format "%S owner=%S" provider change)) (jabber-test-chat--modern-fixture nil (setq-local jabber-chat-encryption provider) (setq-local jabber-chat-send-hooks nil) (let (wire) (jabber-test-chat--r2-enable-sm jc (lambda (_transport text) (push text wire))) (insert "old secret λ") (let ((jabber-sm-max-in-flight 0)) (jabber-test-chat--keyboard (kbd "RET"))) (let* ((token jabber-chat--input-submission) (entry (car (plist-get (get jc :state-data) :sm-pending-queue)))) (should (car token)) (should entry) (jabber-test-chat--r2-replace-owner change) (let ((before (buffer-string))) (jabber-test-chat--publication-drain jc) (should (= 1 (length wire))) (should-not (car token)) (if (eq change 'rename) (progn (should (equal '("old secret λ" "successor history") jabber-chat--input-history)) (should (equal "successor draft λ" (jabber-chat--input-string))) (should (equal "old secret λ" (plist-get (cadr (ewoc-data (ewoc-nth jabber-chat-ewoc 0))) :body)))) (should (equal before (buffer-string))) (should (equal '("successor history") jabber-chat--input-history))) (let ((settled (buffer-string)) (history (copy-sequence jabber-chat--input-history))) (funcall (plist-get entry :success)) (funcall (plist-get entry :failure) "Late failure") (should (equal settled (buffer-string))) (should (equal history jabber-chat--input-history)) (should (= 1 (length wire)))))))))))))) (ert-deftest jabber-test-chat-r2-completion-replaces-owner () "Revalidate after completion and caller callbacks, not just before settlement." (jabber-test-chat--send-key-fixture (lambda () (dolist (provider '(plaintext openpgp)) (dolist (queued '(nil t)) (dolist (boundary '(completion success)) (ert-info ((format "%S queued=%S boundary=%S" provider queued boundary)) (jabber-test-chat--modern-fixture nil (setq-local jabber-chat-encryption provider) (setq-local jabber-chat-send-hooks nil) (let (wire before token (calls 0)) (jabber-test-chat--r2-enable-sm jc (lambda (_transport text) (push text wire))) (setq-local jabber-send-function (lambda (connection body) (setq token jabber-chat--input-submission) (let* ((completion jabber-chat--input-completion) (replace (lambda () (cl-incf calls) (jabber-test-chat--r2-replace-owner 'setup) (setq before (buffer-string)))) (jabber-chat--input-completion (if (eq boundary 'completion) (lambda (success) (prog1 (funcall completion success) (when success (funcall replace)))) completion))) (jabber-chat-send connection body nil (and (eq boundary 'success) replace))))) (insert "old secret λ") (let ((jabber-sm-max-in-flight (and queued 0))) (jabber-test-chat--keyboard (kbd "RET"))) (let ((entry (car (plist-get (get jc :state-data) :sm-pending-queue)))) (when queued (should (car token)) (should-not wire) (should (zerop calls)) (jabber-test-chat--publication-drain jc)) (should (= 1 calls)) (should (= 1 (length wire))) (should-not (car token)) (should (equal before (buffer-string))) (should (equal '("successor history") jabber-chat--input-history)) (should (equal "successor draft λ" (jabber-chat--input-string))) (when entry (funcall (plist-get entry :success)) (funcall (plist-get entry :failure) "Late failure") (should (= 1 calls)) (should (equal before (buffer-string)))))))))))))) (ert-deftest jabber-test-chat-r2-plaintext-queue-rejection () "Recover definite queue failure only into its untouched composer." (dolist (outcome '(drain discard)) (dolist (successor '(nil t)) (jabber-test-chat--journey (setq-local jabber-chat-send-hooks '(jabber-message-reply--send-hook)) (setq-local jabber-message-reply--id "old-reply") (setq-local jabber-message-reply--jid "peer@example.org") (let ((attempts 0)) (jabber-test-chat--r2-enable-sm jc (lambda (_transport _text) (cl-incf attempts) (error "R2 wire refusal"))) (insert "rejected λ") (let ((jabber-sm-max-in-flight 0)) (jabber-test-chat--keyboard (kbd "RET"))) (let ((token jabber-chat--input-submission) (entry (car (plist-get (get jc :state-data) :sm-pending-queue)))) (should (car token)) (should-not jabber-message-reply--id) (should-not jabber-chat--input-history) (when successor (insert "new draft")) (pcase outcome ('drain (let ((jabber-sm-max-in-flight nil) (deadline (+ (float-time) 30))) (fsm-send-sync jc `(:stanza (a ((xmlns . ,jabber-sm-xmlns) (h . "0"))))) (while (and (car token) (< (float-time) deadline)) (accept-process-output nil 0.01))) (should-not (get jc :state))) ('discard (jabber-sm--discard-pending (get jc :state-data) "Discarded"))) (should-not (car token)) (should (= attempts (if (eq outcome 'drain) 1 0))) (should (equal (if successor "new draft" "rejected λ") (jabber-chat--input-string))) (should (equal (unless successor "old-reply") jabber-message-reply--id)) (should-not jabber-chat--input-history) (should-not (ewoc-nth jabber-chat-ewoc 0)) (let ((before (buffer-string))) (funcall (plist-get entry :success)) (funcall (plist-get entry :failure) "Late failure") (should (equal before (buffer-string))) (should-not jabber-chat--input-history)))))))) ;;; OMEMO native discovery ownership (defun jabber-test-chat--omemo-iq-error (id) "Return a device discovery error for query ID." `(iq ((type . "error") (id . ,id) (from . "peer@example.org")) (error ((type . "cancel")) (item-not-found ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))))) (defun jabber-test-chat--omemo-input-state () "Return exact composer text, reply, history and undo state." (list (if (and (markerp jabber-point-insert) (eq (marker-buffer jabber-point-insert) (current-buffer))) (jabber-chat--input-string) (buffer-string)) (jabber-chat--send-context-state nil) (copy-tree jabber-chat--input-history) (copy-tree buffer-undo-list))) (ert-deftest jabber-test-chat-r3-omemo-native-discovery-failure () "Native RET, PubSub and FSM failure preserve each successor composer." (require 'jabber-omemo) (dolist (change '(nil draft cleared submission mode setup ewoc deleted)) (ert-info ((format "OMEMO discovery failure change=%S" change)) (jabber-test-chat--journey (jabber-test-chat--with-db (let ((jabber-open-info-queries nil) (jabber-debug-log-xml nil) (jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (jabber-omemo--device-lists (make-hash-table :test #'equal)) (jabber-omemo--sessions (make-hash-table :test #'equal)) wire) (put jc :name 'jabber-connection) (plist-put (get jc :state-data) :blocking-status 'ready) (plist-put (get jc :state-data) :send-function (lambda (_transport text) (push text wire))) (setq-local jabber-chat-encryption 'omemo) (setq-local jabber-chat-send-hooks '(jabber-message-reply--send-hook)) (setq-local jabber-message-reply--id "old-reply") (setq-local jabber-message-reply--jid "peer@example.org") (buffer-enable-undo) (insert "old secret λ") (jabber-test-chat--keyboard (kbd "RET")) (should (= (length wire) 1)) (should (string-match-p "" (car messages) "") (car (jabber-xml-get-children (car (xml-parse-region (point-min) (point-max))) 'message)))) (encrypted (jabber-xml-child-with-xmlns stanza jabber-omemo-xmlns)) (header (car (jabber-xml-get-children encrypted 'header))) (key (car (jabber-xml-get-children header 'key))) (iv (car (jabber-xml-get-children header 'iv))) (payload (car (jabber-xml-get-children encrypted 'payload))) (decrypted-key (jabber-omemo-decrypt-key (jabber-omemo-make-session) peer-store t (base64-decode-string (car (jabber-xml-node-children key)))))) (should (= (length messages) 1)) (should (equal "old-reply" (jabber-xml-get-attribute (jabber-xml-child-with-xmlns stanza "urn:xmpp:reply:0") 'id))) (should (equal "old secret λ" (decode-coding-string (jabber-omemo-decrypt-message decrypted-key (base64-decode-string (car (jabber-xml-node-children iv))) (base64-decode-string (car (jabber-xml-node-children payload)))) 'utf-8)))) (should (equal '("old secret λ") jabber-chat--input-history)) (should (equal "" (jabber-chat--input-string))) (should-not jabber-message-reply--id) (should (eq :sent (plist-get (cadr (ewoc-data (ewoc-nth jabber-chat-ewoc -1))) :status))) (let ((state (jabber-test-chat--omemo-input-state)) (count (length wire))) (jabber-omemo--send-operation-finish operation 'success) (jabber-omemo--send-operation-finish operation 'failure "late") (jabber-test-chat--keyboard (kbd "RET")) (should (= count (length wire))) (should (equal state (jabber-test-chat--omemo-input-state)))))))))) (ert-deftest jabber-test-chat-r3-omemo-quit-successor () "A discovery quit and its retained callbacks cannot recover over an edit." (require 'jabber-omemo) (require 'jabber-muc) (dolist (group '(nil t)) (dolist (fault '(error quit)) (dolist (successor '(nil draft cleared)) (jabber-test-chat--journey (let ((jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (jabber-muc-participants '(("room@example.org" ("peer" jid "peer@example.org")))) continuation) (when group (jabber-test-chat--owned-omemo-room jc)) (when group (setq-local jabber-group "room@example.org") (setq-local jabber-send-function #'jabber-muc-send)) (setq-local jabber-chat-encryption 'omemo) (setq-local jabber-message-reply--id "old-reply") (setq-local jabber-message-reply--jid "peer@example.org") (insert "old secret λ") (cl-letf (((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc _peer callback) (setq continuation callback) (when successor (insert "successor") (when (eq successor 'cleared) (delete-region jabber-point-insert (point-max)))) (signal fault '("discovery interruption"))))) (if (eq fault 'quit) (should (eq 'quit (condition-case nil (call-interactively (key-binding (kbd "RET"))) (quit 'quit)))) (jabber-test-chat--keyboard (kbd "RET")))) (should-not (gethash jc jabber-omemo--pending-send-operations)) (should (equal (pcase successor ('draft "successor") ('cleared "") (_ "old secret λ")) (jabber-chat--input-string))) (should (equal (unless successor "old-reply") jabber-message-reply--id)) (should-not jabber-chat--input-history) (let ((state (jabber-test-chat--omemo-input-state))) (funcall continuation nil) (funcall continuation '((23 . stale-session))) (should (equal state (jabber-test-chat--omemo-input-state)))))))))) (defun jabber-test-chat--r4-deferred-omemo (outcome change &optional group) "Exercise native delayed OMEMO OUTCOME across composer CHANGE. Non-nil GROUP selects a MUC send through the same native discovery." (require 'jabber-omemo) (jabber-test-chat--journey (jabber-test-chat--with-db (let* ((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)) (jabber-open-info-queries nil) (jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (peer-store (jabber-omemo-deserialize-store (jabber-omemo-setup-store))) (bundle (jabber-omemo-get-bundle peer-store)) (other (make-symbol "other-account")) (origin (current-buffer)) (jabber-chat-buffer-format (buffer-name)) (jabber-chat-default-encryption 'plaintext) (jabber-chat-mode-hook nil) (jabber-muc-participants '(("room@example.org" ("peer" jid "peer@example.org")))) (next-hooks 0) before wire) (put other :state-data (list :username "other" :server "example.org")) (put jc :name 'jabber-connection) (plist-put (get jc :state-data) :blocking-status 'ready) (jabber-test-chat--r2-enable-sm jc (lambda (_transport text) (when (and (eq outcome 'refuse) (string-match-p "" (car wire) "") (car (jabber-xml-get-children (car (xml-parse-region (point-min) (point-max))) 'message)))) (encrypted (jabber-xml-child-with-xmlns stanza jabber-omemo-xmlns)) (header (car (jabber-xml-get-children encrypted 'header))) (key (car (jabber-xml-get-children header 'key))) (iv (car (jabber-xml-get-children header 'iv))) (payload (car (jabber-xml-get-children encrypted 'payload))) (decrypted-key (jabber-omemo-decrypt-key (jabber-omemo-make-session) peer-store t (base64-decode-string (car (jabber-xml-node-children key)))))) (should (equal "old-reply" (jabber-xml-get-attribute (jabber-xml-child-with-xmlns stanza "urn:xmpp:reply:0") 'id))) (should (equal "old-thread" (plist-get (jabber-message-thread-protocol-fields stanza) :thread-id))) (should (equal "old body" (decode-coding-string (jabber-omemo-decrypt-message decrypted-key (base64-decode-string (car (jabber-xml-node-children iv))) (base64-decode-string (car (jabber-xml-node-children payload)))) 'utf-8))))))) (when (eq change 'hook-retarget) (should (zerop next-hooks))) (let ((state (jabber-test-chat--omemo-input-state)) (transcript (buffer-string)) (count (length wire))) (fsm-send-sync jc (list :stanza response)) (jabber-omemo--send-operation-finish operation 'success) (jabber-omemo--send-operation-finish operation 'failure "duplicate") (should (= count (length wire))) (should (equal transcript (buffer-string))) (should (equal state (jabber-test-chat--omemo-input-state))))))))) (ert-deftest jabber-test-chat-r4-omemo-captured-context () "Deferred success, queue discard and refusal preserve successor state." (dolist (outcome '(success queued discard refuse)) (ert-info ((format "outcome=%S" outcome)) (jabber-test-chat--r4-deferred-omemo outcome 'draft)))) (ert-deftest jabber-test-chat-r4-omemo-muc-captured-context () "Native MUC discovery likewise uses captured reply and thread extensions." (dolist (outcome '(success queued discard refuse)) (ert-info ((format "MUC outcome=%S" outcome)) (jabber-test-chat--r4-deferred-omemo outcome 'draft t)))) (ert-deftest jabber-test-chat-r4-omemo-hook-reentry () "Callback edits survive success, error and quit without dynamic shadowing." (dolist (outcome '(success error quit)) (ert-info ((format "outcome=%S" outcome)) (jabber-test-chat--r4-deferred-omemo outcome 'hook-draft)))) (ert-deftest jabber-test-chat-r4-omemo-same-mode-retarget () "Native same-mode replacement fences hooks, publication and handoff." (dolist (change '(retarget hook-retarget)) (ert-info ((format "change=%S" change)) (jabber-test-chat--r4-deferred-omemo 'success change)))) (ert-deftest jabber-test-chat-r4-captured-hook-nested-submit () "An ordinary RET reentered from a captured hook consumes its own reply." (jabber-test-chat--journey (let (nested) (setq-local jabber-message-reply--id "nested-reply") (setq-local jabber-message-reply--jid "peer@example.org") (setq-local jabber-chat-send-hooks (list (lambda (&rest _) (let ((jabber-chat-send-hooks '(jabber-message-reply--send-hook))) (insert "nested body") (jabber-chat-buffer-send)) nil) #'jabber-message-reply--send-hook)) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (_jc stanza &optional success _failure) (setq nested stanza) (when success (funcall success))))) (jabber-chat--run-send-hooks (list 'message nil) "old body" "old-id" t)) (should (equal "nested-reply" (jabber-xml-get-attribute (jabber-xml-child-with-xmlns nested "urn:xmpp:reply:0") 'id))) (should-not jabber-message-reply--id) (should (equal '("nested body") jabber-chat--input-history))))) (provide 'jabber-test-chat) ;;; jabber-test-chat.el ends here emacs-jabber-0.15.1/tests/jabber-test-chatbuffer.el000066400000000000000000002136011527111033600221100ustar00rootroot00000000000000;;; 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))) (defmacro jabber-test-chatbuffer-with-input (&rest body) "Set up a temporary chat composition area, then run BODY." (declare (indent 0) (debug t)) `(with-temp-buffer (let ((jabber-chat-display-help-at-point nil)) (jabber-chat-mode)) (insert "Transcript\n") (setq-local jabber-point-insert (point-marker)) ,@body)) ;;; Input history (ert-deftest jabber-test-chatbuffer-mode-map-has-input-history () "Chat input history uses the conventional M-p and M-n bindings." (should (eq (keymap-lookup jabber-chat-mode-map "M-p") #'jabber-chat-input-history-previous)) (should (eq (keymap-lookup jabber-chat-mode-map "M-n") #'jabber-chat-input-history-next))) (ert-deftest jabber-test-chatbuffer-input-history-restores-draft () "Input history navigates newest-first and restores the unsent draft." (jabber-test-chatbuffer-with-input (let ((jabber-connections '(connection)) sent) (setq-local jabber-buffer-connection 'connection) (setq-local jabber-send-function (lambda (_jc body &optional _extra-elements) (push body sent))) (should-error (jabber-chat-input-history-previous) :type 'user-error) (dolist (input '("first" "second" "second")) (insert input) (jabber-chat-buffer-send)) (should (equal (reverse sent) '("first" "second" "second"))) (insert "draft") (jabber-chat-input-history-previous) (should (equal (buffer-substring-no-properties jabber-point-insert (point-max)) "second")) (jabber-chat-input-history-previous) (should (equal (buffer-substring-no-properties jabber-point-insert (point-max)) "first")) (jabber-chat-input-history-previous) (should (equal (buffer-substring-no-properties jabber-point-insert (point-max)) "first")) (jabber-chat-input-history-next) (should (equal (buffer-substring-no-properties jabber-point-insert (point-max)) "second")) (jabber-chat-input-history-next) (should (equal (buffer-substring-no-properties jabber-point-insert (point-max)) "draft")) (should-error (jabber-chat-input-history-next) :type 'user-error)))) (ert-deftest jabber-test-chatbuffer-input-history-rejects-transcript-point () "Input history does not replace text when point is in the transcript." (jabber-test-chatbuffer-with-input (let ((jabber-connections '(connection))) (setq-local jabber-buffer-connection 'connection) (setq-local jabber-send-function #'ignore) (insert "sent") (jabber-chat-buffer-send) (goto-char (point-min)) (should-error (jabber-chat-input-history-previous) :type 'user-error) (should (equal (buffer-string) "Transcript\n"))))) (ert-deftest jabber-test-chatbuffer-failed-send-is-not-history () "A synchronously rejected send does not enter input history." (jabber-test-chatbuffer-with-input (let ((jabber-connections '(connection))) (setq-local jabber-buffer-connection 'connection) (setq-local jabber-send-function (lambda (&rest _) (error "Rejected"))) (insert "not sent") (should-error (jabber-chat-buffer-send) :type 'error) (should-not jabber-chat--input-history)))) (ert-deftest jabber-test-chatbuffer-send-preserves-result () "Recording input history preserves the sender's return value." (jabber-test-chatbuffer-with-input (let ((jabber-connections '(connection))) (setq-local jabber-buffer-connection 'connection) (setq-local jabber-send-function (lambda (&rest _) :sender-result)) (insert "sent") (should (eq (jabber-chat-buffer-send) :sender-result)) (should (equal jabber-chat--input-history '("sent")))))) ;;; 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))))))))) (defmacro jabber-test-chatbuffer-with-render-boundaries (&rest body) "Run BODY with a read-only transcript and an undo-enabled draft." (declare (indent 0) (debug t)) `(with-temp-buffer (let* ((jabber-chat-ewoc (ewoc-create (lambda (data) (insert (propertize (plist-get (cadr data) :body) 'read-only t 'rear-nonsticky t))) nil "\n\n" 'nosep)) (jabber-chat--msg-nodes (make-hash-table :test 'equal)) (jabber-chat-display-images nil) (jabber-chat--image-cache (make-hash-table :test 'equal)) (jabber-chat--image-scale-cache (make-hash-table :test 'equal))) (setq-local jabber-point-insert (copy-marker (point-max))) (jabber-chat-ewoc-enter '(:local (:id "first" :body "photo https://example.org/a.png\n"))) (goto-char (point-max)) (let ((inhibit-read-only t)) (add-text-properties (point-min) (point) '(read-only t rear-nonsticky t))) (buffer-enable-undo) (insert "draft λ") (undo-boundary) ,@body))) (ert-deftest jabber-test-chatbuffer-image-scan-undo-then-incoming () "Image layout must not enter undo or misalign existing draft edits." (jabber-test-chatbuffer-with-render-boundaries (cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) t))) (jabber-chat-display-buffer-images)) (let ((transcript (buffer-substring (point-min) jabber-point-insert))) (let ((last-command nil)) (undo-only 1)) (should (equal (buffer-substring jabber-point-insert (point-max)) "")) (should (equal-including-properties transcript (buffer-substring (point-min) jabber-point-insert))) (jabber-chat-ewoc-enter '(:local (:id "next" :body "incoming\n"))) (should (string-suffix-p "incoming\n\n\n" (buffer-string)))))) (ert-deftest jabber-test-chatbuffer-image-incoming-day-boundary-undo () "A day separator after image layout preserves the draft's undo positions." (jabber-test-chatbuffer-with-render-boundaries ;; Render the real rare-time node without depending on date formatting. (setf (ewoc--pretty-printer jabber-chat-ewoc) (lambda (data) (insert (propertize (if (eq (car data) :rare-time) "DAY-BOUNDARY\n" (plist-get (cadr data) :body)) 'read-only t 'rear-nonsticky t)))) (cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) t))) (jabber-chat-display-buffer-images)) (let ((jabber-print-rare-time t) (jabber-message-hooks nil) (jabber-alert-message-hooks nil)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me")) ((symbol-function 'jabber-chatstates--clear-typing) #'ignore) ((symbol-function 'jabber-rare-time-needed) (lambda (&rest _) t))) (jabber-chat--display-message nil nil (current-buffer) nil "me" '(:id "next" :body "incoming\n" :timestamp (1 0 0 0))))) (should (eq (car (ewoc-data (ewoc-nth jabber-chat-ewoc 1))) :rare-time)) (should (equal (buffer-substring jabber-point-insert (point-max)) "draft λ")) (let ((transcript (buffer-substring (point-min) jabber-point-insert))) (let ((last-command nil)) (undo-only 1)) (should (equal (buffer-substring jabber-point-insert (point-max)) "")) (should (equal-including-properties transcript (buffer-substring (point-min) jabber-point-insert)))))) (ert-deftest jabber-test-chatbuffer-image-callbacks-preserve-undo () "Fetch start, failure, success and resize leave composer undo alone." (jabber-test-chatbuffer-with-render-boundaries (goto-char (point-min)) (search-forward "https://example.org/a.png") (let* ((url "https://example.org/a.png") (end (point-marker)) (beg (copy-marker (- (point) (length url)))) (history (copy-tree buffer-undo-list))) (cl-letf (((symbol-function 'jabber-chat--scaled-image) (lambda (image _scale) image))) (let ((inhibit-read-only t)) (jabber-chat--mark-image-fetching beg end url)) (should (equal history buffer-undo-list)) (jabber-chat--replace-url-with-image nil url beg end (current-buffer)) (should (eq (get-text-property beg 'jabber-chat-image-fetching) 'failed)) (should (equal history buffer-undo-list)) (jabber-chat--replace-url-with-image '(image :type png) url beg end (current-buffer)) (should (get-text-property beg 'display)) (goto-char beg) (jabber-chat-image-enlarge) (should (equal history buffer-undo-list)))))) (ert-deftest jabber-test-chatbuffer-redraw-repairs-footer-preserves-draft () "Normal redraw repairs orphan footer text without losing draft or undo." (jabber-test-chatbuffer-with-render-boundaries ;; Simulate an interrupted renderer inserting inside the footer. (let ((buffer-undo-list t) (inhibit-read-only t)) (save-excursion (goto-char (1- jabber-point-insert)) (insert "orphan message"))) ;; Realign the fixture's preexisting draft edit to the corrupted transcript. (jabber-chat-buffer--shift-undo-list (length "orphan message")) (setq major-mode 'jabber-chat-mode) (goto-char (+ jabber-point-insert 3)) (cl-letf (((symbol-function 'jabber-chat--peer-jid) #'ignore) ((symbol-function 'jabber-chat-encryption--update-header) #'ignore) ((symbol-function 'jabber-chat-buffer-recenter-input) #'ignore)) (jabber-chat-redisplay)) (should (equal (buffer-substring jabber-point-insert (point-max)) "draft λ")) (should (= (point) (+ jabber-point-insert 3))) (should-not (string-match-p "orphan" (buffer-string))) (should (get-text-property (1- jabber-point-insert) 'read-only)) (should-not (get-text-property jabber-point-insert 'read-only)) (let ((last-command nil)) (undo-only 1)) (should (= jabber-point-insert (point-max))))) (ert-deftest jabber-test-chatbuffer-invalidate-delete-preserve-input-undo () "Length-changing node replacement and deletion preserve draft undo." (dolist (operation '(invalidate delete)) (jabber-test-chatbuffer-with-render-boundaries (let ((node (ewoc-nth jabber-chat-ewoc 0))) (if (eq operation 'delete) (jabber-chat-ewoc-delete node) (ewoc-set-data node '(:local (:id "first" :body "short\n"))) (jabber-chat-ewoc-invalidate node))) (let ((transcript (buffer-substring (point-min) jabber-point-insert))) (let ((last-command nil)) (undo-only 1)) (should (= jabber-point-insert (point-max))) (should (equal-including-properties transcript (buffer-string))))))) (ert-deftest jabber-test-chatbuffer-refresh-chunks-preserve-input-undo () "Database refresh repairs the footer and shifts undo across later chunks." (jabber-test-chatbuffer-with-render-boundaries (let ((buffer-undo-list t) (inhibit-read-only t)) (save-excursion (goto-char (1- jabber-point-insert)) (insert "orphan"))) (jabber-chat-buffer--shift-undo-list (length "orphan")) (let ((jabber-chat-backlog-chunk-size 1) (jabber-print-rare-time nil) (jabber-chat--backlog-generation 0) continuation) (cl-letf (((symbol-function 'jabber-chat-buffer-msg-count) (lambda () 2)) ((symbol-function 'jabber-chat--peer-jid) (lambda () "peer")) ((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me")) ((symbol-function 'jabber-db-backlog) (lambda (&rest _) (list (list :id "new" :body "newer\n" :direction "in" :msg-type "chat" :timestamp (current-time)) (list :id "old" :body "older\n" :direction "in" :msg-type "chat" :timestamp (current-time))))) ((symbol-function 'run-with-timer) (lambda (_secs _repeat fn &rest args) (setq continuation (lambda () (apply fn args)))))) (jabber-chat-buffer-refresh) (should continuation) (should-not (string-match-p "orphan" (buffer-string))) ;; Another real edit between timer ticks must retain its own undo step. (goto-char (point-max)) (insert "!") (undo-boundary) (funcall continuation) (should (equal (buffer-substring jabber-point-insert (point-max)) "draft λ!")) (should (string-prefix-p "older\nnewer\n" (buffer-string))) (let ((last-command nil)) (undo-only 1)) (should (equal (buffer-substring jabber-point-insert (point-max)) "draft λ")) (let ((last-command 'undo)) (undo-only 1)) (should (= jabber-point-insert (point-max))))))) (ert-deftest jabber-test-chatbuffer-redraw-preserves-window-draft-offsets () "Redrawing the footer preserves both windows' independent draft points." (save-window-excursion (jabber-test-chatbuffer-with-render-boundaries (switch-to-buffer (current-buffer)) (let ((other (split-window-below))) (set-window-buffer other (current-buffer)) (goto-char jabber-point-insert) (set-window-point other (+ jabber-point-insert 4)) (jabber-chat-ewoc-refresh) (should (= (point) jabber-point-insert)) (should (= (window-point other) (+ jabber-point-insert 4))) (should (equal (buffer-substring jabber-point-insert (point-max)) "draft λ")))))) ;;; 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-connections '(test-connection))) (jabber-test-chatbuffer-with-ewoc (setq-local major-mode 'jabber-chat-mode jabber-buffer-connection 'test-connection jabber-chatting-with "alice@example.com") (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 'test-connection "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.15.1/tests/jabber-test-chatstates.el000066400000000000000000002173661527111033600221560ustar00rootroot00000000000000;;; 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*")) timer sent) (unwind-protect (cl-letf (((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) (jabber-chatstates-kick-timer) (setq timer jabber-chatstates-paused-timer)) (with-temp-buffer (apply (timer--function timer) (timer--args timer))) (should (equal sent `(message ((to . "them@example.com") (type . "chat")) (thread () "thread-1") (paused ((xmlns . ,jabber-chatstates-xmlns))))))) (when timer (cancel-timer timer)) (with-current-buffer origin (jabber-chatstates-stop-timer)) (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..."))))))))) ;;; Native composition lifecycle (defmacro jabber-test-chatstates--with-composer (&rest body) "Run BODY with real chat input, hooks, and timers but captured wire sends." (declare (indent 0) (debug t)) `(let ((buffer (generate-new-buffer " *chatstate-composer*")) sent) (unwind-protect (save-window-excursion (switch-to-buffer buffer) (jabber-chat-mode) (let ((jabber-chat-encryption 'plaintext)) (jabber-chat-mode-setup 'test-connection #'ignore)) (setq-local jabber-chatting-with "peer@example.invalid") (setq-local jabber-chatstates-confirm t) ;; Avoid a gone send during fixture teardown. (jabber-chatstates--enable-send-hooks t) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (_jc stanza) (push (caar (last stanza)) sent)))) ,@body)) (when (buffer-live-p buffer) (with-current-buffer buffer (jabber-chatstates-stop-timer)) (kill-buffer buffer))))) (defun jabber-test-chatstates--fire (timer) "Deliver TIMER's captured callback, including after cancellation." (cancel-timer timer) (apply (timer--function timer) (timer--args timer))) (ert-deftest jabber-test-chatstates-native-continued-input-restarts-timer () "Typing restarts the deadline without repeated composing notifications." (jabber-test-chatstates--with-composer (execute-kbd-macro "a") (let ((first jabber-chatstates-paused-timer)) (should (timerp first)) (execute-kbd-macro "b") (should-not (eq first jabber-chatstates-paused-timer)) (should-not (memq first timer-list)) (should (equal sent '(composing))) (jabber-test-chatstates--fire first) (should (equal sent '(composing))) (should-not jabber-chatstates-inactive-timer)))) (ert-deftest jabber-test-chatstates-native-clear-retires-timers () "Clearing the draft sends active and makes the old paused callback inert." (jabber-test-chatstates--with-composer (execute-kbd-macro "a") (let ((first jabber-chatstates-paused-timer)) (execute-kbd-macro (kbd "DEL")) (should (equal sent '(active composing))) (should-not jabber-chatstates-paused-timer) (should-not jabber-chatstates-inactive-timer) (should-not (memq first timer-list)) (jabber-test-chatstates--fire first) (should (equal sent '(active composing))) (should-not jabber-chatstates-inactive-timer)))) (ert-deftest jabber-test-chatstates-native-motion-does-not-compose () "Navigation neither restarts composing nor resumes a paused draft." (jabber-test-chatstates--with-composer (execute-kbd-macro "ab") (let ((timer jabber-chatstates-paused-timer)) (execute-kbd-macro (kbd "C-b")) (should (eq timer jabber-chatstates-paused-timer)) (jabber-test-chatstates--fire timer) (should (equal sent '(paused composing))) (let ((inactive jabber-chatstates-inactive-timer)) (execute-kbd-macro (kbd "C-f")) (should (eq inactive jabber-chatstates-inactive-timer)) (should (equal sent '(paused composing))) (execute-kbd-macro "c") (should (equal sent '(composing paused composing))) (should-not (memq inactive timer-list)) (jabber-test-chatstates--fire inactive) (should (equal sent '(composing paused composing))))))) (ert-deftest jabber-test-chatstates-native-clear-after-paused () "Clearing a paused draft retires inactive and reports active once." (jabber-test-chatstates--with-composer (execute-kbd-macro "a") (jabber-test-chatstates--fire jabber-chatstates-paused-timer) (let ((inactive jabber-chatstates-inactive-timer)) (execute-kbd-macro (kbd "DEL")) (should (equal sent '(active paused composing))) (should-not jabber-chatstates-inactive-timer) (jabber-test-chatstates--fire inactive) (should (equal sent '(active paused composing)))))) (ert-deftest jabber-test-chatstates-native-mode-change-retires-timer () "Mode replacement cancels timers and prevents same-buffer stale sends." (jabber-test-chatstates--with-composer (execute-kbd-macro "a") (let ((timer jabber-chatstates-paused-timer)) (fundamental-mode) (should-not (memq timer timer-list)) (jabber-test-chatstates--fire timer) (should (equal sent '(composing)))))) (ert-deftest jabber-test-chatstates-native-timer-delivery () "The native event loop delivers the current timer exactly once." (jabber-test-chatstates--with-composer (execute-kbd-macro "a") (let ((timer jabber-chatstates-paused-timer)) (cancel-timer timer) (timer-set-time timer (current-time)) (timer-activate timer) ;; A single short wait can expire before timers run on a slow host. (let ((deadline (+ (float-time) 30))) (while (and (memq timer timer-list) (< (float-time) deadline)) (sleep-for 0.01))) (should (equal sent '(paused composing))) (should-not jabber-chatstates-paused-timer) (should (timerp jabber-chatstates-inactive-timer)) (jabber-test-chatstates--fire timer) (should (equal sent '(paused composing)))))) (ert-deftest jabber-test-chatstates-native-send-retires-timers () "A send hook retires old callbacks without an extra active notification." (jabber-test-chatstates--with-composer (execute-kbd-macro "draft") (let ((timer jabber-chatstates-paused-timer)) (should (equal (caar (jabber-chatstates-when-sending "draft" "id")) 'active)) (delete-region jabber-point-insert (point-max)) (run-hooks 'post-command-hook) (jabber-test-chatstates--fire timer) (should (equal sent '(composing))) (should-not jabber-chatstates-paused-timer) (should-not jabber-chatstates-inactive-timer)))) (ert-deftest jabber-test-chatstates-native-kill-retires-timer () "A callback for a killed buffer cannot send or create an inactive timer." (jabber-test-chatstates--with-composer (execute-kbd-macro "a") (let ((timer jabber-chatstates-paused-timer)) (kill-buffer buffer) (should-not (memq timer timer-list)) (jabber-test-chatstates--fire timer) (should (equal sent '(composing)))))) (ert-deftest jabber-test-chatstates-native-opt-out-retires-timer () "Negotiation opt-out retires callbacks even if negotiation later resumes." (jabber-test-chatstates--with-composer (execute-kbd-macro "a") (let ((timer jabber-chatstates-paused-timer)) (jabber-chatstates--handle-direct-state buffer 'test-connection (jabber-test-chatstates--plain-message "peer@example.invalid" "chat")) (should-not (memq timer timer-list)) (should-not jabber-chatstates-paused-timer) (jabber-chatstates--enable-send-hooks t) (jabber-test-chatstates--fire timer) (should (equal sent '(composing)))))) (provide 'jabber-test-chatstates) ;;; jabber-test-chatstates.el ends here emacs-jabber-0.15.1/tests/jabber-test-conn.el000066400000000000000000002155131527111033600207400ustar00rootroot00000000000000;;; 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 (get 'fake-fsm :connect-attempt)))) (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") ,(get 'fake-fsm :connect-attempt))))))) (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 ,(get 'fake-fsm :connect-attempt)) (: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-closed-handoff-uses-error-state-cleanup () "A process closed before FSM handoff is rejected and its buffer is cleaned." (dolist (keep-buffer '(nil t)) (let* ((buffer (generate-new-buffer " *jabber-closed-handoff*")) (connection (make-pipe-process :name "jabber-closed-handoff" :buffer buffer)) (fsm (make-symbol "jabber-closed-handoff")) (jabber-connections (list fsm)) (jabber-auto-reconnect t) (jabber-debug-keep-process-buffers keep-buffer) (jabber-lost-connection-hooks nil) (jabber-lifecycle-session-reset-functions nil) (state-data (list :username "romeo" :server "example.org" :resource "emacs" :ever-session-established t)) result) (unwind-protect (progn (delete-process connection) (setq result (funcall (jabber-test-conn--state-handler :connecting) fsm state-data (list :connected connection nil) #'ignore)) (should-not (car result)) (should (equal (plist-get (cadr result) :disconnection-reason) "Connection closed before protocol handoff")) (pcase-let ((`(,cleaned ,delay) (funcall (gethash nil (get 'jabber-connection :fsm-enter)) fsm (cadr result)))) (should (= delay jabber-reconnect-delay)) (should-not (plist-get cleaned :connection))) (should-not (process-live-p connection)) (should (eq (buffer-live-p buffer) keep-buffer))) (when (buffer-live-p buffer) (kill-buffer buffer)))))) (ert-deftest jabber-conn-test-ordinary-reconnect-clears-encryption () "An ordinary TCP reconnect clears old transport state." (let* ((connection 'new-connection) (result (funcall (jabber-test-conn--state-handler :connecting) 'fake-fsm '(:encrypted t :disconnection-reason "old") (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)) (should-not (plist-get state-data :disconnection-reason)))) (ert-deftest jabber-conn-test-stale-dead-event-does-not-close-successor () "Loss evidence for an old transport must not close its successor." (let* ((old-transport (make-symbol "old-transport")) (new-transport (make-symbol "new-transport")) (state-data (list :connection new-transport :disconnection-reason nil)) (handler (jabber-test-conn--state-handler :session-established)) (stale (funcall handler 'fake-fsm state-data (list :connection-dead old-transport "old failure") #'ignore)) (current (funcall handler 'fake-fsm state-data (list :connection-dead new-transport "new failure") #'ignore))) (should (eq (car stale) :session-established)) (should (eq (cadr stale) state-data)) (should-not (car current)) (should (equal (plist-get (cadr current) :disconnection-reason) "new failure")))) (ert-deftest jabber-conn-test-bare-dead-event-is-ignored () "Loss evidence without a transport identity cannot close a session." (let* ((state-data (list :connection (make-symbol "transport"))) (handler (jabber-test-conn--state-handler :session-established)) (result (condition-case nil (funcall handler 'fake-fsm state-data :connection-dead #'ignore) (error 'handler-error)))) (should (eq (car-safe result) :session-established)) (should (eq (cadr result) state-data)))) (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-starttls-requires-tls-namespace () "A local-name collision must not impose STARTTLS on plaintext policy." (let* ((features '(features nil (starttls ((xmlns . "urn:example:not-tls"))))) (result (funcall (jabber-test-conn--state-handler :connected) 'fake-fsm '(:connection-type network :encrypted nil) (list :stanza features) #'ignore))) (should-not (eq (car result) :starttls)))) (ert-deftest jabber-conn-test-starttls-policy-survives-stripped-feature () "Configured STARTTLS policy must attempt TLS without an advertisement." (let* ((features '(features nil (mechanisms ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl"))))) (result (funcall (jabber-test-conn--state-handler :connected) 'fake-fsm '(:connection-type starttls :encrypted nil) (list :stanza features) #'ignore))) (should (eq (car result) :starttls)))) (ert-deftest jabber-conn-test-starttls-required-overrides-plaintext-policy () "A server-required TLS feature must be negotiated before SASL." (let* ((features `(features nil (starttls ((xmlns . ,jabber-tls-xmlns)) (required nil)))) (result (funcall (jabber-test-conn--state-handler :connected) 'fake-fsm '(:connection-type network :encrypted nil) (list :stanza features) #'ignore))) (should (eq (car result) :starttls)))) (ert-deftest jabber-conn-test-starttls-required-validates-child-namespace () "Required is recognized only in the inherited or explicit TLS namespace." (let ((inherited `(features nil (starttls ((xmlns . ,jabber-tls-xmlns)) (required nil)))) (explicit `(features nil (starttls ((xmlns . ,jabber-tls-xmlns)) (required ((xmlns . ,jabber-tls-xmlns)))))) (wrong `(features nil (starttls ((xmlns . ,jabber-tls-xmlns)) (required ((xmlns . "urn:example:not-tls"))))))) (should (jabber-conn--starttls-required-p inherited)) (should (jabber-conn--starttls-required-p explicit)) (should-not (jabber-conn--starttls-required-p wrong)))) (ert-deftest jabber-conn-test-starttls-rejects-premature-stream-start () "A stream restart before TLS succeeds must fail closed." (let* ((state-data '(:connection connection :server "example.com")) (result (funcall (jabber-test-conn--state-handler :starttls) 'fake-fsm state-data '(:stream-start "premature" "1.0") #'ignore))) (should-not (car result)) (should-not (plist-get (cadr result) :encrypted)) (should (string-match-p "Unexpected stream restart during STARTTLS" (plist-get (cadr result) :disconnection-reason))))) (ert-deftest jabber-conn-test-starttls-rejects-stale-features () "Pre-TLS features must not be accepted as a STARTTLS response." (let* ((state-data '(:connection connection :server "example.com")) (fsm (make-symbol "jabber-test-starttls")) (features `(features nil (starttls ((xmlns . ,jabber-tls-xmlns)) (required nil)))) result) (put fsm :state-data state-data) (setq result (funcall (jabber-test-conn--state-handler :starttls) fsm state-data (list :stanza features) #'ignore)) (should-not (car result)) (should-not (plist-get (cadr result) :encrypted)) (should (string-match-p "Unexpected STARTTLS response" (plist-get (cadr result) :disconnection-reason))))) (ert-deftest jabber-conn-test-starttls-rejects-wrong-response-namespace () "A proceed element outside the TLS namespace must fail closed." (let* ((state-data '(:connection connection :server "example.com")) (fsm (make-symbol "jabber-test-starttls")) (proceed '(proceed ((xmlns . "urn:example:not-tls")))) result) (put fsm :state-data state-data) (setq result (funcall (jabber-test-conn--state-handler :starttls) fsm state-data (list :stanza proceed) #'ignore)) (should-not (car result)) (should-not (plist-get (cadr result) :encrypted)) (should (string-match-p "Unexpected STARTTLS response" (plist-get (cadr result) :disconnection-reason))))) (ert-deftest jabber-conn-test-starttls-rejects-queued-pre-restart-features () "Queued pre-TLS features must not cross a successful TLS restart." (let ((features `(features nil (starttls ((xmlns . ,jabber-tls-xmlns)) (required nil)))) (connection (make-symbol "jabber-test-connection")) sasl-called) (cl-letf (((symbol-function 'jabber-network-connect) #'ignore) ((symbol-function 'jabber-send-stream-header) #'ignore) ((symbol-function 'jabber-starttls-initiate) #'ignore) ((symbol-function 'gnutls-negotiate) (lambda (&rest _) connection)) ((symbol-function 'jabber-sasl-start-auth) (lambda (&rest _) (setq sasl-called t)))) (let ((fsm (start-jabber-connection "romeo" "example.com" "emacs" nil "secret" nil nil 'starttls))) (fsm-send-sync fsm (list :connected connection nil)) (fsm-send-sync fsm '(:stream-start "before-tls" "1.0")) (fsm-send-sync fsm (list :stanza features)) (fsm-send-sync fsm `(:stanza (proceed ((xmlns . ,jabber-tls-xmlns))))) (fsm-send-sync fsm (list :stanza features)) (should-not (get fsm :state)) (should-not sasl-called) (should (string-match-p "before the restarted stream header" (plist-get (fsm-get-state-data fsm) :disconnection-reason))))))) (ert-deftest jabber-conn-test-starttls-restarts-with-fresh-features () "A successful TLS restart authenticates from post-TLS features only." (let* ((pre-tls-features `(features nil (starttls ((xmlns . ,jabber-tls-xmlns)) (required nil)))) (post-tls-features '(features nil (mechanisms ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl")) (mechanism nil "PLAIN")))) (connection (make-symbol "jabber-test-connection")) negotiated-features tls-called) (cl-letf (((symbol-function 'jabber-network-connect) #'ignore) ((symbol-function 'jabber-send-stream-header) #'ignore) ((symbol-function 'jabber-starttls-initiate) #'ignore) ((symbol-function 'gnutls-negotiate) (lambda (&rest _) (setq tls-called t) connection)) ((symbol-function 'jabber-sasl-start-auth) (lambda (_fsm features) (setq negotiated-features features) '(sasl-state)))) (let ((fsm (start-jabber-connection "romeo" "example.com" "emacs" nil "secret" nil nil 'starttls))) (fsm-send-sync fsm (list :connected connection nil)) (fsm-send-sync fsm '(:stream-start "before-tls" "1.0")) (fsm-send-sync fsm (list :stanza pre-tls-features)) (should (eq (get fsm :state) :starttls)) (fsm-send-sync fsm `(:stanza (proceed ((xmlns . ,jabber-tls-xmlns))))) (should tls-called) (should (eq (get fsm :state) :connected)) (should (plist-get (fsm-get-state-data fsm) :encrypted)) (fsm-send-sync fsm '(:stream-start "after-tls" "1.0")) (fsm-send-sync fsm (list :stanza post-tls-features)) (should (eq (get fsm :state) :sasl-auth)) (should (eq negotiated-features post-tls-features)) (should-not (eq negotiated-features pre-tls-features)))))) (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)) ;; Model a reconnect, not an initial connection failure. (put fsm :state-data (plist-put (fsm-get-state-data fsm) :ever-session-established t)) (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 '(:stream-start "reconnected" "1.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))))))) ;;; Transport event ownership (ert-deftest jabber-conn-test-stale-sentinel-preserves-successor () "A late sentinel cannot close a successor, including virtual transports." (let ((jabber-connections nil) (jabber-lost-connection-hooks nil)) (cl-letf (((symbol-function 'jabber-network-connect) #'ignore) ((symbol-function 'jabber-send-stream-header) #'ignore) ((symbol-function 'jabber-lifecycle-dispatch-session-reset) #'ignore) ((symbol-function 'jabber-lifecycle-dispatch-connection-list-changed) #'ignore)) (let* ((fsm (start-jabber-connection "romeo" "example.com" "emacs" nil "secret" nil nil 'starttls)) (old (make-symbol "old-transport")) (current (make-symbol "current-virtual-transport"))) (fsm-send-sync fsm (list :connected current)) (let ((state-data (fsm-get-state-data fsm))) (fsm-send-sync fsm (list :sentinel old "closed\n")) (should (eq (get fsm :state) :connected)) (should (eq (fsm-get-state-data fsm) state-data)) (should-not (plist-get state-data :disconnection-reason))) (fsm-send-sync fsm (list :sentinel current "closed\n")) (should-not (get fsm :state)) (should (equal (plist-get (fsm-get-state-data fsm) :disconnection-reason) "closed")))))) (ert-deftest jabber-conn-test-stale-filter-preserves-parse-buffers () "Old transport data is ignored before insertion or XML parser effects." (let ((old-buffer (generate-new-buffer " *jabber-old-filter*")) (new-buffer (generate-new-buffer " *jabber-new-filter*")) old current parsed) (unwind-protect (cl-letf (((symbol-function 'jabber-network-connect) #'ignore) ((symbol-function 'jabber-send-stream-header) #'ignore) ((symbol-function 'jabber-filter) (lambda (process _fsm) (push process parsed)))) (setq old (make-pipe-process :name "jabber-old" :buffer old-buffer)) (setq current (make-pipe-process :name "jabber-new" :buffer new-buffer)) (let ((fsm (start-jabber-connection "romeo" "example.com" "emacs" nil "secret" nil nil 'starttls))) (fsm-send-sync fsm (list :connected current)) (fsm-send-sync fsm (list :filter old "")) (should-not parsed) (should (equal (with-current-buffer old-buffer (buffer-string)) "")) (should (equal (with-current-buffer new-buffer (buffer-string)) "")) (fsm-send-sync fsm (list :filter current "")) (should (equal parsed (list current))) (should (equal (with-current-buffer new-buffer (buffer-string)) "")) (set-process-sentinel current #'ignore))) (when old (delete-process old)) (when current (set-process-sentinel current #'ignore) (delete-process current)) (kill-buffer old-buffer) (kill-buffer new-buffer)))) ;;; 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") ,(get 'fake-fsm :connect-attempt)) 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") ,(get 'fake-fsm :connect-attempt)) 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))))) (ert-deftest jabber-conn-test-disconnect-cancels-targets () "Cancel TCP and SOCKS attempts, timers, and late completions before retry." (dolist (timeout '(nil 60)) (dolist (phase '(tcp handoff method reply)) (let* ((jabber-connections nil) (jabber-process-buffer " *jabber-test-cancel*") (jabber-debug-keep-process-buffers nil) (jabber-connection-timeout timeout) (proxy (unless (memq phase '(tcp handoff)) '(:type socks5 :host "proxy.test" :port 1080))) (native-run-at-time (symbol-function 'run-at-time)) processes buffers targets timers jc fresh) (cl-letf (((symbol-function 'jabber-srv-targets) (lambda (&rest _) '(("first.test" 5222 nil) ("second.test" 5222 nil)))) ((symbol-function 'jabber-conn--make-process) (lambda (host _port buffer &rest _) (push host targets) (push buffer buffers) (let ((process (make-pipe-process :name "jabber-test-cancel" :buffer buffer :noquery t))) (push process processes) process))) ((symbol-function 'process-send-string) #'ignore) ((symbol-function 'run-at-time) (lambda (time repeat function &rest args) (let ((timer (apply native-run-at-time time repeat function args))) (when (equal time 60) (push timer timers)) timer)))) (unwind-protect (progn (setq jc (start-jabber-connection "alice" "example.test" "desktop" nil nil nil nil 'network proxy)) (push jc jabber-connections) (let* ((process (car processes)) (buffer (process-buffer process)) (sentinel (process-sentinel process)) filter) (when (eq phase 'handoff) (funcall sentinel process "open\n")) (when proxy (funcall sentinel process "open\n") (setq filter (process-filter process)) (when (eq phase 'reply) (funcall filter process (unibyte-string 5 0)))) (jabber-disconnect-one jc) (should-not (get jc :state)) (should (plist-get (fsm-get-state-data jc) :disconnection-expected)) (should-not (memq jc jabber-connections)) (should-not (process-live-p process)) (should-not (buffer-live-p buffer)) (dolist (timer timers) (should-not (memq timer timer-list))) ;; Old callbacks must not start another target or affect a ;; newly connecting account, even when invoked explicitly. (setq fresh (start-jabber-connection "alice" "example.test" "desktop" nil nil nil nil 'network proxy)) (push fresh jabber-connections) (funcall sentinel process "failed\n") (funcall sentinel process "open\n") (when filter (funcall filter process (unibyte-string 5 0 0 1 127 0 0 1 0 0))) (dolist (timer timers) (unless (memq timer timer-list) (apply (timer--function timer) (timer--args timer)))) (accept-process-output nil 0.01) (should (equal targets '("first.test" "first.test"))) (should (eq (get fresh :state) :connecting)) (should (process-live-p (car processes))) ;; The fresh attempt can still complete normally. (let ((new (car processes))) (funcall (process-sentinel new) new "open\n") (when proxy (funcall (process-filter new) new (unibyte-string 5 0)) (funcall (process-filter new) new (unibyte-string 5 0 0 1 127 0 0 1 0 0))) (let ((deadline (+ (float-time) 30))) (while (and (eq (get fresh :state) :connecting) (< (float-time) deadline)) (accept-process-output nil 0.01))) (should (eq (get fresh :state) :connected)) (should (eq new (plist-get (fsm-get-state-data fresh) :connection)))))) (dolist (timer timers) (cancel-timer timer)) (dolist (fsm (list jc fresh)) (when fsm (jabber-disconnect-one fsm))) (dolist (process processes) (set-process-sentinel process #'ignore) (delete-process process)) (dolist (buffer buffers) (when (buffer-live-p buffer) (kill-buffer buffer))))))))) (ert-deftest jabber-conn-test-replacement-rejects-queued-result () "A queued result from an old attempt cannot claim its replacement." (dolist (status '("open\n" "failed\n")) (let ((jabber-connections nil) (jabber-process-buffer " *jabber-test-replacement*") (jabber-debug-keep-process-buffers nil) (jabber-connection-timeout nil) processes buffers jc) (cl-letf (((symbol-function 'jabber-srv-targets) (lambda (&rest _) '(("target.test" 5222 nil)))) ((symbol-function 'jabber-conn--make-process) (lambda (_host _port buffer &rest _) (push buffer buffers) (let ((process (make-pipe-process :name "jabber-test-replacement" :buffer buffer :noquery t))) (push process processes) process))) ((symbol-function 'process-send-string) #'ignore)) (unwind-protect (progn (setq jc (start-jabber-connection "alice" "example.test" "desktop" nil nil nil nil 'network)) (push jc jabber-connections) (let ((old (car processes))) (funcall (process-sentinel old) old status) (jabber-network-connect-async jc "example.test" nil nil) (accept-process-output nil 0.01) (should-not (process-live-p old)) (should (eq (get jc :state) :connecting)) (should (process-live-p (car processes))) (funcall (process-sentinel (car processes)) (car processes) "open\n") (let ((deadline (+ (float-time) 30))) (while (and (eq (get jc :state) :connecting) (< (float-time) deadline)) (accept-process-output nil 0.01))) (should (eq (get jc :state) :connected)) (should (eq (car processes) (plist-get (fsm-get-state-data jc) :connection))))) (when jc (jabber-disconnect-one jc)) (dolist (process processes) (set-process-sentinel process #'ignore) (delete-process process)) (dolist (buffer buffers) (when (buffer-live-p buffer) (kill-buffer buffer)))))))) (defun jabber-conn-test--cancel-during-entry (phase) "Cancel a native reconnect while its PHASE yields, then replace it." (dolist (timeout '(nil 60)) (let* ((jc (make-symbol "jabber-test-entry")) (jabber-connections (list jc)) (jabber-auto-reconnect t) (jabber-reconnect-delay 600) (jabber-direct-tls-lookup nil) (jabber-connection-timeout timeout) (jabber-debug-keep-process-buffers nil) (jabber-process-buffer " *jabber-test-entry*") (state (jabber-sm--reset (list :username "alice" :server "example.test" :resource "desktop" :connection-type 'network :connection 'old-transport :send-function #'ignore :ever-session-established t))) (failures 0) (creates 0) cancelled old-attempt fresh processes buffers timers) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state) (plist-put state :sm-enabled t) (plist-put state :sm-id "resume-id") (when (eq phase 'process) (plist-put state :network-server "old.test")) (jabber-sm--enqueue-pending state '(message nil (body nil "queued")) nil (lambda (_reason) (cl-incf failures))) (cl-labels ((cancel-and-replace () (jabber-disconnect-one jc) (setq cancelled t) ;; Install a successor before the old connecting entry returns. (setq fresh (start-jabber-connection "alice" "example.test" "desktop" nil nil "fresh.test" 5222 'network)) (push fresh jabber-connections))) (cl-letf (((symbol-function 'dns-query-asynchronous) (lambda (_name callback &rest _) ;; Retain native SRV discovery and dns-query's wait loop. (setq old-attempt (get jc :connect-attempt)) (push (run-at-time 0 nil (lambda () (cancel-and-replace) (funcall callback nil))) timers) t)) ((symbol-function 'jabber-conn--make-process) (lambda (host _port buffer &rest _) (cl-incf creates) (push buffer buffers) (let ((process (make-pipe-process :name "jabber-test-entry" :buffer buffer :noquery t))) (push process processes) (when (equal host "old.test") (setq old-attempt (get jc :connect-attempt)) (push (run-at-time 0 nil #'cancel-and-replace) timers) (let ((deadline (+ (float-time) 30))) (while (and (not cancelled) (< (float-time) deadline)) (accept-process-output nil 0.01)))) process))) ((symbol-function 'process-send-string) #'ignore)) (unwind-protect (progn (fsm-send-sync jc '(:connection-dead old-transport "lost")) (should (timerp (get jc :timeout))) (fsm-send-sync jc :timeout) (should cancelled) (should old-attempt) (should-not (get jc :state)) (should (plist-get (fsm-get-state-data jc) :terminalized)) (should (plist-get (fsm-get-state-data jc) :disconnection-expected)) (should-not (memq jc jabber-connections)) (dolist (key '(:sm-pending-queue :sm-recovered-queue :sm-outbound-queue)) (should-not (plist-get (fsm-get-state-data jc) key))) (should-not (get jc :timeout)) (should-not (get jc :connect-attempt)) (should-not (get jc :connect-cancel)) (should (= failures 1)) ;; Neither repeated stop nor late results may settle it again. (jabber-disconnect-one jc) (fsm-send-sync jc (list :connected 'old-transport nil old-attempt)) (fsm-send-sync jc (list :connection-failed '("late") old-attempt)) (fsm-send-sync jc :timeout) (should (= failures 1)) (should-not (get jc :state)) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (should (equal jabber-connections (list fresh))) (should (eq (get fresh :state) :connecting)) (should (= creates (if (eq phase 'process) 2 1))) (dolist (process (cdr processes)) (should-not (process-live-p process)) (funcall (process-sentinel process) process "failed\n") (funcall (process-sentinel process) process "open\n")) (dolist (buffer (cdr buffers)) (should-not (buffer-live-p buffer))) (let ((new (car processes))) (should (process-live-p new)) (funcall (process-sentinel new) new "open\n") (let ((deadline (+ (float-time) 30))) (while (and (eq (get fresh :state) :connecting) (< (float-time) deadline)) (accept-process-output nil 0.01))) (should (eq (get fresh :state) :connected)) (should (eq new (plist-get (fsm-get-state-data fresh) :connection)))) (should (= failures 1)) (should (= creates (if (eq phase 'process) 2 1)))) (dolist (timer timers) (cancel-timer timer)) (dolist (fsm (list jc fresh)) (when fsm (jabber-disconnect-one fsm) (fsm-stop-timer fsm) (jabber-conn--cancel-connect fsm))) (dolist (process processes) (set-process-sentinel process #'ignore) (delete-process process)) (dolist (buffer buffers) (when (buffer-live-p buffer) (kill-buffer buffer))))))))) (ert-deftest jabber-conn-test-disconnect-during-native-dns-entry () "Keep terminal settlement when public disconnect interrupts native DNS." (jabber-conn-test--cancel-during-entry 'dns)) (ert-deftest jabber-conn-test-disconnect-during-process-entry () "Keep terminal settlement when public disconnect interrupts process setup." (jabber-conn-test--cancel-during-entry 'process)) (ert-deftest jabber-conn-test-connecting-entry-preserves-successor-timer () "Preserve a retry timer installed by a reentrant connecting failure." (let* ((jc (make-symbol "jabber-test-entry-timer")) (jabber-connections (list jc)) (jabber-auto-reconnect t) (jabber-reconnect-delay 600) (state (jabber-sm--reset (list :username "alice" :server "example.test" :ever-session-established t))) successor-state successor-timer) (put jc :name 'jabber-connection) (cl-letf (((symbol-function 'jabber-get-connect-function) (lambda (_type) (lambda (fsm &rest _) (fsm-send-sync fsm '(:connection-failed ("setup failed"))) (setq successor-state (fsm-get-state-data fsm) successor-timer (get fsm :timeout)))))) (unwind-protect (progn (fsm-update jc :connecting state nil) (should-not (get jc :state)) (should (eq successor-state (fsm-get-state-data jc))) (should (timerp successor-timer)) (should (eq successor-timer (get jc :timeout))) (should (memq successor-timer timer-list))) (jabber-disconnect-one jc) (fsm-stop-timer jc))))) (defun jabber-conn-test--replacement-cleanup (action timeout) "Exercise ACTION in predecessor cleanup with connection TIMEOUT." (let ((jabber-connections nil) (jabber-process-buffer " *jabber-test-cleanup-admission*") (jabber-debug-keep-process-buffers nil) (jabber-connection-timeout timeout) (native-run-at-time (symbol-function 'run-at-time)) (native-srv-targets (symbol-function 'jabber-srv-targets)) jc processes buffers hosts discoveries timers old-token outer-token newer-token newer-cancel newer-process) (cl-letf (((symbol-function 'jabber-conn--make-process) (lambda (host _port buffer &rest _) (push host hosts) (push buffer buffers) (let ((process (make-pipe-process :name "jabber-test-cleanup-admission" :buffer buffer :noquery t))) (push process processes) process))) ((symbol-function 'jabber-srv-targets) (lambda (server network-server port &optional proxy) (push network-server discoveries) (funcall native-srv-targets server network-server port proxy))) ((symbol-function 'process-send-string) #'ignore) ((symbol-function 'run-at-time) (lambda (time repeat function &rest args) (let ((timer (apply native-run-at-time time repeat function args))) ;; Native editing may also allocate an undo boundary timer. (when (equal time 60) (push timer timers)) timer)))) (unwind-protect (progn ;; Native construction connects before account registration. (setq jc (start-jabber-connection "alice" "example.test" "desktop" nil nil "old.test" 5222 'network)) (should-not (memq jc jabber-connections)) (should (process-live-p (car processes))) (setq old-token (get jc :connect-attempt)) (push jc jabber-connections) (with-current-buffer (car buffers) (add-hook 'kill-buffer-hook (lambda () (setq outer-token (get jc :connect-attempt)) (if (eq action 'stop) (jabber-disconnect-one jc) (jabber-network-connect-async jc "example.test" "newer.test" 5222) (setq newer-token (get jc :connect-attempt) newer-cancel (get jc :connect-cancel) newer-process (car processes)))) nil t)) (jabber-network-connect-async jc "example.test" "outer.test" 5222) (if (eq action 'stop) (progn (should (equal hosts '("old.test"))) (should (equal discoveries '("old.test"))) (should (= (length timers) (if timeout 1 0)))) (should (equal hosts '("newer.test" "old.test"))) (should (equal discoveries '("newer.test" "old.test"))) (should (= (length timers) (if timeout 2 0))) (should newer-token) (should newer-cancel) (should-not (eq newer-token outer-token)) (should (eq newer-token (get jc :connect-attempt))) (should (eq newer-cancel (get jc :connect-cancel))) (should (process-live-p newer-process)) (should-not (process-live-p (cadr processes))) (should-not (buffer-live-p (cadr buffers))) ;; The winner's timer remains active until normal handoff. (when timeout (should (memq (car timers) timer-list)) (should-not (memq (cadr timers) timer-list))) (funcall (process-sentinel newer-process) newer-process "open\n") (let ((deadline (+ (float-time) 30))) (while (and (eq (get jc :state) :connecting) (< (float-time) deadline)) (accept-process-output nil 0.01))) (should (eq (get jc :state) :connected)) (should (eq newer-process (plist-get (fsm-get-state-data jc) :connection)))) ;; Teardown must see B's admission, not A or an empty slot. (should outer-token) (should-not (eq old-token outer-token)) (jabber-disconnect-one jc) (jabber-disconnect-one jc) (should-not (get jc :state)) (should (plist-get (fsm-get-state-data jc) :terminalized)) (should (plist-get (fsm-get-state-data jc) :disconnection-expected)) (should-not (memq jc jabber-connections)) (should-not (get jc :timeout)) (should-not (get jc :connect-attempt)) (should-not (get jc :connect-cancel)) (should-not (cl-some #'process-live-p processes)) (should-not (cl-some #'buffer-live-p buffers)) (dolist (timer timers) (should-not (memq timer timer-list)) (should-not (memq timer timer-idle-list)))) (when jc (jabber-disconnect-one jc) (jabber-conn--cancel-connect jc) (fsm-stop-timer jc)) (dolist (timer timers) (cancel-timer timer)) (dolist (process processes) (set-process-sentinel process #'ignore) (delete-process process)) (dolist (buffer buffers) (when (buffer-live-p buffer) (with-current-buffer buffer (setq kill-buffer-hook nil)) (kill-buffer buffer))))))) (ert-deftest jabber-conn-test-replacement-cleanup-stop-without-timeout () "Respect public stop during replacement cleanup without a timeout." (jabber-conn-test--replacement-cleanup 'stop nil)) (ert-deftest jabber-conn-test-replacement-cleanup-stop-with-timeout () "Respect public stop during replacement cleanup with a finite timeout." (jabber-conn-test--replacement-cleanup 'stop 60)) (ert-deftest jabber-conn-test-replacement-cleanup-successor-without-timeout () "Preserve a cleanup-hook successor without a timeout." (jabber-conn-test--replacement-cleanup 'replace nil)) (ert-deftest jabber-conn-test-replacement-cleanup-successor-with-timeout () "Preserve a cleanup-hook successor with a finite timeout." (jabber-conn-test--replacement-cleanup 'replace 60)) (defun jabber-conn-test--handoff-change (action keep-buffer timeout hook) "Exercise ACTION during native handoff with KEEP-BUFFER, TIMEOUT and HOOK." (let ((jabber-connections nil) (jabber-process-buffer " *jabber-test-handoff-change*") (jabber-debug-keep-process-buffers keep-buffer) (jabber-connection-timeout timeout) (jabber-auto-reconnect t) (jabber-reconnect-delay 600) (native-send (symbol-function 'process-send-string)) (native-run-at-time (symbol-function 'run-at-time)) (failures 0) jc processes buffers timers writes fired successor-state successor-token successor-cancel successor-timer retired-filter retired-sentinel) (cl-letf (((symbol-function 'jabber-conn--make-process) (lambda (_host _port buffer &rest _) (push buffer buffers) (let ((process (make-pipe-process :name "jabber-test-handoff-change" :buffer buffer :noquery t))) (push process processes) process))) ((symbol-function 'process-send-string) (lambda (process wire) (push process writes) (funcall native-send process wire))) ((symbol-function 'run-at-time) (lambda (time repeat function &rest args) (let ((timer (apply native-run-at-time time repeat function args))) (when (memq time '(60 600)) (push timer timers)) timer)))) (unwind-protect (progn (setq jc (start-jabber-connection "alice" "example.test" "desktop" nil nil "old.test" 5222 'network)) (push jc jabber-connections) (plist-put (fsm-get-state-data jc) :ever-session-established t) (jabber-sm--enqueue-pending (fsm-get-state-data jc) '(message nil (body nil "pending")) nil (lambda (_reason) (cl-incf failures))) (let ((old (car processes)) (buffer (car buffers))) (with-current-buffer buffer (insert "transport bytes") (add-hook hook (lambda (&rest _) (unless fired (setq fired t) (pcase action ('error (error "Native handoff hook failed")) ('stop (jabber-disconnect-one jc)) ('replace (jabber-network-connect-async jc "example.test" "newer.test" 5222)) ('retry (fsm-send-sync jc '(:connection-failed ("handoff lost"))))) (setq successor-state (fsm-get-state-data jc) successor-token (get jc :connect-attempt) successor-cancel (get jc :connect-cancel) successor-timer (get jc :timeout) retired-filter (process-filter old) retired-sentinel (process-sentinel old)))) nil t)) (if (eq action 'error) ;; Inspect the real handler's condition before fsm.el's ;; debug/error adapter consumes it. (funcall (gethash :connecting (get 'jabber-connection :fsm-event)) jc (fsm-get-state-data jc) (list :connected old nil (get jc :connect-attempt)) #'ignore) (funcall (process-sentinel old) old "open\n")) (let ((deadline (+ (float-time) 30))) (while (and (not fired) (< (float-time) deadline)) (accept-process-output nil 0.01))) (should fired) (if (eq action 'normal) (progn (should (eq (get jc :state) :connected)) (should (eq old (plist-get (fsm-get-state-data jc) :connection))) (should (plist-get (fsm-get-state-data jc) :awaiting-stream-start)) (should (equal writes (list old))) (should (process-live-p old)) (should-not (get jc :connect-attempt)) (should-not (get jc :connect-cancel)) (should (= (buffer-size buffer) 0))) (should-not writes) (should (eq successor-state (fsm-get-state-data jc))) (should (eq retired-filter (process-filter old))) (should (eq retired-sentinel (process-sentinel old))) (should-not (process-live-p old)) (should (eq (buffer-live-p buffer) keep-buffer)) (should (eq successor-token (get jc :connect-attempt))) (should (eq successor-cancel (get jc :connect-cancel))) (should (eq successor-timer (get jc :timeout))) (pcase action ('stop (should-not (get jc :state)) (should (= failures 1)) (should (plist-get successor-state :terminalized)) (should (plist-get successor-state :disconnection-expected)) (should-not (memq jc jabber-connections)) (should-not (plist-get successor-state :sm-pending-queue))) ('retry (should-not (get jc :state)) (should (timerp successor-timer)) (should (memq successor-timer timer-list)) (should (memq jc jabber-connections))) ('replace (should (eq (get jc :state) :connecting)) (should successor-token) (should successor-cancel) (should (process-live-p (car processes))) (when timeout (should (memq (car timers) timer-list))) (let ((new (car processes))) (funcall (process-sentinel new) new "open\n") (let ((deadline (+ (float-time) 30))) (while (and (eq (get jc :state) :connecting) (< (float-time) deadline)) (accept-process-output nil 0.01))) (should (eq (get jc :state) :connected)) (should (eq new (plist-get (fsm-get-state-data jc) :connection))) (should (equal writes (list new))))))) (jabber-disconnect-one jc) (jabber-disconnect-one jc) (should (= failures 1)) (should-not (get jc :state)) (should-not (memq jc jabber-connections)) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (should-not (get jc :connect-attempt)) (should-not (get jc :connect-cancel)) (should-not (get jc :timeout)) (should-not (cl-some #'process-live-p processes)) (unless keep-buffer (should-not (cl-some #'buffer-live-p buffers))) (dolist (timer timers) (should-not (memq timer timer-list))))) (when jc (jabber-disconnect-one jc) (jabber-conn--cancel-connect jc) (fsm-stop-timer jc)) (dolist (timer timers) (cancel-timer timer)) (dolist (process processes) (set-process-sentinel process #'ignore) (delete-process process)) (dolist (buffer buffers) (when (buffer-live-p buffer) (with-current-buffer buffer (setq before-change-functions nil after-change-functions nil)) (kill-buffer buffer))))))) (ert-deftest jabber-conn-test-handoff-change-stop () "Preserve terminal settlement after native buffer modification hooks." (dolist (timeout '(nil 60)) (dolist (keep-buffer '(nil t)) (dolist (hook '(before-change-functions after-change-functions)) (jabber-conn-test--handoff-change 'stop keep-buffer timeout hook))))) (ert-deftest jabber-conn-test-handoff-change-successor () "Preserve same-FSM replacement and retire only the captured transport." (dolist (timeout '(nil 60)) (dolist (keep-buffer '(nil t)) (dolist (hook '(before-change-functions after-change-functions)) (jabber-conn-test--handoff-change 'replace keep-buffer timeout hook))))) (ert-deftest jabber-conn-test-handoff-change-retry-timer () "Preserve the authoritative retry timer after handoff cleanup reentry." (dolist (timeout '(nil 60)) (dolist (keep-buffer '(nil t)) (jabber-conn-test--handoff-change 'retry keep-buffer timeout 'before-change-functions)))) (ert-deftest jabber-conn-test-handoff-change-current-error () "Propagate a native modification-hook error while the attempt is current." (dolist (hook '(before-change-functions after-change-functions)) (should (equal (should-error (jabber-conn-test--handoff-change 'error nil nil hook)) '(error "Native handoff hook failed"))))) (ert-deftest jabber-conn-test-handoff-change-normal () "Complete normal handoff after harmless native modification hooks." (dolist (timeout '(nil 60)) (dolist (keep-buffer '(nil t)) (jabber-conn-test--handoff-change 'normal keep-buffer timeout 'before-change-functions)))) (ert-deftest jabber-conn-test-handoff-send-reentry () "Preserve current state and timer after a synchronous stream-header send." (dolist (action '(stop retry reply)) (let ((jabber-connections nil) (jabber-auto-reconnect t) (jabber-reconnect-delay 600) (failures 0) fired successor-state successor-timer jc) (cl-letf (((symbol-function 'jabber-network-connect) #'ignore)) (unwind-protect (progn (setq jc (start-jabber-connection "alice" "example.test" "desktop" nil nil "old.test" 5222 'network)) (push jc jabber-connections) (let ((state (fsm-get-state-data jc))) (plist-put state :ever-session-established t) (jabber-sm--enqueue-pending state '(message nil (body nil "pending")) nil (lambda (_reason) (cl-incf failures))) (plist-put state :send-function (lambda (_connection _wire) (unless fired (setq fired t) (pcase action ('stop (jabber-disconnect-one jc)) ('retry (fsm-send-sync jc '(:sentinel transport "lost\n"))) ('reply (fsm-send-sync jc '(:stream-start "new-stream" "1.0")))) (setq successor-state (fsm-get-state-data jc) successor-timer (get jc :timeout)))))) (fsm-send-sync jc '(:connected transport nil)) (should fired) (should (eq successor-state (fsm-get-state-data jc))) (should (eq successor-timer (get jc :timeout))) (pcase action ('stop (should-not (get jc :state)) (should (plist-get successor-state :terminalized)) (should-not (plist-get successor-state :sm-pending-queue)) (should (= failures 1))) ('retry (should-not (get jc :state)) (should (timerp successor-timer)) (should (memq successor-timer timer-list))) ('reply (should (eq (get jc :state) :connected)) (should-not (plist-get successor-state :awaiting-stream-start)) (should (equal (plist-get successor-state :session-id) "new-stream")))) (jabber-disconnect-one jc) (jabber-disconnect-one jc) (should (= failures 1))) (when jc (jabber-disconnect-one jc) (fsm-stop-timer jc))))))) (provide 'jabber-test-conn) ;;; jabber-test-conn.el ends here emacs-jabber-0.15.1/tests/jabber-test-console.el000066400000000000000000000236461527111033600214510ustar00rootroot00000000000000;;; jabber-test-console.el --- Console retention tests -*- lexical-binding: t; -*- ;;; Commentary: ;; Exercise real console EWOCs and shared chat truncation without a connection. ;;; Code: (require 'ert) (require 'cl-lib) (require 'jabber-console) (require 'jabber-chatbuffer) (defmacro jabber-test-console--with-buffer (&rest body) "Run BODY in a disposable console with no file logging." (declare (indent 0) (debug t)) `(let ((jabber-console-name-format " *jabber-test-console-%s*") (jabber-debug-log-xml nil) buffer) (unwind-protect (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "console@example.invalid"))) (setq buffer (jabber-console-create-buffer 'test-connection)) (with-current-buffer buffer ,@body)) (when (buffer-live-p buffer) (kill-buffer buffer))))) (defun jabber-test-console--append (count) "Append COUNT real console entries." (dotimes (i count) (jabber-process-console 'test-connection "recv" (format "\n" i)))) (ert-deftest jabber-test-console-retention-option () "Honor the console cap independently of the chat cap, including one." (dolist (cap '(1 8)) (let ((jabber-console-truncate-lines cap) (jabber-log-lines-to-keep 1000)) (jabber-test-console--with-buffer (jabber-test-console--append 20) (should (< (length (ewoc-collect jabber-console-ewoc #'identity)) 5)) (should (string-match-p "id='19'" (buffer-string))) (should-not (string-match-p "id='0'" (buffer-string))) (should (= jabber-log-lines-to-keep 1000)))))) (ert-deftest jabber-test-console-zero-retains-history () "Zero disables truncation even when the chat cap is small." (let ((jabber-console-truncate-lines 0) (jabber-log-lines-to-keep 1)) (jabber-test-console--with-buffer (jabber-test-console--append 20) (should (= (length (ewoc-collect jabber-console-ewoc #'identity)) 20))))) (ert-deftest jabber-test-console-append-preserves-draft-positions () "Append and real deletion preserve hidden and visible draft positions." (dolist (cap '(0 8 3000)) (dolist (visibility '(hidden selected unselected)) (let ((jabber-console-truncate-lines cap)) (jabber-test-console--with-buffer (save-window-excursion (delete-other-windows) (jabber-test-console--append 10) (goto-char (point-max)) (insert "draft") (backward-char 5) (let* ((offset (- (point) jabber-point-insert)) (draft (jabber-chat--input-string)) (window (unless (eq visibility 'hidden) (set-window-buffer (selected-window) buffer) (selected-window))) (other (when window (split-window-below)))) (when other (set-window-buffer other buffer) (set-window-point other (+ jabber-point-insert 2)) (when (eq visibility 'unselected) (select-window other) (switch-to-buffer (get-buffer-create " *console-other*")))) (with-current-buffer buffer (goto-char (+ jabber-point-insert offset)) (jabber-test-console--append 20) (should (equal (jabber-chat--input-string) draft)) (should (= (- (point) jabber-point-insert) offset)) (when window (should (= (- (window-point window) jabber-point-insert) offset))) (when (and other (eq (window-buffer other) buffer)) (should (= (- (window-point other) jabber-point-insert) 2)))))))))) (when-let* ((buffer (get-buffer " *console-other*"))) (kill-buffer buffer))) (ert-deftest jabber-test-console-truncate-preserves-chat-undo () "Shared truncation leaves chat draft undo aligned after deleting history." (with-temp-buffer (jabber-chat-mode) (let ((jabber-chat-encryption 'plaintext) (jabber-log-lines-to-keep 4)) (jabber-chat-mode-setup 'test-connection (lambda (data) (insert (cadr data) "\n"))) (dotimes (i 20) (jabber-chat-ewoc-enter (list :notice (format "history %d" i)))) (goto-char (point-max)) (buffer-enable-undo) (setq buffer-undo-list nil) (insert "draft") (undo-boundary) (let ((before jabber-point-insert) (position (marker-position jabber-point-insert))) (jabber-truncate-top (current-buffer)) (should (< jabber-point-insert position)) (should (eq before jabber-point-insert)) (should (equal (jabber-chat--input-string) "draft")) (undo 1) (should (equal (jabber-chat--input-string) "")) (should (string-match-p "history 19" (buffer-string))))))) (ert-deftest jabber-test-console-native-typing-and-undo () "Keyboard edits and undo stay in the draft across append and truncation." (let ((jabber-console-truncate-lines 8)) (jabber-test-console--with-buffer (save-window-excursion (switch-to-buffer buffer) (jabber-test-console--append 20) (goto-char (point-max)) (buffer-enable-undo) (setq buffer-undo-list nil) (should (eq (key-binding "a") 'self-insert-command)) (should (eq (key-binding (kbd "C-c C-i")) 'jabber-info-menu)) (should (eq (key-binding (kbd "RET")) 'jabber-chat-buffer-send)) (save-excursion (goto-char (ewoc-location (ewoc-nth jabber-console-ewoc 0))) (should-error (insert "X") :type 'text-read-only)) (execute-kbd-macro "draft") (undo-boundary) (execute-kbd-macro (kbd "C-b C-b")) (jabber-test-console--append 20) (execute-kbd-macro "X") (should (equal (jabber-chat--input-string) "draXft")) (undo-boundary) (execute-kbd-macro (kbd "C-/")) (should (equal (jabber-chat--input-string) "draft")) (should (string-match-p "id='19'" (buffer-string))))))) (ert-deftest jabber-test-console-retained-reader-window () "Truncation preserves another window's surviving history and viewport." (let ((jabber-console-truncate-lines 0)) (jabber-test-console--with-buffer (save-window-excursion (switch-to-buffer buffer) (delete-other-windows) (jabber-test-console--append 30) (goto-char (point-max)) (insert "draft") (let* ((other (split-window-below)) (node (ewoc-nth jabber-console-ewoc -2)) (anchor (copy-marker (ewoc-location node))) (jabber-console-truncate-lines 20)) (set-window-buffer other buffer) (set-window-point other anchor) (set-window-start other anchor t) (jabber-test-console--append 1) (should (= (window-point other) anchor)) (should (= (window-start other) anchor)) (should (string-match-p "id='28'" (buffer-substring anchor jabber-point-insert))) (should-not (string-match-p "id='1'" (buffer-string))) (set-marker anchor nil)))))) (ert-deftest jabber-test-console-transcript-separators-read-only () "Protect every transcript character, including native EWOC separators." (dolist (xml '("" "\n" (message ((id . "xml")) (body nil "body")))) (let ((jabber-console-truncate-lines 0)) (jabber-test-console--with-buffer (save-window-excursion (switch-to-buffer buffer) (goto-char jabber-point-insert) (buffer-enable-undo) (setq buffer-undo-list nil) (execute-kbd-macro "draft") (undo-boundary) (dolist (truncate '(nil t)) (let ((jabber-console-truncate-lines (if truncate 8 0))) (dotimes (_ 10) (jabber-process-console 'test-connection "recv" xml))) (let ((count (length (ewoc-collect jabber-console-ewoc #'identity)))) (if truncate (should (< count 10)) (should (= count 10)))) (let ((before (buffer-string)) (boundary (marker-position jabber-point-insert)) (separator (save-excursion (goto-char jabber-point-insert) (forward-line -1) (1- (point))))) (should (eq (char-after separator) ?\n)) (should-not inhibit-read-only) ;; This newline used to be inserted after the printer's guard. (goto-char separator) (should-error (execute-kbd-macro "X") :type 'text-read-only) (goto-char separator) (should-error (execute-kbd-macro (kbd "C-d")) :type 'text-read-only) (goto-char (1+ separator)) (should-error (execute-kbd-macro (kbd "DEL")) :type 'text-read-only) (cl-loop for position from (point-min) below boundary do (should (get-text-property position 'read-only)) (goto-char position) (should-error (insert "X") :type 'text-read-only) (should-error (delete-char 1) :type 'text-read-only)) (should (equal (buffer-string) before)) (should (= jabber-point-insert boundary)) (should (equal (jabber-chat--input-string) "draft")) ;; The first draft position must remain writable and undoable. (goto-char jabber-point-insert) (execute-kbd-macro "X") (should (equal (jabber-chat--input-string) "Xdraft")) (undo-boundary) (execute-kbd-macro (kbd "C-/")) (should (equal (buffer-string) before)) (should (= (point) jabber-point-insert))))))))) (provide 'jabber-test-console) ;;; jabber-test-console.el ends here emacs-jabber-0.15.1/tests/jabber-test-contact-owners.el000066400000000000000000000650071527111033600227520ustar00rootroot00000000000000;;; jabber-test-contact-owners.el --- Contact ownership tests -*- lexical-binding: t; -*- (require 'ert) (require 'cl-lib) (require 'jabber-presence) (require 'jabber-roster) (require 'jabber-receipts) (require 'jabber-info) (require 'jabber-vcard-avatars) (require 'jabber-notifications) (require 'jabber-core) (require 'jabber-openpgp-legacy) (require 'jabber-modeline) (require 'jabber-compose) (require 'jabber-widget) (require 'jabber-chatstates) (defun jabber-test-contact--owner (name) "Return a disposable connection named NAME." (let ((jc (make-symbol name))) (put jc :state :session-established) (put jc :state-data (list :username name :server "example.test" :resource "test" :roster nil :roster-hash nil :roster-groups nil)) jc)) (defun jabber-test-contact--roster (jc name subscription &optional initial) "Deliver JC's roster with NAME and SUBSCRIPTION; INITIAL resets the item." (jabber-process-roster jc `(iq ((type . "result")) (query ((xmlns . "jabber:iq:roster")) (item ((jid . "peer@example.test") (name . ,name) (subscription . ,subscription)) (group () ,name)))) (and initial 'initial))) (defmacro jabber-test-contact--with-owners (&rest body) "Evaluate BODY with disposable owners A and B and isolated hooks." (declare (indent 0) (debug t)) `(let* ((a (jabber-test-contact--owner "A")) (b (jabber-test-contact--owner "B")) (jabber-connections (list a b)) (jabber-jid-obarray (make-vector 127 0)) (jabber-db-path nil) (jabber-post-connect-hooks nil) (jabber-presence-roster-update-functions '(jabber-roster-update)) (jabber-presence-contact-functions nil) (jabber-presence-hooks nil) (jabber-alert-presence-hooks nil)) (cl-letf (((symbol-function 'fsm-send) #'ignore) ((symbol-function 'jabber-send-sexp) (lambda (&rest _) (error "Unexpected wire"))) ((symbol-function 'jabber-send-iq) (lambda (&rest _) (error "Unexpected IQ")))) ,@body))) (ert-deftest jabber-test-contact-owners-roster-presence () (dolist (reverse '(nil t)) (jabber-test-contact--with-owners (dolist (owner (if reverse (list b a) (list a b))) (jabber-test-contact--roster owner (symbol-name owner) (if (eq owner a) "both" "none") t)) (let ((pa (car (plist-get (fsm-get-state-data a) :roster))) (pb (car (plist-get (fsm-get-state-data b) :roster)))) (should-not (eq pa pb)) (should (eq (jabber-jid-symbol pa b) pb)) (should (eq (jabber-jid-symbol pa) pa)) (should (eq (jabber-jid-owner pa) a)) (should (equal (get pa 'name) "A")) (should (equal (get pb 'groups) '("B"))) (jabber-process-presence a '(presence ((from . "peer@example.test/Phone")) (priority () "10") (status () "A status"))) (jabber-process-presence b '(presence ((from . "peer@example.test/Phone")) (show () "away") (status () "B status"))) (should (equal (get pa 'status) "A status")) (should (equal (get pb 'status) "B status")) (jabber-process-presence b '(presence ((from . "peer@example.test") (type . "unavailable")))) (should (get pa 'connected)) (should-not (get pb 'connected)) (jabber-test-contact--roster b "B reset" "none" t) (should (eq (jabber-jid-owner pb) b)) (should (get pa 'connected)))))) (ert-deftest jabber-test-contact-owners-receipt-permissions () (dolist (reverse '(nil t)) (jabber-test-contact--with-owners (dolist (owner (if reverse (list b a) (list a b))) (jabber-test-contact--roster owner (symbol-name owner) (if (eq owner a) "both" "none") t)) (let ((jabber-chat-send-receipts t) (xml '(message ((id . "owned")) (body () "fixture") (request ((xmlns . "urn:xmpp:receipts"))) (markable ((xmlns . "urn:xmpp:chat-markers:0"))))) sent) (with-temp-buffer (let ((buffer (current-buffer))) (cl-letf (((symbol-function 'jabber-send-sexp-if-connected) (lambda (jc stanza) (push (list jc stanza) sent))) ((symbol-function 'jabber-receipts--display-buffer) (lambda (&rest _) buffer)) ((symbol-function 'get-buffer-window) (lambda (&rest _) t))) (dolist (owner (list b a)) (jabber-receipts--maybe-send-receipt owner xml "peer@example.test/Phone" nil) (jabber-receipts--track-displayed owner xml "peer@example.test/Phone" nil))) (should (= (length sent) 2)) (should (cl-every (lambda (entry) (eq (car entry) a)) sent)))))))) (ert-deftest jabber-test-contact-owners-groups-completion-resources () (jabber-test-contact--with-owners (jabber-test-contact--roster a "Alice" "both" t) (jabber-test-contact--roster b "Bob" "none" t) (dolist (entry (list (cons a "Phone/A") (cons b "Phone/B"))) (jabber-process-presence (car entry) `(presence ((from . ,(concat "peer@example.test/" (cdr entry))))))) (let* ((pa (jabber-jid-symbol "peer@example.test" a)) (pb (jabber-jid-symbol "peer@example.test" b)) (table (jabber--jid-completion-table (list pa))) (metadata (completion-metadata "" (jabber--jid-completion-with-metadata table) nil))) (should (eq pa (car (gethash "Alice" (plist-get (fsm-get-state-data a) :roster-hash))))) (should (eq pb (car (gethash "Bob" (plist-get (fsm-get-state-data b) :roster-hash))))) (should (string-match-p "Alice" (funcall (completion-metadata-get metadata 'annotation-function) "peer@example.test"))) (should (equal (jabber-info--connected-resources "peer@example.test" a) '("peer@example.test/Phone/A"))) (should (equal (jabber-info--connected-resources "peer@example.test" b) '("peer@example.test/Phone/B"))) (let ((jabber-jid-completion-display 'name)) (cl-letf (((symbol-function 'completing-read) (lambda (_prompt collection &rest _) (should (equal (all-completions "" collection) '("Bob"))) "Bob"))) (should (equal (jabber-read-jid-completing "Peer: " nil t nil 'full nil b) "peer@example.test/Phone/B")))) (let ((full (jabber--roster-full-jids (list pb)))) (should (equal (mapcar #'symbol-name full) '("peer@example.test/Phone/B"))) (should (eq (jabber-jid-owner (car full)) b))) (let ((jabber-jid-completion-display 'jid)) (cl-letf (((symbol-function 'completing-read) (lambda (_prompt collection &rest _) (should (equal (all-completions "" collection) '("peer@example.test/Exact/Case"))) "peer@example.test/Exact/Case"))) (should (equal (jabber-read-jid-completing "Peer: " (list (make-symbol "peer@example.test/Exact/Case")) t nil nil nil b) "peer@example.test/Exact/Case")))) (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) "peer@example.test"))) ;; Ambiguous aggregate completion must not borrow the first resource. (should (equal (jabber-read-jid-completing "Peer: " nil nil nil 'full) "peer@example.test"))) (let ((empty (jabber-test-contact--owner "empty"))) (cl-letf (((symbol-function 'completing-read) (lambda (_prompt collection &rest _) (should-not (all-completions "" collection)) ""))) (should-not (jabber-read-jid-completing "Peer: " nil nil nil nil nil empty))))))) (ert-deftest jabber-test-contact-owners-priority-caps-extension () (jabber-test-contact--with-owners (jabber-test-contact--roster a "A" "both" t) (jabber-test-contact--roster b "B" "none" t) (let ((pa (jabber-jid-symbol "peer@example.test" a)) (pb (jabber-jid-symbol "peer@example.test" b))) (jabber-caps--store-hash "peer@example.test/Phone" '("sha-1" . "A") a) (jabber-caps--store-hash "peer@example.test/Phone" '("sha-1" . "B") b) (dolist (owner (list a b)) (jabber-process-presence owner '(presence ((from . "peer@example.test/Phone")) (priority () "10")))) (should (equal (plist-get (cdr (assoc "Phone" (get pa 'resources))) 'caps) '("sha-1" . "A"))) (should (equal (plist-get (cdr (assoc "Phone" (get pb 'resources))) 'caps) '("sha-1" . "B"))) (jabber-process-presence a '(presence ((from . "peer@example.test/Desktop")) (priority () "10"))) ;; Existing equal-priority rule: first resource in the stored alist wins. (should (equal (get pa 'resource) "Desktop")) (jabber-process-presence a '(presence ((from . "peer@example.test/Desktop") (type . "error")) (error ((code . "500")) (text nil "bad")))) (should (equal (get pa 'resource) "Phone")) (should (get pb 'connected))))) (ert-deftest jabber-test-contact-owners-lifetime-and-cleanup () (jabber-test-contact--with-owners (jabber-test-contact--roster a "A" "both" t) (jabber-test-contact--roster b "B" "none" t) (let ((pa (jabber-jid-symbol "peer@example.test" a)) (pb (jabber-jid-symbol "peer@example.test" b))) (put a :state-data (jabber-sm--prepare-drain-state (fsm-get-state-data a))) (should (eq (jabber-jid-symbol "PEER@EXAMPLE.TEST/Resource" a) pa)) (should-not (get (jabber-jid-symbol "peer@example.test" (jabber-test-contact--owner "A")) 'name)) (let ((jabber-pre-disconnect-hook nil) (jabber-post-disconnect-hook nil)) (cl-letf (((symbol-function 'fsm-send-sync) (lambda (jc _event) (setq jabber-connections (delq jc jabber-connections))))) (jabber-disconnect-one a) (should-not (get pa 'name)) (should (eq (jabber-jid-owner pa) a)) (should (equal (get pb 'name) "B")) (jabber-disconnect) (should-not (get pb 'name)) (should-not jabber-connections)))))) (ert-deftest jabber-test-contact-owners-avatar-delayed-vcard () (jabber-test-contact--with-owners (let* ((pa (jabber-jid-symbol "peer@example.test" a)) (pb (jabber-jid-symbol "peer@example.test" b)) (jabber-vcard-avatars-retrieve t) callbacks) (cl-letf (((symbol-function 'jabber-avatar-find-cached) (lambda (_) nil)) ((symbol-function 'jabber-vcard-avatars-fetch) (lambda (jc from hash) (push (list jc from hash) callbacks)))) (dolist (owner (list a b)) (jabber-vcard-avatars-presence owner `(presence ((from . "peer@example.test/Phone")) (x ((xmlns . "vcard-temp:x:update")) (photo nil ,(symbol-name owner))))))) (should (= (length callbacks) 2)) (cl-letf (((symbol-function 'jabber-vcard-parse) (lambda (_) '((PHOTO "image/png" "bytes")))) ((symbol-function 'jabber-avatar-from-base64-string) (lambda (&rest _) (make-jabber-avatar :sha1-sum "A"))) ((symbol-function 'jabber-avatar-image) (lambda (_) 'image-A)) ((symbol-function 'jabber-avatar-cache) #'ignore)) (put pb 'avatar-hash "B") (put pb 'avatar 'image-B) (with-temp-buffer (setq-local jabber-buffer-connection b) (jabber-vcard-avatars-vcard a '(iq nil (vCard nil)) '("peer@example.test" . "A"))) (should (equal (get pa 'avatar-hash) "A")) (should (eq (get pa 'avatar) 'image-A)) (should (equal (get pb 'avatar-hash) "B")) (jabber-vcard-avatars-presence a '(presence ((from . "peer@example.test/Phone")))) (should-not (get pa 'avatar-hash)) (should (eq (get pb 'avatar) 'image-B)))))) (ert-deftest jabber-test-contact-owners-pgp-observation () (jabber-test-contact--with-owners (cl-letf (((symbol-function 'epg-verify-string) (lambda (context &rest _) (let ((signature (epg-make-signature 'good))) (setf (epg-signature-fingerprint signature) "fingerprint-A" (epg-context-result context) (list (cons 'verify (list signature)))))))) (jabber-openpgp-legacy--process-presence a '(presence ((from . "peer@example.test/Phone")) (x ((xmlns . "jabber:x:signed")) "signature")))) (should (equal (get (jabber-jid-symbol "peer@example.test" a) 'pgp-key-id) "fingerprint-A")) (should-not (get (jabber-jid-symbol "peer@example.test" b) 'pgp-key-id)))) (ert-deftest jabber-test-contact-owners-background-alert-notification () (jabber-test-contact--with-owners (jabber-test-contact--roster a "Alice" "both" t) (jabber-test-contact--roster b "Bob" "none" t) (let ((target (generate-new-buffer " *contact-owner-B*")) captured) (unwind-protect (with-temp-buffer (setq-local jabber-buffer-connection a) (with-current-buffer target (setq-local jabber-buffer-connection b)) (put (jabber-jid-symbol "peer@example.test" a) 'avatar-hash "A") (put (jabber-jid-symbol "peer@example.test" b) 'avatar-hash "B") (should (equal (jabber-message-default-message "peer@example.test" target "hello") "Bob:")) (cl-letf (((symbol-function 'jabber-avatar-find-cached) (lambda (hash) (concat "icon-" hash))) ((symbol-function 'notifications-notify) (lambda (&rest args) (setq captured args)))) (jabber-message-notifications "peer@example.test" target "hello" "title") (should (equal (plist-get captured :app-icon) "icon-B")) (jabber-message-notifications "peer@example.test" nil "hello" "title") (should (equal (plist-get captured :app-icon) jabber-notifications-icon)))) (kill-buffer target))))) (ert-deftest jabber-test-contact-owners-hook-reset-and-delayed-subscription () (jabber-test-contact--with-owners (jabber-test-contact--roster a "Alice" "both" t) (jabber-test-contact--roster b "Bob" "none" t) (let* ((target (generate-new-buffer " *contact-hook-B*")) (jabber-presence-contact-functions nil) (jabber-alert-presence-message-function (lambda (who _old _new _status) (should (eq (jabber-jid-owner who) b)) "title")) (jabber-presence-hooks (list (lambda (who _old _new _status title) (should (eq (jabber-jid-owner who) b)) (should (equal title "title"))))) pending) (unwind-protect (progn (with-current-buffer target (setq-local major-mode 'jabber-chat-mode jabber-buffer-connection b jabber-chatting-with "peer@example.test") (setq-local jabber-chat-ewoc (ewoc-create #'ignore))) (jabber-test-contact--roster b "Bob reset" "none" t) (jabber-process-presence b '(presence ((from . "peer@example.test/Phone")))) (cl-letf (((symbol-function 'run-with-idle-timer) (lambda (_seconds _repeat fn &rest args) (setq pending (cons fn args))))) (jabber-process-presence b '(presence ((from . "peer@example.test") (type . "subscribe"))))) (with-temp-buffer (setq-local jabber-buffer-connection a) (cl-letf (((symbol-function 'jabber-chat-create-buffer) (lambda (&rest _) target))) (apply (car pending) (cdr pending)))) (should (equal (jabber-presence-only-chat-open-message (jabber-jid-symbol "peer@example.test" b) nil "subscribe" nil) "Bob reset requests subscription to your presence")) (should-not (jabber-presence-only-chat-open-message (jabber-jid-symbol "peer@example.test" a) nil "subscribe" nil)) (let* ((replacement (jabber-test-contact--owner "B")) (jabber-connections (cons replacement jabber-connections))) (should-not (jabber-presence-only-chat-open-message (jabber-jid-symbol "peer@example.test" replacement) nil "subscribe" nil)))) (kill-buffer target))))) (ert-deftest jabber-test-contact-owners-renderers-and-bookmarks () (jabber-test-contact--with-owners (jabber-test-contact--roster a "Alice" "both" t) (jabber-test-contact--roster b "Bob" "none" t) (let ((jabber-bookmarks (make-hash-table :test #'equal)) (jabber-mode-line-compact t) (jabber-mode-line-contacts nil)) (puthash "A@example.test" '((:jid "peer@example.test" :name "A room")) jabber-bookmarks) (puthash "B@example.test" '((:jid "peer@example.test" :name "B room")) jabber-bookmarks) (should (equal (jabber-jid-bookmarkname "peer@example.test" b) "B room")) (should (equal (jabber-jid-bookmarkname "peer@example.test") "peer@example.test")) (puthash "B@example.test" t jabber-bookmarks) (should (equal (jabber-jid-bookmarkname "peer@example.test" b) "Bob")) (put (jabber-jid-symbol "peer@example.test" a) 'show "chat") (jabber-mode-line--do-count-contacts) (should (equal jabber-mode-line-contacts "(1/0/1)"))) (with-temp-buffer (setq-local jabber-buffer-connection b jabber-chatting-with "peer@example.test" jabber-message-thread-peer "peer@example.test") (should (string-match-p "Bob" (jabber-message-thread--header))) (should (equal (jabber-chat--reply-context-label '(:reply-to-id "one" :reply-to-jid "peer@example.test")) "reply to Bob")) (should (equal (jabber-reactions--entry-help-echo '(:reaction "+" :senders ("peer@example.test")) b) "+: Bob")) (let ((jabber-group "room@example.test")) (should (equal (jabber-message-reply--author-name "peer@example.test") "Bob"))) (let ((jabber-chatstates--ewoc-node nil) entry) (cl-letf (((symbol-function 'jabber-chat-ewoc-enter) (lambda (data) (setq entry data)))) (jabber-chatstates--update-ewoc 'composing)) (should (equal (cadr entry) "Bob is typing..."))) (let ((widget (widget-convert 'jabber-widget-jid :jabber-connection b))) (should (equal (widget-apply widget :value-to-internal "peer@example.test") "Bob ")))) (let (compose) (unwind-protect (with-temp-buffer (setq-local jabber-buffer-connection a) (cl-letf (((symbol-function 'pop-to-buffer) (lambda (buffer &rest _) (setq compose buffer)))) (jabber-compose b "peer@example.test")) (should (string-match-p "Bob" (buffer-name compose))) (should (eq (buffer-local-value 'jabber-buffer-connection compose) b))) (when (buffer-live-p compose) (kill-buffer compose)))))) (ert-deftest jabber-test-contact-owners-observation-render-and-query () (dolist (reverse '(nil t)) (jabber-test-contact--with-owners (cl-letf (((symbol-function 'jabber-avatar-cache) #'ignore) ((symbol-function 'jabber-avatar-image) (lambda (avatar) (jabber-avatar-sha1-sum avatar))) ((symbol-function 'jabber-vcard-parse) (lambda (_) '((PHOTO "image/png" "bytes"))))) (dolist (owner (if reverse (list b a) (list a b))) (let* ((name (symbol-name owner)) (full (concat "peer@example.test/" name))) (jabber-test-contact--roster owner name "both" t) (jabber-caps--store-hash full (cons "sha-1" name) owner) (jabber-process-presence owner `(presence ((from . ,full)) (status () ,(concat name " status")))) (cl-letf (((symbol-function 'jabber-avatar-from-base64-string) (lambda (&rest _) (make-jabber-avatar :sha1-sum name))) ((symbol-function 'epg-verify-string) (lambda (context &rest _) (let ((signature (epg-make-signature 'good))) (setf (epg-signature-fingerprint signature) name (epg-context-result context) (list (cons 'verify (list signature)))))))) (jabber-vcard-avatars-vcard owner '(iq nil (vCard nil)) (cons "peer@example.test" name)) (jabber-openpgp-legacy--process-presence owner `(presence ((from . ,full)) (x ((xmlns . "jabber:x:signed")) "signature"))))))) (dolist (owner (list a b)) (let* ((name (symbol-name owner)) (full (concat "peer@example.test/" name)) (contact (jabber-jid-symbol "peer@example.test" owner)) sent) (should (equal (get contact 'pgp-key-id) name)) (should (equal (plist-get (cdr (assoc name (get contact 'resources))) 'caps) (cons "sha-1" name))) (with-temp-buffer (setq-local jabber-buffer-connection owner jabber-chatting-with "peer@example.test") ;; Evaluate the production header forms, not a parallel renderer. (let ((fields (mapcar (lambda (entry) (eval (cadr entry) t)) (cl-remove-if-not (lambda (entry) (eq (car-safe entry) :eval)) jabber-chat-header-line-format)))) (should (equal (car fields) name)) (should (equal (nth 2 fields) (concat name " status")))) (should (equal (get-text-property 0 'display (eval (cadr (cadr (nth 1 jabber-chat-header-line-format))) t)) name)) (jabber-muc-private-print-prompt '(:from "peer@example.test/Nick")) (should (string-match-p (concat name "/Nick") (buffer-string))) (erase-buffer) (let ((buffer (current-buffer))) (cl-letf (((symbol-function 'jabber-browse--buffer) (lambda (_) buffer)) ((symbol-function 'display-buffer) #'ignore) ((symbol-function 'jabber-send-iq) (lambda (jc to &rest _) (push (cons jc to) sent))) ((symbol-function 'jabber-ping-send) (lambda (jc to &rest _) (push (cons jc to) sent)))) (jabber-get-info owner "peer@example.test"))) (should (cl-some (lambda (entry) (equal (cdr entry) full)) sent)) (should (cl-every (lambda (entry) (and (eq (car entry) owner) (member (cdr entry) (list "peer@example.test" full)))) sent)))))))) (ert-deftest jabber-test-contact-owners-named-resource-completion () "Select exact resources through the reader and interactive version command." (dolist (resources '((("Phone") ("DeskTOP")) (("DeskTOP") ("Phone")) (("Phone") ("phone")) (("phone") ("Phone")))) (dolist (display '(name jid)) (jabber-test-contact--with-owners (let* ((jabber-jid-completion-display display) (contact (jabber-jid-symbol "alice@example.test" b))) (put contact 'name "Alice") (put contact 'resources resources) (setf (plist-get (get b :state-data) :roster) (list contact)) (dolist (resource resources) (let* ((expected (concat "alice@example.test/" (car resource))) (fulls (jabber--roster-full-jids (list contact))) (table (jabber--jid-completion-table fulls)) (label (car (cl-find expected table :key (lambda (entry) (symbol-name (cdr entry))) :test #'equal))) sent) (should (= 2 (length (delete-dups (mapcar #'car table))))) (cl-letf (((symbol-function 'jabber-read-account) (lambda (&rest _) b)) ((symbol-function 'completing-read) (lambda (_prompt collection &rest _) (should (member label (all-completions "" collection))) (should (= 2 (length (all-completions "alice@example.test/" collection)))) (should (test-completion label collection)) label)) ((symbol-function 'jabber-send-iq) (lambda (owner to &rest _) (setq sent (list owner to))))) (call-interactively #'jabber-get-version) (should (equal sent (list b expected))) ;; Explicit ownership must re-scope a foreign full-JID subset. (let ((foreign (mapcar (lambda (full) (let ((copy (make-symbol (symbol-name full)))) (put copy 'jabber--jid-owner a) (put copy 'name "Foreign") copy)) fulls))) (should (equal (jabber-read-jid-completing "Resource: " foreign t nil 'full t b) expected)))) ;; Accepting a full-JID default must retain its exact resource. (cl-letf (((symbol-function 'completing-read) (lambda (_prompt collection _pred _match _initial _history default &rest _) (should (member default (all-completions "" collection))) default))) (should (equal (jabber-read-jid-completing "Resource: " fulls t expected 'full t b) expected)))))))))) (provide 'jabber-test-contact-owners) ;;; jabber-test-contact-owners.el ends here emacs-jabber-0.15.1/tests/jabber-test-csi.el000066400000000000000000000157621527111033600205650ustar00rootroot00000000000000;;; 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.15.1/tests/jabber-test-db.el000066400000000000000000005764541527111033600204060ustar00rootroot00000000000000;;; 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-mam) (require 'jabber-muc) (require 'jabber-reactions) (require 'jabber-archive-test-helpers) (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-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')")))))) ;;; Indexed duplicate lookup (defun jabber-test-db--duplicate-plans (function) "Return native query plans for message candidate queries in FUNCTION." (let ((select (symbol-function 'sqlite-select)) queries) (cl-letf (((symbol-function 'sqlite-select) (lambda (db sql &rest args) (when (string-prefix-p "SELECT id FROM message" sql) (push (cons sql (car args)) queries)) (apply select db sql args)))) (funcall function)) (mapcan (lambda (query) (mapcar (lambda (row) (nth 3 row)) (funcall select jabber-db--connection (concat "EXPLAIN QUERY PLAN " (car query)) (cdr query)))) queries))) (defun jabber-test-db--assert-indexed-duplicates (plans) "Reject history-wide message scans in PLANS, including peer-only searches." (should plans) (dolist (plan plans) (should-not (string-match-p "SCAN message" plan)) (when (string-match-p "SEARCH message" plan) (should (string-match-p "\\(?:rowid\\|stanza_id\\|server_id\\|origin_id\\|room_id\\|timestamp\\)=?" plan))))) (ert-deftest jabber-test-db-duplicate-legacy-indexed-plan () "Seek transport/server IDs and the legacy timestamp, not the peer's history." (jabber-test-db-with-db (let ((plans (jabber-test-db--duplicate-plans (lambda () (should-not (jabber-db--detect-duplicate jabber-db--connection "me" "peer" 1 "body" "transport" "server" "chat" "in" "phone" nil)))))) (jabber-test-db--assert-indexed-duplicates plans) (dolist (key '("server_id=?" "stanza_id=?" "timestamp=?")) (should (seq-some (lambda (plan) (string-search key plan)) plans)))))) (ert-deftest jabber-test-db-duplicate-strong-indexed-plan () "Seek origin/room/occurrence candidates without a peer-wide scan." (jabber-test-db-with-db (let ((plans (jabber-test-db--duplicate-plans (lambda () (should-not (jabber-db--identity-duplicate jabber-db--connection "me" "peer" "in" "chat" nil nil "phone" nil '(:origin-id "origin" :room-id "room" :archive "archive" :archive-id "uid") nil)))))) (jabber-test-db--assert-indexed-duplicates plans) (dolist (key '("origin_id=?" "room_id=?" "rowid=?")) (should (seq-some (lambda (plan) (string-search key plan)) plans)))))) (ert-deftest jabber-test-db-duplicate-union-counts-rows-not-branches () "Count two eligible rows as ambiguous, but one row with both IDs once." (jabber-test-db-with-db (let ((id (jabber-db-store-message "me" "peer" "in" "chat" "body" 1 "phone" "transport" "server"))) (should (= id (jabber-db-store-message "me" "peer" "in" "chat" "body" 1 "phone" "transport" "server"))) (sqlite-execute jabber-db--connection "INSERT INTO message (account,peer,direction,type,resource,body,timestamp,stanza_id) VALUES ('me','peer','in','chat','phone','other',2,'transport')") (should-not (jabber-db--detect-duplicate jabber-db--connection "me" "peer" 1 "body" "transport" "server" "chat" "in" "phone" nil))))) (ert-deftest jabber-test-db-duplicate-strong-conflicting-candidates () "Do not remove incompatible strong candidates before checking ambiguity." (jabber-test-db-with-db (let ((id (jabber-db-store-message "me" "peer" "in" "chat" "body" 1 "phone" nil nil nil nil nil nil nil '(:origin-id "origin" :room-id "room" :archive "archive" :archive-id "uid")))) ;; The same row appears in all three branches, but remains one candidate. (should (= id (jabber-db--identity-duplicate jabber-db--connection "me" "peer" "in" "chat" nil nil "phone" nil '(:origin-id "origin" :room-id "room" :archive "archive" :archive-id "uid") nil))) (sqlite-execute jabber-db--connection "INSERT INTO message (account,peer,direction,type,resource,body,timestamp,origin_id) VALUES ('me','peer','in','chat','incompatible','other',2,'origin')") (should-not (jabber-db--identity-duplicate jabber-db--connection "me" "peer" "in" "chat" nil nil "phone" nil '(:origin-id "origin" :room-id "room") nil)) (let ((before (sqlite-select jabber-db--connection "SELECT * FROM message"))) (should-error (jabber-db-store-message "me" "peer" "in" "chat" "replacement" 3 "phone" nil nil nil nil nil nil nil '(:origin-id "origin" :archive "archive" :archive-id "uid"))) (should (equal before (sqlite-select jabber-db--connection "SELECT * FROM message"))))))) (ert-deftest jabber-test-db-duplicate-null-type-keeps-sql-semantics () "A NULL kind admits server/room IDs, but not non-MUC transport/origin IDs." (jabber-test-db-with-db (let ((id (jabber-db-store-message "me" "peer" "in" nil "body" 1 "phone" "transport" "server" nil nil nil nil nil '(:origin-id "origin" :room-id "room")))) (should-not (jabber-db--detect-duplicate jabber-db--connection "me" "peer" 2 "different" "transport" nil nil "in" "phone" nil)) (should (= id (jabber-db--detect-duplicate jabber-db--connection "me" "peer" 2 "different" nil "server" nil "in" "phone" nil))) (should-not (jabber-db--identity-duplicate jabber-db--connection "me" "peer" "in" nil nil nil "phone" nil '(:origin-id "origin") nil)) (should (= id (jabber-db--identity-duplicate jabber-db--connection "me" "peer" "in" nil nil nil "phone" nil '(:room-id "room") nil)))))) (ert-deftest jabber-test-db-duplicate-empty-identity-keeps-legacy () "Missing strong evidence skips its SQL without bypassing legacy admission." (jabber-test-db-with-db (let ((id (jabber-db-store-message "me" "peer" "in" "chat" "body" 1 "phone" "transport"))) (should-not (jabber-test-db--duplicate-plans (lambda () (should (= id (jabber-db--identity-duplicate jabber-db--connection "me" "peer" "in" "chat" "transport" nil "phone" nil '(:origin-id nil) id)))))) (should (= id (jabber-db-store-message "me" "peer" "in" "chat" "body" 1 "phone" "transport" nil nil nil nil nil nil '(:origin-id nil))))))) ;;; 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-preserves-conflicting-identities () "Equal content and timestamps never override distinct message identities." (dolist (pair '((("in" "groupchat" "alice" "a" "sa" "oa") ("in" "groupchat" "bob" "b" "sb" "ob")) (("in" "chat" nil "a" "sa" nil) ("in" "chat" nil "b" "sb" nil)) (("in" "chat" nil "same" nil nil) ("out" "chat" nil "same" nil nil)) (("in" "groupchat" "alice" "same" "same" "a") ("in" "groupchat" "alice" "same" "same" "b")) (("in" "groupchat" "alice" "a" "same" "same") ("in" "groupchat" "alice" "b" "same" "same")) (("in" "groupchat" "alice" nil nil nil) ("in" "groupchat" "bob" nil nil nil)) (("in" "chat" nil nil nil nil) ("in" "headline" nil nil nil nil)) (("in" "chat" nil nil nil nil) ("in" "chat" nil nil nil nil)))) (jabber-test-db-with-db (dolist (entry pair) (pcase-let ((`(,direction ,type ,resource ,stanza ,server ,occupant) entry)) (jabber-db-store-message "me@x" "peer@x" direction type "yes" 100 resource stanza server occupant))) (should (= 2 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message")))) (jabber-db-close) (let ((jabber-backlog-days nil)) (should (= 2 (length (jabber-db-backlog "me@x" "peer@x")))))))) (ert-deftest jabber-test-db-dedup-muc-live-before-archive-id () "An exact MUC replay upgrades its live row's missing archive identity." (jabber-test-db-with-db (jabber-db-store-message "me@x" "room@x" "in" "groupchat" "yes" 100 "alice" "client" nil "actor") (dotimes (_ 2) (jabber-db-store-message "me@x" "room@x" "in" "groupchat" "yes" 100 "alice" "client" "archive" "actor")) (should (equal '(("client" "archive")) (sqlite-select jabber-db--connection "SELECT stanza_id,server_id FROM message"))))) (ert-deftest jabber-test-db-dedup-legacy-candidate-must-be-unambiguous () "Only one exactly scoped ID-less row may receive replay identifiers." (dolist (count '(1 2)) (jabber-test-db-with-db (dotimes (_ count) (jabber-db-store-message "me@x" "room@x" "in" "groupchat" "yes" 100 "alice")) (jabber-db-store-message "me@x" "room@x" "in" "groupchat" "yes" 100 "alice" "client" "archive") (let ((rows (sqlite-select jabber-db--connection "SELECT stanza_id, server_id FROM message ORDER BY id"))) (should (equal rows (if (= count 1) '(("client" "archive")) '((nil nil) (nil nil) ("client" "archive"))))))))) (ert-deftest jabber-test-db-dedup-conflicting-ids-do-not-rewrite-siblings () "A replay updates only its exact row, even with recycled client IDs." (jabber-test-db-with-db (dolist (server '("a" "b")) (jabber-db-store-message "me@x" "peer@x" "in" "chat" "yes" 100 nil "same" server)) (jabber-db-store-message "me@x" "peer@x" "in" "chat" "yes" 200 nil "same" "b" nil nil nil '(:reply-to-id "parent")) (should (equal '(("a" 100 nil) ("b" 200 "parent")) (sqlite-select jabber-db--connection "SELECT server_id,timestamp,reply_to_id FROM message ORDER BY id"))))) (ert-deftest jabber-test-db-dedup-live-and-archive-fields-roundtrip () "Live storage and MAM field extraction retain one exact encrypted message." (require 'jabber-mam) (jabber-test-db-with-db (let* ((stamp "2026-01-01T00:00:00Z") (timestamp (floor (float-time (jabber-parse-time stamp)))) (message `(message ((from . "peer@x/phone") (to . "me@x") (type . "chat") (id . "client")) (body () "decrypted text") (delay ((xmlns . "urn:xmpp:delay") (stamp . ,stamp))) (stanza-id ((xmlns . "urn:xmpp:sid:0") (by . "me@x") (id . "archive"))))) (jabber-history-inhibit-received-message-functions nil)) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@x"))) (jabber-db--message-handler 'jc message) (let ((fields (jabber-mam--extract-fields 'jc message stamp))) (dotimes (_ 2) (jabber-db-store-message (plist-get fields :our-jid) (plist-get fields :peer) (plist-get fields :direction) (plist-get fields :type) (plist-get fields :body) timestamp (jabber-jid-resource (plist-get fields :from)) (plist-get fields :stanza-id) "archive" nil nil t)))) ;; A later decryption failure must not replace valid stored text. (jabber-db-store-message "me@x" "peer@x" "in" "chat" "[OMEMO: could not decrypt]" timestamp "phone" "client" "archive" nil nil t) (jabber-db-close) (let ((rows (jabber-db-query "me@x" "peer@x"))) (should (= 1 (length rows))) (should (equal "decrypted text" (plist-get (car rows) :body)))) (should (equal '(("client" "archive")) (sqlite-select jabber-db--connection "SELECT stanza_id,server_id FROM message")))))) (defun jabber-test-db--archive-message (from inner) "Wrap INNER in a MAM result from FROM for the replay test query." (list 'message `((from . ,from)) (list 'result `((xmlns . ,jabber-mam-xmlns) (queryid . "replay") (id . "archive")) (list 'forwarded `((xmlns . ,jabber-mam-forward-xmlns)) '(delay ((xmlns . "urn:xmpp:delay") (stamp . "2026-01-01T00:00:00Z"))) (copy-tree inner))))) (defun jabber-test-db--replay-message (from inner &optional room) "Replay INNER from FROM through a native MAM query, optionally for ROOM." (let ((jabber-mam--syncing nil) (jabber-mam--dirty-peers nil) (jabber-mam-sync-complete-functions nil) (jabber-open-info-queries nil) (stanza (jabber-test-db--archive-message from inner)) sent callback closure) (cl-letf (((symbol-function 'jabber-send-iq) (lambda (_jc _to _type query success data &rest _) (setq sent query callback success closure data)))) (unwind-protect (progn (jabber-mam--query 'jc nil "replay" nil nil room) (should (equal "replay" (jabber-xml-get-attribute sent 'queryid))) (should (jabber-test-archive--idle-p)) (jabber-mam--process-message 'jc stanza) ;; A rejected result must not make an unchanged-row test pass. (should-not (jabber-xml-node-children stanza)) (should jabber-mam--dirty-peers) (funcall callback 'jc `(iq ((from . ,from) (type . "result")) (fin ((xmlns . ,jabber-mam-xmlns) (complete . "true")))) closure) (should-not jabber-mam--syncing) (should (jabber-test-archive--idle-p)) (should-not jabber-mam--dirty-peers)) (jabber-mam--cleanup-connection 'jc))))) (ert-deftest jabber-test-db-dedup-native-muc-nickname-replay () "Native MAM replay retains outgoing identity after our nickname changes." (jabber-test-db-with-db (let ((nickname "old-custom") (jabber-history-inhibit-received-message-functions nil) (inner '(message ((from . "room@x/old-custom") (to . "me@x/desktop") (type . "groupchat") (id . "client")) (body () "preserved") (delay ((xmlns . "urn:xmpp:delay") (stamp . "2026-01-01T00:00:00Z"))) (stanza-id ((xmlns . "urn:xmpp:sid:0") (by . "room@x") (id . "archive"))) (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "same-actor")))))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@x")) ((symbol-function 'jabber-muc-nickname) (lambda (&rest _) nickname)) ((symbol-function 'jabber-muc-joined-p) (lambda (_ &optional _jc) t)) ((symbol-function 'fsm-get-state-data) (lambda (_) '(:username "me")))) (jabber-db--message-handler 'jc inner) (let ((original (sqlite-select jabber-db--connection "SELECT * FROM message"))) (should (equal '(("out")) (sqlite-select jabber-db--connection "SELECT direction FROM message"))) (setq nickname "new-custom") (should (equal '("in" . "room@x") (jabber-mam--classify-direction 'jc "room@x/old-custom" "me@x/desktop" "groupchat"))) ;; Replay both before and after reopening, preserving the primary ID. (dotimes (_ 2) (jabber-test-db--replay-message "room@x" inner "room@x") (jabber-db-close) (jabber-db-ensure-open) (should (equal original (sqlite-select jabber-db--connection "SELECT * FROM message"))))))))) (ert-deftest jabber-test-db-dedup-native-idless-outgoing-replay () "Own full-JID replay upgrades one ID-less send, never ambiguous siblings." (dolist (count '(1 2)) (jabber-test-db-with-db (let ((jabber-history-inhibit-received-message-functions nil) (instant (jabber-parse-time "2026-01-01T00:00:00Z")) (real-float-time (symbol-function 'float-time))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@x")) ((symbol-function 'fsm-get-state-data) (lambda (_) '(:username "me" :server "x"))) ((symbol-function 'jabber-send-sexp) (lambda (&rest _) nil)) ((symbol-function 'float-time) (lambda (&optional time) (funcall real-float-time (or time instant))))) (dotimes (_ count) (jabber-send-message 'jc "peer@x" "" "preserved" "chat")) (should (equal (make-list count '(nil nil nil)) (sqlite-select jabber-db--connection "SELECT resource,stanza_id,server_id FROM message"))) (dotimes (_ 2) (jabber-test-db--replay-message "me@x" '(message ((from . "me@x/desktop") (to . "peer@x") (type . "chat")) (body () "preserved"))) (jabber-db-close) (jabber-db-ensure-open) (should (equal (if (= count 1) '((1 "out" nil nil "archive" "preserved")) '((1 "out" nil nil nil "preserved") (2 "out" nil nil nil "preserved") (3 "out" "desktop" nil "archive" "preserved"))) (sqlite-select jabber-db--connection "SELECT id,direction,resource,stanza_id,server_id,body FROM message ORDER BY id"))))))))) (ert-deftest jabber-test-db-dedup-direction-drift-requires-muc-identity () "Conflicting or incomplete MUC identities cannot cross direction scope." (dolist (identity '(("chat" "nick" "client" "archive" "actor") ("groupchat" "other" "client" "archive" "actor") ("groupchat" "nick" "other" "archive" "actor") ("groupchat" "nick" "client" "other" "actor") ("groupchat" "nick" "client" "archive" "other") ("groupchat" "nick" nil "archive" "actor") ("groupchat" "nick" "client" nil "actor") ("groupchat" "nick" "client" "archive" nil))) (jabber-test-db-with-db (pcase-let ((`(,type ,resource ,client ,server ,occupant) identity)) (jabber-db-store-message "me@x" "room@x" "out" type "original" 100 "nick" "client" "archive" "actor") (let ((original (car (sqlite-select jabber-db--connection "SELECT * FROM message")))) (dotimes (_ (if server 2 1)) (jabber-db-store-message "me@x" "room@x" "in" type "replay" 200 resource client server occupant)) (jabber-db-close) (jabber-db-ensure-open) (let ((rows (sqlite-select jabber-db--connection "SELECT * FROM message ORDER BY id"))) (should (= 2 (length rows))) (should (equal original (car rows))))))))) (ert-deftest jabber-test-db-dedup-direction-drift-refuses-ambiguity () "Direction drift cannot choose between two historical matching rows." (jabber-test-db-with-db (jabber-db-store-message "me@x" "room@x" "out" "groupchat" "original" 100 "nick" "client" "archive" "actor") ;; Model a database already containing both classifications of this ID. (sqlite-execute jabber-db--connection "INSERT INTO message (account,peer,direction,type,body,timestamp,resource,stanza_id,server_id,occupant_id) SELECT account,peer,'in',type,body,timestamp,resource,stanza_id,server_id,occupant_id FROM message") (let ((original (sqlite-select jabber-db--connection "SELECT * FROM message ORDER BY id"))) (dotimes (_ 2) (jabber-db-store-message "me@x" "room@x" "in" "groupchat" "replay" 200 "nick" "client" "archive" "actor")) (jabber-db-close) (jabber-db-ensure-open) (should (equal original (sqlite-select jabber-db--connection "SELECT * FROM message WHERE id <= 2 ORDER BY id")))))) (ert-deftest jabber-test-db-dedup-missing-resource-is-outgoing-only () "Missing-resource fallback never conflates MUC senders or incoming rows." (dolist (scope '(("in" "chat") ("out" "groupchat") ("in" "groupchat"))) (jabber-test-db-with-db (pcase-let ((`(,direction ,type) scope)) (jabber-db-store-message "me@x" "peer@x" direction type "same" 100) (dotimes (_ 2) (jabber-db-store-message "me@x" "peer@x" direction type "same" 100 "desktop" nil "archive")) (jabber-db-close) (jabber-db-ensure-open) (should (equal '((nil nil) ("desktop" "archive")) (sqlite-select jabber-db--connection "SELECT resource,server_id FROM message ORDER BY id"))))))) (ert-deftest jabber-test-db-dedup-missing-resource-mixed-ambiguity () "Exact-resource and missing-resource candidates participate in one count." (jabber-test-db-with-db (dolist (resource '(nil "desktop")) (jabber-db-store-message "me@x" "peer@x" "out" "chat" "same" 100 resource)) (dotimes (_ 2) (jabber-db-store-message "me@x" "peer@x" "out" "chat" "same" 100 "desktop" nil "archive")) (jabber-db-close) (jabber-db-ensure-open) (should (equal '((nil nil) ("desktop" nil) ("desktop" "archive")) (sqlite-select jabber-db--connection "SELECT resource,server_id FROM message ORDER BY id"))))) (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"))))) (ert-deftest jabber-test-db-author-retraction-uses-exact-row () "Author retraction lookup exposes ambiguity and writes one chosen row." (jabber-test-db-with-db (dolist (entry '(("alice" "occupant-alice" "first") ("mallory" "occupant-mallory" "collision"))) (jabber-db-store-message "me@x.com" "room@conference.x" "in" "groupchat" (nth 2 entry) 1700000000 (car entry) nil (concat (car entry) "-server-id") (cadr entry))) (sqlite-execute jabber-db--connection "UPDATE message SET server_id = 'shared-server-id'") (let ((candidates (jabber-db-message-retraction-candidates "me@x.com" "room@conference.x" "shared-server-id"))) (should (= 2 (length candidates))) (should (equal '("room@conference.x/alice" "room@conference.x/mallory") (mapcar (lambda (candidate) (plist-get candidate :from)) candidates))) (jabber-db-retract-message-row (plist-get (car candidates) :row-id) "room@conference.x/alice") (should (equal '(("first" "room@conference.x/alice") ("collision" nil)) (sqlite-select jabber-db--connection "SELECT body, retracted_by FROM message ORDER BY id")))))) (ert-deftest jabber-test-db-author-retraction-preserves-existing-tombstone () "Row-scoped author retraction cannot overwrite moderator metadata." (jabber-test-db-with-db (jabber-db-store-message "me@x.com" "room@conference.x" "in" "groupchat" "spam" 1700000000 "alice" nil "server-id" "occupant-alice") (let ((row-id (caar (sqlite-select jabber-db--connection "SELECT id FROM message")))) (should (jabber-db-retract-message-row row-id "room@conference.x/mod" "spam")) (let ((candidate (car (jabber-db-message-retraction-candidates "me@x.com" "room@conference.x" "server-id")))) (should (equal "room@conference.x/mod" (plist-get candidate :retracted-by))) (should (equal "spam" (plist-get candidate :retraction-reason)))) (should-not (jabber-db-retract-message-row row-id "room@conference.x/alice")) (should (equal '(("room@conference.x/mod" "spam")) (sqlite-select jabber-db--connection "SELECT retracted_by, retraction_reason FROM message")))))) ;;; Group: Failed-decrypt replacement (ert-deftest jabber-test-db-store-preserves-placeholder-like-text-and-oob () "Only full decrypt-failure placeholders permit body and OOB replacement." (dolist (body '("Log: could not decrypt]" "[OMEMO: could not decrypt] trailing text" "prefix [OMEMO: could not decrypt]" "[OMEMO: could not decrypt]")) (jabber-test-db-with-db (jabber-db-store-message "me@x" "peer@x" "in" "chat" body 100 nil "client" "archive" nil '(("https://example.org/old" . "original"))) ;; A recycled client ID must not upgrade a sibling placeholder. (jabber-db-store-message "me@x" "peer@x" "in" "chat" "[OMEMO: could not decrypt]" 100 nil "client" "other" nil '(("https://example.org/sibling" . "sibling"))) (dotimes (_ 2) (jabber-db-store-message "me@x" "peer@x" "in" "chat" "decrypted" 100 nil "client" "archive" nil '(("https://example.org/new" . "replacement"))) ;; A failed decryption retry must not replace either valid body. (jabber-db-store-message "me@x" "peer@x" "in" "chat" "[OpenPGP: could not decrypt]" 100 nil "client" "archive") (jabber-db-close) (jabber-db-ensure-open) (should (equal (list (if (jabber--decrypt-failure-body-p body) '(1 "decrypted" "https://example.org/new" "replacement") (list 1 body "https://example.org/old" "original")) '(2 "[OMEMO: could not decrypt]" "https://example.org/sibling" "sibling")) (sqlite-select jabber-db--connection "SELECT m.id,m.body,o.url,o.desc FROM message m JOIN message_oob o ON o.message_id=m.id ORDER BY m.id"))))))) (ert-deftest jabber-test-db-store-preserves-retracted-placeholder-and-oob () "Even a real placeholder cannot upgrade a retracted message's body or OOB." (jabber-test-db-with-db (jabber-db-store-message "me@x" "room@x" "in" "groupchat" "[OMEMO: could not decrypt]" 100 "nick" "client" "archive" nil '(("https://example.org/old" . "original"))) (jabber-db-retract-message-in-peer "me@x" "room@x" "archive" nil) (dotimes (_ 2) (jabber-db-store-message "me@x" "room@x" "in" "groupchat" "decrypted" 200 "nick" "client" "archive" nil '(("https://example.org/new" . "replacement"))) (jabber-db-close) (jabber-db-ensure-open) (should (equal '((1 100 "[OMEMO: could not decrypt]" "https://example.org/old" "original")) (sqlite-select jabber-db--connection "SELECT m.retracted,m.timestamp,m.body,o.url,o.desc FROM message m JOIN message_oob o ON o.message_id=m.id")))))) (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))))) (ert-deftest jabber-test-db-legacy-migration-failure-is-atomic () "A failed legacy ALTER rolls back schema, rows and version before retry." (jabber-test-db-with-v1-db (let ((db (sqlite-open jabber-db-path))) (unwind-protect (progn (dolist (migration '(jabber-db--migrate-v1-to-v2 jabber-db--migrate-v2-to-v3 jabber-db--migrate-v3-to-v4 jabber-db--migrate-v4-to-v5 jabber-db--migrate-v5-to-v6)) (funcall migration db)) (sqlite-execute db "INSERT INTO message (account,peer,direction,type,body,timestamp) VALUES ('me@x','peer@x','in','chat','preserve',100)") (let ((before (sqlite-select db "SELECT * FROM sqlite_master")) (real-execute (symbol-function 'sqlite-execute))) (cl-letf (((symbol-function 'sqlite-execute) (lambda (connection sql &rest values) (if (equal sql "ALTER TABLE message ADD COLUMN reply_to_jid TEXT") (error "Injected migration failure") (apply real-execute connection sql values))))) (should-error (jabber-db--migrate-v6-to-v7 db))) (should (equal before (sqlite-select db "SELECT * FROM sqlite_master"))) (should (= 6 (caar (sqlite-select db "PRAGMA user_version"))))) (jabber-db--migrate db) (should (= jabber-db--schema-version (caar (sqlite-select db "PRAGMA user_version"))))) (sqlite-close db))) (should (equal "preserve" (plist-get (car (jabber-db-backlog "me@x" "peer@x")) :body))))) (ert-deftest jabber-test-db-ensure-open-migrates-live-connection () "Ensure-open migrates an existing historical connection after a reload." (jabber-test-db-with-v1-db (setq jabber-db--connection (sqlite-open jabber-db-path)) (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 (jabber-db--table-exists-p jabber-db--connection "message_thread")))) (defun jabber-test-db--prepare-version (db version) "Populate the historical v1 DB and advance it to VERSION." (sqlite-execute db "INSERT INTO message (account,peer,direction,type,body,timestamp,raw_xml,oob_url,oob_desc,retracted_by) VALUES ('me@x','peer@x','in','chat','preserved',100,'','https://x','file','mod@x')") (sqlite-execute db "INSERT INTO omemo_store (account,store_blob) VALUES ('me@x',x'010203')") (cl-loop for old from 1 below version do (funcall (intern (format "jabber-db--migrate-v%d-to-v%d" old (1+ old))) db))) (defun jabber-test-db--snapshot (db) "Return schema, version and message/encryption rows from DB." (list (sqlite-select db "SELECT type,name,tbl_name,sql FROM sqlite_master ORDER BY name") (sqlite-select db "PRAGMA user_version") (sqlite-select db "SELECT * FROM message") (sqlite-select db "SELECT * FROM omemo_store"))) (ert-deftest jabber-test-db-migrations-rollback-every-statement () "Every legacy or retraction migration write rolls back after a fault." (dolist (version '(1 2 3 4 5 6 10)) (let ((migration (intern (format "jabber-db--migrate-v%d-to-v%d" version (1+ version)))) (statements 0)) ;; Discover the actual writes on this version, excluding savepoint control. (jabber-test-db-with-v1-db (let ((db (sqlite-open jabber-db-path))) (unwind-protect (progn (jabber-test-db--prepare-version db version) (let ((execute (symbol-function 'sqlite-execute))) (cl-letf (((symbol-function 'sqlite-execute) (lambda (connection sql &rest values) (when (string-match-p "\\`\\(?:ALTER\\|CREATE\\|INSERT\\|UPDATE\\|PRAGMA user_version\\)" sql) (cl-incf statements)) (apply execute connection sql values)))) (funcall migration db)))) (sqlite-close db)))) (should (> statements 0)) (dotimes (failure statements) (ert-info ((format "version=%d write=%d" version (1+ failure))) (jabber-test-db-with-v1-db (let ((db (sqlite-open jabber-db-path))) (unwind-protect (progn (jabber-test-db--prepare-version db version) (let ((before (jabber-test-db--snapshot db)) (execute (symbol-function 'sqlite-execute)) (writes 0)) (cl-letf (((symbol-function 'sqlite-execute) (lambda (connection sql &rest values) (prog1 (apply execute connection sql values) (when (and (string-match-p "\\`\\(?:ALTER\\|CREATE\\|INSERT\\|UPDATE\\|PRAGMA user_version\\)" sql) (= (cl-incf writes) (1+ failure))) (error "Injected failure after migration write")))))) (should-error (funcall migration db))) (sqlite-close db) (setq db (sqlite-open jabber-db-path)) (should (equal before (jabber-test-db--snapshot db)))) (jabber-db--migrate db) (should (= jabber-db--schema-version (caar (sqlite-select db "PRAGMA user_version"))))) (sqlite-close db))) (let ((row (car (jabber-db-backlog "me@x" "peer@x")))) (should (equal "preserved" (plist-get row :body))) (should (plist-get row :retracted)) (should (equal '(("https://x" "file")) (sqlite-select jabber-db--connection "SELECT url,desc FROM message_oob")))))))))) (ert-deftest jabber-test-db-migration-nonlocal-exit-preserves-caller-transaction () "A migration throw rolls back only migration work inside the caller's SQL." (jabber-test-db-with-v1-db (let ((db (sqlite-open jabber-db-path))) (unwind-protect (progn (jabber-test-db--prepare-version db 6) (sqlite-execute db "BEGIN") (sqlite-execute db "UPDATE message SET body = 'caller-owned'") (let ((execute (symbol-function 'sqlite-execute))) (should (eq 'cancelled (catch 'stop (cl-letf (((symbol-function 'sqlite-execute) (lambda (connection sql &rest values) (prog1 (apply execute connection sql values) (when (equal sql "PRAGMA user_version=7") (throw 'stop 'cancelled)))))) (jabber-db--migrate db)))))) (should (= 6 (caar (sqlite-select db "PRAGMA user_version")))) (should (equal '(("caller-owned")) (sqlite-select db "SELECT body FROM message"))) (sqlite-execute db "ROLLBACK") (should (equal '(("preserved")) (sqlite-select db "SELECT body FROM message"))) (jabber-db--migrate db)) (sqlite-close db))))) (ert-deftest jabber-test-db-open-failure-closes-and-unpublishes () "Old-schema failures close newly opened and retained connections." (dolist (live '(nil t)) (jabber-test-db-with-v1-db (let ((db (sqlite-open jabber-db-path))) (jabber-test-db--prepare-version db 6) (sqlite-close db)) (let ((execute (symbol-function 'sqlite-execute)) failed-db) (when live (setq jabber-db--connection (sqlite-open jabber-db-path))) (cl-letf (((symbol-function 'sqlite-execute) (lambda (db sql &rest values) (if (equal sql "ALTER TABLE message ADD COLUMN reply_to_jid TEXT") (progn (setq failed-db db) (error "Injected open failure")) (apply execute db sql values))))) (should-error (jabber-db-ensure-open))) (should failed-db) (should-not jabber-db--connection) (should-error (sqlite-select failed-db "SELECT 1")) (let ((db (sqlite-open jabber-db-path))) (unwind-protect (should (= 6 (caar (sqlite-select db "PRAGMA user_version")))) (sqlite-close db))) (should (sqlitep (jabber-db-ensure-open))) (should (equal "preserved" (plist-get (car (jabber-db-backlog "me@x" "peer@x")) :body))))))) (ert-deftest jabber-test-db-initial-schema-failure-is-retryable () "Failure during initial DDL leaves an empty version-zero database." (let* ((directory (make-temp-file "jabber-db-init" t)) (jabber-db-path (expand-file-name "history.sqlite" directory)) (jabber-db--connection nil) (execute (symbol-function 'sqlite-execute)) failed-db) (unwind-protect (progn (cl-letf (((symbol-function 'sqlite-execute) (lambda (db sql &rest values) (if (string-prefix-p "CREATE TABLE IF NOT EXISTS message_oob" sql) (progn (setq failed-db db) (error "Injected DDL failure")) (apply execute db sql values))))) (should-error (jabber-db-ensure-open))) (should failed-db) (should-not jabber-db--connection) (should-error (sqlite-select failed-db "SELECT 1")) (let ((db (sqlite-open jabber-db-path))) (unwind-protect (progn (should (= 0 (caar (sqlite-select db "PRAGMA user_version")))) (should-not (sqlite-select db "SELECT name FROM sqlite_master"))) (sqlite-close db))) (should (sqlitep (jabber-db-ensure-open)))) (jabber-db-close) (delete-directory directory t)))) (ert-deftest jabber-test-db-migration-v11-retraction-state () "Migrated and fresh databases agree on independent retraction state." (let (fresh-column) (jabber-test-db-with-db (setq fresh-column (sqlite-select jabber-db--connection "SELECT name,type,\"notnull\",dflt_value,pk FROM pragma_table_info('message') WHERE name = 'retracted'"))) (jabber-test-db-with-v1-db (let ((db (sqlite-open jabber-db-path))) (unwind-protect (jabber-test-db--prepare-version db 10) (sqlite-close db))) (jabber-db-ensure-open) (should (equal fresh-column (sqlite-select jabber-db--connection "SELECT name,type,\"notnull\",dflt_value,pk FROM pragma_table_info('message') WHERE name = 'retracted'"))) (should (equal '((1 "mod@x")) (sqlite-select jabber-db--connection "SELECT retracted,retracted_by FROM message"))) (jabber-db-store-message "me@x" "peer@x" "in" "chat" "new" 101) (should (equal '((1 "mod@x") (0 nil)) (sqlite-select jabber-db--connection "SELECT retracted,retracted_by FROM message ORDER BY id"))) (jabber-db-close) (should (= 2 (length (jabber-db-backlog "me@x" "peer@x"))))))) (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, account TEXT, retracted_by TEXT)" "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, account TEXT, retracted_by TEXT)" "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)) (backlog (car (jabber-db-backlog "me@x.com" "room@x.com" nil nil nil "groupchat")))) (should row) (should (string= "occ-abc-123" (plist-get row :occupant-id))) (should (string= "occ-abc-123" (plist-get backlog :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, retracted_by 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, retracted_by 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, retracted_by TEXT)") (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, retracted_by TEXT)") (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, resource TEXT, stanza_id TEXT, retracted_by 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)))))) (ert-deftest jabber-test-db-displayed-cascade-ambiguous-time () "A timestamp alone cannot select one of two equal-second messages." (jabber-test-db-with-db (dolist (id '("first" "second")) (jabber-db-store-message "me@example.org" "peer@example.org" "out" "chat" id 100 nil id) (jabber-db-update-receipt "me@example.org" "peer@example.org" id "delivered_at" 101)) (jabber-db-update-receipt "me@example.org" "peer@example.org" "first" "displayed_at" 102) (jabber-db-cascade-displayed "me@example.org" "peer@example.org" 102 100) (should (equal '(("first" 102) ("second" nil)) (sqlite-select jabber-db--connection "SELECT stanza_id, displayed_at FROM message ORDER BY id"))))) (ert-deftest jabber-test-db-displayed-cascade-row-order () "Use persisted row order for ties and preserve scope after reopening." (jabber-test-db-with-db ;; Insert the older timestamp last: timestamp is the primary ordering key. (dolist (row '(("me@example.org" "peer@example.org" "out" "chat" "first" 100) ("me@example.org" "peer@example.org" "out" "chat" "second" 100) ("me@example.org" "peer@example.org" "out" "chat" "future" 101) ("other@example.org" "peer@example.org" "out" "chat" "first" 99) ("me@example.org" "other@example.org" "out" "chat" "first" 99) ("me@example.org" "peer@example.org" "in" "chat" "incoming" 99) ("me@example.org" "peer@example.org" "out" "groupchat" "room" 99) ("me@example.org" "peer@example.org" "out" "chat" "undelivered" 99) ("me@example.org" "peer@example.org" "out" "chat" "older" 99))) (apply #'jabber-db-store-message (append row (list nil (nth 4 row))))) (sqlite-execute jabber-db--connection "UPDATE message SET delivered_at = 101 WHERE stanza_id != 'undelivered'") (cl-labels ((state () (sqlite-select jabber-db--connection "SELECT stanza_id, displayed_at FROM message ORDER BY id")) (mark (id time) (jabber-db-cascade-displayed "me@example.org" "peer@example.org" time 100 id))) (mark "first" 102) (let ((expected '(("first" 102) ("second" nil) ("future" nil) ("first" nil) ("first" nil) ("incoming" nil) ("room" nil) ("undelivered" nil) ("older" 102)))) (should (equal expected (state))) (jabber-db-close) (jabber-db-ensure-open) (should (equal expected (state))) (mark "missing" 103) (mark "first" 103) (should (equal expected (state)))) (mark "second" 104) (let ((expected '(("first" 102) ("second" 104) ("future" nil) ("first" nil) ("first" nil) ("incoming" nil) ("room" nil) ("undelivered" nil) ("older" 102)))) (should (equal expected (state))) (mark "first" 105) (mark "older" 105) (mark "second" 105) (mark "missing" 105) (should (equal expected (state))) (jabber-db-close) (jabber-db-ensure-open) (should (equal expected (state))))))) (ert-deftest jabber-test-db-displayed-cascade-reverse-and-missing () "Ignore stale or missing boundaries, including late delivery changes." (jabber-test-db-with-db (dolist (id '("older" "first" "second" "future")) (jabber-db-store-message "me@example.org" "peer@example.org" "out" "chat" id 100 nil id)) (dolist (id '("first" "second" "future")) (jabber-db-update-receipt "me@example.org" "peer@example.org" id "delivered_at" 101)) (jabber-db-cascade-displayed "me@example.org" "peer@example.org" 102 100 "second") (jabber-db-update-receipt "me@example.org" "peer@example.org" "older" "delivered_at" 103) (jabber-db-cascade-displayed "me@example.org" "peer@example.org" 104 100 "first") (jabber-db-cascade-displayed "me@example.org" "peer@example.org" 104 100 "missing") (jabber-db-close) (jabber-db-ensure-open) (should (equal '(("older" nil) ("first" 102) ("second" 102) ("future" nil)) (sqlite-select jabber-db--connection "SELECT stanza_id, displayed_at FROM message ORDER BY id"))))) (ert-deftest jabber-test-db-displayed-cascade-ambiguous-id () "Refuse a reused stanza ID instead of choosing an arbitrary row." (jabber-test-db-with-db (dolist (timestamp '(100 101)) (jabber-db-store-message "me@example.org" "peer@example.org" "out" "chat" "body" timestamp nil)) (sqlite-execute jabber-db--connection "UPDATE message SET stanza_id = 'reused', delivered_at = 102") (jabber-db-cascade-displayed "me@example.org" "peer@example.org" 103 100 "reused") (jabber-db-cascade-displayed "me@example.org" "peer@example.org" 103 999) (should (equal '((nil) (nil)) (sqlite-select jabber-db--connection "SELECT displayed_at FROM message ORDER BY id"))))) (provide 'jabber-test-db) ;;; jabber-test-db.el ends here emacs-jabber-0.15.1/tests/jabber-test-disco-owner.el000066400000000000000000000514041527111033600222310ustar00rootroot00000000000000;;; jabber-test-disco-owner.el --- Owned discovery regressions -*- lexical-binding: t; -*- ;;; Commentary: ;; Exercise production IQ registration, dispatch, discovery and caps together. ;; Only the network write is replaced; all state is disposable. ;;; Code: (require 'ert) (require 'jabber-disco) (require 'jabber-moderation) (require 'jabber-disco-test-helpers) (require 'jabber-sm) (ert-deftest jabber-test-disco-owner-info-and-items () "Identical destinations retain separate answers and force invalidation." (dolist (kind '(info items)) (jabber-test-disco-owner--with-state (let* ((getter (if (eq kind 'info) #'jabber-disco-get-info #'jabber-disco-get-items)) (cache (if (eq kind 'info) jabber-disco-info-cache jabber-disco-items-cache)) (payload-a (if (eq kind 'info) '((feature ((var . "A")))) '((item ((name . "A") (jid . "a.example")))))) (payload-b (if (eq kind 'info) '((feature ((var . "B")))) '((item ((name . "B") (jid . "b.example")))))) delivered) (funcall getter a "same.example" "node" nil nil) (jabber-test-disco-owner--reply (car wire) payload-a) (funcall getter b "same.example" "node" (lambda (jc ctx value) (push (list jc ctx value) delivered)) 'b) (should (= (length wire) 2)) (jabber-test-disco-owner--reply (car wire) payload-b) (should (eq (caar delivered) b)) (let ((answer-b (gethash (jabber-disco--cache-key b "same.example" "node") cache))) (should answer-b) (should-not (equal answer-b (gethash (jabber-disco--cache-key a "same.example" "node") cache))) (funcall getter b "same.example" "node" nil nil) (should (= (length wire) 2)) (funcall getter a "same.example" "node" nil nil t) (should (= (length wire) 3)) (should (eq answer-b (gethash (jabber-disco--cache-key b "same.example" "node") cache)))))))) (ert-deftest jabber-test-disco-owner-callback-retirement () "Ignore foreign and retired replies but accept ordinary FSM state copies." (dolist (getter (list #'jabber-disco-get-info #'jabber-disco-get-items)) (jabber-test-disco-owner--with-state (let (delivered) (funcall getter a "same.example" "node" (lambda (&rest args) (push args delivered)) nil) (let* ((sent (car wire)) (entry (car jabber-open-info-queries)) (success (nth 1 entry)) (xml '(iq ((from . "same.example")) (query ((node . "node")) (feature ((var . "A"))))))) (funcall (car success) b xml (cdr success)) (should-not delivered) (put a :state-data (copy-sequence (fsm-get-state-data a))) (jabber-test-disco-owner--reply sent '((feature ((var . "A"))))) (should (= (length delivered) 1)) (setf (plist-get (get a :state-data) :connection) (make-symbol "reconnect")) (funcall (car success) a xml (cdr success)) (should (= (length delivered) 1)) (should-not (jabber-disco-get-info-immediately "same.example" "node" a)) (should-not (gethash (jabber-disco--cache-key a "same.example" "node") jabber-disco-items-cache))))))) (ert-deftest jabber-test-disco-owner-cached-callback-retirement () "A deferred cache hit cannot deliver into a retired connection." (jabber-test-disco-owner--with-state (jabber-disco-get-info a "same.example" "node" nil nil) (jabber-test-disco-owner--reply (car wire) '((feature ((var . "A"))))) (let (delivered) (let ((timer (jabber-disco-get-info a "same.example" "node" (lambda (&rest args) (setq delivered args)) nil))) (unwind-protect (progn (setq jabber-connections (delq a jabber-connections)) (apply (timer--function timer) (timer--args timer)) (should-not delivered)) (cancel-timer timer)))))) (ert-deftest jabber-test-disco-owner-predicate-bypasses-cache () "Predicate-bearing queries require admitted wire replies even on cache hit." (jabber-test-disco-owner--with-state (jabber-disco-get-info a "same.example" "node" nil nil) (jabber-test-disco-owner--reply (car wire) '((feature ((var . "cached"))))) (let (admit delivered) (jabber-disco-get-info a "same.example" "node" (lambda (&rest args) (setq delivered args)) nil nil (lambda (_jc _xml) admit)) (should (= (length wire) 2)) (jabber-test-disco-owner--reply (car wire) '((feature ((var . "fresh"))))) (should-not delivered) (should (= (length jabber-open-info-queries) 1)) (setq admit t) (jabber-test-disco-owner--reply (car wire) '((feature ((var . "fresh"))))) (should (equal (cadr (nth 2 delivered)) '("fresh"))) (should-not jabber-open-info-queries)))) (ert-deftest jabber-test-disco-owner-moderation-reads () "The native moderation predicate uses the caller's account, not ambient state." (jabber-test-disco-owner--with-state (jabber-disco-get-info a "room.example" nil nil nil) (jabber-test-disco-owner--reply (car wire) `((feature ((var . ,jabber-moderation-occupant-id-xmlns))))) (jabber-disco-get-info b "room.example" nil nil nil) (jabber-test-disco-owner--reply (car wire) '((feature ((var . "other"))))) (should (jabber-moderation--room-supports-occupant-id-p "room.example" a)) (should-not (jabber-moderation--room-supports-occupant-id-p "room.example" b)) (should-not (jabber-disco-get-info-immediately "room.example" nil)) (let (queried) (cl-letf (((symbol-function 'jabber-moderation--room-supports-occupant-id-p) (lambda (room jc) (setq queried (list room jc)) nil))) (jabber-moderation--handle-author-retraction b '(message ((from . "room.example/nick"))) '(retract ((id . "x")))) (should (equal queried (list "room.example" b))))))) (ert-deftest jabber-test-disco-owner-caps-fallback-owned-node () "Identical full JIDs on different accounts retain distinct owned candidates." (jabber-test-disco-owner--with-state (let ((key '("sha-1" . "unknown"))) (jabber-caps--query-if-needed a "same.example/res" "sha-1" "node-a" "unknown" key nil) (jabber-caps--query-if-needed b "same.example/res" "sha-1" "node-b" "unknown" key (gethash key jabber-caps-cache)) (jabber-caps--query-if-needed b "same.example/res" "sha-1" "node-b" "unknown" key (gethash key jabber-caps-cache)) (should (= (length wire) 1)) (jabber-test-disco-owner--reply (car wire) nil t) (should (= (length wire) 2)) (should (eq (caar wire) b)) (should (equal (jabber-xml-get-attribute (jabber-iq-query (cdar wire)) 'node) "node-b#unknown")) (jabber-test-disco-owner--reply (car wire) nil t) (should-not (gethash key jabber-caps--pending)) (should-not (gethash key jabber-caps-cache))))) (ert-deftest jabber-test-disco-owner-caps-timeout-and-stale-result () "Timeout advances candidates; stale errors, results and timers cannot settle successors." (jabber-test-disco-owner--with-state (let* ((children '((feature ((var . "verified"))))) (ver (jabber-caps-ver-string `(query nil ,@children) "sha-1")) (key (cons "sha-1" ver))) (jabber-caps--query-if-needed a "same.example/r" "sha-1" "a" ver key nil) (let* ((first (car wire)) (first-iq (car jabber-open-info-queries)) (pending (gethash key jabber-caps--pending)) (timer (plist-get pending :timer))) (jabber-caps--query-if-needed b "same.example/r" "sha-1" "b" ver key nil) (jabber-test-disco-owner--expire pending) (should (eq (caar wire) b)) (apply (timer--function timer) (timer--args timer)) (dolist (callback (list (nth 1 first-iq) (nth 2 first-iq))) (funcall (car callback) a `(iq nil (query nil ,@children)) (cdr callback))) (should-not (memq first-iq jabber-open-info-queries)) (should (= (length jabber-open-info-queries) 1)) (should (= (length wire) 2)) (jabber-test-disco-owner--reply first children) (should-not (gethash key jabber-caps-cache)) (should (eq pending (gethash key jabber-caps--pending))) (jabber-test-disco-owner--reply (car wire) children) (should (equal (cadr (gethash key jabber-caps-cache)) '("verified"))) (should-not (gethash key jabber-caps--pending)) (jabber-caps--query-if-needed c "other.example/r" "sha-1" "c" ver key (gethash key jabber-caps-cache)) (should (= (length wire) 2)) (should (eq (gethash key jabber-caps-cache) (jabber-disco-get-info-immediately "other.example/r" nil c))))))) (ert-deftest jabber-test-disco-owner-caps-retired-and-failed-candidates () "Discard retired queued owners, reject bad hashes and settle a silent last peer." (jabber-test-disco-owner--with-state (let ((key '("sha-1" . "unknown"))) (jabber-caps--query-if-needed a "a.example/r" "sha-1" "a" "unknown" key nil) (jabber-caps--query-if-needed c "c.example/r" "sha-1" "c" "unknown" key nil) (jabber-caps--query-if-needed b "b.example/r" "sha-1" "b" "unknown" key nil) (setf (plist-get (get b :state-data) :connection) (make-symbol "reconnected")) (jabber-test-disco-owner--reply (car wire) '((feature ((var . "wrong-hash"))))) (should (= (length wire) 2)) (should (eq (caar wire) c)) (jabber-test-disco-owner--expire (gethash key jabber-caps--pending)) (should-not jabber-open-info-queries) (should-not (gethash key jabber-caps--pending)) (should-not (gethash key jabber-caps-cache)) (jabber-caps--query-if-needed a "a.example/r" "sha-1" "a" "unknown" key nil) (should (= (length wire) 3))))) (ert-deftest jabber-test-disco-owner-caps-active-retirement () "A retired active owner cannot install even hash-verified content." (jabber-test-disco-owner--with-state (let* ((children '((feature ((var . "verified"))))) (ver (jabber-caps-ver-string `(query nil ,@children) "sha-1")) (key (cons "sha-1" ver))) (jabber-caps--query-if-needed a "same.example/r" "sha-1" "a" ver key nil) (jabber-caps--query-if-needed b "same.example/r" "sha-1" "b" ver key nil) (setq jabber-connections (delq a jabber-connections)) (jabber-test-disco-owner--reply (car wire) children) (should-not (gethash key jabber-caps-cache)) (should (eq (caar wire) b)) (jabber-test-disco-owner--reply (car wire) children) (should (gethash key jabber-caps-cache))))) (ert-deftest jabber-test-disco-owner-caps-contact-and-aliases () "Scope resource observations and aliases without duplicating verified content." (jabber-test-disco-owner--with-state (let* ((peer "same.example/r") (children '((feature ((var . "verified"))))) (ver (jabber-caps-ver-string `(query nil ,@children) "sha-1")) (key (cons "sha-1" ver))) (jabber-process-caps-modern a peer "sha-1" "node-a" ver) (jabber-process-caps-modern b peer "sha-1" "node-b" ver) (should (= (length wire) 1)) (jabber-test-disco-owner--reply (car wire) nil t) (should (eq (caar wire) b)) (should (equal (jabber-xml-get-attribute (jabber-iq-query (cdar wire)) 'node) (concat "node-b#" ver))) (jabber-test-disco-owner--reply (car wire) children) (let ((info (gethash key jabber-caps-cache))) (should info) (should (eq (jabber-caps-get-cached peer a) info)) (should (eq (jabber-caps-get-cached peer b) info)) (should-not (jabber-caps-get-cached peer c)) (should-not (jabber-caps-get-cached peer)) (jabber-process-caps-modern a peer "sha-1" "node-a" ver) (jabber-process-caps-modern b peer "sha-1" "node-b" ver) (should (= (length wire) 2)) (should (eq (gethash (jabber-disco--cache-key a peer nil) jabber-disco-info-cache) info)) (should (eq (gethash (jabber-disco--cache-key b peer nil) jabber-disco-info-cache) info)) (jabber-process-caps-modern a peer "sha-1" "changed" "unknown") (should-not (jabber-disco-get-info-immediately peer nil a)) (should (eq (jabber-disco-get-info-immediately peer nil b) info)) (setf (plist-get (get b :state-data) :session-id) "new-stream") (should-not (jabber-caps-get-cached peer b)) (should-not (jabber-disco-get-info-immediately peer nil b)))))) (ert-deftest jabber-test-disco-owner-persisted-caps () "Reuse persisted verified payloads, creating aliases only for the observer." (jabber-test-disco-owner--with-state (let ((jabber-db-path (make-temp-file "jabber-disco-db-")) (jabber-db--connection nil) (info '((["client" "client" "pc"]) ("feature")))) (unwind-protect (progn (jabber-db-caps-store "sha-1" "stored" (car info) (cadr info)) (jabber-process-caps-modern a "same.example/r" "sha-1" "node" "stored") (should-not wire) (should (equal (jabber-disco-get-info-immediately "same.example/r" nil a) info)) (should-not (jabber-disco-get-info-immediately "same.example/r" nil b)) (jabber-process-caps-modern b "same.example/r" "sha-1" "other" "stored") (should-not wire) (should (eq (jabber-caps-get-cached "same.example/r" a) (jabber-caps-get-cached "same.example/r" b)))) (jabber-db-close) (delete-file jabber-db-path))))) (ert-deftest jabber-test-disco-owner-caps-send-failure () "Settle failed transport admission and allow a later attempt." (jabber-test-disco-owner--with-state (let ((key '("sha-1" . "unknown"))) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (&rest _) (error "Transport closed")))) (jabber-caps--query-if-needed a "same.example/r" "sha-1" "a" "unknown" key nil)) (should-not (gethash key jabber-caps--pending)) (should-not jabber-open-info-queries) (jabber-caps--query-if-needed b "same.example/r" "sha-1" "b" "unknown" key nil) (should (eq (caar wire) b))))) (ert-deftest jabber-test-disco-owner-retired-observations-bounded () "Reclaim retired observations without clearing live or verified content." (jabber-test-disco-owner--with-state (let* ((children '((feature ((var . "verified"))))) (ver (jabber-caps-ver-string `(query nil ,@children) "sha-1")) (key (cons "sha-1" ver))) ;; Populate verified global data through the native IQ/hash check. (jabber-process-caps-modern b "peer.example/r" "sha-1" "node" ver) (jabber-test-disco-owner--reply (car wire) children) (jabber-process-caps-modern b "peer.example/r" "sha-1" "node" ver) (jabber-disco-get-items b "service.example" nil nil nil) (jabber-test-disco-owner--reply (car wire) '((item ((jid . "live.example"))))) (let ((verified (gethash key jabber-caps-cache)) (live-info (gethash (jabber-disco--cache-key b "peer.example/r" nil) jabber-disco-info-cache)) (live-items (gethash (jabber-disco--cache-key b "service.example" nil) jabber-disco-items-cache))) (dotimes (generation 12) ;; Replace transports, streams and entire connections in turn. (pcase (% generation 3) (0 (setf (plist-get (get a :state-data) :connection) (make-symbol "replacement"))) (1 (setf (plist-get (get a :state-data) :session-id) (format "stream-%s" generation))) (2 (setq jabber-connections (delq a jabber-connections) a (jabber-test-disco-owner--connection "a")) (push a jabber-connections))) ;; Exercise each insertion boundary as the first cleanup after loss. (pcase (% generation 3) (0 (jabber-disco-get-info a "service.example" nil nil nil) (jabber-test-disco-owner--reply (car wire) children)) (1 (jabber-disco-get-items a "service.example" nil nil nil) (jabber-test-disco-owner--reply (car wire) '((item ((jid . "current.example")))))) (2 (jabber-process-caps-modern a "peer.example/r" "sha-1" "node" ver))) (dolist (cache (list jabber-disco-info-cache jabber-disco-items-cache)) (maphash (lambda (observation _) (should (jabber-disco--owner-current-p (car observation)))) cache)) (jabber-disco-get-info a "service.example" nil nil nil t) (jabber-test-disco-owner--reply (car wire) children) (jabber-disco-get-items a "service.example" nil nil nil t) (jabber-test-disco-owner--reply (car wire) '((item ((jid . "current.example"))))) (jabber-process-caps-modern a "peer.example/r" "sha-1" "node" ver) (should (= (hash-table-count jabber-disco-info-cache) 3)) (should (= (hash-table-count jabber-disco-items-cache) 2)) (dolist (cache (list jabber-disco-info-cache jabber-disco-items-cache)) (maphash (lambda (observation _) (should (jabber-disco--owner-current-p (car observation)))) cache)) (should (eq verified (gethash key jabber-caps-cache))) (should (eq live-info (jabber-disco-get-info-immediately "peer.example/r" nil b))) (should (eq live-items (gethash (jabber-disco--cache-key b "service.example" nil) jabber-disco-items-cache)))) ;; A successful native SM resume preserves the other live owner's ;; observations and contact namespace across ordinary state copies. (let ((contact (jabber-jid-symbol "peer.example" b)) (state (append (list :sm-enabled t :sm-id "resumable" :sm-resuming t :sm-outbound-count 0 :sm-last-acked 0) (copy-sequence (fsm-get-state-data b))))) (put b :state-data (jabber-sm--handle-resumed state '(resumed ((xmlns . "urn:xmpp:sm:3") (h . "0") (previd . "resumable"))))) (should (plist-get (fsm-get-state-data b) :sm-resumed)) (jabber-disco-get-info a "after-resume.example" nil nil nil) (jabber-test-disco-owner--reply (car wire) children) (should (eq contact (jabber-jid-symbol "peer.example" b))) (should (eq live-info (jabber-disco-get-info-immediately "peer.example/r" nil b))) (should (eq verified (jabber-caps-get-cached "peer.example/r" b)))))))) (ert-deftest jabber-test-disco-owner-resume-reclaims-old-transport () "Retire transport observations on resume, retaining verified caps and contacts." (jabber-test-disco-owner--with-state (let* ((children '((feature ((var . "verified"))))) (ver (jabber-caps-ver-string `(query nil ,@children) "sha-1")) (key (cons "sha-1" ver))) (jabber-process-caps-modern a "peer.example/r" "sha-1" "node" ver) (jabber-test-disco-owner--reply (car wire) children) (jabber-process-caps-modern a "peer.example/r" "sha-1" "node" ver) (let* ((contact (jabber-jid-symbol "peer.example" a)) (verified (gethash key jabber-caps-cache)) (old-key (jabber-disco--cache-key a "peer.example/r" nil)) (state (copy-sequence (fsm-get-state-data a)))) (setf (plist-get state :connection) (make-symbol "resumed-transport") (plist-get state :session-id) "resumed-stream") (put a :state-data (jabber-sm--handle-resumed (append (list :sm-id "resumable" :sm-enabled t :sm-resuming t :sm-outbound-count 0 :sm-last-acked 0) state) '(resumed ((xmlns . "urn:xmpp:sm:3") (h . "0") (previd . "resumable"))))) (should (plist-get (fsm-get-state-data a) :sm-resumed)) (should (eq contact (jabber-jid-symbol "peer.example" a))) (should-not (jabber-caps-get-cached "peer.example/r" a)) (jabber-process-caps-modern a "peer.example/r" "sha-1" "node" ver) (should-not (gethash old-key jabber-disco-info-cache)) (should (= (hash-table-count jabber-disco-info-cache) 1)) (should (= (length wire) 1)) (should (eq verified (gethash key jabber-caps-cache))) (should (eq verified (jabber-disco-get-info-immediately "peer.example/r" nil a))))))) (provide 'jabber-test-disco-owner) ;;; jabber-test-disco-owner.el ends here emacs-jabber-0.15.1/tests/jabber-test-disco.el000066400000000000000000000217341527111033600211040ustar00rootroot00000000000000;;; 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) (require 'jabber-disco-test-helpers) ;;; Group 1: jabber-caps--store-hash (ert-deftest jabber-test-disco-store-hash-sets-caps-on-resource () "Store the mapping on the explicitly owned contact resource." (jabber-test-disco-owner--with-state (jabber-caps--store-hash "alice@example.com/mobile" '("sha-1" . "abc123") a) (let* ((sym (jabber-jid-symbol "alice@example.com" a)) (entry (assoc "mobile" (get sym 'resources)))) (should entry) (should (equal (plist-get (cdr entry) 'caps) '("sha-1" . "abc123"))) (should-not (get (jabber-jid-symbol "alice@example.com" b) 'resources))))) (ert-deftest jabber-test-disco-store-hash-updates-existing-resource () "Update only the specified owner's existing resource." (jabber-test-disco-owner--with-state (jabber-caps--store-hash "alice@example.com/mobile" '("sha-1" . "v1") a) (jabber-caps--store-hash "alice@example.com/mobile" '("sha-1" . "b") b) (jabber-caps--store-hash "alice@example.com/mobile" '("sha-1" . "v2") a) (let ((resources (get (jabber-jid-symbol "alice@example.com" a) 'resources))) (should (= (length resources) 1)) (should (equal (plist-get (cdar resources) 'caps) '("sha-1" . "v2")))) (should (equal (plist-get (cdar (get (jabber-jid-symbol "alice@example.com" b) 'resources)) 'caps) '("sha-1" . "b"))))) (ert-deftest jabber-test-disco-store-hash-bare-jid () "Use the empty resource for a bare JID on its explicit owner." (jabber-test-disco-owner--with-state (jabber-caps--store-hash "bob@example.com" '("sha-256" . "xyz") a) (let ((entry (assoc "" (get (jabber-jid-symbol "bob@example.com" a) 'resources)))) (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 () "Reuse verified data globally but qualify observation aliases." (jabber-test-disco-owner--with-state (let ((info '(("id1") ("feat1" "feat2"))) (key '("sha-1" . "ver1"))) (puthash key info jabber-caps-cache) (jabber-caps--query-if-needed a "alice@example.com/res" "sha-1" "node" "ver1" key info) (should (eq (jabber-disco-get-info-immediately "alice@example.com/res" nil a) info)) (should-not (jabber-disco-get-info-immediately "alice@example.com/res" nil b)) (jabber-caps--query-if-needed b "alice@example.com/res" "sha-1" "node-b" "ver1" key info) (should (eq (jabber-disco-get-info-immediately "alice@example.com/res" nil b) info)) (should-not wire)))) (ert-deftest jabber-test-disco-query-if-needed-cache-miss () "Keep pending candidates out of the verified payload cache." (jabber-test-disco-owner--with-state (let ((key '("sha-1" . "ver1"))) (jabber-caps--query-if-needed a "alice@example.com/res" "sha-1" "node" "ver1" key nil) (should-not (gethash key jabber-caps-cache)) (should (gethash key jabber-caps--pending)) (should (= (length wire) 1))))) (ert-deftest jabber-test-disco-query-if-needed-pending-recent () "Deduplicate by owned identity including the advertised node." (jabber-test-disco-owner--with-state (let ((key '("sha-1" . "ver1"))) (jabber-caps--query-if-needed a "same.example/r" "sha-1" "node-a" "ver1" key nil) (jabber-caps--query-if-needed b "same.example/r" "sha-1" "node-b" "ver1" key nil) (jabber-caps--query-if-needed b "same.example/r" "sha-1" "node-b" "ver1" key nil) (jabber-caps--query-if-needed b "same.example/r" "sha-1" "node-c" "ver1" key nil) (should (= (length wire) 1)) (should (= (length (plist-get (gethash key jabber-caps--pending) :queue)) 2))))) (ert-deftest jabber-test-disco-query-if-needed-pending-stale () "Settle a timed-out last candidate and admit a later advertisement." (jabber-test-disco-owner--with-state (let ((key '("sha-1" . "ver1"))) (jabber-caps--query-if-needed a "same.example/r" "sha-1" "node" "ver1" key nil) (jabber-test-disco-owner--expire (gethash key jabber-caps--pending)) (should-not (gethash key jabber-caps--pending)) (jabber-caps--query-if-needed a "same.example/r" "sha-1" "node" "ver1" key nil) (should (= (length wire) 2))))) ;;; 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 () "Store the scoped resource and dispatch through the advertised owner." (jabber-test-disco-owner--with-state (jabber-process-caps-modern a "alice@example.com/phone" "sha-1" "node" "ver1") (let ((entry (assoc "phone" (get (jabber-jid-symbol "alice@example.com" a) 'resources)))) (should (equal (plist-get (cdr entry) 'caps) '("sha-1" . "ver1")))) (should (eq (caar wire) a)))) (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)))) (ert-deftest jabber-test-disco-caps-xep-0115-known-answer () "Match the XEP-0115 Unicode identities and data forms reference hash." (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)))))) (should (equal "q07IKJEyjvHSyhy//CH0CxmKi8w=" (jabber-caps-ver-string query "sha-1"))))) (provide 'jabber-test-disco) ;;; jabber-test-disco.el ends here emacs-jabber-0.15.1/tests/jabber-test-history-cost.el000066400000000000000000000513721527111033600224530ustar00rootroot00000000000000;;; jabber-test-history-cost.el --- Bounded history reads and replay writes -*- lexical-binding: t; -*- ;;; Commentary: ;; Archive replay must not rewrite unchanged rows, and thread views must ;; convert only the rows they display. Parent backlog thread summaries ;; keep their existing selection among threads that share a root. ;;; Code: (require 'jabber-archive-test-helpers) (require 'jabber-message-reply) ;;; Replay writes (defmacro jabber-test-history-cost--with-db (&rest body) "Run BODY with a disposable database." (declare (indent 0) (debug t)) `(let* ((directory (make-temp-file "jabber-history-cost-" t)) (jabber-db-path (expand-file-name "history.sqlite" directory)) (jabber-db--connection nil) (jabber-backlog-days nil) (jabber-backlog-number 30)) (unwind-protect (progn (jabber-db-ensure-open) ,@body) (jabber-db-close) (delete-directory directory t)))) (defun jabber-test-history-cost--updates (thunk) "Return the number of message row UPDATEs made by calling THUNK." (let ((db jabber-db--connection)) (sqlite-execute db "CREATE TEMP TABLE IF NOT EXISTS history_cost_update (id INTEGER)") (sqlite-execute db "DELETE FROM history_cost_update") (sqlite-execute db "CREATE TEMP TRIGGER IF NOT EXISTS history_cost_update_message AFTER UPDATE ON main.message BEGIN INSERT INTO history_cost_update VALUES (new.id); END") (unwind-protect (progn (funcall thunk) (caar (sqlite-select db "SELECT count(*) FROM history_cost_update"))) (sqlite-execute db "DROP TRIGGER history_cost_update_message")))) (defun jabber-test-history-cost--replay (jc inner uid) "Replay INNER on JC with UID through a complete page after the cursor. An overlapping server page redelivers UID after the durable cursor." (let ((query (jabber-mam--query jc (car (jabber-test-archive--progress))))) (jabber-mam--process-message jc (jabber-test-archive--result query uid (copy-tree inner))) (jabber-test-archive--fin jc query uid))) (defun jabber-test-history-cost--direct (&optional origin encrypted) "Return a direct chat message with ORIGIN, ENCRYPTED when non-nil." `(message ((from . "friend@example.com/phone") (to . "me@example.com") (type . "chat") (id . "transport")) (body () ,(if encrypted "OMEMO fallback" "retained")) ,@(when origin `((origin-id ((xmlns . "urn:xmpp:sid:0") (id . ,origin))))) ,@(when encrypted '((encrypted ((xmlns . "eu.siacs.conversations.axolotl")) (payload () "ciphertext")))))) (defun jabber-test-history-cost--counts () "Return message, archive alias and searchable row counts." (mapcar (lambda (sql) (caar (sqlite-select jabber-db--connection sql))) '("SELECT count(*) FROM message" "SELECT count(*) FROM message_archive" "SELECT count(*) FROM message_fts WHERE message_fts MATCH 'retained OR secret'"))) (defun jabber-test-history-cost--identity () "Return the stored identity columns of the only message row." (car (sqlite-select jabber-db--connection "SELECT stanza_id, server_id, origin_id, room_id, body FROM message"))) (ert-deftest jabber-test-history-cost-exact-replay-writes-nothing () "Exact archive replay keeps the row, aliases and presentation signal." (jabber-test-archive--with-file (let ((xml (jabber-test-history-cost--direct "origin")) dirty) (jabber-test-history-cost--replay jc xml "uid-1") (setq jabber-mam-sync-complete-functions (list (lambda (peers) (setq dirty peers)))) (should (= 0 (jabber-test-history-cost--updates (lambda () (jabber-test-history-cost--replay jc xml "uid-1"))))) ;; Replay remains a dirty-peer settlement; redraw policy is unchanged. (should (equal '(("me@example.com" "friend@example.com" "chat")) dirty)) (should (equal '(1 1 1) (jabber-test-history-cost--counts))) (jabber-db-close) (jabber-db-ensure-open) (should (equal '("transport" "uid-1" "origin" nil "retained") (jabber-test-history-cost--identity))) (should (equal "uid-1" (car (jabber-test-archive--progress)))) (should (sqlite-execute jabber-db--connection "INSERT INTO message_fts(message_fts) VALUES ('integrity-check')"))))) (ert-deftest jabber-test-history-cost-direct-store-replay-keeps-row-id () "Repeated store calls return the canonical row without rewriting it." (jabber-test-history-cost--with-db (let* ((identity '(:origin-id "origin" :room-id nil :archive "me@example.com" :archive-id "uid-1")) (store (lambda () (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "retained" 100 "phone" "transport" "uid-1" nil nil nil nil nil identity))) (id (funcall store))) (should (= 0 (jabber-test-history-cost--updates (lambda () (should (equal id (funcall store))))))) (should (equal '(1 1 1) (jabber-test-history-cost--counts)))))) (ert-deftest jabber-test-history-cost-encrypted-cache-replay-writes-nothing () "A cached decryption is replayed without ratchet use or row rewrites." (jabber-test-archive--with-file (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)) (runs 0) (xml (jabber-test-history-cost--direct "origin" t))) (jabber-chat-register-decrypt-handler 'history-cost-omemo :detect (lambda (stanza) (jabber-xml-child-with-xmlns stanza "eu.siacs.conversations.axolotl")) :decrypt (lambda (_jc stanza _parsed) (setq runs (1+ runs)) (jabber-chat--set-body stanza "secret")) :priority 10 :error-label "OMEMO") (jabber-test-history-cost--replay jc xml "uid-1") (should (= 0 (jabber-test-history-cost--updates (lambda () (jabber-test-history-cost--replay jc xml "uid-1"))))) (should (= 1 runs)) (should (equal '(1 1 1) (jabber-test-history-cost--counts))) (should (equal '("transport" "uid-1" "origin" nil "secret") (jabber-test-history-cost--identity)))))) (ert-deftest jabber-test-history-cost-replay-fills-missing-identity () "Replay still fills NULL transport, archive and origin identity once." (jabber-test-archive--with-file (jabber-db--message-handler jc (jabber-test-history-cost--direct)) (should (equal '("transport" nil nil nil "retained") (jabber-test-history-cost--identity))) (let ((xml (jabber-test-history-cost--direct "origin"))) (should (< 0 (jabber-test-history-cost--updates (lambda () (jabber-test-history-cost--replay jc xml "uid-1"))))) (should (equal '("transport" "uid-1" "origin" nil "retained") (jabber-test-history-cost--identity))) (should (= 0 (jabber-test-history-cost--updates (lambda () (jabber-test-history-cost--replay jc xml "uid-1"))))) (should (equal '(1 1 1) (jabber-test-history-cost--counts)))))) (ert-deftest jabber-test-history-cost-room-identity-fills-only-null () "Room identity and a missing server ID are each added exactly when absent." (jabber-test-history-cost--with-db (let ((store (lambda (server identity) (jabber-db-store-message "me@example.com" "room@conference.example.com" "in" "groupchat" "room text" 100 "Alice" "client" server "occupant" nil nil nil nil identity))) (room '(:origin-id nil :room-id "room-sid"))) (let ((id (funcall store nil nil))) ;; One statement fills the server ID, another the room identity. (should (= 2 (jabber-test-history-cost--updates (lambda () (should (equal id (funcall store "room-sid" room))))))) (should (= 0 (jabber-test-history-cost--updates (lambda () (should (equal id (funcall store "room-sid" room))))))) (should (equal '("client" "room-sid" nil "room-sid" "room text") (jabber-test-history-cost--identity))))))) ;;; Thread backlog (defun jabber-test-history-cost--insert (&rest columns) "Insert one message from plist COLUMNS and return its row ID." (let ((columns (append columns '(:account "me@x" :peer "peer@x" :direction "in" :type "chat")))) (sqlite-execute jabber-db--connection "INSERT INTO message (id, account, peer, direction, type, body, timestamp, stanza_id, server_id, room_id, thread_id) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" (mapcar (lambda (key) (plist-get columns key)) '(:id :account :peer :direction :type :body :timestamp :stanza-id :server-id :room-id :thread-id))) (caar (sqlite-select jabber-db--connection "SELECT last_insert_rowid()")))) (defun jabber-test-history-cost--thread (thread-id &rest root) "Register dedicated THREAD-ID with ROOT plist identity." (sqlite-execute jabber-db--connection "INSERT INTO message_thread (account, peer, type, thread_id, root_message_id, root_stanza_id, root_server_id, created_at, dedicated, title) VALUES (?, ?, ?, ?, ?, ?, ?, 0, 1, ?)" (list (or (plist-get root :account) "me@x") "peer@x" (or (plist-get root :type) "chat") thread-id (plist-get root :id) (plist-get root :stanza-id) (plist-get root :server-id) (plist-get root :title)))) (defun jabber-test-history-cost--bodies (messages) "Return MESSAGES' bodies." (mapcar (lambda (message) (plist-get message :body)) messages)) (defun jabber-test-history-cost--thread-bodies (count &optional start-time type) "Return bodies of thread \"t\" for COUNT, START-TIME and TYPE." (jabber-test-history-cost--bodies (jabber-db-thread-backlog "me@x" "peer@x" (or type "chat") "t" count start-time))) (ert-deftest jabber-test-history-cost-thread-backlog-bounded-rows () "A short thread view converts only its root and newest replies." (jabber-test-history-cost--with-db (jabber-test-history-cost--insert :id 1 :body "root" :timestamp 1) (jabber-test-history-cost--thread "t" :id 1) (dotimes (i 200) (jabber-test-history-cost--insert :body (format "reply %d" i) :timestamp (+ 10 i) :thread-id "t")) (let ((converted 0) (convert (symbol-function 'jabber-db--row-to-plist))) (cl-letf (((symbol-function 'jabber-db--row-to-plist) (lambda (row) (setq converted (1+ converted)) (funcall convert row)))) (should (equal '("reply 199" "reply 198" "reply 197" "reply 196" "root") (jabber-test-history-cost--thread-bodies 5)))) (should (= 5 converted))))) (ert-deftest jabber-test-history-cost-thread-backlog-counts-and-cutoff () "Counts keep the root plus newest replies; cutoff can exclude the root." (jabber-test-history-cost--with-db (jabber-test-history-cost--insert :id 1 :body "root" :timestamp 1) (jabber-test-history-cost--thread "t" :id 1) (dolist (spec '((2 "a" 10) (3 "b" 20) (4 "c" 20) (5 "d" 30))) (jabber-test-history-cost--insert :id (car spec) :body (cadr spec) :timestamp (nth 2 spec) :thread-id "t")) ;; Unrelated account, peer and type rows share the thread ID. (jabber-test-history-cost--insert :body "foreign" :timestamp 40 :thread-id "t" :account "other@x") (jabber-test-history-cost--insert :body "muc" :timestamp 40 :thread-id "t" :type "groupchat") (should (equal '("root") (jabber-test-history-cost--thread-bodies 0))) (should (equal '("root") (jabber-test-history-cost--thread-bodies 1))) (should (equal '("d" "c" "root") (jabber-test-history-cost--thread-bodies 3))) ;; Equal timestamps keep the newer row first. (should (equal '("d" "c" "b" "a" "root") (jabber-test-history-cost--thread-bodies t))) (should (equal '("d" "c" "b" "a" "root") (jabber-test-history-cost--thread-bodies nil))) (should (equal '("d" "c") (jabber-test-history-cost--thread-bodies 3 5))) (should-not (jabber-db-thread-backlog "me@x" "peer@x" "chat" "absent" t)))) (ert-deftest jabber-test-history-cost-thread-backlog-root-fallbacks () "Historical root IDs follow row, room-server and stanza precedence." (jabber-test-history-cost--with-db ;; The newest row carrying a fallback stanza ID is the root; an older ;; copy remains an ordinary reply. (jabber-test-history-cost--insert :body "old copy" :timestamp 1 :stanza-id "root-s" :thread-id "t") (jabber-test-history-cost--insert :body "root" :timestamp 2 :stanza-id "root-s") (jabber-test-history-cost--insert :body "reply" :timestamp 3 :thread-id "t") (jabber-test-history-cost--thread "t" :stanza-id "root-s") (should (equal '("reply" "root") (jabber-test-history-cost--thread-bodies 2))) (should (equal '("reply" "old copy" "root") (jabber-test-history-cost--thread-bodies t))) ;; Groupchat roots match a server ID or a room ID in thread rows. (jabber-test-history-cost--insert :body "muc root" :timestamp 5 :type "groupchat" :server-id "legacy" :room-id "room-root" :thread-id "t") (jabber-test-history-cost--insert :body "muc reply" :timestamp 6 :type "groupchat" :thread-id "t" :stanza-id "root-s") (jabber-test-history-cost--thread "t" :type "groupchat" :server-id "room-root" :stanza-id "root-s") (should (equal '("muc reply" "muc root") (jabber-test-history-cost--thread-bodies 2 nil "groupchat"))) ;; Without root identity only replies remain. (jabber-test-history-cost--insert :body "loose" :timestamp 7 :thread-id "u") (jabber-test-history-cost--thread "u") (should (equal '("loose") (jabber-test-history-cost--bodies (jabber-db-thread-backlog "me@x" "peer@x" "chat" "u" 5)))))) (ert-deftest jabber-test-history-cost-thread-root-timestamp-tie () "Equal-time copies of a stanza root keep the newer row as root." (jabber-test-history-cost--with-db (jabber-test-history-cost--insert :id 1 :body "first" :timestamp 5 :stanza-id "s") (jabber-test-history-cost--insert :id 2 :body "second" :timestamp 5 :stanza-id "s") (jabber-test-history-cost--insert :id 3 :body "reply" :timestamp 5 :thread-id "t") (jabber-test-history-cost--thread "t" :stanza-id "s") (should (equal '("reply" "first" "second") (jabber-test-history-cost--thread-bodies t))) (should (equal '("reply" "second") (jabber-test-history-cost--thread-bodies 2))))) ;;; Thread summaries in the parent backlog (ert-deftest jabber-test-history-cost-summaries-match-root-identities () "Row, room-server and stanza roots attach only within their own type." (jabber-test-history-cost--with-db (let ((row-root (jabber-test-history-cost--insert :body "row root" :timestamp 1 :stanza-id "shared"))) (jabber-test-history-cost--insert :body "server root" :timestamp 2 :type "groupchat" :room-id "room-root" :server-id "legacy" :stanza-id "shared") (jabber-test-history-cost--insert :body "stanza root" :timestamp 3 :stanza-id "chat-root") (jabber-test-history-cost--thread "by-row" :id row-root) (jabber-test-history-cost--thread "by-server" :type "groupchat" :server-id "room-root" :stanza-id "shared") (jabber-test-history-cost--thread "by-stanza" :stanza-id "chat-root") ;; A groupchat thread cannot claim a chat row by its row ID. (jabber-test-history-cost--thread "wrong-type" :type "groupchat" :id row-root) (jabber-test-history-cost--thread "other-account" :account "other@x" :id row-root) (let ((threads (mapcar (lambda (message) (cons (plist-get message :body) (plist-get (plist-get message :thread-summary) :thread-id))) (jabber-db-backlog "me@x" "peer@x" t 0)))) (should (equal '(("stanza root" . "by-stanza") ("server root" . "by-server") ("row root" . "by-row")) threads))) (should-not (jabber-db--attach-thread-summaries jabber-db--connection "me@x" "peer@x" nil))))) ;; Several dedicated threads may claim one root. The parent backlog ;; attaches the claimant that comes last in its unordered metadata read, ;; so the winner depends on the database's query plan, including SQLite ;; statistics persisted by an earlier ANALYZE. Cost changes must keep ;; that selection until a deliberate contract replaces it. (defun jabber-test-history-cost--last-claimant (claimants) "Return the last of CLAIMANTS in the parent backlog's thread read." (car (last (seq-filter (lambda (thread-id) (member thread-id claimants)) (mapcar #'car (sqlite-select jabber-db--connection "SELECT thread_id FROM message_thread \ WHERE account = ? AND peer = ? AND dedicated = 1" '("me@x" "peer@x"))))))) (defun jabber-test-history-cost--shared-root-view () "Return the parent root's summary fields and consumed reply thread." (let* ((root (seq-find (lambda (message) (equal "root" (plist-get message :body))) (jabber-db-backlog "me@x" "peer@x" t 0))) (summary (plist-get root :thread-summary))) (list (plist-get summary :thread-id) (plist-get summary :title) (plist-get summary :reply-count) (plist-get summary :unread) (jabber-message-reply--thread-fields root)))) (defun jabber-test-history-cost--analyzed-p () "Return non-nil when thread metadata has persisted SQLite statistics." (let ((db jabber-db--connection)) (and (sqlite-select db "SELECT 1 FROM sqlite_master WHERE name = 'sqlite_stat1'") (sqlite-select db "SELECT 1 FROM sqlite_stat1 WHERE tbl = 'message_thread'") t))) (ert-deftest jabber-test-history-cost-summaries-shared-root-selection () "Shared-root summaries follow the metadata read fresh and after ANALYZE." (jabber-test-history-cost--with-db (let ((root (jabber-test-history-cost--insert :id 1 :body "root" :timestamp 1 :stanza-id "s")) (claimants '("z" "a" "m")) (expected '(("z" "Z topic" 0 nil) ("a" "A topic" 1 nil) ("m" "M topic" 2 t)))) ;; Insertion order differs from key order; each claimant is distinct. (jabber-db-register-message-thread "me@x" "peer@x" "chat" "z" nil "s" nil 1) (jabber-db-register-message-thread "me@x" "peer@x" "chat" "a" nil "s" nil 1 root) (jabber-db-register-message-thread "me@x" "peer@x" "chat" "m" nil "s" nil 1) (dolist (thread expected) (jabber-db-set-message-thread-title "me@x" "peer@x" "chat" (car thread) (cadr thread))) (jabber-test-history-cost--insert :id 2 :body "a1" :timestamp 2 :thread-id "a" :stanza-id "a1") (jabber-db-mark-message-thread-read "me@x" "peer@x" "chat" "a") (jabber-test-history-cost--insert :id 3 :body "m1" :timestamp 3 :thread-id "m" :stanza-id "m1") (jabber-test-history-cost--insert :id 4 :body "m2" :timestamp 4 :thread-id "m" :stanza-id "m2") (dolist (state '(fresh analyzed reopened)) (pcase state ('analyzed (sqlite-execute jabber-db--connection "ANALYZE")) ('reopened (jabber-db-close) (jabber-db-ensure-open))) (should (eq (not (eq state 'fresh)) (jabber-test-history-cost--analyzed-p))) (let ((winner (jabber-test-history-cost--last-claimant claimants))) (should (equal (list state (append (assoc winner expected) (list (list :thread-id winner :thread-parent-id nil)))) (list state (jabber-test-history-cost--shared-root-view))))))))) (provide 'jabber-test-history-cost) ;;; jabber-test-history-cost.el ends here emacs-jabber-0.15.1/tests/jabber-test-httpupload.el000066400000000000000000000746411527111033600221740ustar00rootroot00000000000000;;; 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 &optional _inhibit-buffer-hooks) 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 &optional _force) (funcall callback jc closure nil))) ((symbol-function 'message) #'ignore)) (should-error (jabber-httpupload--discover-and-upload 'jc #'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 &optional _force) (funcall callback jc closure items))) ((symbol-function 'jabber-disco-get-info) (lambda (jc jid _node callback closure &optional _force) (funcall callback jc closure (list nil (list (format "feature:%s" jid)))))) ((symbol-function 'message) #'ignore)) (should-error (jabber-httpupload--discover-and-upload 'jc #'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 &optional _force) (funcall callback jc closure items))) ((symbol-function 'jabber-disco-get-info) (lambda (jc _jid _node callback closure &optional _force) (funcall callback jc closure (list nil (list jabber-httpupload-xmlns) (list (jabber-test-httpupload--max-size-form "4096")))))) ((symbol-function 'message) #'ignore)) (jabber-httpupload--discover-and-upload 'jc (lambda () (setq uploaded t))) (should (equal jabber-httpupload-support '((jc . "upload.example.net")))) (should (equal jabber-httpupload-max-file-size '((jc . 4096)))) (should uploaded)))) (ert-deftest jabber-test-httpupload-selected-service-keeps-limit () "Later discovery must not attach another service's limit to the first." (let ((jabber-httpupload-support nil) (jabber-httpupload-max-file-size nil)) (cl-labels ((info (limit) `(nil (,jabber-httpupload-xmlns) ((x () (field ((var . "FORM_TYPE")) (value () ,jabber-httpupload-xmlns)) (field ((var . "max-file-size")) (value () ,limit))))))) (jabber-httpupload--record-support 'jc "first.example" (info "100")) (jabber-httpupload--record-support 'jc "second.example" (info "900")) (should (equal (cdr (assq 'jc jabber-httpupload-support)) "first.example")) (should (= (cdr (assq 'jc jabber-httpupload-max-file-size)) 100)) (jabber-httpupload--record-support 'jc "second.example" '(nil nil nil)) (should (= (cdr (assq 'jc jabber-httpupload-max-file-size)) 100)) (jabber-httpupload--record-support 'jc "first.example" (info "200")) (should (= (cdr (assq 'jc jabber-httpupload-max-file-size)) 200)) (jabber-httpupload--record-support 'jc "first.example" '(nil nil nil)) (should-not (assq 'jc jabber-httpupload-max-file-size))))) ;;; Native discovery, service limits and disconnection (defun jabber-test-httpupload--native-connection (name) ;; Install the native FSM's established-state data without authenticating. (let ((jc (make-symbol name))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data (list :username name :server "example.invalid" :resource "probe" :ever-session-established t)) (put jc :deferred nil) (push jc jabber-connections) jc)) (defmacro jabber-test-httpupload--native-isolated (&rest body) (declare (indent 0) (debug t)) `(let ((jabber-db-path nil) (jabber-httpupload-support nil) (jabber-httpupload--discoveries nil) (jabber-disco-items-cache (make-hash-table :test #'equal)) (jabber-httpupload-max-file-size nil) (jabber-disco-info-cache (make-hash-table :test #'equal)) (jabber-open-info-queries nil) (jabber-httpupload-pre-upload-transform nil) (jabber-auto-reconnect nil) (jabber-jid-obarray (make-vector 31 0)) (jabber-roster-list nil) (jabber-connections nil) (kill-ring nil) (interprogram-cut-function nil) (jabber-test-httpupload-native-wire nil) (jabber-httpupload-upload-function (lambda (&rest _args) (error "Unexpected HTTP upload")))) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (jc xml &rest _args) (push (cons jc xml) jabber-test-httpupload-native-wire))) ((symbol-function 'jabber-send-string) (lambda (&rest _args) t)) ((symbol-function 'make-network-process) (lambda (&rest _args) (error "Network forbidden"))) ((symbol-function 'open-network-stream) (lambda (&rest _args) (error "Network forbidden"))) ((symbol-function 'url-retrieve) (lambda (&rest _args) (error "HTTP forbidden"))) ((symbol-function 'start-process) (lambda (&rest _args) (error "External process forbidden")))) ,@body))) (defun jabber-test-httpupload--native-xml (text) (with-temp-buffer (insert text) (car (xml-parse-region (point-min) (point-max))))) (defun jabber-test-httpupload--native-reply (jc request payload) (jabber-process-iq jc (jabber-test-httpupload--native-xml (format "%s" (jabber-xml-get-attribute request 'to) (jabber-xml-get-attribute request 'id) payload)))) (defun jabber-test-httpupload--native-discover (jc service limit) ;; No direct calls to record-support or max-size parser: get-info sends a ;; real IQ; native IQ dispatch and native disco parser consume wire XML. (remhash (jabber-disco--cache-key jc service nil) jabber-disco-info-cache) (let (wire) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (owner xml &rest _args) (should (eq owner jc)) (push xml wire)))) (jabber-httpupload-test-item-support jc service)) (should (= (length wire) 1)) (should (equal (jabber-xml-get-attribute (car wire) 'to) service)) (jabber-test-httpupload--native-reply jc (car wire) (concat "" "" "" (if limit (format (concat "" "" "urn:xmpp:http:upload:0" "%d") limit) "") "")) (should-not jabber-open-info-queries))) (defun jabber-test-httpupload--native-tuple (jc) (list (cdr (assq jc jabber-httpupload-support)) (cdr (assq jc jabber-httpupload-max-file-size)))) (defun jabber-test-httpupload--native-upload-at-size (jc service limit size) ;; Exercise the PUBLIC command, real validation, native slot IQ creation, ;; native result dispatch/slot parsing and terminal callback. HTTP alone ;; is intercepted (file bytes/headers/URL are inspected, never transmitted). (let ((file (make-temp-file "jabber-test-httpupload-native-file-" nil ".bin")) wire puts) (unwind-protect (progn (with-temp-file file (insert (make-string size ?x))) (let ((jabber-httpupload-upload-function (lambda (path headers put-url callback callback-arg &rest _) (push (list path headers put-url) puts) (should (= (file-attribute-size (file-attributes path)) size)) (should (= (cdr (assoc "content-length" headers)) size)) (should (equal put-url (concat "https://" service "/put"))) (funcall callback callback-arg) t))) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (owner xml &rest _) (should (eq owner jc)) (push xml wire)))) (if (and limit (> size limit)) (progn (should-error (jabber-httpupload-upload-file jc file) :type 'user-error) (should-not wire) (should-not puts)) (jabber-httpupload-upload-file jc file) (should (= (length wire) 1)) (let* ((iq (car wire)) (request (car (jabber-xml-get-children iq 'request)))) (should (equal (jabber-xml-get-attribute iq 'to) service)) (should (equal (jabber-xml-get-attribute request 'xmlns) jabber-httpupload-xmlns)) (should (= (jabber-xml-get-attribute request 'size) size)) (jabber-test-httpupload--native-reply jc iq (format (concat "" "" "") service service))) (should (= (length puts) 1)) (should (equal (car kill-ring) (concat "https://" service "/get"))) (should-not jabber-open-info-queries))))) (delete-file file)))) (defun jabber-test-httpupload--native-matrix (a b reverse-order) (jabber-test-httpupload--native-isolated (let* ((jc (jabber-test-httpupload--native-connection "matrix")) (items (list (cons "a.example.invalid" a) (cons "b.example.invalid" b))) (order (if reverse-order (reverse items) items)) (service (caar order)) (limit (cdar order))) (dolist (entry order) (jabber-test-httpupload--native-discover jc (car entry) (cdr entry))) (should (equal (jabber-test-httpupload--native-tuple jc) (list service limit))) (dolist (size '(50 100 101 500 900 901 1000)) (jabber-test-httpupload--native-upload-at-size jc service limit size))))) (dolist (a '(100 900 nil)) (dolist (b '(100 900 nil)) (dolist (reverse-order '(nil t)) (eval `(ert-deftest ,(intern (format "jabber-test-httpupload-native-matrix-a%s-b%s-%s" a b (if reverse-order "BA" "AB"))) () (jabber-test-httpupload--native-matrix ,a ,b ,reverse-order)) t)))) (dolist (service '("a.example.invalid" "b.example.invalid")) (eval `(ert-deftest ,(intern (format "jabber-test-httpupload-native-refresh-%s" service)) () (jabber-test-httpupload--native-isolated (let ((jc (jabber-test-httpupload--native-connection "refresh"))) (dolist (limit '(100 900 nil 50)) (jabber-test-httpupload--native-discover jc ,service limit) (should (equal (jabber-test-httpupload--native-tuple jc) (list ,service limit))) (jabber-test-httpupload--native-upload-at-size jc ,service limit 500))))) t)) (defun jabber-test-httpupload--native-disconnect (mode) (jabber-test-httpupload--native-isolated (let* ((a (jabber-test-httpupload--native-connection "account-a")) (b (jabber-test-httpupload--native-connection "account-b")) (jabber-connections (list a b)) (resets nil) (jabber-lifecycle-session-reset-functions (cons (lambda (jc) (push jc resets)) jabber-lifecycle-session-reset-functions))) (jabber-test-httpupload--native-discover a "a.example.invalid" 100) (jabber-test-httpupload--native-discover b "b.example.invalid" 900) (pcase mode ('one (jabber-disconnect-one a) (jabber-disconnect-one a)) ('all (jabber-disconnect) (jabber-disconnect)) ('loss (fsm-send-sync a '(:connection-dead nil "fixture transport loss")))) ;; Validate native terminal transition before diagnosing upload cleanup. (should-not (memq a jabber-connections)) (should (null (get a :state))) (should (plist-get (fsm-get-state-data a) :terminalized)) (should (= (cl-count a resets) 1)) (if (eq mode 'all) (progn (should-not jabber-connections) (should (= (cl-count b resets) 1))) (should (memq b jabber-connections)) (should (equal (jabber-test-httpupload--native-tuple b) '("b.example.invalid" 900)))) (should-not (assq a jabber-httpupload-support)) (should-not (assq a jabber-httpupload-max-file-size)) (when (eq mode 'all) (should-not jabber-httpupload-support) (should-not jabber-httpupload-max-file-size))))) (ert-deftest jabber-test-httpupload-native-disconnect-one () (jabber-test-httpupload--native-disconnect 'one)) (ert-deftest jabber-test-httpupload-native-disconnect-all () (jabber-test-httpupload--native-disconnect 'all)) (ert-deftest jabber-test-httpupload-native-disconnect-loss () (jabber-test-httpupload--native-disconnect 'loss)) ;;; Retired continuations and sibling responses (defconst jabber-test-httpupload--native-items "") (defconst jabber-test-httpupload--native-info "") (ert-deftest jabber-test-httpupload-native-sibling-settlement () "Success, errors and quits all retire duplicate and sibling discovery IQs." (dolist (failure '(nil error quit)) (jabber-test-httpupload--native-isolated (let ((jc (jabber-test-httpupload--native-connection "siblings")) (calls 0)) ;; An unrelated consumer's opaque data must survive upload retirement. (jabber-send-iq jc "other.example.invalid" "get" '(query ()) #'ignore 'opaque #'ignore 'opaque) (let ((unrelated (car jabber-open-info-queries))) (jabber-httpupload--discover-and-upload jc (lambda () (cl-incf calls) (should (= (length jabber-open-info-queries) 1)) (when failure (signal failure '("Originating failure"))))) (let ((items (cdar jabber-test-httpupload-native-wire))) (jabber-test-httpupload--native-reply jc items jabber-test-httpupload--native-items) (let ((infos (mapcar #'cdr (cl-subseq jabber-test-httpupload-native-wire 0 2))) (callbacks (cl-subseq jabber-open-info-queries 0 2)) caught) (condition-case err (jabber-test-httpupload--native-reply jc (car infos) jabber-test-httpupload--native-info) ((error quit) (setq caught err))) (should (equal caught (and failure (list failure "Originating failure")))) (should (= calls 1)) (should (equal jabber-open-info-queries (list unrelated))) (should-not jabber-httpupload--discoveries) (jabber-test-httpupload--native-reply jc items jabber-test-httpupload--native-items) (dolist (info infos) (jabber-test-httpupload--native-reply jc info jabber-test-httpupload--native-info)) ;; Even already-captured callbacks cannot resurrect an operation. (dolist (entry callbacks) (let ((data (cdr (nth 1 entry)))) (funcall (car data) jc (cdr data) (list nil (list jabber-httpupload-xmlns))))) (should (= calls 1)) (should (equal jabber-open-info-queries (list unrelated)))))))))) (ert-deftest jabber-test-httpupload-native-reset-retires-discovery () "Reset fences items, info and background discovery but preserves other accounts." (dolist (phase '(items info background)) (jabber-test-httpupload--native-isolated (let* ((a (jabber-test-httpupload--native-connection "retired")) (b (jabber-test-httpupload--native-connection "live")) (jabber-connections (list a b)) (file (make-temp-file "jabber-upload-reset-" nil nil "draft"))) (unwind-protect (progn (jabber-httpupload-test-item-support b "live.example.invalid") (let ((b-query (car jabber-open-info-queries)) (b-wire (cdar jabber-test-httpupload-native-wire))) (if (eq phase 'background) (jabber-httpupload-test-connection-support a) (jabber-httpupload-upload-file a file)) (unless (eq phase 'items) (jabber-test-httpupload--native-reply a (cdar jabber-test-httpupload-native-wire) jabber-test-httpupload--native-items)) (let ((old-wire (mapcar #'cdr (cl-remove-if-not (lambda (entry) (eq (car entry) a)) jabber-test-httpupload-native-wire))) (old-queries (delq b-query (copy-sequence jabber-open-info-queries)))) (jabber-disconnect-one a) (jabber-disconnect-one a) (should (equal jabber-open-info-queries (list b-query))) (should (= (length jabber-httpupload--discoveries) 1)) (dolist (stanza old-wire) (jabber-test-httpupload--native-reply a stanza (if (equal (jabber-xml-get-attribute (jabber-iq-query stanza) 'xmlns) jabber-disco-xmlns-items) jabber-test-httpupload--native-items jabber-test-httpupload--native-info))) (dolist (entry old-queries) (let ((data (cdr (nth 1 entry)))) (funcall (car data) a (cdr data) (list nil (list jabber-httpupload-xmlns))))) (should-not (assq a jabber-httpupload-support)) (should-not (assq a jabber-httpupload-max-file-size)) (should-not kill-ring) (should-not (cl-find-if (lambda (entry) (eq (car (jabber-iq-query (cdr entry))) 'request)) jabber-test-httpupload-native-wire)) ;; The other account's outstanding response remains usable. (jabber-test-httpupload--native-reply b b-wire jabber-test-httpupload--native-info) (should (equal (jabber-test-httpupload--native-tuple b) '("live.example.invalid" nil))) ;; Fresh logical-session discovery can choose a new tuple. (put a :state :session-established) (put a :state-data (list :server "example.invalid")) (push a jabber-connections) (jabber-test-httpupload--native-discover a "new.example.invalid" 900) (should (equal (jabber-test-httpupload--native-tuple a) '("new.example.invalid" 900))) (should-not jabber-open-info-queries) (should-not jabber-httpupload--discoveries)))) (delete-file file)))))) (provide 'jabber-test-httpupload) ;;; jabber-test-httpupload.el ends here emacs-jabber-0.15.1/tests/jabber-test-image.el000066400000000000000000000104431527111033600210600ustar00rootroot00000000000000;;; 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.15.1/tests/jabber-test-keepalive.el000066400000000000000000000604461527111033600217530ustar00rootroot00000000000000;;; jabber-test-keepalive.el --- Tests for jabber-keepalive -*- lexical-binding: t; -*- ;;; Commentary: ;; Keepalive timer lifecycle. ;;; Code: (require 'cl-lib) (require 'ert) (require 'jabber-keepalive) (defvar system-sleep-event-functions) (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-system-sleep-pre-sleep-is-inert () "A pre-sleep event does not mutate transport or keepalive state." (let* ((entry '(connection . transport)) (timeout '(mock-timer timeout)) (jabber-connections '(connection)) (jabber-keepalive-round 4) (jabber-keepalive-pending (list entry)) (jabber-keepalive-timeout-timer timeout) cancelled sent result) (cl-letf (((symbol-function 'sleep-event-state) (lambda (_) 'pre-sleep)) ((symbol-function 'cancel-timer) (lambda (&rest _) (setq cancelled t))) ((symbol-function 'fsm-send-sync) (lambda (&rest args) (setq sent args)))) (setq result (condition-case nil (progn (jabber-keepalive--system-sleep-event 'event) 'ok) (void-function 'missing)))) (should (eq result 'ok)) (should (= jabber-keepalive-round 4)) (should (equal jabber-keepalive-pending (list entry))) (should (eq jabber-keepalive-timeout-timer timeout)) (should-not cancelled) (should-not sent))) (ert-deftest jabber-test-system-sleep-post-wake-invalidates-snapshot () "Post-wake retires one round and contains stale per-peer failures." (let* ((first (make-symbol "first")) (second (make-symbol "second")) (connecting (make-symbol "connecting")) (first-transport (make-symbol "first-transport")) (second-transport (make-symbol "second-transport")) (successor (make-symbol "successor")) (timeout '(mock-timer timeout)) (recurring '(mock-timer recurring)) (jabber-connections (list first second connecting)) (jabber-keepalive-timer recurring) (jabber-keepalive-timeout-timer timeout) (jabber-keepalive-pending '((old . transport))) (jabber-keepalive-round 9) cancelled events second-result result) (put first :state :session-established) (put first :state-data (list :connection first-transport)) (put second :state :session-established) (put second :state-data (list :connection second-transport)) (put connecting :state :connecting) (put connecting :state-data '(:connection nil)) (cl-letf (((symbol-function 'sleep-event-state) (lambda (_) 'post-wake)) ((symbol-function 'timerp) #'jabber-test-keepalive--mock-timer-p) ((symbol-function 'cancel-timer) (lambda (timer) (push timer cancelled))) ((symbol-function 'fsm-send-sync) (lambda (jc event) (push (cons jc event) events) (if (eq jc first) (progn (put second :state-data (list :connection successor)) (error "first failed")) (setq second-result (funcall (gethash :session-established (get 'jabber-connection :fsm-event)) jc (fsm-get-state-data jc) event #'ignore)))))) (setq result (condition-case nil (progn (jabber-keepalive--system-sleep-event 'event) 'ok) (void-function 'missing)))) (setq events (nreverse events)) (should (eq result 'ok)) (should (= jabber-keepalive-round 10)) (should-not jabber-keepalive-pending) (should-not jabber-keepalive-timeout-timer) (should (eq jabber-keepalive-timer recurring)) (should (equal cancelled (list timeout))) (should (equal (mapcar #'car events) (list first second))) (should (equal (cdr (assq first events)) (list :connection-dead first-transport "System wake"))) (should (equal (cdr (assq second events)) (list :connection-dead second-transport "System wake"))) (should (eq (car second-result) :session-established)) (should (eq (plist-get (cadr second-result) :connection) successor)))) (ert-deftest jabber-test-system-sleep-handler-contains-event-errors () "A malformed sleep event cannot stop the abnormal hook chain." (let (result) (cl-letf (((symbol-function 'sleep-event-state) (lambda (_) (error "bad event")))) (setq result (condition-case nil (progn (jabber-keepalive--system-sleep-event 'event) 'ok) (error 'escaped)))) (should (eq result 'ok)))) (ert-deftest jabber-test-system-sleep-registration-is-optional () "Sleep support registers idempotently and absence remains inert." (let ((was-loaded (featurep 'system-sleep)) (hooks-bound (boundp 'system-sleep-event-functions)) (saved-hooks (and (boundp 'system-sleep-event-functions) (symbol-value 'system-sleep-event-functions))) (enabled 0)) (set 'system-sleep-event-functions nil) (unless was-loaded (provide 'system-sleep)) (unwind-protect (progn (cl-letf (((symbol-function 'system-sleep-enable) (lambda () (cl-incf enabled)))) (jabber-keepalive--enable-system-sleep nil) (jabber-keepalive--enable-system-sleep nil)) (should (= enabled 2)) (should (equal (symbol-value 'system-sleep-event-functions) '(jabber-keepalive--system-sleep-event)))) (unless was-loaded (setq features (delq 'system-sleep features))) (if hooks-bound (set 'system-sleep-event-functions saved-hooks) (makunbound 'system-sleep-event-functions)))) (let ((was-loaded (featurep 'system-sleep)) (hooks-bound (boundp 'system-sleep-event-functions)) (saved-hooks (and (boundp 'system-sleep-event-functions) (symbol-value 'system-sleep-event-functions))) (load-path nil) called) (set 'system-sleep-event-functions '(existing)) (unwind-protect (progn (setq features (delq 'system-sleep features)) (cl-letf (((symbol-function 'system-sleep-enable) (lambda () (setq called t)))) (jabber-keepalive--enable-system-sleep nil)) (should (equal (symbol-value 'system-sleep-event-functions) '(existing))) (should-not called)) (when was-loaded (provide 'system-sleep)) (if hooks-bound (set 'system-sleep-event-functions saved-hooks) (makunbound 'system-sleep-event-functions))))) (ert-deftest jabber-test-system-sleep-registration-is-automatic () "Session bootstrap owns sleep-event registration." (should (memq #'jabber-keepalive--enable-system-sleep jabber-lifecycle-session-bootstrap-functions))) (ert-deftest jabber-test-keepalive-monitors-only-active-transports () "A keepalive round snapshots only established exact transports." (let* ((active (make-symbol "active")) (reconnecting (make-symbol "reconnecting")) (transport (make-symbol "transport")) (jabber-connections (list reconnecting active)) (jabber-keepalive-timeout-timer nil) (jabber-keepalive-pending nil) (jabber-keepalive-round 0) pings) (put active :state :session-established) (put active :state-data (list :connection transport)) (put reconnecting :state :connecting) (put reconnecting :state-data '(:connection nil)) (cl-letf (((symbol-function 'run-with-timer) (lambda (&rest _) '(mock-timer timeout))) ((symbol-function 'timerp) #'jabber-test-keepalive--mock-timer-p) ((symbol-function 'jabber-ping-send) (lambda (jc &rest args) (push (cons jc args) pings)))) (jabber-keepalive-do)) (should (equal (mapcar #'car pings) (list active))) (should (equal jabber-keepalive-pending (list (cons active transport)))))) (ert-deftest jabber-test-keepalive-timeout-reconnects-current-transport () "A current keepalive timeout remains an unexpected reconnectable loss." (let* ((jc (make-symbol "keepalive-timeout")) (transport (make-symbol "transport")) (jabber-connections (list jc)) (jabber-auto-reconnect t) (jabber-reconnect-delay 5) (jabber-lost-connection-hooks nil) (jabber-lifecycle-session-reset-functions nil) (jabber-keepalive-round 7) (jabber-keepalive-timeout-timer nil) (jabber-keepalive-pending (list (cons jc transport)))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data (list :username "romeo" :server "example.org" :resource "emacs" :connection transport :ever-session-established t)) (put jc :deferred nil) (jabber-keepalive-timeout 7) (unwind-protect (progn (should-not (get jc :state)) (should-not (plist-get (fsm-get-state-data jc) :disconnection-expected)) (should (timerp (get jc :timeout))) (should (memq jc jabber-connections))) (when (timerp (get jc :timeout)) (cancel-timer (get jc :timeout)))))) (ert-deftest jabber-test-keepalive-stale-timeout-ignores-successor () "A prior round and transport cannot retire a successor connection." (let* ((jc (make-symbol "keepalive-successor")) (old-transport (make-symbol "old-transport")) (new-transport (make-symbol "new-transport")) (jabber-connections (list jc)) (jabber-keepalive-round 8) (jabber-keepalive-timeout-timer '(mock-timer timeout)) (jabber-keepalive-pending (list (cons jc old-transport))) sent) (put jc :state :session-established) (put jc :state-data (list :connection new-transport)) (cl-letf (((symbol-function 'fsm-send-sync) (lambda (&rest args) (setq sent args))) ((symbol-function 'timerp) #'jabber-test-keepalive--mock-timer-p) ((symbol-function 'cancel-timer) #'ignore)) (jabber-keepalive-timeout 7)) (should-not sent) (should (eq (plist-get (fsm-get-state-data jc) :connection) new-transport)))) (ert-deftest jabber-test-keepalive-stale-response-does-not-settle-round () "Responses from old rounds or transports do not settle the current round." (let* ((jc (make-symbol "keepalive-current")) (old-transport (make-symbol "old-transport")) (transport (make-symbol "transport")) (entry (cons jc transport)) (jabber-keepalive-round 8) (jabber-keepalive-pending (list entry)) (jabber-keepalive-timeout-timer '(mock-timer timeout)) cancelled) (put jc :state-data '(:server "example.org")) (cl-letf (((symbol-function 'timerp) #'jabber-test-keepalive--mock-timer-p) ((symbol-function 'cancel-timer) (lambda (&rest _) (setq cancelled t)))) (jabber-keepalive-got-response jc nil (cons 7 transport)) (jabber-keepalive-got-response jc nil (cons 8 old-transport))) (should (equal jabber-keepalive-pending (list entry))) (should-not cancelled))) (ert-deftest jabber-test-keepalive-send-failure-isolated-per-transport () "A synchronous ping failure retires only its exact transport." (let* ((failed (make-symbol "failed")) (healthy (make-symbol "healthy")) (failed-transport (make-symbol "failed-transport")) (healthy-transport (make-symbol "healthy-transport")) (jabber-connections (list failed healthy)) (jabber-keepalive-timeout-timer nil) (jabber-keepalive-pending nil) (jabber-keepalive-round 0) pings losses) (dolist (jc jabber-connections) (put jc :state :session-established)) (put failed :state-data (list :connection failed-transport)) (put healthy :state-data (list :connection healthy-transport)) (cl-letf (((symbol-function 'run-with-timer) (lambda (&rest _) '(mock-timer timeout))) ((symbol-function 'timerp) #'jabber-test-keepalive--mock-timer-p) ((symbol-function 'jabber-ping-send) (lambda (jc &rest _) (if (eq jc failed) (error "send failed") (push jc pings)))) ((symbol-function 'fsm-send) (lambda (jc event) (push (cons jc event) losses)))) (jabber-keepalive-do)) (should (equal pings (list healthy))) (should (equal jabber-keepalive-pending (list (cons healthy healthy-transport)))) (should (equal losses (list (cons failed (list :connection-dead failed-transport "Keepalive send failed"))))) (should (equal jabber-keepalive-timeout-timer '(mock-timer timeout))))) (ert-deftest jabber-test-keepalive-normal-round-uses-ping-contract () "A normal round calls the five-argument ping API without reporting loss." (let* ((jc (make-symbol "active")) (transport (make-symbol "transport")) (jabber-connections (list jc)) (jabber-keepalive-timeout-timer nil) (jabber-keepalive-pending nil) (jabber-keepalive-round 0) call loss) (put jc :state :session-established) (put jc :state-data (list :connection transport)) (cl-letf (((symbol-function 'run-with-timer) (lambda (&rest _) '(mock-timer timeout))) ((symbol-function 'timerp) #'jabber-test-keepalive--mock-timer-p) ((symbol-function 'jabber-ping-send) (lambda (connection to callback success-data error-data) (setq call (list connection to callback success-data error-data)))) ((symbol-function 'fsm-send) (lambda (&rest args) (setq loss args)))) (jabber-keepalive-do)) (should (equal call (list jc nil #'jabber-keepalive-got-response (cons jabber-keepalive-round transport) (cons jabber-keepalive-round transport)))) (should (equal jabber-keepalive-pending (list (cons jc transport)))) (should-not loss))) (ert-deftest jabber-test-whitespace-failure-carries-exact-transport () "Whitespace send failure reports the exact transport that failed." (let* ((jc (make-symbol "whitespace-failure")) (transport (make-symbol "transport")) (jabber-connections (list jc)) sent) (put jc :state :session-established) (put jc :state-data (list :connection transport)) (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) ((symbol-function 'jabber-send-string) (lambda (&rest _) (error "send failed"))) ((symbol-function 'fsm-send) (lambda (_jc event) (setq sent event)))) (jabber-whitespace-ping-do)) (should (equal sent (list :connection-dead transport "Whitespace ping failed"))))) (ert-deftest jabber-test-whitespace-ping-skips-negotiating-streams () "Whitespace pings reach only established sessions. A space sent while SASL restarts the stream precedes the restarted stream's XML declaration, which the server rejects as not well-formed." (let* ((established (make-symbol "established")) (negotiating (make-symbol "negotiating")) (jabber-connections (list established negotiating)) sent) (put established :state :session-established) (put established :state-data (list :connection 'established-transport)) (put negotiating :state :sasl-auth) (put negotiating :state-data (list :connection 'negotiating-transport)) (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) ((symbol-function 'jabber-send-string) (lambda (jc string) (push (cons jc string) sent))) ((symbol-function 'fsm-send) (lambda (&rest args) (error "Unexpected fsm-send %S" args)))) (jabber-whitespace-ping-do)) (should (equal sent (list (cons established " ")))))) (ert-deftest jabber-test-keepalive-do-replaces-timeout-timer () "Rearming keepalive cancels the previous timeout timer." (let* ((first (make-symbol "first")) (second (make-symbol "second")) (jabber-connections (list first second)) (jabber-keepalive-timeout-timer nil) (jabber-keepalive-pending nil) (live-timers nil) (cancelled-timers nil) (next-timer-id 0)) (dolist (jc jabber-connections) (put jc :state :session-established) (put jc :state-data (list :connection jc))) (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 (make-symbol "survivor")) (lost (make-symbol "lost")) (survivor-transport (make-symbol "survivor-transport")) (lost-transport (make-symbol "lost-transport")) (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) (jabber-keepalive-round 0) (live-timers (list recurring-timer)) (cancelled-timers nil) (losses nil) (pings nil) (next-timer-id 0)) (put survivor :state :session-established) (put survivor :state-data (list :server "survivor" :connection survivor-transport)) (put lost :state :session-established) (put lost :state-data (list :server "lost" :connection lost-transport)) (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-send-sync) (lambda (jc event) (push (cons jc event) losses) (setq jabber-connections (delq jc jabber-connections))))) (jabber-keepalive-do) (jabber-keepalive-got-response survivor nil (cons jabber-keepalive-round survivor-transport)) (setq pings nil) (jabber-keepalive-timeout jabber-keepalive-round) (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 losses (list (cons lost (list :connection-dead lost-transport "Keepalive timeout"))))) (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 (make-symbol "lost")) (transport (make-symbol "transport")) (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 (cons lost transport))) (jabber-keepalive-round 3) (cancelled-timers nil) loss) (put lost :state-data (list :server "lost" :connection transport)) (cl-letf (((symbol-function 'cancel-timer) (lambda (timer) (push timer cancelled-timers))) ((symbol-function 'fsm-send-sync) (lambda (jc event) (setq loss (cons jc event)) (setq jabber-connections (delq jc jabber-connections))))) (jabber-keepalive-timeout 3) (should (null jabber-connections)) (should (null jabber-keepalive-timer)) (should (null jabber-keepalive-timeout-timer)) (should (null jabber-keepalive-pending)) (should (equal loss (cons lost (list :connection-dead transport "Keepalive timeout")))) (should (equal cancelled-timers (list recurring-timer)))))) (ert-deftest jabber-test-keepalive-default-session-hooks () "Default fresh and resumed sessions enable response-checked liveness." (dolist (hook '(jabber-post-connect-hooks jabber-post-resume-hooks)) (should (memq #'jabber-keepalive-start (default-value hook))))) (provide 'jabber-test-keepalive) ;;; jabber-test-keepalive.el ends here emacs-jabber-0.15.1/tests/jabber-test-link-preview.el000066400000000000000000000444771527111033600224300ustar00rootroot00000000000000;;; jabber-test-link-preview.el --- Tests for link previews -*- lexical-binding: t; -*- ;;; Commentary: ;;; Code: (require 'ert) (require 'cl-lib) (require 'jabber-chat) (require 'jabber-link-preview) (defconst jabber-test-link-preview--html " Ignored title ") (ert-deftest jabber-test-link-preview-youtube-oembed-metadata () (let* ((url "https://www.youtube.com/watch?v=NYFGCESmikA") (endpoint (jabber-link-preview--youtube-oembed-url url)) (json "{\"title\":\"Video title\",\"author_name\":\"Author\",\"provider_name\":\"YouTube\",\"thumbnail_url\":\"https://i.ytimg.com/vi/x/hqdefault.jpg\"}")) (should (string-prefix-p "https://www.youtube.com/oembed?url=" endpoint)) (should (equal (jabber-link-preview--parse-youtube-json json url) '(:url "https://www.youtube.com/watch?v=NYFGCESmikA" :site "YouTube" :title "Video title" :description "Author" :image "https://i.ytimg.com/vi/x/hqdefault.jpg"))))) (ert-deftest jabber-test-link-preview-parses-open-graph () (should (equal (jabber-link-preview-parse-html jabber-test-link-preview--html "https://example.org/news/item") '(:url "https://example.org/news/item" :site "Example" :title "A useful page" :description "A short description." :image "https://example.org/card.png" :image-alt "Card alt text")))) (ert-deftest jabber-test-link-preview-falls-back-to-html-title () (let ((html " Plain title ")) (should (equal (jabber-link-preview-parse-html html "https://example.org/a") '(:url "https://example.org/a" :site "example.org" :title "Plain title" :description "Plain description"))))) (ert-deftest jabber-test-link-preview-selects-first-page-url () (should (equal (jabber-link-preview-url "photo https://example.org/pic.png then https://example.org/page?q=1") "https://example.org/page?q=1"))) (ert-deftest jabber-test-link-preview-skips-images-without-revisiting () "URL parsing must advance even when validation changes match data." (dolist (suffix '("" " then https://example.org/page")) (let ((validate (symbol-function 'jabber-link-preview-safe-url-p)) (calls 0)) (cl-letf (((symbol-function 'jabber-link-preview-safe-url-p) (lambda (url &optional resolve) ;; Bound a broken scan without hanging the test runner. (should (<= (cl-incf calls) 2)) (funcall validate url resolve)))) (should (equal (jabber-link-preview-url (concat "look at this https://www.example.org/foo.webp" suffix)) (unless (string-empty-p suffix) "https://example.org/page"))))))) (ert-deftest jabber-test-link-preview-rejects-http-and-local-hosts () (should-not (jabber-link-preview-url "http://example.org/page")) (should-not (jabber-link-preview-url "https://localhost/private")) (should-not (jabber-link-preview-url "https://127.0.0.1/private"))) (ert-deftest jabber-test-link-preview-card-uses-shadow-throughout () (let ((card (jabber-link-preview-format '(:url "https://example.org/a" :site "Example" :title "Title" :description "Summary")))) (should (equal (substring-no-properties card) "\n│ Example\n│ Title\n│ Summary")) (cl-loop for position from 1 below (length card) do (should (eq (get-text-property position 'face card) 'shadow))) (should (equal (get-text-property 2 'jabber-chat-link-preview-url card) "https://example.org/a")))) (ert-deftest jabber-test-chat-marks-only-first-preview-url () (with-temp-buffer (insert "See https://example.org/one and https://example.org/two") (let ((jabber-chat--body-start (point-min))) (jabber-chat-mark-link-preview-url '(:body "See https://example.org/one and https://example.org/two") :foreign :insert)) (goto-char (point-min)) (search-forward "https://example.org/one") (should (equal (get-text-property (1- (point)) 'jabber-chat-link-preview-url) "https://example.org/one")) (search-forward "https://example.org/two") (should-not (get-text-property (1- (point)) 'jabber-chat-link-preview-url)))) (ert-deftest jabber-test-chat-preview-keymap-overrides-goto-address () (with-temp-buffer (insert "See https://example.org/one") (let ((jabber-chat--body-start (point-min))) (jabber-chat-goto-address nil nil :insert) (jabber-chat-mark-link-preview-url '(:body "See https://example.org/one") :foreign :insert)) (goto-char (point-min)) (search-forward "https://example.org/one") (backward-char) (should (eq (key-binding (kbd "RET")) #'jabber-chat-url-action-at-point)))) (ert-deftest jabber-test-link-preview-rejects-mixed-dns-answers () (cl-letf (((symbol-function 'network-lookup-address-info) (lambda (&rest _) '([93 184 216 34 0] [127 0 0 1 0])))) (should-not (jabber-link-preview-safe-url-p "https://example.org/a" t)))) (ert-deftest jabber-test-link-preview-rejects-ipv4-mapped-ipv6 () (should-not (jabber-link-preview--public-address-p [0 0 0 0 0 65535 32512 1 0])) (should-not (jabber-link-preview--public-address-p [0 0 0 0 0 65535 2560 1 0])) ;; This transport deliberately pins IPv4 only; mapped public IPv4 is ;; rejected rather than expanding the IPv6 trust boundary. (should-not (jabber-link-preview--public-address-p [0 0 0 0 0 65535 23994 55330 0]))) (ert-deftest jabber-test-link-preview-curl-pins-vetted-address () (let ((command (jabber-link-preview--curl-command "https://example.org/a" "93.184.216.34"))) (should (member "--noproxy" command)) (should (member "*" command)) (should (member "--resolve" command)) (should (member "example.org:443:93.184.216.34" command)) (should-not (member "--max-filesize" command)) (should-not (member "--location" command)))) (ert-deftest jabber-test-link-preview-parser-unavailable-is-an-error-result () (cl-letf (((symbol-function 'libxml-parse-html-region) nil)) (should (equal (jabber-link-preview--parse-result "Page" "https://example.org/") '(:error parser-unavailable))))) (ert-deftest jabber-test-link-preview-filter-aborts-oversize-response () (let* ((buffer (generate-new-buffer " *jabber-preview-filter-test*")) (process (make-process :name "jabber-preview-filter-test" :buffer buffer :command '("cat") :noquery t)) (jabber-link-preview-max-html-bytes 8)) (unwind-protect (progn (jabber-link-preview--process-filter process "HTTP/1.1 200 OK\r\n\r\n123456789") (should (process-get process 'jabber-link-preview-too-large)) (with-current-buffer buffer (should (<= (buffer-size) jabber-link-preview--response-overhead-bytes)))) (when (process-live-p process) (delete-process process)) (when (buffer-live-p buffer) (kill-buffer buffer))))) (ert-deftest jabber-test-link-preview-parses-bounded-prefix-of-large-page () (let* ((buffer (generate-new-buffer " *jabber-preview-prefix-test*")) (process (make-process :name "jabber-preview-prefix-test" :buffer buffer :command '("cat") :sentinel #'ignore :noquery t)) (jabber-link-preview-max-html-bytes 80)) (unwind-protect (progn (with-current-buffer buffer (set-buffer-multibyte nil)) (jabber-link-preview--process-filter process (concat "HTTP/1.1 200 OK\r\nContent-Type: text/html\r\n\r\n" "YouTube video" (make-string 80 ?x))) (should (equal (jabber-link-preview--buffer-result process "https://www.youtube.com/watch?v=test") '(:url "https://www.youtube.com/watch?v=test" :site "www.youtube.com" :title "YouTube video")))) (when (process-live-p process) (delete-process process)) (when (buffer-live-p buffer) (kill-buffer buffer))))) (ert-deftest jabber-test-link-preview-filter-bounds-terminated-huge-header () (let* ((buffer (generate-new-buffer " *jabber-preview-header-test*")) (process (make-process :name "jabber-preview-header-test" :buffer buffer :command '("cat") :sentinel #'ignore :noquery t)) (jabber-link-preview--response-overhead-bytes 32)) (unwind-protect (progn (jabber-link-preview--process-filter process (concat "HTTP/1.1 200 OK\r\nX-Fill: " (make-string 64 ?x) "\r\n\r\nbody")) (should (process-get process 'jabber-link-preview-too-large)) (with-current-buffer buffer (should (<= (buffer-size) jabber-link-preview--response-overhead-bytes)))) (when (process-live-p process) (delete-process process)) (when (buffer-live-p buffer) (kill-buffer buffer))))) (ert-deftest jabber-test-link-preview-filter-bounds-unterminated-header () (let* ((buffer (generate-new-buffer " *jabber-preview-open-header-test*")) (process (make-process :name "jabber-preview-open-header-test" :buffer buffer :command '("cat") :sentinel #'ignore :noquery t)) (jabber-link-preview--response-overhead-bytes 32)) (unwind-protect (progn (jabber-link-preview--process-filter process (concat "HTTP/1.1 200 OK\r\nX-Fill: " (make-string 64 ?x))) (should (process-get process 'jabber-link-preview-too-large)) (with-current-buffer buffer (should (<= (buffer-size) jabber-link-preview--response-overhead-bytes)))) (when (process-live-p process) (delete-process process)) (when (buffer-live-p buffer) (kill-buffer buffer))))) (ert-deftest jabber-test-link-preview-sentinel-kills-error-buffer () (let* ((buffer (generate-new-buffer " *jabber-preview-sentinel-test*")) (result nil) (process (make-process :name "jabber-preview-sentinel-test" :buffer buffer :command '("cat") :coding 'binary :noquery t :sentinel #'jabber-link-preview--process-sentinel))) (process-put process 'jabber-link-preview-callback (lambda (value) (setq result value))) (process-put process 'jabber-link-preview-cbargs nil) (process-put process 'jabber-link-preview-url "https://example.org/") (process-send-eof process) ;; Process status can change before its sentinel runs; wait for the ;; sentinel's callback rather than a fixed slice. (let ((deadline (+ (float-time) 30))) (while (and (null result) (< (float-time) deadline)) (accept-process-output nil 0.01))) (should (equal result '(:error response))) (should-not (buffer-live-p buffer)))) (ert-deftest jabber-test-chat-dead-buffer-completion-clears-loading-state () (let* ((url "https://example.org/a") (token (list 'loading (gensym))) (buffer (generate-new-buffer " *jabber-preview-dead-test*")) (result '(:url "https://example.org/a" :title "Page"))) (unwind-protect (progn (jabber-link-preview-put url token) (kill-buffer buffer) (jabber-chat--handle-link-preview result url token nil buffer) (should (equal (jabber-link-preview-get url) result))) (remhash url jabber-link-preview--cache) (when (buffer-live-p buffer) (kill-buffer buffer))))) (ert-deftest jabber-test-chat-stale-preview-completion-cannot-overwrite-newer () (let* ((url "https://example.org/a") (old-token (list 'loading 'old)) (new-token (list 'loading 'new))) (unwind-protect (progn (jabber-link-preview-put url new-token) (jabber-chat--handle-link-preview '(:url "https://example.org/a" :title "Old") url old-token nil nil) (should (eq (jabber-link-preview-get url) new-token))) (remhash url jabber-link-preview--cache)))) (ert-deftest jabber-test-chat-auto-preview-schedules-live-links () (with-temp-buffer (let ((url "https://example.org/page") scheduled) (insert url) (put-text-property (point-min) (point-max) 'jabber-chat-link-preview-url url) (cl-letf (((symbol-function 'run-at-time) (lambda (&rest args) (setq scheduled args)))) (jabber-chat--schedule-link-preview (list :body url) :muc-local :insert)) (should (equal (nth 2 scheduled) #'jabber-chat--auto-load-link-preview))))) (ert-deftest jabber-test-chat-auto-preview-skips-backlog () (with-temp-buffer (let ((scheduled nil)) (insert "https://example.org/page") (cl-letf (((symbol-function 'run-at-time) (lambda (&rest _) (setq scheduled t)))) (jabber-chat--schedule-link-preview '(:body "https://example.org/page" :delayed t) :foreign :insert)) (should-not scheduled)))) (defun jabber-test-link-preview--chat-buffer (url) "Return a temporary chat buffer displaying URL in one EWOC node." (let ((buffer (generate-new-buffer " *jabber-preview-shared-test*"))) (with-current-buffer buffer (setq-local jabber-chat-ewoc (ewoc-create (lambda (data) (let ((message (cadr data)) (jabber-chat--body-start (point))) (jabber-chat-print-body message :foreign :insert) (jabber-chat-print-link-preview message :foreign :insert) (jabber-chat-goto-address message :foreign :insert) (jabber-chat-mark-link-preview-url message :foreign :insert) (jabber-chat--schedule-link-preview message :foreign :insert))))) (jabber-chat-ewoc-enter (list :foreign (list :body url))) (goto-char (point-min)) (search-forward url) (backward-char)) buffer)) (ert-deftest jabber-test-chat-shared-fetch-redraws-every-waiter () (let ((url "https://example.org/shared") first second pending timers (fetches 0)) (unwind-protect (cl-letf (((symbol-function 'run-at-time) (lambda (_time _repeat function &rest args) (setq timers (append timers (list (cons function args)))))) ((symbol-function 'jabber-link-preview-fetch) (lambda (_url callback &rest args) (setq pending (cons callback args)) (cl-incf fetches)))) (setq first (jabber-test-link-preview--chat-buffer url)) (apply (caar timers) (cdar timers)) (setq timers (cdr timers)) (should (= fetches 1)) (setq second (jabber-test-link-preview--chat-buffer url)) (apply (caar timers) (cdar timers)) (should (= fetches 1)) (should-not (with-current-buffer second (string-match-p "│ Shared" (buffer-string)))) (apply (car pending) (list :url url :site "Example" :title "Shared") (cdr pending)) (dolist (buffer (list first second)) (should (with-current-buffer buffer (string-match-p "│ Shared" (buffer-string)))))) (remhash url jabber-link-preview--cache) (when (boundp 'jabber-chat--link-preview-waiters) (remhash url jabber-chat--link-preview-waiters)) (mapc (lambda (buffer) (when (buffer-live-p buffer) (kill-buffer buffer))) (list first second))))) (ert-deftest jabber-test-chat-link-preview-ret-lifecycle () (with-temp-buffer (let* ((url "https://example.org/page") (msg (list :body url)) pending opened) (unwind-protect (progn (setq-local jabber-chat-ewoc (ewoc-create (lambda (data) (let ((message (cadr data)) (jabber-chat--body-start (point))) (jabber-chat-print-body message :foreign :insert) (jabber-chat-print-link-preview message :foreign :insert) (jabber-chat-goto-address message :foreign :insert) (jabber-chat-mark-link-preview-url message :foreign :insert))))) (jabber-chat-ewoc-enter (list :foreign msg)) (goto-char (point-min)) (search-forward url) (backward-char) (should (equal (get-text-property (point) 'jabber-chat-link-preview-url) url)) (cl-letf (((symbol-function 'jabber-link-preview-fetch) (lambda (_url callback &rest args) (setq pending (cons callback args))))) (jabber-chat-url-action-at-point)) (should (eq (car (jabber-link-preview-get url)) 'loading)) (apply (car pending) (list :url url :site "Example" :title "Page") (cdr pending)) (should (string-match-p "│ Page" (buffer-string))) (goto-char (point-min)) (search-forward url) (backward-char) (cl-letf (((symbol-function 'browse-url) (lambda (target &rest _) (setq opened target)))) (jabber-chat-url-action-at-point)) (should (equal opened url))) (remhash url jabber-link-preview--cache))))) (provide 'jabber-test-link-preview) ;;; jabber-test-link-preview.el ends hereemacs-jabber-0.15.1/tests/jabber-test-mam-room-identity.el000066400000000000000000000150001527111033600233430ustar00rootroot00000000000000;;; jabber-test-mam-room-identity.el --- Room archive identity tests -*- lexical-binding: t; -*- ;;; Commentary: ;; Replay idless forwarded room messages against stable live room identities. ;;; Code: (require 'jabber-archive-test-helpers) (defun jabber-test-mam-room--message (&optional room-id transport-id) "Return a room message with optional ROOM-ID and TRANSPORT-ID." `(message ((from . "room@conference.example.com/nick") (type . "groupchat") ,@(when transport-id `((id . ,transport-id)))) (body () "A repeatable message") ,@(when room-id `((stanza-id ((xmlns . "urn:xmpp:sid:0") (by . "room@conference.example.com") (id . ,room-id))))))) (defun jabber-test-mam-room--live (jc uid &optional transport-id) "Store a live message on JC with room UID and TRANSPORT-ID." (let ((xml (jabber-test-mam-room--message uid transport-id))) (jabber-db-store-message (jabber-connection-bare-jid jc) "room@conference.example.com" "in" "groupchat" "A repeatable message" 1735689600 "nick" transport-id uid nil nil nil nil nil (jabber-db--message-identity xml)))) (defun jabber-test-mam-room--query (jc &optional archive) "Start an owned room query on JC against ARCHIVE." (jabber-mam--query jc nil nil nil nil (or archive "room@conference.example.com"))) (defun jabber-test-mam-room--rows () "Return stored room identity metadata, never message bodies." (sqlite-select jabber-db--connection "SELECT account, room_id, server_id, stanza_id FROM message ORDER BY id")) (ert-deftest jabber-test-mam-room-uid-live-first () "An owned room UID reconciles an idless archive after live delivery." (jabber-test-archive--with-file (let* ((id (jabber-test-mam-room--live jc "room-uid" "transport")) (query (jabber-test-mam-room--query jc))) (jabber-mam--process-message jc (jabber-test-archive--result query "room-uid" (jabber-test-mam-room--message))) (should (= 1 (length (jabber-test-mam-room--rows)))) (should (equal (sqlite-select jabber-db--connection "SELECT message_id FROM message_archive") (list (list id))))))) (ert-deftest jabber-test-mam-room-uid-archive-first () "An idless owned archive row acquires the later live transport ID." (jabber-test-archive--with-file (let ((query (jabber-test-mam-room--query jc))) (jabber-mam--process-message jc (jabber-test-archive--result query "room-uid" (jabber-test-mam-room--message))) (jabber-test-mam-room--live jc "room-uid" "transport") (should (equal (jabber-test-mam-room--rows) '(("me@example.com" "room-uid" "room-uid" "transport"))))))) (ert-deftest jabber-test-mam-room-uid-wrong-archive () "A foreign room or personal archive UID is not the sender room's ID." (dolist (archive '("other@conference.example.com" "me@example.com")) (jabber-test-archive--with-file (jabber-test-mam-room--live jc "room-uid") (let ((query (jabber-test-mam-room--query jc archive))) (jabber-mam--process-message jc (jabber-test-archive--result query "room-uid" (jabber-test-mam-room--message))) (should (= 2 (length (jabber-test-mam-room--rows)))) (should-not (nth 1 (cadr (jabber-test-mam-room--rows)))))))) (ert-deftest jabber-test-mam-room-uid-explicit-conflict () "An explicit different room stanza ID is never replaced by the UID." (jabber-test-archive--with-file (jabber-test-mam-room--live jc "room-uid") (let ((query (jabber-test-mam-room--query jc))) (jabber-mam--process-message jc (jabber-test-archive--result query "room-uid" (jabber-test-mam-room--message "explicit"))) (should (= 2 (length (jabber-test-mam-room--rows)))) (should (equal (nth 1 (cadr (jabber-test-mam-room--rows))) "explicit"))))) (ert-deftest jabber-test-mam-room-uid-transport-conflict () "Matching room UID does not override conflicting transport evidence." (jabber-test-archive--with-file (jabber-test-mam-room--live jc "room-uid" "live-transport") (let ((query (jabber-test-mam-room--query jc))) (jabber-mam--process-message jc (jabber-test-archive--result query "room-uid" (jabber-test-mam-room--message nil "archive-transport"))) (should (= 2 (length (jabber-test-mam-room--rows))))))) (ert-deftest jabber-test-mam-room-uid-legitimate-repeats () "Same sender, body and timestamp with distinct UIDs remain distinct." (jabber-test-archive--with-file (let ((query (jabber-test-mam-room--query jc))) (dolist (uid '("first" "second")) (jabber-mam--process-message jc (jabber-test-archive--result query uid (jabber-test-mam-room--message))) (jabber-test-mam-room--live jc uid)) (should (equal (jabber-test-mam-room--rows) '(("me@example.com" "first" "first" nil) ("me@example.com" "second" "second" nil))))))) (ert-deftest jabber-test-mam-room-uid-account-scope () "Identical room UIDs on different local accounts do not merge." (jabber-test-archive--with-file (jabber-test-mam-room--live jc "room-uid") (let* ((jc (jabber-test-mam--native-connection "other")) (query (jabber-test-mam-room--query jc))) (jabber-mam--process-message jc (jabber-test-archive--result query "room-uid" (jabber-test-mam-room--message))) (should (equal (mapcar #'car (jabber-test-mam-room--rows)) '("me@example.com" "other@example.com")))))) (ert-deftest jabber-test-mam-room-uid-unowned-result () "Wrong sender and retired session results cannot install room identity." (jabber-test-archive--with-file (let* ((query (jabber-test-mam-room--query jc)) (xml (jabber-test-archive--result query "room-uid" (jabber-test-mam-room--message)))) (setcdr (assq 'from (cadr xml)) "other@conference.example.com") (jabber-mam--process-message jc xml) (should-not (jabber-test-mam-room--rows)) (setcdr (assq 'from (cadr xml)) "room@conference.example.com") (plist-put (get jc :state-data) :session-id "retired") (jabber-mam--process-message jc xml) (should-not (jabber-test-mam-room--rows))))) (provide 'jabber-test-mam-room-identity) ;;; jabber-test-mam-room-identity.el ends here emacs-jabber-0.15.1/tests/jabber-test-mam.el000066400000000000000000003252301527111033600205530ustar00rootroot00000000000000;;; 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-moderation) (require 'jabber-message-thread) (require 'jabber-omemo-store) (require 'jabber-archive-test-helpers) ;;; 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)) (defun jabber-test-mam--queries (jc id) "Build an active message-only query fixture for JC and ID." (list (list :id id :jc jc :current-p (jabber-mam--session-predicate jc) :to nil :page (list nil) :transaction nil))) ;; Bodyless results reach downstream handlers as an unwrapped copy, while ;; live handlers see only the consumed envelope. (defun jabber-test-mam--dispatched (jc stanza) "Process MAM STANZA on JC; return the unwrapped stanzas sent downstream." (let* ((seen nil) (jabber-message-chain (list (lambda (_jc xml) (push xml seen))))) (jabber-mam--process-message jc stanza) (should-not (cddr stanza)) (nreverse seen))) ;;; 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) 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 (nth 8 (car query-requests))) (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) 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)))))) ;;; 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 (jabber-test-mam--queries jc jabber-test-mam-queryid)) (jabber-muc-participants nil)) ;; Each message commits in its own short transaction. (dotimes (i count) (jabber-mam--process-message jc (jabber-test-mam--make-message i))) ;; Verify all stored (let ((rows (jabber-db-query "me@example.com" "friend@example.com" 0 (+ 1700000000 (* count 86400)) -1))) (should (= count (length rows))))))) ;;; 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 (jabber-test-mam--queries jc jabber-test-mam-queryid)) (jabber-muc-participants nil)) ;; First pass, then a re-sync (dotimes (_pass 2) (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 (jabber-test-mam--queries jc jabber-test-mam-queryid)) (stanza (jabber-test-mam--make-message 1)) (replay (jabber-test-mam--without-delay stanza))) (jabber-mam--process-message jc stanza) (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")))))) (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 (jabber-test-mam--queries 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 (ert-deftest jabber-test-mam-transaction-batching () "Each processed message commits in its own transaction." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (batch-count 500) (jabber-mam--syncing (jabber-test-mam--queries jc jabber-test-mam-queryid)) (jabber-muc-participants nil) (execute (symbol-function 'sqlite-execute)) (commits 0)) (cl-letf (((symbol-function 'sqlite-execute) (lambda (db sql &rest args) (when (equal sql "COMMIT") (cl-incf commits)) (apply execute db sql args)))) (dotimes (i batch-count) (jabber-mam--process-message jc (jabber-test-mam--make-message i)) (should (jabber-test-archive--idle-p)))) (should (= batch-count commits)) (let ((rows (jabber-db-query "me@example.com" "friend@example.com" 0 (+ 1700000000 (* batch-count 86400)) -1))) (should (= batch-count (length rows))))))) (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 (jabber-test-mam--queries 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))) (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)") (cl-letf (((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc message) (should-not (jabber-test-archive--idle-p)) (jabber-omemo-store-save-session-and-clear-legacy-keys "me@example.com" "friend@example.com" 7 envelope) (jabber-chat--set-body message "decrypted")))) (jabber-mam--process-message jc stanza)) (should (jabber-test-archive--idle-p)) (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 (jabber-test-mam--queries 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-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 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 (jabber-test-mam--queries jc "muc-query")) (jabber-muc--rooms (make-hash-table :test 'equal)) (jabber-muc-participants nil)) (puthash room (list (cons jc "mynick")) jabber-muc--rooms) (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 (jabber-test-mam--queries 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-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))))) ;;; 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)))) ;;; 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 (jabber-test-mam--queries jc jabber-test-mam-queryid)) (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 (jabber-test-mam--queries jc jabber-test-mam-queryid)) (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 (jabber-test-mam--queries jc jabber-test-mam-queryid)) (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'")))))) ;;; 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 (jabber-test-mam--queries jc jabber-test-mam-queryid)) (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 (jabber-test-mam--queries jc jabber-test-mam-queryid)) (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))))))) (let ((unwrapped (car (jabber-test-mam--dispatched 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 unwrapped 'jabber-mam--origin)) (should (car (jabber-xml-get-children unwrapped 'reactions))))))) (ert-deftest jabber-test-mam-author-retract-fallback-unwrapped-not-stored () "Archived author retraction is unwrapped but never stored as chat text." (jabber-test-mam-with-db (let* ((jc (jabber-test-mam--make-fake-jc "me@example.com")) (jabber-mam--syncing (jabber-test-mam--queries jc jabber-test-mam-queryid)) (jabber-chat--crypto-loaded t) (stanza `(message ((from . "room@conference.example")) (result ((xmlns . ,jabber-mam-xmlns) (queryid . ,jabber-test-mam-queryid) (id . "archive-retract-1")) (forwarded ((xmlns . ,jabber-mam-forward-xmlns)) (delay ((xmlns . ,jabber-mam-delay-xmlns) (stamp . "2026-08-13T13:45:00Z"))) (message ((from . "room@conference.example/alice") (to . "me@example.com") (type . "groupchat") (id . "retract-message-1")) (body () "sender-controlled fallback") (retract ((id . "target-server-id") (xmlns . ,jabber-moderation-retract-xmlns))) (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "occupant-alice"))))))))) (plist-put (car jabber-mam--syncing) :to "room@conference.example") (jabber-db-store-message "me@example.com" "room@conference.example" "in" "groupchat" "original message" 1786628700 "alice" "original-client-id" "target-server-id" "occupant-alice") (let ((unwrapped (car (jabber-test-mam--dispatched jc stanza)))) (cl-letf (((symbol-function 'jabber-moderation--room-supports-occupant-id-p) (lambda (_room owner) (eq owner jc)))) (should (jabber-moderation--handle-message jc unwrapped))) (should (equal '(("original message" "room@conference.example/alice")) (sqlite-select (jabber-db-ensure-open) "SELECT body, retracted_by FROM message ORDER BY id"))) (should (jabber-xml-get-attribute unwrapped 'jabber-mam--origin)) (should (jabber-moderation--muc-retraction-message-p unwrapped)))))) (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 (jabber-test-mam--queries jc jabber-test-mam-queryid)) (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"))))))))) (let ((unwrapped (car (jabber-test-mam--dispatched jc stanza)))) ;; The dispatched stanza has the inner message's from (should (string= "alice@example.com/res" (jabber-xml-get-attribute unwrapped 'from))) ;; MAM origin marker should be set (should (jabber-xml-get-attribute unwrapped 'jabber-mam--origin)) ;; Archive id is needed by downstream tombstone handlers. (should (equal "archive-001" (jabber-xml-get-attribute unwrapped 'jabber-mam--archive-id))) ;; The receipt element should be a child (should (car (jabber-xml-get-children unwrapped '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 (jabber-test-mam--queries jc "known-query")) (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 (jabber-test-mam--queries jc "known-query")) (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 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 (jabber-test-mam--queries jc jabber-test-mam-queryid)) (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 (jabber-test-mam--queries jc jabber-test-mam-queryid)) (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 (jabber-test-mam--queries jc "muc-query")) (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) (plist-put (car jabber-mam--syncing) :to room) ;; 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'"))))))) ;;; Native admission and settlement regressions (defmacro jabber-test-mam--with-native (&rest body) "Run BODY with native IQ dispatch and isolated SQLite." (declare (indent 0) (debug t)) `(jabber-test-mam-with-db (let* ((jc (jabber-test-mam--native-connection)) (other (jabber-test-mam--native-connection "other")) (jabber-connections (list jc other)) (jabber-open-info-queries nil) (jabber-mam--syncing nil) (jabber-mam--peer-syncing nil) (jabber-mam--dirty-peers nil) (jabber-mam--redraw-timer nil) (jabber-mam--redraw-peers nil) (jabber-mam-sync-complete-functions nil) (jabber-mam-peer-syncing-functions nil) (fsm-debug nil) sent) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (_jc xml &rest _) (push xml sent)))) (unwind-protect (progn ,@body) (jabber-mam--cleanup-all) (when jabber-mam--redraw-timer (cancel-timer jabber-mam--redraw-timer))))))) (defun jabber-test-mam--reply (jc request &optional from failure incomplete) "Deliver REQUEST's IQ reply through JC's native FSM. FROM is the archive sender; FAILURE and INCOMPLETE select the response." (fsm-send-sync jc `(:stanza (iq ((type . ,(if failure "error" "result")) (id . ,(jabber-xml-get-attribute request 'id)) ,@(when from `((from . ,from)))) ,(if failure '(error () (service-unavailable ())) `(fin ((xmlns . ,jabber-mam-xmlns) (complete . ,(if incomplete "false" "true"))) (set ((xmlns . ,jabber-mam-rsm-xmlns)) (last () "next-page")))))))) (ert-deftest jabber-test-mam-native-archive-admission () "Reject occupant, missing room sender and foreign connection before decrypt." (jabber-test-mam--with-native (let ((jabber-test-mam-queryid "owned") (decrypts 0)) (jabber-mam--query jc nil "owned" nil nil "room@example.com") (cl-letf (((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc xml) (cl-incf decrypts) xml))) (dolist (case `((,jc "room@example.com/occupant") (,jc "other@example.com") (,jc nil) (,other "room@example.com"))) (let ((xml (jabber-test-mam--make-message 1))) (setf (cadr xml) (when (cadr case) `((from . ,(cadr case))))) (jabber-mam--process-message (car case) xml) (should (cddr xml)))) (should (= 0 decrypts)) (should-not (sqlite-select jabber-db--connection "SELECT id FROM message")))))) (ert-deftest jabber-test-mam-native-session-admission () "Accept native state copies, but reject retired transport before decrypt." (jabber-test-mam--with-native (let ((jabber-test-mam-queryid "owned") (decrypts 0)) (jabber-mam--query jc nil "owned") (jabber-sm--drain-pending jc (fsm-get-state-data jc)) (cl-letf (((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc xml) (cl-incf decrypts) xml))) (jabber-mam--process-message jc (jabber-test-mam--make-message 1)) (should (= 1 decrypts)) (plist-put (fsm-get-state-data jc) :connection (list 'replacement)) (jabber-mam--process-message jc (jabber-test-mam--make-message 2)) (should (= 1 decrypts)))))) (ert-deftest jabber-test-mam-native-cancel-late-replies () "Late fin/error from a cancelled room cannot settle another query." (dolist (error-first '(nil t)) (jabber-test-mam--with-native (jabber-mam--query jc nil "room-query" nil nil "room@example.com") (let ((room-request (car sent))) (jabber-mam--query jc nil "other-query") (let ((other-request (car sent))) (should (jabber-test-archive--idle-p)) (jabber-mam--cancel-muc-query "room@example.com") (should (jabber-test-archive--idle-p)) (jabber-test-mam--reply jc room-request "room@example.com" error-first) (jabber-test-mam--reply jc room-request "room@example.com" (not error-first)) (should (jabber-test-archive--idle-p)) (should (jabber-mam-syncing-p)) (jabber-test-mam--reply jc other-request) (should (jabber-test-archive--idle-p)) (should-not (jabber-mam-syncing-p))))))) (ert-deftest jabber-test-mam-native-bounded-sync-preserves-absence () "Limited success, partial failure and disconnect never delete absent rows." (dolist (ending '(success error disconnect)) (jabber-test-mam--with-native (let ((stamp (+ 1700000000 86400))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "unfetched same second" stamp nil "unfetched" "unfetched-archive")) (with-temp-buffer (setq-local jabber-buffer-connection jc) (setq-local jabber-chatting-with "friend@example.com") (setq-local jabber-chat-buffer-msg-count 1) (jabber-mam-sync-buffer)) (let* ((request (car sent)) (jabber-test-mam-queryid (jabber-xml-get-attribute (car (jabber-xml-get-children request 'query)) 'queryid))) (jabber-mam--process-message jc (jabber-test-mam--make-message 1)) (pcase ending ('success (jabber-test-mam--reply jc request)) ('error (jabber-test-mam--reply jc request nil t)) ('disconnect (jabber-mam--cleanup-connection jc))) (should (= 2 (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message")))) (should (jabber-test-archive--idle-p)))))) (ert-deftest jabber-test-mam-native-iq-admission () "Forged IQs leave the real page pending; valid completion fires once." (dolist (room '(nil "room@example.com")) (dolist (failure '(nil t)) (jabber-test-mam--with-native (let ((calls 0)) (jabber-mam--query jc nil nil nil nil room nil nil (lambda () (cl-incf calls))) (let* ((request (car sent)) (id (jabber-xml-get-attribute request 'id)) (pending (assoc id jabber-open-info-queries))) (dolist (case `((,other ,room) (,jc "foreign@example.com") (,jc ,(concat (or room "me@example.com") "/resource")))) (jabber-test-mam--reply (car case) request (cadr case) failure) (should (eq pending (assoc id jabber-open-info-queries))) (should (= 0 calls)) (should (jabber-test-archive--idle-p))) (when room (jabber-test-mam--reply jc request nil failure) (should (eq pending (assoc id jabber-open-info-queries)))) (jabber-test-mam--reply jc request room failure) (jabber-test-mam--reply jc request room failure) (should (= 1 calls)) (should (jabber-test-archive--idle-p)) (should-not jabber-open-info-queries))))))) (ert-deftest jabber-test-mam-native-missing-from-and-retirement () "Missing FROM requires personal ownership; each lifecycle replacement rejects." (dolist (change '(nil (:connection . replacement) (:session-id . "new-stream") (:username . "other") (:server . "other.example"))) (jabber-test-mam--with-native (let ((jabber-test-mam-queryid "own") (decrypts 0)) (jabber-mam--query jc nil "own") (jabber-sm--drain-pending jc (fsm-get-state-data jc)) (when change (plist-put (fsm-get-state-data jc) (car change) (cdr change))) (cl-letf (((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc xml) (cl-incf decrypts) xml))) (let ((xml (jabber-test-mam--make-message 1))) (setf (cadr xml) nil) (jabber-mam--process-message jc xml))) (should (= (if change 0 1) decrypts)) (should (= (if change 0 1) (caar (sqlite-select jabber-db--connection "SELECT count(*) FROM message")))))))) (ert-deftest jabber-test-mam-native-pagination-retirement () "Pagination retains ownership across timers and retires safely at every exit." (dolist (ending '(success connection all room replacement)) (jabber-test-mam--with-native (let ((calls 0) outcomes) (jabber-mam--query jc nil "pages" nil nil "room@example.com" nil 7 (lambda () (cl-incf calls)) (lambda (outcome) (push outcome outcomes))) (let ((first (car sent)) (query (car jabber-mam--syncing))) (jabber-test-mam--reply jc first "room@example.com" nil t) (should (= 0 calls)) (should-not outcomes) (should (jabber-test-archive--idle-p)) (should (jabber-mam-syncing-p)) (let* ((timer (plist-get query :timer)) (function (timer--function timer)) (args (timer--args timer))) (should (timerp timer)) ;; Deterministic delivery of the native timer, even if cancelled. (cancel-timer timer) (pcase ending ('connection (jabber-mam--cleanup-connection jc)) ('all (jabber-mam--cleanup-all)) ('room (jabber-mam--cancel-muc-query "room@example.com")) ('replacement (plist-put (fsm-get-state-data jc) :connection (list 'new)))) (apply function args) (if (eq ending 'success) (progn (should (= 2 (length sent))) (should (jabber-test-archive--idle-p)) (let* ((payload (car (jabber-xml-get-children (car sent) 'query))) (rsm (car (jabber-xml-get-children payload 'set)))) (should (equal '(after nil "next-page") (car (jabber-xml-get-children rsm 'after)))) (should (equal '(max nil "7") (car (jabber-xml-get-children rsm 'max))))) (jabber-test-mam--reply jc (car sent) "room@example.com")) (should (= 1 (length sent)))) (should (= 1 calls)) (should (equal (list (if (eq ending 'success) 'success 'cancelled)) outcomes)) (apply function args) (should (= 1 (length outcomes))) (should-not (jabber-mam-syncing-p)) (should-not jabber-open-info-queries) (should (jabber-test-archive--idle-p)))))))) (ert-deftest jabber-test-mam-native-cancelled-callbacks-preserve-transaction () "Captured stale callbacks cannot settle a surviving query or its cursor." (jabber-test-mam--with-native (let ((calls 0) (jabber-test-mam-queryid "survivor")) (jabber-mam--query jc nil "cancelled" nil nil "room@example.com" nil nil (lambda () (cl-incf calls))) (let ((callbacks (car jabber-open-info-queries))) (jabber-mam--query jc nil "survivor" nil nil nil nil nil (lambda () (cl-incf calls))) (let ((request (car sent))) (jabber-mam--process-message jc (jabber-test-mam--make-message 1)) (jabber-mam--cancel-muc-query "room@example.com") (should (= 1 calls)) (dolist (callback (list (nth 1 callbacks) (nth 2 callbacks))) (funcall (car callback) jc '(iq ((from . "room@example.com")) (fin ((xmlns . "urn:xmpp:mam:2") (complete . "true")))) (cdr callback))) (should (= 1 calls)) (should (jabber-test-archive--idle-p)) (let ((reader (sqlite-open jabber-db-path))) (unwind-protect (progn ;; The result committed on arrival; its cursor waits for fin. (should (equal '(("Message 1")) (sqlite-select reader "SELECT body FROM message"))) (should-not (sqlite-select reader "SELECT uid FROM mam_progress")) (jabber-test-mam--reply jc request) (should (sqlite-select reader "SELECT uid FROM mam_progress"))) (sqlite-close reader))) (should (= 2 calls)) (should-not jabber-open-info-queries)))))) (ert-deftest jabber-test-mam-native-query-start-failures () "Failed send settles only the owned query and touches no transaction." (dolist (failure '(send quit)) (jabber-test-mam--with-native (let ((calls 0) outcomes returned quit-seen) ;; Another writer's open transaction is neither joined nor ended. (sqlite-execute jabber-db--connection "BEGIN") (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (&rest _) (if (eq failure 'quit) (signal 'quit nil) (error "Injected send failure"))))) (condition-case nil (progn (jabber-mam--query jc nil nil nil nil nil nil nil (lambda () (cl-incf calls)) (lambda (outcome) (push (list outcome returned) outcomes))) (setq returned t)) (quit (setq quit-seen t)))) (should (= 1 calls)) (should (eq quit-seen (eq failure 'quit))) (should (equal (list (list (if quit-seen 'cancelled 'failed) nil)) outcomes)) (should-not (jabber-mam-syncing-p)) (should-not jabber-open-info-queries) (should-not (jabber-test-archive--idle-p)) (sqlite-execute jabber-db--connection "ROLLBACK"))))) (ert-deftest jabber-test-mam-native-stale-cursor-retry () "A stale cursor retry retains filters and callback and cannot loop forever." (dolist (failure '(nil t)) (jabber-test-mam--with-native (let ((calls 0) outcomes) (jabber-mam--query jc "expired" "retry" "friend@example.com" "2020-01-01T00:00:00Z" nil nil 7 (lambda () (cl-incf calls)) (lambda (outcome) (push outcome outcomes))) (cl-labels ((stale () (fsm-send-sync jc `(:stanza (iq ((type . "error") (id . ,(jabber-xml-get-attribute (car sent) 'id))) (error () (item-not-found ()))))))) (stale) (should (= 0 calls)) (should-not outcomes) (should (jabber-test-archive--idle-p)) (if failure (stale) (jabber-test-mam--reply jc (car sent)))) (should (= 2 (length sent))) (should (= 1 calls)) (should (equal (list (if failure 'failed 'success)) outcomes)) (should-not (jabber-mam-syncing-p)) (should-not jabber-open-info-queries) (let ((xml (jabber-sexp2xml (car sent)))) (should (string-match-p "friend@example.com" xml)) (should (string-match-p "2020-01-01T00:00:00Z" xml)) (should-not (string-match-p "" xml))))))) (ert-deftest jabber-test-mam-native-reentrant-decrypt-retirement () "Retirement during decryption prevents storage and downstream dispatch." (jabber-test-mam--with-native (let* ((jabber-test-mam-queryid "retire") (dispatched nil) (jabber-message-chain (list (lambda (_jc xml) (push xml dispatched)))) ;; A bodyless receipt would otherwise be dispatched downstream. (receipt (jabber-test-mam--make-message 1))) (jabber-mam--query jc nil "retire") (setf (nthcdr 2 (nth 3 (nth 2 (nth 2 receipt)))) '((received ((xmlns . "urn:xmpp:receipts") (id . "x"))))) (cl-letf (((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc xml) (jabber-mam--cleanup-connection jc) xml))) (jabber-mam--process-message jc (jabber-test-mam--make-message 2)) (jabber-mam--process-message jc receipt)) (should-not dispatched) (should (jabber-test-archive--idle-p)) (should-not (sqlite-select jabber-db--connection "SELECT body FROM message"))))) (ert-deftest jabber-test-mam-native-buffer-sync-contract () "Bounded personal and room sync preserve absent threads and settle indicators." (dolist (room '(nil "room@example.com")) (dolist (ending '(success error disconnect)) (jabber-test-mam--with-native (let* ((peer (or room "friend@example.com")) (type (if room "groupchat" "chat")) (signals nil) (refreshes nil) (jabber-mam-peer-syncing-functions (list (lambda (&rest args) (push args signals)))) (jabber-mam-sync-complete-functions (list (lambda (peers) (push peers refreshes))))) (jabber-db-store-message "me@example.com" peer "in" type "root" 1700086400 "phone" "root" "archive-root" nil nil nil nil '(:thread-id "thread")) (jabber-db-register-message-thread "me@example.com" peer type "thread" nil "root" "archive-root" 1700086400) (with-temp-buffer (setq-local jabber-buffer-connection jc) (setq-local jabber-chatting-with peer) (setq-local jabber-group room) (setq-local jabber-chat-buffer-msg-count 1) (jabber-mam-sync-buffer)) (let* ((request (car sent)) (payload (car (jabber-xml-get-children request 'query))) (rsm (car (jabber-xml-get-children payload 'set))) (jabber-test-mam-queryid (jabber-xml-get-attribute payload 'queryid)) (xml (jabber-test-mam--make-message 1 peer type))) (should (equal room (jabber-xml-get-attribute request 'to))) (should (equal '(before nil) (car (jabber-xml-get-children rsm 'before)))) (should (equal '(max nil "1") (car (jabber-xml-get-children rsm 'max)))) (setf (cadr xml) `((from . ,(or room "me@example.com")))) (jabber-mam--process-message jc xml) (pcase ending ;; A successful bounded page need not exhaust the archive. ('success (jabber-test-mam--reply jc request room nil t)) ('error (jabber-test-mam--reply jc request room t)) ('disconnect (jabber-mam--cleanup-connection jc))) (should (= 1 (length sent))) (should (equal (list (list peer type nil) (list peer type t)) signals)) (should (equal (list (list (list "me@example.com" peer type))) refreshes)) (should (jabber-db-message-thread-known-p "me@example.com" peer type "thread")) ;; Reopen the actual file, not just the writer's uncommitted view. (jabber-db-close) (should (= 2 (caar (sqlite-select (jabber-db-ensure-open) "SELECT count(*) FROM message")))) (should (jabber-db-message-thread-known-p "me@example.com" peer type "thread")))))))) (ert-deftest jabber-test-mam-native-connection-cleanup-is-scoped () "Disconnect settles only the selected connection, even with failing callbacks." (jabber-test-mam--with-native (let ((calls 0)) (jabber-mam--query jc nil nil nil nil nil nil nil (lambda () (cl-incf calls) (error "Callback failure"))) (jabber-mam--query other nil nil nil nil nil nil nil (lambda () (cl-incf calls))) (let ((request (car sent))) (jabber-mam--cleanup-connection jc) (jabber-mam--cleanup-connection jc) (should (= 1 calls)) (should (jabber-test-archive--idle-p)) (should (= 1 (length jabber-open-info-queries))) (jabber-test-mam--reply other request) (should (= 2 calls)) (should (jabber-test-archive--idle-p)) (should-not (jabber-mam-syncing-p)))))) ;;; Native room departure and disconnect fault regressions (defmacro jabber-test-mam--with-lifecycle (&rest body) "Run BODY with the registered MAM lifecycle hooks, without unrelated UI." (declare (indent 0) (debug t)) `(let ((jabber-lifecycle-session-reset-functions (cl-remove-if-not (lambda (function) (eq function #'jabber-mam--cleanup-connection)) jabber-lifecycle-session-reset-functions)) (jabber-lost-connection-hooks (cl-remove-if-not (lambda (function) (eq function #'jabber-mam--cleanup-connection)) jabber-lost-connection-hooks)) (jabber-pre-disconnect-hook (cl-remove-if-not (lambda (function) (eq function #'jabber-mam--cleanup-all)) jabber-pre-disconnect-hook)) (jabber-lifecycle-connection-list-changed-functions nil) (jabber-post-disconnect-hook nil) (jabber-auto-reconnect nil)) (cl-letf (((symbol-function 'jabber-clear-roster) #'ignore)) ,@body))) (defun jabber-test-mam--capture-page (query request &optional waiting) "Capture QUERY's native REQUEST callbacks, optionally enter WAITING state." (let ((callbacks (assoc (plist-get query :iq-id) jabber-open-info-queries))) (when waiting (jabber-test-mam--reply (plist-get query :jc) request (plist-get query :to) nil t)) (list query request callbacks (plist-get query :timer)))) (defun jabber-test-mam--deliver-late-page (capture) "Deliver both retired IQ callbacks and any pagination timer in CAPTURE." (pcase-let ((`(,query ,_request ,callbacks ,timer) capture)) (dolist (callback (list (nth 1 callbacks) (nth 2 callbacks))) (funcall (car callback) (plist-get query :jc) `(iq ((from . ,(or (plist-get query :to) (jabber-connection-bare-jid (plist-get query :jc))))) (fin ((xmlns . ,jabber-mam-xmlns) (complete . "true")))) (cdr callback))) (when timer (should-not (memq timer timer-list)) (apply (timer--function timer) (timer--args timer))))) (defun jabber-test-mam--assert-retired (capture) "Assert that CAPTURE owns no query, IQ, page, timer or contribution." (let ((query (car capture))) (should-not (memq query jabber-mam--syncing)) (should-not (assoc (jabber-xml-get-attribute (nth 1 capture) 'id) jabber-open-info-queries)) (dolist (key '(:page :iq-id :timer :transaction)) (should-not (plist-get query key))))) (ert-deftest jabber-test-mam-native-room-departure-account-scope () "Room departure retires every A query but preserves B in either order." (dolist (other-first '(nil t)) (dolist (a-waiting '(nil t)) (dolist (b-waiting '(nil t)) (jabber-test-mam--with-native (let ((room "room@example.com") (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-participants nil) (a-calls 0) (b-calls 0) captures survivor) (jabber-muc-add-groupchat room "me" jc) (jabber-muc-add-groupchat room "other" other) (cl-labels ((start-a () (dotimes (i 3) (let ((query (jabber-mam--query jc nil nil nil nil room nil nil (lambda () (cl-incf a-calls))))) (push (jabber-test-mam--capture-page query (car sent) (and a-waiting (zerop i))) captures)))) (start-b () (let ((query (jabber-mam--query other nil "survivor" nil nil room nil nil (lambda () (cl-incf b-calls))))) (setq survivor (jabber-test-mam--capture-page query (car sent) b-waiting))))) (if other-first (progn (start-b) (start-a)) (start-a) (start-b))) (jabber-db-store-message "me@example.com" room "in" "groupchat" "A accepted" 1 nil "A-row" "A-archive") (jabber-muc-remove-groupchat room jc) (should-not (jabber-muc-joined-p room jc)) (should (equal "other" (jabber-muc-nickname room other))) (should (= 3 a-calls)) (should (= 0 b-calls)) (should (equal (list (car survivor)) jabber-mam--syncing)) (dolist (capture captures) (jabber-test-mam--assert-retired capture) (jabber-test-mam--deliver-late-page capture)) (jabber-muc-remove-groupchat room jc) (should (= 3 a-calls)) (should (jabber-test-archive--idle-p)) (let ((reader (sqlite-open jabber-db-path))) (unwind-protect (progn ;; Writes outside a result are never held by a MAM page. (should (= 1 (caar (sqlite-select reader "SELECT count(*) FROM message")))) (when b-waiting (let ((timer (nth 3 survivor))) (should (memq timer timer-list)) (cancel-timer timer) (apply (timer--function timer) (timer--args timer)))) (should (jabber-test-archive--idle-p)) (should (= 1 (length jabber-open-info-queries))) (let* ((jabber-test-mam-queryid "survivor") (xml (jabber-test-mam--make-message 1 room "groupchat"))) (setf (cadr xml) `((from . ,room))) (jabber-mam--process-message other xml)) (jabber-test-mam--reply other (if b-waiting (car sent) (nth 1 survivor)) room) (should (= 1 b-calls)) (should (jabber-test-archive--idle-p)) (should (equal '(("me@example.com" "A accepted") ("other@example.com" "Message 1")) (sqlite-select reader "SELECT account,body FROM message ORDER BY account")))) (sqlite-close reader))))))))) (ert-deftest jabber-test-mam-native-accountless-room-departure () "An intentional accountless departure cancels that room on every account." (jabber-test-mam--with-native (let ((room "room@example.com") (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-participants nil) (calls 0)) (jabber-mam--query other nil "foreign-room" nil nil "elsewhere@example.com") (let ((survivor (car jabber-mam--syncing))) (dolist (account (list jc other)) (jabber-muc-add-groupchat room "nick" account) (jabber-mam--query account nil nil nil nil room nil nil (lambda () (cl-incf calls)))) (jabber-muc-remove-groupchat room) (should-not (jabber-muc-joined-p room)) (should (= 2 calls)) (should (equal (list survivor) jabber-mam--syncing)) (should (jabber-test-archive--idle-p)) (should (= 1 (length jabber-open-info-queries))))))) (ert-deftest jabber-test-mam-native-cleanup-callback-faults () "Error or quit cannot strand selected pages, timers, IQs or physical writes." (dolist (ending '(lost room all)) (dolist (failure '(error quit)) (jabber-test-mam--with-native (jabber-test-mam--with-lifecycle (let ((room "room@example.com") (calls nil) outcomes captures survivor) (jabber-mam--query other nil "foreign" nil nil nil nil nil (lambda () (push 'foreign calls)) (lambda (outcome) (push (cons 'foreign outcome) outcomes))) (setq survivor (car sent)) ;; The faulting page is selected first, before another active page ;; and a waiting timer. Every callback faults independently. (dolist (id '(waiting active fault)) (let ((query (jabber-mam--query jc nil nil nil nil room nil nil (lambda () (push id calls) (signal failure nil)) (lambda (outcome) (push (cons id outcome) outcomes) (signal failure nil))))) (push (jabber-test-mam--capture-page query (car sent) (eq id 'waiting)) captures))) (jabber-db-store-message "me@example.com" room "in" "groupchat" "accepted" 1 nil "row" "archive") (cl-labels ((cleanup () (pcase ending ('lost (fsm-send-sync jc (list :connection-dead (plist-get (fsm-get-state-data jc) :connection) "Fixture loss"))) ('room (jabber-mam--cancel-muc-query room jc)) ('all (jabber-mam--cleanup-all))))) (cleanup) (dolist (id '(waiting active fault)) (should (= 1 (cl-count id calls))) (should (= 1 (cl-count (cons id 'cancelled) outcomes :test #'equal)))) (dolist (capture captures) (jabber-test-mam--assert-retired capture) (jabber-test-mam--deliver-late-page capture)) (unless (eq ending 'lost) (cleanup)) (jabber-mam--cleanup-connection jc) (should (= 3 (length (remq 'foreign (copy-sequence calls)))))) (let ((reader (sqlite-open jabber-db-path))) (unwind-protect (progn (if (eq ending 'all) (should (jabber-test-archive--idle-p)) (should (jabber-test-archive--idle-p)) (should (= 1 (length jabber-open-info-queries))) (should (equal '(("accepted")) (sqlite-select reader "SELECT body FROM message"))) (jabber-test-mam--reply other survivor)) (should (equal '(("accepted")) (sqlite-select reader "SELECT body FROM message")))) (sqlite-close reader))) (should (= 1 (cl-count 'foreign calls))) (should (= 4 (length outcomes))) (should (equal (if (eq ending 'all) 'cancelled 'success) (alist-get 'foreign outcomes))) (should-not jabber-mam--syncing) (should-not jabber-open-info-queries) (should (jabber-test-archive--idle-p)))))))) (ert-deftest jabber-test-mam-native-cleanup-presentation-faults () "Attempt every peer and redraw hook despite earlier errors or quits." (dolist (failure '(error quit)) (jabber-test-mam--with-native (let* ((calls nil) (jabber-mam-peer-syncing-functions (list (lambda (&rest _) (push 'peer-fault calls) (signal failure nil)) (lambda (&rest _) (push 'peer-good calls)))) (jabber-mam-sync-complete-functions (list (lambda (_) (push 'redraw-fault calls) (signal failure nil)) (lambda (_) (push 'redraw-good calls))))) ;; Peer catch-ups awaiting discovery own tokens but no page yet. (jabber-mam--begin-peer-sync other "foreign@example.com") (jabber-mam--begin-peer-sync jc "one@example.com") (jabber-mam--begin-peer-sync jc "two@example.com") (jabber-mam--cleanup-connection jc) (should (= 2 (cl-count 'peer-good calls))) (should (= 2 (cl-count 'peer-fault calls))) (should (= 1 (length jabber-mam--peer-syncing))) ;; Put waiting queries behind the final active page: redisplay failure ;; must not prevent their completion or the remaining peer cleanup. (dotimes (_ 2) (let ((query (jabber-mam--query jc nil nil nil nil nil nil nil (lambda () (push 'complete calls))))) (jabber-test-mam--capture-page query (car sent) t))) (jabber-mam--query jc) (jabber-mam--mark-dirty jc "friend@example.com" "chat") (jabber-mam--cleanup-all) (jabber-mam--cleanup-all) (should (= 2 (cl-count 'complete calls))) (should (= 3 (cl-count 'peer-good calls))) (should (= 3 (cl-count 'peer-fault calls))) (should (= 1 (cl-count 'redraw-fault calls))) (should (= 1 (cl-count 'redraw-good calls))) (should-not jabber-mam--syncing) (should-not jabber-mam--peer-syncing) (should-not jabber-open-info-queries) (should-not jabber-mam--dirty-peers) (should (jabber-test-archive--idle-p)))))) (ert-deftest jabber-test-mam-native-public-disconnect-settlement () "Real voluntary single/all-account and lost-session paths settle personal MAM." (should (memq #'jabber-mam--cleanup-connection jabber-lifecycle-session-reset-functions)) (dolist (ending '(one all lost)) (dolist (waiting '(nil t)) (jabber-test-mam--with-native (jabber-test-mam--with-lifecycle (let ((a-calls 0) (b-calls 0) a-outcomes b-outcomes) (jabber-mam--query other nil "foreign" nil nil nil nil nil (lambda () (cl-incf b-calls)) (lambda (outcome) (push outcome b-outcomes))) (let* ((survivor (car sent)) (query (jabber-mam--query jc nil "personal" nil nil nil nil nil (lambda () (cl-incf a-calls)) (lambda (outcome) (push outcome a-outcomes)))) (capture (jabber-test-mam--capture-page query (car sent) waiting))) (jabber-db-store-message "me@example.com" "friend@example.com" "in" "chat" "accepted" 1 nil "row" "archive") (pcase ending ('one (jabber-disconnect-one jc t)) ('all (jabber-disconnect)) ('lost (fsm-send-sync jc (list :connection-dead (plist-get (fsm-get-state-data jc) :connection) "Fixture loss")))) (should-not (get jc :state)) (should (= 1 a-calls)) (jabber-test-mam--assert-retired capture) (jabber-test-mam--deliver-late-page capture) (jabber-mam--cleanup-connection jc) (should (= 1 a-calls)) (should (equal '(cancelled) a-outcomes)) (let ((reader (sqlite-open jabber-db-path))) (unwind-protect (progn (if (eq ending 'all) (progn (should-not (get other :state)) (should-not jabber-connections)) (should (= 0 b-calls)) (should-not b-outcomes) (should (eq :session-established (get other :state))) (should (memq other jabber-connections)) (should (jabber-test-archive--idle-p)) (should (= 1 (length jabber-open-info-queries))) (should (equal '(("accepted")) (sqlite-select reader "SELECT body FROM message"))) (jabber-test-mam--reply other survivor)) (should (equal '(("accepted")) (sqlite-select reader "SELECT body FROM message")))) (sqlite-close reader))) (should (= 1 b-calls)) (should (jabber-test-archive--idle-p)) (should (equal (list (if (eq ending 'all) 'cancelled 'success)) b-outcomes)) (should-not jabber-mam--syncing) (should-not jabber-open-info-queries)))))))) ;;; Explicit terminal outcome contract (ert-deftest jabber-test-mam-native-terminal-outcomes () "Report query success, failure and cancellation without changing legacy arity." (dolist (ending '(success bounded failed cancelled)) (jabber-test-mam--with-native (let* ((calls 0) observations (query (jabber-mam--query jc nil "outcome" nil nil "room@example.com" (eq ending 'bounded) 1 (lambda () (cl-incf calls)) (lambda (outcome) (push (list outcome calls (length jabber-mam--syncing) (jabber-test-archive--idle-p) (length jabber-open-info-queries)) observations)))) (request (car sent)) (jabber-test-mam-queryid "outcome") (xml (jabber-test-mam--make-message 1)) (refreshes nil) (jabber-mam-sync-complete-functions (list (lambda (peers) (push peers refreshes))))) (setf (cadr xml) '((from . "room@example.com"))) (jabber-mam--process-message jc xml) (pcase ending ('cancelled (jabber-mam--cancel-muc-query "room@example.com" jc)) (_ (jabber-test-mam--reply jc request "room@example.com" (eq ending 'failed) (eq ending 'bounded)))) (jabber-test-mam--reply jc request "room@example.com") (jabber-test-mam--reply jc request "room@example.com" t) (should (equal (list (list (if (eq ending 'bounded) 'success ending) 1 0 t 0)) observations)) (should-not (memq query jabber-mam--syncing)) (should (= 1 calls)) (should (= 1 (length refreshes))) (jabber-db-close) (should (equal '(("Message 1")) (sqlite-select (jabber-db-ensure-open) "SELECT body FROM message"))))))) (ert-deftest jabber-test-mam-native-nonprogress-outcome () "An incomplete forward page without a new cursor fails, not succeeds." (dolist (last '(nil "same")) (jabber-test-mam--with-native (let (outcomes) ;; Opt in to results without a legacy settlement callback. (jabber-mam--query jc "same" nil nil nil nil nil nil nil (lambda (outcome) (push outcome outcomes))) (fsm-send-sync jc `(:stanza (iq ((type . "result") (id . ,(jabber-xml-get-attribute (car sent) 'id))) (fin ((xmlns . ,jabber-mam-xmlns) (complete . "false")) (set ((xmlns . ,jabber-mam-rsm-xmlns)) ,@(when last `((last () ,last)))))))) (should (equal '(failed) outcomes)) (should-not jabber-mam--syncing) (should-not jabber-open-info-queries) (should (jabber-test-archive--idle-p)) (should (= 1 (length sent))))))) (ert-deftest jabber-test-mam-native-cancel-then-new-query-outcomes () "Cancel a room, start unrelated work, then replay stale fin/error both ways." (dolist (error-first '(nil t)) (jabber-test-mam--with-native (let ((a 0) (b 0) a-outcomes b-outcomes (jabber-test-mam-queryid "new-survivor")) (jabber-mam--query jc nil "cancel-first" nil nil "room@example.com" nil nil (lambda () (cl-incf a)) (lambda (outcome) (push outcome a-outcomes))) (let ((captured (car jabber-open-info-queries))) (jabber-mam--cancel-muc-query "room@example.com" jc) (should (= 1 a)) (should (equal '(cancelled) a-outcomes)) (should (jabber-test-archive--idle-p)) (let* ((survivor (jabber-mam--query jc nil jabber-test-mam-queryid nil nil nil nil nil (lambda () (cl-incf b)) (lambda (outcome) (push outcome b-outcomes)))) (request (car sent)) (pending (car jabber-open-info-queries)) (reader (sqlite-open jabber-db-path))) (unwind-protect (progn (jabber-mam--process-message jc (jabber-test-mam--make-message 1)) (dolist (index (if error-first '(2 1) '(1 2))) (let ((callback (nth index captured))) (funcall (car callback) jc '(iq ((from . "room@example.com")) (fin ((xmlns . "urn:xmpp:mam:2") (complete . "true")))) (cdr callback)))) (should (= 1 a)) (should (= 0 b)) (should (equal '(cancelled) a-outcomes)) (should-not b-outcomes) (should (jabber-test-archive--idle-p)) (should (equal (list survivor) jabber-mam--syncing)) (should (equal (list pending) jabber-open-info-queries)) ;; The survivor's result committed on arrival; stale ;; callbacks could not settle its cursor. (should (equal '(("Message 1")) (sqlite-select reader "SELECT body FROM message"))) (should-not (sqlite-select reader "SELECT uid FROM mam_progress")) (jabber-test-mam--reply jc request) (should (= 1 a)) (should (= 1 b)) (should (equal '(success) b-outcomes)) (should (jabber-test-archive--idle-p)) (should (equal '(("Message 1")) (sqlite-select reader "SELECT body FROM message")))) (sqlite-close reader)))))))) (ert-deftest jabber-test-mam-native-outcome-callback-reentry () "Each consumer can reenter then error or quit without leaking query outcomes." (dolist (consumer '(legacy result)) (dolist (failure '(error quit)) (jabber-test-mam--with-native (let ((calls 0) outcomes nested-outcomes foreign-outcomes observations capture) (jabber-mam--query other nil "foreign" nil nil nil nil nil nil (lambda (outcome) (push outcome foreign-outcomes))) (let ((foreign (car jabber-mam--syncing)) (foreign-iq (car jabber-open-info-queries)) (foreign-request (car sent))) (cl-labels ((reenter () ;; Retirement is observable before either consumer. Replay ;; the captured page and cleanup while the old stack exists. (push (list (memq (car capture) jabber-mam--syncing) (plist-get (car capture) :transaction)) observations) (jabber-test-mam--deliver-late-page capture) (jabber-mam--cleanup-connection jc) (jabber-mam--query jc nil "nested" nil nil nil nil nil nil (lambda (outcome) (push outcome nested-outcomes))) (jabber-test-mam--reply jc (car sent) nil t) (signal failure nil))) (let ((query (jabber-mam--query jc nil "outer" nil nil nil nil nil (lambda () (cl-incf calls) (when (eq consumer 'legacy) (reenter))) (lambda (outcome) (push outcome outcomes) (when (eq consumer 'result) (reenter)))))) (setq capture (jabber-test-mam--capture-page query (car sent))) (jabber-test-mam--reply jc (car sent)))) (should (equal '((nil nil)) observations)) (should (= 1 calls)) (should (equal '(success) outcomes)) (should (equal '(failed) nested-outcomes)) (should-not foreign-outcomes) (should (equal (list foreign) jabber-mam--syncing)) (should (equal (list foreign-iq) jabber-open-info-queries)) (should (jabber-test-archive--idle-p)) (jabber-test-mam--deliver-late-page capture) (should (= 1 (length outcomes))) (jabber-test-mam--reply other foreign-request) (should (equal '(success) foreign-outcomes)) (should (jabber-test-archive--idle-p)))))))) ;;; Progressive room catch-up display (defun jabber-test-mam--room-message (jc request room index &optional body) "Deliver room archive message INDEX for REQUEST through JC. ROOM is the archive JID. BODY, when non-nil, replaces the message body." (let* ((jabber-test-mam-queryid (jabber-xml-get-attribute (car (jabber-xml-get-children request 'query)) 'queryid)) (xml (jabber-test-mam--make-message index room "groupchat"))) (setf (cadr xml) `((from . ,room))) (when body (let ((inner (nth 2 (jabber-mam--parse-result xml)))) (setcar (cddr (car (jabber-xml-get-children inner 'body))) body))) (jabber-mam--process-message jc xml))) (defun jabber-test-mam--room-page (jc request room index complete) "Deliver room archive message INDEX and REQUEST's fin through JC. ROOM is the archive JID. COMPLETE marks the last page." (jabber-test-mam--room-message jc request room index) (fsm-send-sync jc `(:stanza (iq ((type . "result") (from . ,room) (id . ,(jabber-xml-get-attribute request 'id))) (fin ((xmlns . ,jabber-mam-xmlns) (complete . ,(if complete "true" "false"))) (set ((xmlns . ,jabber-mam-rsm-xmlns)) (last () ,(format "archive-%06d" index)))))))) (defun jabber-test-mam--wait-for (predicate) "Run timers until PREDICATE returns non-nil or two seconds pass." (let ((deadline (+ (float-time) 2))) (while (and (not (funcall predicate)) (< (float-time) deadline)) (accept-process-output nil 0.05)) (funcall predicate))) (ert-deftest jabber-test-mam-room-catch-up-is-progressive () "Committed room pages appear while catch-up continues, with an indicator." (jabber-test-mam--with-native (let* ((room "room@example.com") (jabber-mam-page-size 1) (jabber-mam--redraw-delay 0.05) (jabber-mam-sync-complete-functions (list #'jabber-chat--handle-mam-sync-complete)) (jabber-chat-mode-hook nil) (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) (jabber-jid-obarray (make-vector 127 0)) (jabber-groupchat-buffer-format " *jabber-test-mam-%a-%j*") (buffer (jabber-muc-create-buffer jc room)) (foreign (jabber-muc-create-buffer other room))) (unwind-protect (cl-letf (((symbol-function 'jabber-disco-get-info) (lambda (jc _to _node callback closure) (funcall callback jc closure (list nil (list jabber-mam-xmlns)))))) (with-current-buffer buffer (goto-char (point-max)) (insert "unsent draft")) (jabber-mam-muc-joined jc room) (should (buffer-local-value 'jabber-chat-mam-syncing buffer)) (should-not (buffer-local-value 'jabber-chat-mam-syncing foreign)) (jabber-test-mam--room-page jc (car sent) room 1 nil) ;; Page 1 is committed; the next page is still outstanding. (should (jabber-test-mam--wait-for (lambda () (= 2 (length sent))))) (should (jabber-test-mam--wait-for (lambda () (with-current-buffer buffer (string-search "Message 1" (buffer-string)))))) (should (jabber-mam-syncing-p)) (should (buffer-local-value 'jabber-chat-mam-syncing buffer)) (with-current-buffer foreign (should-not (string-search "Message 1" (buffer-string)))) (jabber-test-mam--room-page jc (car sent) room 2 t) (should-not (jabber-mam-syncing-p)) (should-not (buffer-local-value 'jabber-chat-mam-syncing buffer)) (should (jabber-test-mam--wait-for (lambda () (with-current-buffer buffer (string-search "Message 2" (buffer-string)))))) (with-current-buffer buffer (let ((text (buffer-string))) (should (= 1 (cl-count-if (lambda (data) (equal "Message 1" (plist-get (cadr data) :body))) (ewoc-collect jabber-chat-ewoc #'identity)))) (should (string-search "Message 1" text)) (should (equal "unsent draft" (buffer-substring-no-properties jabber-point-insert (point-max))))))) (kill-buffer buffer) (kill-buffer foreign))))) (ert-deftest jabber-test-mam-progressive-redraw-keeps-history-reader () "A progressive redraw leaves a buffer alone while its reader reads history. The refresh reloads only the newest backlog window, which can evict the reader's anchor and move the window to the composer. The buffer is left for the completion refresh, which behaves as it did before progressive display and so is not asserted to keep the anchor." (jabber-test-mam--with-native (save-window-excursion (let* ((room "room@example.com") (jabber-backlog-number 10) (jabber-mam-page-size 1) (jabber-mam--redraw-delay 0.05) (jabber-mam-sync-complete-functions (list #'jabber-chat--handle-mam-sync-complete)) (jabber-chat-mode-hook nil) (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) (jabber-jid-obarray (make-vector 127 0)) (jabber-groupchat-buffer-format " *jabber-test-mam-%a-%j*") (buffer (jabber-muc-create-buffer jc room))) (unwind-protect (progn ;; Seed ten loaded messages from a completed page. (jabber-mam--query jc nil nil nil nil room nil 10) (let ((request (car sent))) (dolist (index '(1 2 4 5 7 8 10 11 13)) (jabber-test-mam--room-message jc request room index)) (jabber-test-mam--room-page jc request room 14 t)) (should (jabber-test-mam--wait-for (lambda () (null jabber-mam--redraw-timer)))) (with-current-buffer buffer (should (string-search "Message 1" (buffer-string))) (goto-char (point-max)) (insert "draft survives")) (switch-to-buffer buffer) (let* ((window (selected-window)) (pos (with-current-buffer buffer (ewoc-location (jabber-chat-ewoc-find-by-id "archive-000001"))))) (set-window-start window pos t) (set-window-point window pos) (with-current-buffer buffer (should (equal '(msg . "archive-000001") (jabber-chat-buffer--window-anchor window)))) ;; Page 16 commits; the catch-up continues. (jabber-mam--query jc "archive-000014" nil nil nil room) (jabber-test-mam--room-page jc (car sent) room 16 nil) (should jabber-mam--redraw-timer) (should (jabber-test-mam--wait-for (lambda () (null jabber-mam--redraw-timer)))) (should (jabber-mam-syncing-p)) (with-current-buffer buffer (should (equal '(msg . "archive-000001") (jabber-chat-buffer--window-anchor window))) (should (equal "draft survives" (buffer-substring-no-properties jabber-point-insert (point-max)))) (should-not (string-search "Message 16" (buffer-string)))) ;; Completion still refreshes the deferred buffer. (should (jabber-test-mam--wait-for (lambda () (= 3 (length sent))))) (jabber-test-mam--room-page jc (car sent) room 17 t) (should-not (jabber-mam-syncing-p)) (with-current-buffer buffer (should (string-search "Message 16" (buffer-string))) (should (string-search "Message 17" (buffer-string))) (should (equal "draft survives" (buffer-substring-no-properties jabber-point-insert (point-max))))))) (kill-buffer buffer)))))) (ert-deftest jabber-test-mam-rollback-redraws-speculative-rows () "A result whose transaction fails never shows its row in the buffer. Each result commits in its own short transaction before any redraw can read it. A real SQLITE_FULL while storing page 2 leaves page 1 displayed, page 2 nowhere and the draft intact." (jabber-test-mam--with-native (let* ((room "room@example.com") (jabber-mam-page-size 1) (jabber-mam--redraw-delay 0.05) (jabber-mam-sync-complete-functions (list #'jabber-chat--handle-mam-sync-complete)) (jabber-chat-mode-hook nil) (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) (jabber-jid-obarray (make-vector 127 0)) (jabber-groupchat-buffer-format " *jabber-test-mam-%a-%j*") (buffer (jabber-muc-create-buffer jc room))) (unwind-protect (progn (with-current-buffer buffer (goto-char (point-max)) (insert "unsent draft")) (sqlite-execute jabber-db--connection (format "PRAGMA max_page_count=%d" (+ 20 (caar (sqlite-select jabber-db--connection "PRAGMA page_count"))))) (jabber-mam--query jc nil nil nil nil room) (jabber-test-mam--room-page jc (car sent) room 1 nil) (should (jabber-test-mam--wait-for (lambda () (= 2 (length sent))))) (should (jabber-test-mam--wait-for (lambda () (with-current-buffer buffer (string-search "Message 1" (buffer-string)))))) ;; Page 2's row arrives; it does not fit in the database. (should-error (jabber-test-mam--room-message jc (car sent) room 2 (concat "Message 2 " (make-string (* 1024 1024) ?x))) :type 'sqlite-error) (should (jabber-test-archive--idle-p)) (jabber-test-mam--reply jc (car sent) room) (should-not (jabber-mam-syncing-p)) (should (equal '(("Message 1")) (sqlite-select jabber-db--connection "SELECT body FROM message ORDER BY id"))) (should (jabber-test-mam--wait-for (lambda () (null jabber-mam--redraw-timer)))) (with-current-buffer buffer (should (string-search "Message 1" (buffer-string))) (should-not (string-search "Message 2" (buffer-string))) (should (equal "unsent draft" (buffer-substring-no-properties jabber-point-insert (point-max)))))) (kill-buffer buffer))))) (ert-deftest jabber-test-mam-progressive-redraw-keeps-idless-history-reader () "A progressive redraw leaves a history reader alone without message IDs. Stored incoming chat messages need not carry message/@id or an XEP-0359 server-id, so the reader's window has no message anchor; it still does not follow the composer and must not be moved there mid-sync." (jabber-test-mam--with-native (save-window-excursion (let* ((peer "friend@example.com") (jabber-backlog-number 10) (jabber-mam--redraw-delay 0.05) (jabber-chat-mode-hook nil) (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) (jabber-chat-buffer-format " *jabber-test-mam-%a-%j*") (buffer (jabber-chat-create-buffer jc peer)) (refreshes 0) (refresh (symbol-function 'jabber-chat-buffer-refresh))) (unwind-protect (progn (dotimes (index 10) (jabber-db-store-message "me@example.com" peer "in" "chat" (format "Existing message %d\n%s" index (make-string 100 ?x)) (+ 1700000000 index) "phone")) (with-current-buffer buffer (jabber-chat-buffer-refresh)) (switch-to-buffer buffer) (let ((node (ewoc-nth jabber-chat-ewoc 0))) (while (eq (car (ewoc-data node)) :rare-time) (setq node (ewoc-next jabber-chat-ewoc node))) (set-window-start (selected-window) (ewoc-location node) t) (set-window-point (selected-window) (ewoc-location node))) (should (< (window-point (selected-window)) jabber-point-insert)) (should (jabber-chat-buffer--reading-history-p)) (cl-letf (((symbol-function 'jabber-chat-buffer-refresh) (lambda () (cl-incf refreshes) (funcall refresh)))) (jabber-mam--query jc) (let* ((request (car sent)) (jabber-test-mam-queryid (jabber-xml-get-attribute (car (jabber-xml-get-children request 'query)) 'queryid)) (xml (jabber-test-mam--make-message 1 peer "chat")) (inner (nth 2 (jabber-mam--parse-result xml)))) (setf (cadr inner) (assq-delete-all 'id (cadr inner))) (jabber-mam--process-message jc xml) (jabber-test-mam--reply jc request nil nil t)) (should (jabber-test-mam--wait-for (lambda () (null jabber-mam--redraw-timer)))) (should (jabber-mam-syncing-p)) (should (= 0 refreshes)))) (kill-buffer buffer)))))) (ert-deftest jabber-test-mam-progressive-redraw-thread-and-account-policy () "Progressive redraw skips history readers in any window, per account. A thread buffer read in one of two windows is skipped while its parent refreshes; once both windows follow the composer it refreshes. The completion refresh covers a history reader. Another account's buffers for the same room are never touched." (jabber-test-mam--with-native (save-window-excursion (let* ((room "room@example.com") (jabber-chat-mode-hook nil) (jabber-message-thread-use-buffers t) (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) (jabber-jid-obarray (make-vector 127 0)) (jabber-groupchat-buffer-format " *jabber-test-mam-%a-%j*") (parent (jabber-muc-create-buffer jc room)) (foreign-parent (jabber-muc-create-buffer other room)) (thread (jabber-message-thread-create-buffer jc room "groupchat" "thread-a" nil parent)) (foreign-thread (jabber-message-thread-create-buffer other room "groupchat" "thread-a" nil foreign-parent)) (peers (list (list "me@example.com" room "groupchat"))) refreshed marked) (unwind-protect (progn (with-current-buffer thread (jabber-chat-ewoc-enter (list :muc-foreign (list :id "client-1" :server-id "room-1" :body "Read me" :from "room@example.com/occupant" :msg-type "groupchat" :timestamp (seconds-to-time 1700000000))))) (switch-to-buffer thread) (let* ((bottom (selected-window)) (history (split-window-below)) (insert (buffer-local-value 'jabber-point-insert thread)) (pos (with-current-buffer thread (ewoc-location (jabber-chat-ewoc-find-by-id "room-1"))))) (set-window-buffer history thread) (set-window-point bottom insert) (set-window-start history pos t) (set-window-point history pos) (with-current-buffer thread (should (jabber-chat-buffer--reading-history-p))) (cl-letf (((symbol-function 'jabber-chat-buffer-refresh) (lambda () (push (current-buffer) refreshed))) ((symbol-function 'jabber-db-mark-message-thread-read) (lambda (&rest args) (push args marked)))) (jabber-chat--handle-mam-sync-complete peers t) (should (memq parent refreshed)) (should-not (memq thread refreshed)) (should-not (memq foreign-parent refreshed)) (should-not (memq foreign-thread refreshed)) (should-not marked) ;; Both windows follow the composer. (set-window-point history insert) (setq refreshed nil) (jabber-chat--handle-mam-sync-complete peers t) (should (memq thread refreshed)) (should (= 1 (length marked))) (should-not (memq foreign-thread refreshed)) ;; Completion refreshes even a history reader. (set-window-point history pos) (setq refreshed nil) (jabber-chat--handle-mam-sync-complete peers) (should (memq thread refreshed))))) (dolist (buffer (list thread foreign-thread parent foreign-parent)) (when (buffer-live-p buffer) (kill-buffer buffer)))))))) (ert-deftest jabber-test-mam-rollback-reconciles-history-reader () "A history reader never sees a result whose transaction fails. The reader scrolls into history before page 2 arrives; page 2's transaction fails, so its row is never displayed and page 1 stays visible." (jabber-test-mam--with-native (save-window-excursion (let* ((room "room@example.com") (jabber-mam-page-size 1) (jabber-mam--redraw-delay 0.05) (jabber-chat-mode-hook nil) (jabber-mam-sync-complete-functions (list #'jabber-chat--handle-mam-sync-complete)) (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) (jabber-jid-obarray (make-vector 127 0)) (jabber-groupchat-buffer-format " *jabber-test-mam-%a-%j*") (buffer (jabber-muc-create-buffer jc room))) (unwind-protect (progn (sqlite-execute jabber-db--connection (format "PRAGMA max_page_count=%d" (+ 20 (caar (sqlite-select jabber-db--connection "PRAGMA page_count"))))) (jabber-mam--query jc nil nil nil nil room) (jabber-test-mam--room-page jc (car sent) room 1 nil) (should (jabber-test-mam--wait-for (lambda () (= 2 (length sent))))) (should (jabber-test-mam--wait-for (lambda () (with-current-buffer buffer (string-search "Message 1" (buffer-string)))))) ;; The reader scrolls into history before page 2 settles. (switch-to-buffer buffer) (let ((pos (with-current-buffer buffer (ewoc-location (jabber-chat-ewoc-find-by-id "archive-000001"))))) (set-window-start (selected-window) pos t) (set-window-point (selected-window) pos)) (with-current-buffer buffer (should (jabber-chat-buffer--reading-history-p))) (should-error (jabber-test-mam--room-message jc (car sent) room 2 (concat "Message 2 " (make-string (* 1024 1024) ?x))) :type 'sqlite-error) (jabber-test-mam--reply jc (car sent) room) (should-not (jabber-mam-syncing-p)) (should (equal '(("Message 1")) (sqlite-select jabber-db--connection "SELECT body FROM message ORDER BY id"))) (should (jabber-test-mam--wait-for (lambda () (null jabber-mam--redraw-timer)))) (with-current-buffer buffer (should (string-search "Message 1" (buffer-string))) (should-not (string-search "Message 2" (buffer-string))))) (kill-buffer buffer)))))) (ert-deftest jabber-test-mam-peer-syncing-hook-keeps-three-arguments () "Three-argument handlers still run; a failing one strands no catch-up." (jabber-test-mam--with-native (let* ((peer "friend@example.com") (calls nil) (jabber-mam-peer-syncing-functions (list (lambda (_peer _type _syncing-p) (error "Handler bug")) (lambda (peer type syncing-p) (push (list peer type syncing-p) calls))))) (cl-letf (((symbol-function 'jabber-disco-get-info) (lambda (jc _to _node callback closure) (funcall callback jc closure (list nil (list jabber-mam-xmlns)))))) (jabber-mam-chat-opened jc peer) (should (equal (list (list peer "chat" t)) calls)) (should (= 1 (length sent))) (jabber-test-mam--reply jc (car sent)) (should (equal (list peer "chat" nil) (car calls))) (should-not jabber-mam--peer-syncing) (should-not (jabber-mam-syncing-p)))))) (provide 'jabber-test-mam) ;;; jabber-test-mam.el ends here emacs-jabber-0.15.1/tests/jabber-test-menu.el000066400000000000000000000364251527111033600207520ustar00rootroot00000000000000;;; 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))) (ert-deftest jabber-test-menu-thread-title-context () "Resolve the title command only in its current thread buffer." (with-temp-buffer (let ((map jabber-chat-operations-menu-map)) (use-local-map map) (dolist (id '(nil "thread-id" nil "other-thread")) (setq-local jabber-message-thread-id id) (let ((command (and id #'jabber-message-thread-set-title))) (should (eq (keymap-lookup map "L") command)) (should (eq (local-key-binding (kbd "L")) command))))))) (defun jabber-test-menu--connection (name contacts) "Return a disposable connection NAME with CONTACTS." (let ((jc (make-symbol name))) (put jc :state-data (list :username name :server "example.test" :roster (mapcar (lambda (jid) (jabber-jid-symbol jid jc)) contacts))) jc)) (ert-deftest jabber-test-menu-scoped-contact-actions () "Every action uses the selected account when peers overlap." (let* ((jabber-jid-obarray (make-vector 31 0)) (a (jabber-test-menu--connection "a" '("peer@example.test"))) (b (jabber-test-menu--connection "b" '("peer@example.test"))) (jabber-connections (list a b)) (jabber-roster--scoped-connection b) (jabber-roster--selected-jid "peer@example.test") calls) (cl-letf (((symbol-function 'jabber-chat-with) (lambda (jc jid) (push (list jc jid) calls))) ((symbol-function 'jabber-get-info) (lambda (jc jid) (push (list jc jid) calls))) ((symbol-function 'jabber-roster-delete) (lambda (jc jid) (push (list jc jid) calls))) ((symbol-function 'jabber-blocking-block-jid) (lambda (jc jid) (push (list jc jid) calls))) ((symbol-function 'yes-or-no-p) (lambda (&rest _) t))) (mapc #'call-interactively '(jabber-roster--action-chat jabber-roster--action-info jabber-roster--action-delete jabber-roster--action-block))) (should (= (length calls) 4)) (should (cl-every (lambda (call) (eq (car call) b)) calls)))) (ert-deftest jabber-test-menu-selection-survives-scope-change () "A selected contact retains its owner even after scope changes." (let* ((jabber-jid-obarray (make-vector 31 0)) (a (jabber-test-menu--connection "a" '("peer@example.test"))) (b (jabber-test-menu--connection "b" '("peer@example.test"))) (peer (jabber-jid-symbol "peer@example.test" b)) (jabber-connections (list a b)) (jabber-roster--scoped-connection b) (jabber-roster--selected-jid nil) calls) (cl-letf (((symbol-function 'jabber-read-jid-completing) (lambda (_prompt subset &rest _) (should (equal subset (list peer))) (setq jabber-roster--scoped-connection a) "peer@example.test")) ((symbol-function 'keymap-popup) #'ignore) ((symbol-function 'jabber-chat-with) (lambda (jc jid) (push (list jc jid) calls)))) (call-interactively #'jabber-roster-chat-any) (call-interactively #'jabber-roster--action-chat) (should (eq (caar calls) b)) (setq jabber-connections (list a)) (should-error (call-interactively #'jabber-roster--action-chat) :type 'user-error) (should (= (length calls) 1))))) (ert-deftest jabber-test-menu-delete-retains-selection-through-prompt () "Confirmation cannot retarget the selected contact or retired account." (let* ((jabber-jid-obarray (make-vector 31 0)) (a (jabber-test-menu--connection "a" '("peer@example.test"))) (b (jabber-test-menu--connection "b" '("peer@example.test"))) (jabber-connections (list a b)) (jabber-roster--scoped-connection b) (jabber-roster--selected-jid "peer@example.test") sent) (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) (setq jabber-roster--selected-jid "other@example.test" jabber-roster--scoped-connection a) t)) ((symbol-function 'jabber-roster-delete) (lambda (jc jid) (setq sent (list jc jid))))) (call-interactively #'jabber-roster--action-delete) (should (equal sent (list b "peer@example.test")))))) (ert-deftest jabber-test-menu-online-scoped-and-empty () "Online completion stays scoped, including when its subset is empty." (let* ((jabber-jid-obarray (make-vector 31 0)) (a (jabber-test-menu--connection "a" '("peer@example.test"))) (b (jabber-test-menu--connection "b" '("peer@example.test"))) (peer (jabber-jid-symbol "peer@example.test" b)) (jabber-connections (list a b)) (jabber-roster--scoped-connection b) sent) (put peer 'connected t) (cl-letf (((symbol-function 'jabber-read-jid-completing) (lambda (_prompt subset &rest _) (should (equal subset (list peer))) (setq jabber-roster--scoped-connection a) "peer@example.test")) ((symbol-function 'jabber-chat-with) (lambda (jc jid) (setq sent (list jc jid))))) (call-interactively #'jabber-roster-chat-online) (should (equal sent (list b "peer@example.test"))) (put peer 'connected nil) (should-error (call-interactively #'jabber-roster-chat-online) :type 'user-error)))) (ert-deftest jabber-test-menu-ambiguous-contact-asks-and-retains-account () "Unscoped duplicate peers require an account choice, retained by actions." (let* ((jabber-jid-obarray (make-vector 31 0)) (a (jabber-test-menu--connection "a" '("peer@example.test"))) (b (jabber-test-menu--connection "b" '("peer@example.test"))) (jabber-connections (list a b)) (jabber-roster--scoped-connection nil) (jabber-roster--selected-jid nil) (choices 0) sent) (cl-letf (((symbol-function 'jabber-read-jid-completing) (lambda (&rest _) "peer@example.test")) ((symbol-function 'completing-read) (lambda (_prompt accounts &rest _) (cl-incf choices) (should (equal (mapcar #'cdr accounts) (list a b))) "b@example.test")) ((symbol-function 'keymap-popup) #'ignore) ((symbol-function 'jabber-blocking-block-jid) (lambda (jc jid) (setq sent (list jc jid))))) (call-interactively #'jabber-roster-chat-any) (call-interactively #'jabber-roster--action-block) (should (= choices 1)) (should (equal sent (list b "peer@example.test")))))) (ert-deftest jabber-test-menu-roster-edit-policy () "Both entry points preserve defaults, empty groups, and selected account." (dolist (command '(jabber-roster-change jabber-roster--action-edit)) (dolist (groups '(("friends") ("work" "family") ("") nil)) (let* ((jabber-jid-obarray (make-vector 31 0)) (jc (jabber-test-menu--connection "a" '("peer@example.test"))) (peer (jabber-jid-symbol "peer@example.test" jc)) (jabber-connections (list jc)) (jabber-roster--scoped-connection jc) (jabber-roster--selected-jid "peer@example.test") sent) (put peer 'name "Peer") (put peer 'groups '("friends")) (cl-letf (((symbol-function 'jabber-read-jid-completing) (lambda (&rest _) "peer@example.test")) ((symbol-function 'read-string) (lambda (_prompt _initial _history default &rest _) (should (equal default "Peer")) ;; A recursive command changing global selection is harmless. (setq jabber-roster--selected-jid "other@example.test") default)) ((symbol-function 'completing-read-multiple) (lambda (_prompt candidates _pred _match _initial _history default &rest _) (should (equal candidates '("friends"))) (should (equal default "friends")) (copy-sequence groups))) ((symbol-function 'jabber-send-iq) (lambda (owner _to _type stanza &rest _) (setq sent (list owner stanza))))) (call-interactively command) (should (eq (car sent) jc)) (let ((item (car (jabber-xml-get-children (cadr sent) 'item)))) (should (equal (jabber-xml-get-attribute item 'jid) "peer@example.test")) (should (equal (jabber-xml-get-attribute item 'name) "Peer")) (should (equal (mapcar #'jabber-xml-node-children (jabber-xml-get-children item 'group)) (mapcar #'list (delete "" (copy-sequence groups))))))))))) (ert-deftest jabber-test-menu-roster-edit-quit-and-disconnect () "Cancellation and retirement during editing cause zero remote mutation." (dolist (command '(jabber-roster-change jabber-roster--action-edit)) (dolist (failure '(quit disconnect)) (let* ((jabber-jid-obarray (make-vector 31 0)) (jc (jabber-test-menu--connection "a" '("peer@example.test"))) (jabber-connections (list jc)) (jabber-roster--scoped-connection jc) (jabber-roster--selected-jid "peer@example.test") sent) (cl-letf (((symbol-function 'jabber-read-jid-completing) (lambda (&rest _) "peer@example.test")) ((symbol-function 'read-string) (lambda (&rest _) "Peer")) ((symbol-function 'completing-read-multiple) (lambda (&rest _) (if (eq failure 'quit) (signal 'quit nil) (setq jabber-connections nil) '("friends")))) ((symbol-function 'jabber-send-iq) (lambda (&rest _) (setq sent t)))) (if (eq failure 'quit) (should (eq (condition-case nil (progn (call-interactively command) 'sent) (quit 'cancelled)) 'cancelled)) (should-error (call-interactively command) :type 'user-error)) (should-not sent)))))) (ert-deftest jabber-test-menu-scoped-room-switch () "Room candidates and the actual switched buffer retain the selected account." (let* ((a (jabber-test-menu--connection "a" nil)) (b (jabber-test-menu--connection "b" nil)) (jabber-connections (list a b)) (jabber-roster--scoped-connection b) (jabber-muc--rooms (make-hash-table :test #'equal)) (jabber-db-path nil) (jabber-chat-mode-hook nil) created) (unwind-protect (save-window-excursion (jabber-muc-join-set "only-a@example.test" a "alice") (jabber-muc-join-set "shared@example.test" a "alice") (jabber-muc-join-set "shared@example.test" b "bob") (push (jabber-muc-create-buffer a "shared@example.test") created) (push (jabber-muc-create-buffer b "shared@example.test") created) (cl-letf (((symbol-function 'jabber-get-conference-data) (lambda (jc &rest _) (should (eq jc b)) "Shared")) ((symbol-function 'completing-read) (lambda (_prompt table &rest _) (should (equal (all-completions "" table) '("Shared"))) (setq jabber-roster--scoped-connection a) "Shared"))) (jabber-roster-switch-muc t) (should (eq (current-buffer) (car created))) (should (eq jabber-buffer-connection b)))) (mapc #'kill-buffer created)))) (provide 'jabber-test-menu) ;;; jabber-test-menu.el ends here emacs-jabber-0.15.1/tests/jabber-test-message-correct.el000066400000000000000000002046431527111033600230700ustar00rootroot00000000000000;;; 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-rejections-are-silent () "Repeated rejected corrections neither notify nor change messages." (dolist (case '(missing ambiguous undecryptable unknown wrong-sender)) (let* ((scoped-p (memq case '(missing ambiguous undecryptable))) (candidate '(:from "alice@example.com/phone" :row-id 1)) (candidates (pcase case ('missing nil) ('ambiguous (list candidate candidate)) (_ (list candidate)))) notifications writes renders) (cl-letf (((symbol-function 'jabber-db-message-correction-candidates) (lambda (&rest _) candidates)) ((symbol-function 'jabber-db-message-sender-by-stanza-id) (lambda (_id) (unless (eq case 'unknown) "alice@example.com/phone"))) ((symbol-function 'jabber-db-correct-message) (lambda (&rest _) (push t writes))) ((symbol-function 'jabber-db-correct-message-row) (lambda (&rest _) (push t writes))) ((symbol-function 'jabber-message-correct--update-buffer) (lambda (&rest _) (push t renders))) ((symbol-function 'message) (lambda (&rest args) (push args notifications)))) (dotimes (_ 10) (should-not (jabber-message-correct--apply "original" (if (eq case 'undecryptable) "[OMEMO: could not decrypt]" "corrected") (if (eq case 'wrong-sender) "mallory@example.com/phone" "alice@example.com/laptop") nil (lambda (_original) (push t renders)) nil (and scoped-p "me@example.com") (and scoped-p "alice@example.com"))))) (should-not notifications) (should-not writes) (should-not renders)))) (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 (_ &optional _jc) 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 (_ &optional _jc) 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 &optional success _failure) (let* ((replace (car (jabber-xml-get-children stanza 'replace)))) (setq sent-replace-id (jabber-xml-get-attribute replace 'id))) (when success (funcall success)))) ((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 &optional _jc) 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 &optional success _failure) (setq sent stanza) (when success (funcall success)))) ((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 &optional success _failure) (setq sent stanza) (when success (funcall success)))) ((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 &optional success _failure) (setq sent stanza) (when success (funcall success)))) ((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-persists () "An OMEMO handoff commits its row even after its original view 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 (= 1 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")))) (defun jabber-test-message-correct--r4-view (change outcome) "Complete a native correction with view CHANGE and transport OUTCOME." (require 'jabber-sm-runtime) (let* ((a (make-symbol "account-a")) (b (make-symbol "account-b")) (jabber-connections (list a b)) (jabber-db-path (make-temp-file "jabber-correction-" nil ".sqlite")) (jabber-db--connection nil) (jabber-chat-buffer-format " *jabber-correction-owner*") (jabber-chat-default-encryption 'plaintext) (jabber-chat-mode-hook nil) (jabber-chat-display-help-at-point nil) (jabber-chat-display-images nil) (jabber-chat-display-link-previews nil) (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) wire successor-token) (dolist (jc (list a b)) (put jc :state :session-established) (put jc :state-data (list :username (if (eq jc a) "a" "b") :server "example.test" :resource "test" :connection 'inert-transport :send-function (lambda (_connection xml) (push xml wire)) :sm-enabled t :sm-outbound-count 0 :sm-last-acked 0 :sm-pending-queue nil))) (jabber-db-ensure-open) (jabber-db-store-message "a@example.test" "peer@example.test" "out" "chat" "A original" 100 nil "same-id") (jabber-db-store-message "b@example.test" "peer@example.test" "out" "chat" "B original" 100 nil "same-id") (jabber-db-store-message "a@example.test" "other@example.test" "out" "chat" "other original" 100 nil "same-id") (let* ((buffer (jabber-chat-create-buffer a "peer@example.test")) (retarget (lambda () (jabber-chat-create-buffer (if (eq change 'peer) a b) (if (eq change 'peer) "other@example.test" "peer@example.test")) ;; The native constructor updates the account, not an existing ;; peer. Exercise peer reassignment separately without mode reset. (when (eq change 'peer) (setq-local jabber-chatting-with "other@example.test")) (jabber-chat-buffer-refresh))) (sql (symbol-function 'jabber-db-correct-message-row))) (unwind-protect (with-current-buffer buffer (let ((jabber-sm-max-in-flight 0)) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "A correction"))) (jabber-correct-last-message))) (let* ((token jabber-message-correct--pending-outgoing) (entry (car (plist-get (get a :state-data) :sm-pending-queue))) (ewoc jabber-chat-ewoc)) (should token) (should entry) (should-not wire) (when (memq change '(account peer)) (funcall retarget) ;; The native constructor did not rerun the mode or retire A. (should (eq token jabber-message-correct--pending-outgoing)) (should (car token)) (should (eq ewoc jabber-chat-ewoc))) (cl-letf (((symbol-function 'jabber-db-correct-message-row) (lambda (row body) (funcall sql row body) (when (eq change 'sql-reentry) (funcall retarget) ;; Native B admission replaces A's retired token; ;; no mode reset or manual pending-slot clearing. (let ((jabber-sm-max-in-flight 0)) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "B correction"))) (jabber-correct-last-message))) (setq successor-token jabber-message-correct--pending-outgoing))))) (if (eq outcome 'discard) (jabber-sm--discard-pending (get a :state-data) "Test discard") (let ((jabber-sm-max-in-flight nil)) (jabber-sm--drain-pending a (get a :state-data))))) (should-not (car token)) (should (= (length wire) (if (eq outcome 'discard) 0 1))) (should (equal (list (list "a@example.test" "other@example.test" "other original") (list "a@example.test" "peer@example.test" (if (eq outcome 'discard) "A original" "A correction")) (list "b@example.test" "peer@example.test" "B original")) (sqlite-select jabber-db--connection "SELECT account, peer, body FROM message ORDER BY account, peer"))) (should (equal (pcase change ('nil (if (eq outcome 'discard) "A original" "A correction")) ('peer "other original") (_ "B original")) (plist-get (cadr (ewoc-data (jabber-chat-ewoc-find-by-id "same-id"))) :body))) (if (null change) (should-not jabber-message-correct--pending-outgoing) (should (eq (or successor-token token) jabber-message-correct--pending-outgoing))) (when (memq change '(account peer)) (let ((jabber-sm-max-in-flight 0)) (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "successor correction"))) (jabber-correct-last-message))) (setq successor-token jabber-message-correct--pending-outgoing)) (when successor-token (should (car successor-token))) (let ((text (buffer-string)) (rows (sqlite-select jabber-db--connection "SELECT * FROM message"))) (funcall (plist-get entry :success)) (funcall (plist-get entry :failure) "late") (should (equal text (buffer-string))) (should (equal rows (sqlite-select jabber-db--connection "SELECT * FROM message"))) (when successor-token (should (car successor-token)))))) (when (buffer-live-p buffer) (kill-buffer buffer)) (jabber-db-close) (delete-file jabber-db-path))))) (ert-deftest jabber-test-message-correct-r4-native-retarget () "Same-mode account or peer replacement cannot publish a stale correction." (dolist (change '(nil account peer)) (dolist (outcome '(success discard)) (ert-info ((format "change=%S outcome=%S" change outcome)) (jabber-test-message-correct--r4-view change outcome))))) (ert-deftest jabber-test-message-correct-r4-native-sql-reentry () "After native SQL, revalidate the view and preserve B's new pending token." (jabber-test-message-correct--r4-view 'sql-reentry 'success)) (provide 'jabber-test-message-correct) ;;; jabber-test-message-correct.el ends here emacs-jabber-0.15.1/tests/jabber-test-message-reply.el000066400000000000000000000700311527111033600225520ustar00rootroot00000000000000;;; 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.15.1/tests/jabber-test-message-thread.el000066400000000000000000002322021527111033600226660ustar00rootroot00000000000000;;; 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 'jabber-chat-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 (_ &optional _jc) 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) (lambda (_jc _stanza &optional success _failure) (when success (funcall success))))) (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) (lambda (_jc _stanza &optional success _failure) (when success (funcall success))))) (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) (lambda (_jc _stanza &optional success _failure) (when success (funcall success))))) (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 (_ &optional _jc) 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 (_ &optional _jc) 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 (_ &optional _jc) 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 owned parent without inserting there." (let ((parent (generate-new-buffer " *jabber-thread-alert-parent*")) (jabber-chat-mode-hook nil) seen) (with-current-buffer parent (jabber-chat-mode) (setq-local jabber-buffer-connection 'jc jabber-chatting-with "alice@example.com") (insert "draft λ")) (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)) (with-current-buffer parent (should (eq jabber-buffer-connection 'jc)) (should (equal jabber-chatting-with "alice@example.com")) (should (equal "draft λ" (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 only through its still-owned native room." (let* ((jc (make-symbol "thread-account")) (other (make-symbol "other-account")) (jabber-db-path nil) (jabber-chat-mode-hook nil) (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) (jabber-jid-obarray (make-vector 127 0))) (put jc :state-data '(:username "me" :server "example.com")) (save-window-excursion (dolist (change '(nil account room killed)) (let* ((jabber-groupchat-buffer-format (generate-new-buffer-name " *jabber-thread-muc-alert-parent*")) (parent (jabber-muc-create-buffer jc "room@example.com")) (calls 0) seen before) (unwind-protect (progn (should (eq parent (jabber-muc-find-buffer "room@example.com" jc))) (with-current-buffer parent (should (derived-mode-p 'jabber-chat-mode)) (should (eq jabber-buffer-connection jc)) (should (equal jabber-group "room@example.com")) (insert "Unsent room draft") (setq before (buffer-string))) (let ((jabber-muc-hooks (list ;; An earlier hook can invalidate a once-valid origin. (lambda (_nick _group _buffer _body _alert) (pcase change ('account (with-current-buffer parent (setq jabber-buffer-connection other))) ('room (with-current-buffer parent (setq jabber-group "other-room@example.com"))) ('killed (kill-buffer parent)))) (lambda (_nick _group buffer _body _alert) (setq seen buffer) (cl-incf calls)))) (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 (= calls 1)) (should (eq seen (unless change parent))) (when (buffer-live-p parent) (with-current-buffer parent (should (equal before (buffer-string))) (should-not (ewoc-nth jabber-chat-ewoc 0))))) (when (buffer-live-p parent) (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 (_ &optional _jc) 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-reactions--find-target-node) (lambda (&rest _) '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.15.1/tests/jabber-test-modeline.el000066400000000000000000000050521527111033600215720ustar00rootroot00000000000000;;; 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.15.1/tests/jabber-test-moderation.el000066400000000000000000001236621527111033600221470ustar00rootroot00000000000000;;; 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-author-retract-updates-exact-target () "Author retraction updates its one occupant-matched target." (jabber-test-moderation-with-ewoc (setq-local jabber-group "room@muc.example.com") (setq-local jabber-buffer-connection 'fake-jc) (let* ((from "room@muc.example.com/alice") (msg (list :id "client-id-1" :server-id "server-id-1" :from from :occupant-id "occupant-alice" :body "mistake" :timestamp (current-time))) (buf (current-buffer)) db-call) (jabber-chat-ewoc-enter (list :muc-foreign msg)) (cl-letf (((symbol-function 'jabber-moderation--room-supports-occupant-id-p) (lambda (_room _jc) t)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-retraction-candidates) (lambda (_account _room _server-id) (list (list :row-id 42 :from from :occupant-id "occupant-alice")))) ((symbol-function 'jabber-db-retract-message-row) (lambda (&rest args) (setq db-call args))) ((symbol-function 'jabber-moderation--target-buffers-for-row) (lambda (_jc _room _row-id) (list buf)))) (should (jabber-moderation--handle-message 'fake-jc `(message ((from . ,from) (type . "groupchat")) (body () "Your contact attempted to retract a previous message, but it's unsupported by your client") (retract ((id . "server-id-1") (xmlns . ,jabber-moderation-retract-xmlns))) (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "occupant-alice"))))))) (should (equal '(42 "room@muc.example.com/alice") db-call)) (let ((updated (cadr (ewoc-data (jabber-chat-ewoc-find-by-id "server-id-1"))))) (should (plist-get updated :retracted)) (should (equal from (plist-get updated :retracted-by))))))) (ert-deftest jabber-test-moderation-author-retract-without-history () "Live author retraction works when persistent history is disabled." (jabber-test-moderation-with-ewoc (setq-local jabber-group "room@muc.example.com") (setq-local jabber-buffer-connection 'fake-jc) (let ((jabber-db-path nil) (original '(message ((from . "room@muc.example.com/alice") (id . "client-id-1") (type . "groupchat")) (body () "mistake") (stanza-id ((id . "server-id-1") (by . "room@muc.example.com") (xmlns . "urn:xmpp:sid:0"))) (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "occupant-alice"))))) (retraction '(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (body () "sender-controlled fallback") (retract ((id . "server-id-1") (xmlns . "urn:xmpp:message-retract:1"))) (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "occupant-alice")))))) (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (_room &optional _jc) (current-buffer))) ((symbol-function 'jabber-muc-nickname) (lambda (_room _jc) "me")) ((symbol-function 'jabber-moderation--room-supports-occupant-id-p) (lambda (_room _jc) t))) (jabber-process-input 'fake-jc original) (jabber-process-input 'fake-jc retraction)) (let ((msg (cadr (ewoc-data (jabber-chat-ewoc-find-by-id "server-id-1"))))) (should (equal "occupant-alice" (plist-get msg :occupant-id))) (should (plist-get msg :retracted))) (should (= 1 (length (ewoc-collect jabber-chat-ewoc (lambda (data) (memq (car-safe data) '(:muc-local :muc-foreign)))))))))) (ert-deftest jabber-test-moderation-live-author-retract-updates-projections () "One live target is tombstoned in its parent and thread views." (let ((parent (generate-new-buffer " *jabber-retract-parent*")) (thread (generate-new-buffer " *jabber-retract-thread*"))) (unwind-protect (progn (dolist (entry (list (cons parent nil) (cons thread "thread-1"))) (with-current-buffer (car entry) (setq-local jabber-group "room@muc.example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-message-thread-id (cdr entry)) (setq-local jabber-chat-ewoc (ewoc-create #'ignore nil nil 'nosep)) (setq-local jabber-chat--msg-nodes (make-hash-table :test 'equal)) (jabber-chat-ewoc-enter (list :muc-foreign (list :server-id "server-id-1" :from "room@muc.example.com/alice" :occupant-id "occupant-alice" :body "mistake" :timestamp (current-time)))))) (let ((jabber-db-path nil)) (cl-letf (((symbol-function 'jabber-moderation--room-supports-occupant-id-p) (lambda (_room _jc) t)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com"))) (should (jabber-moderation--handle-message 'fake-jc '(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (retract ((id . "server-id-1") (xmlns . "urn:xmpp:message-retract:1"))) (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "occupant-alice")))))))) (dolist (buffer (list parent thread)) (with-current-buffer buffer (should (plist-get (cadr (ewoc-data (jabber-chat-ewoc-find-by-id "server-id-1"))) :retracted))))) (dolist (buffer (list parent thread)) (when (buffer-live-p buffer) (kill-buffer buffer)))))) (ert-deftest jabber-test-moderation-author-retract-rejects-live-disagreement () "Stored authorization cannot override conflicting live occupant identity." (jabber-test-moderation-with-ewoc (setq-local jabber-group "room@muc.example.com") (setq-local jabber-buffer-connection 'fake-jc) (jabber-chat-ewoc-enter (list :muc-foreign (list :server-id "server-id-1" :from "room@muc.example.com/alice" :occupant-id "occupant-mallory" :body "keep" :timestamp (current-time)))) (let (db-call) (cl-letf (((symbol-function 'jabber-moderation--room-supports-occupant-id-p) (lambda (_room _jc) t)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-retraction-candidates) (lambda (_account _room _server-id) (list (list :row-id 42 :from "room@muc.example.com/alice" :occupant-id "occupant-alice")))) ((symbol-function 'jabber-db-retract-message-row) (lambda (&rest args) (setq db-call args)))) (should-not (jabber-moderation--handle-message 'fake-jc '(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (retract ((id . "server-id-1") (xmlns . "urn:xmpp:message-retract:1"))) (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "occupant-alice"))))))) (should-not db-call) (should-not (plist-get (cadr (ewoc-data (jabber-chat-ewoc-find-by-id "server-id-1"))) :retracted))))) (ert-deftest jabber-test-moderation-author-retract-rejects-missing-live-identity () "Stored authorization cannot override missing live occupant identity." (jabber-test-moderation-with-ewoc (setq-local jabber-group "room@muc.example.com") (setq-local jabber-buffer-connection 'fake-jc) (jabber-chat-ewoc-enter (list :muc-foreign (list :server-id "server-id-1" :from "room@muc.example.com/alice" :body "keep" :timestamp (current-time)))) (let (db-call) (cl-letf (((symbol-function 'jabber-moderation--room-supports-occupant-id-p) (lambda (_room _jc) t)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-retraction-candidates) (lambda (_account _room _server-id) (list (list :row-id 42 :from "room@muc.example.com/alice" :occupant-id "occupant-alice")))) ((symbol-function 'jabber-db-retract-message-row) (lambda (&rest args) (setq db-call args)))) (should-not (jabber-moderation--handle-message 'fake-jc '(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (retract ((id . "server-id-1") (xmlns . "urn:xmpp:message-retract:1"))) (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "occupant-alice"))))))) (should-not db-call) (should-not (plist-get (cadr (ewoc-data (jabber-chat-ewoc-find-by-id "server-id-1"))) :retracted))))) (ert-deftest jabber-test-moderation-author-retract-preserves-moderator-projections () "A later author action cannot downgrade a moderator tombstone." (let* ((dir (make-temp-file "jabber-moderation-test" t)) (jabber-db-path (expand-file-name "test.sqlite" dir)) (jabber-db--connection nil) (parent (generate-new-buffer " *jabber-moderated-parent*")) (thread (generate-new-buffer " *jabber-moderated-thread*")) (moderator "room@muc.example.com/admin")) (unwind-protect (progn (jabber-db-ensure-open) (jabber-db-store-message "me@example.com" "room@muc.example.com" "in" "groupchat" "spam" 1700000000 "alice" "client-id-1" "server-id-1" "occupant-alice") (dolist (entry (list (cons parent nil) (cons thread "thread-1"))) (with-current-buffer (car entry) (setq-local jabber-group "room@muc.example.com") (setq-local jabber-buffer-connection 'fake-jc) (setq-local jabber-message-thread-id (cdr entry)) (setq-local jabber-chat-ewoc (ewoc-create #'ignore nil nil 'nosep)) (setq-local jabber-chat--msg-nodes (make-hash-table :test 'equal)) (jabber-chat-ewoc-enter (list :muc-foreign (list :server-id "server-id-1" :from "room@muc.example.com/alice" :occupant-id "occupant-alice" :body "spam" :timestamp (current-time)))))) (cl-letf (((symbol-function 'jabber-moderation--room-supports-occupant-id-p) (lambda (_room _jc) t)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-moderation--target-buffers) (lambda (_jc _room _server-id) (list parent thread))) ((symbol-function 'jabber-moderation--target-buffers-for-row) (lambda (_jc _room _row-id) (list parent thread)))) (should (jabber-moderation--handle-message 'fake-jc `(message ((from . "room@muc.example.com") (type . "groupchat")) (retract ((id . "server-id-1") (xmlns . ,jabber-moderation-retract-xmlns)) (moderated ((by . ,moderator) (xmlns . ,jabber-moderation-xmlns))) (reason () "spam"))))) (should (jabber-moderation--handle-message 'fake-jc '(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (retract ((id . "server-id-1") (xmlns . "urn:xmpp:message-retract:1"))) (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "occupant-alice"))))))) (should (equal `((,moderator "spam")) (sqlite-select jabber-db--connection "SELECT retracted_by, retraction_reason FROM message"))) (dolist (buffer (list parent thread)) (with-current-buffer buffer (let ((msg (cadr (ewoc-data (jabber-chat-ewoc-find-by-id "server-id-1"))))) (should (plist-get msg :retracted)) (should (equal moderator (plist-get msg :retracted-by))) (should (equal "spam" (plist-get msg :retraction-reason))))))) (jabber-db-close) (dolist (buffer (list parent thread)) (when (buffer-live-p buffer) (kill-buffer buffer))) (delete-directory dir t)))) (ert-deftest jabber-test-moderation-live-author-retract-fails-closed () "Live lookup rejects mismatched, missing, and duplicate target identities." (dolist (messages '(((:server-id "server-id-1" :from "room@muc.example.com/alice" :occupant-id "occupant-bob")) ((:server-id "other-id" :from "room@muc.example.com/alice" :occupant-id "occupant-alice")) ((:server-id "server-id-1" :from "room@muc.example.com/alice" :occupant-id "occupant-alice") (:server-id "server-id-1" :from "room@muc.example.com/alice" :occupant-id "occupant-alice")))) (jabber-test-moderation-with-ewoc (setq-local jabber-group "room@muc.example.com") (setq-local jabber-buffer-connection 'fake-jc) (dolist (msg messages) (ewoc-enter-last jabber-chat-ewoc (list :muc-foreign (append msg (list :body "keep" :timestamp (current-time)))))) (when (cdr messages) (setq-local jabber-message-thread-id "same-view")) (let ((jabber-db-path nil)) (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (_room &optional _jc) (current-buffer))) ((symbol-function 'jabber-moderation--room-supports-occupant-id-p) (lambda (_room _jc) t))) (should-not (jabber-moderation--handle-message 'fake-jc '(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (retract ((id . "server-id-1") (xmlns . "urn:xmpp:message-retract:1"))) (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "occupant-alice")))))))) (let ((node (ewoc-nth jabber-chat-ewoc 0))) (while node (should-not (plist-get (cadr (ewoc-data node)) :retracted)) (setq node (ewoc-next jabber-chat-ewoc node))))))) (ert-deftest jabber-test-moderation-author-retract-rejects-occupant-mismatch () "Author retraction cannot retract another occupant's message." (let (db-call) (cl-letf (((symbol-function 'jabber-moderation--room-supports-occupant-id-p) (lambda (_room _jc) t)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-retraction-candidates) (lambda (_account _room _server-id) (list (list :row-id 42 :from "room@muc.example.com/bob" :occupant-id "occupant-bob")))) ((symbol-function 'jabber-db-retract-message-row) (lambda (&rest args) (setq db-call args)))) (jabber-moderation--handle-message 'fake-jc `(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (retract ((id . "server-id-1") (xmlns . ,jabber-moderation-retract-xmlns))) (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "occupant-alice")))))) (should-not db-call))) (ert-deftest jabber-test-moderation-author-retract-rejects-ambiguous-target () "Author retraction cannot choose among duplicate room stanza IDs." (cl-letf (((symbol-function 'jabber-moderation--room-supports-occupant-id-p) (lambda (_room _jc) t)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-retraction-candidates) (lambda (_account _room _server-id) (list (list :row-id 42 :from "room@muc.example.com/alice" :occupant-id "occupant-alice") (list :row-id 43 :from "room@muc.example.com/mallory" :occupant-id "occupant-mallory")))) ((symbol-function 'jabber-db-retract-message-row) (lambda (&rest _args) (ert-fail "Retracted an ambiguous stanza ID")))) (should-not (jabber-moderation--handle-message 'fake-jc `(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (retract ((id . "duplicate-server-id") (xmlns . ,jabber-moderation-retract-xmlns))) (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "occupant-alice")))))))) (ert-deftest jabber-test-moderation-author-retract-requires-trusted-occupant-id () "Unadvertised or ambiguous occupant IDs cannot authorize retraction." (dolist (case `((nil (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "occupant-alice")))) (t (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "occupant-alice"))) (occupant-id ((xmlns . "urn:xmpp:occupant-id:0") (id . "occupant-mallory")))))) (let ((advertised (car case)) (occupant-elements (cdr case)) db-call) (cl-letf (((symbol-function 'jabber-moderation--room-supports-occupant-id-p) (lambda (_room _jc) advertised)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((symbol-function 'jabber-db-message-retraction-candidates) (lambda (_account _room _server-id) (list (list :row-id 42 :from "room@muc.example.com/alice" :occupant-id "occupant-alice")))) ((symbol-function 'jabber-db-retract-message-row) (lambda (&rest args) (setq db-call args)))) (jabber-moderation--handle-message 'fake-jc `(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (retract ((id . "server-id-1") (xmlns . ,jabber-moderation-retract-xmlns))) ,@occupant-elements))) (should-not db-call)))) (ert-deftest jabber-test-moderation-retract-fallback-is-protocol-only () "Any XEP-0424 retract body is hidden and excluded from history." (dolist (stanza `((message ((from . "room@muc.example.com/alice") (type . "groupchat")) (body () "sender-controlled fallback") (retract ((id . "missing-id") (xmlns . ,jabber-moderation-retract-xmlns)))) (message ((from . "room@muc.example.com/alice") (type . "groupchat")) (body () "ambiguous protocol action") (retract ((id . "first") (xmlns . ,jabber-moderation-retract-xmlns))) (retract ((id . "second") (xmlns . ,jabber-moderation-retract-xmlns)))))) (should (jabber-moderation--muc-retraction-message-p stanza)) (should (jabber-moderation--history-inhibit-p nil stanza))) (should-not (jabber-moderation--muc-retraction-message-p '(message ((type . "groupchat")) (retract ((id . "ordinary-extension") (xmlns . "urn:example:not-retraction"))))))) (ert-deftest jabber-test-moderation-muc-does-not-render-retract-fallback () "MUC processing never displays a XEP-0424 retract fallback body." (let ((displayed nil) (stanza `(message ((from . "room@muc.example.com/alice") (type . "groupchat")) (body () "sender-controlled fallback") (retract ((id . "unknown-id") (xmlns . ,jabber-moderation-retract-xmlns)))))) (cl-letf (((symbol-function 'jabber-chat--decrypt-if-needed) (lambda (_jc xml-data) xml-data)) ((symbol-function 'jabber-muc--display-message) (lambda (&rest _args) (setq displayed t)))) (jabber-muc-process-message 'fake-jc stanza)) (should-not displayed))) (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))))))) (ert-deftest jabber-test-moderation-tombstone-persists-without-attribution () "Anonymous and attributed archive tombstones survive history reopening." (require 'jabber-mam) (dolist (moderator '(nil "room@x/admin")) (let* ((directory (make-temp-file "jabber-moderation-db" t)) (jabber-db-path (expand-file-name "history.sqlite" directory)) (jabber-db--connection nil)) (unwind-protect (progn (jabber-db-store-message "me@x" "room@x" "in" "groupchat" "original" 100 "alice" "client" "archive" "actor" nil nil nil '(:thread-id "thread")) ;; An unrelated account and room with the same ID stay untouched. (jabber-db-store-message "other@x" "room@x" "in" "groupchat" "other account" 100 nil nil "archive") (jabber-db-store-message "me@x" "other-room@x" "in" "groupchat" "other room" 100 nil nil "archive") (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@x")) ((symbol-function 'jabber-moderation--target-buffers) (lambda (&rest _) nil))) (let ((outer (list 'message nil)) (inner `(message ((from . "room@x/alice") (type . "groupchat")) (retracted ((xmlns . "urn:xmpp:message-retract:1")) (moderated ((xmlns . "urn:xmpp:message-moderate:1") ,@(when moderator `((by . ,moderator))))) (reason () "spam"))))) (jabber-mam--unwrap-into outer inner "archive") (should (jabber-moderation--handle-message 'jc outer)))) (jabber-db-close) (let ((row (car (jabber-db-backlog "me@x" "room@x")))) (should (plist-get row :retracted)) (should (equal moderator (plist-get row :retracted-by))) (should (equal "spam" (plist-get row :retraction-reason))) ;; A later author action cannot invent attribution for this row. (should-not (jabber-db-retract-message-row (plist-get row :db-id) "room@x/alice"))) (should-not (plist-get (car (jabber-db-backlog "other@x" "room@x")) :retracted)) (should-not (plist-get (car (jabber-db-backlog "me@x" "other-room@x")) :retracted)) (let ((root (plist-get (car (jabber-db-message-threads "me@x" "room@x" "groupchat")) :root-message))) (should (plist-get root :retracted)) (should (equal moderator (plist-get root :retracted-by)))) (should-not (jabber-db-server-ids-by-occupant-id "me@x" "room@x" "actor")) (should-not (jabber-db-reply-target-body "me@x" "room@x" "archive" t)) (jabber-db-store-message "me@x" "room@x" "in" "groupchat" "[OMEMO: could not decrypt]" 200 "alice" "client" "archive" "actor" nil t) (should (equal (list (list 1 moderator "spam" "original" 100)) (sqlite-select jabber-db--connection "SELECT retracted,retracted_by,retraction_reason,body,timestamp FROM message WHERE account = 'me@x' AND peer = 'room@x'")))) (jabber-db-close) (delete-directory directory t))))) ;;; 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 () "Build message state with server and occupant IDs." (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"))) (occupant-id ((id . "occupant-alice") (xmlns . "urn:xmpp:occupant-id:0"))))) (plist (jabber-chat--msg-plist-from-stanza stanza))) (should (equal "server-id-42" (plist-get plist :server-id))) (should (equal "occupant-alice" (plist-get plist :occupant-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.15.1/tests/jabber-test-muc-affiliations.el000066400000000000000000000744141527111033600232400ustar00rootroot00000000000000;;; jabber-test-muc-affiliations.el --- Owned MUC snapshots -*- lexical-binding: t; -*- (require 'ert) (require 'cl-lib) (require 'jabber-core) (require 'jabber-muc) (require 'jabber-omemo) (defun jabber-test-muc-aff--connection (user) "Return a disposable established connection for USER." (let ((jc (make-symbol user))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data (jabber-sm--reset (list :username user :server "example.org" :connection (list 'transport) :session-id "stream"))) jc)) (defmacro jabber-test-muc-aff--with-room (&rest body) "Run BODY with two isolated connections and a room." (declare (indent 0) (debug t)) `(let* ((a (jabber-test-muc-aff--connection "a")) (b (jabber-test-muc-aff--connection "b")) (room "room@conference.example.org") (jabber-connections (list a b)) (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--rooms-before-disconnect (make-hash-table :test #'equal)) (jabber-muc--session-passwords (make-hash-table :test #'equal)) (jabber-muc-participants nil) (jabber-open-info-queries nil) (jabber-muc--autojoin-queue nil) (jabber-muc--autojoin-pending nil) (jabber-muc--autojoin-disco-count nil) (jabber-muc--autojoin-timer nil) (jabber-presence-chain '(jabber-muc-process-presence)) (jabber-iq-chain '(jabber-process-iq)) sent) (jabber-muc-add-groupchat room "self-a" a) (jabber-muc-add-groupchat room "self-b" b) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (jc xml &rest _) (push (cons jc xml) sent)))) ,@body))) (defun jabber-test-muc-aff--requests (sent jc) "Return affiliation/ID pairs from SENT stanzas on JC." (cl-loop for (owner . xml) in sent when (eq owner jc) collect (cons (jabber-xml-get-attribute (car (jabber-xml-get-children (jabber-iq-query xml) 'item)) 'affiliation) (jabber-xml-get-attribute xml 'id)))) (defun jabber-test-muc-aff--reply (jc room requests affiliation jids &optional from) "Deliver a native FSM IQ on JC for ROOM from REQUESTS. AFFILIATION selects the request; JIDS become items. FROM overrides issuer." (fsm-send-sync jc `(:stanza (iq ((type . "result") (id . ,(cdr (assoc affiliation requests))) (from . ,(or from room))) (query ((xmlns . ,jabber-muc-xmlns-admin)) ,@(mapcar (lambda (jid) `(item ((jid . ,jid) (affiliation . ,affiliation)))) jids)))))) (defun jabber-test-muc-aff--recipients (jc room) "Collect ROOM recipients using JC's buffer context." (let ((jabber-buffer-connection jc)) (sort (jabber-omemo--muc-participant-jids room (cdr (assoc room jabber-muc-participants))) #'string<))) (defun jabber-test-muc-aff--presence (jc room nick jid &optional unavailable) "Dispatch native occupant presence on JC in ROOM for NICK and JID. UNAVAILABLE removes the occupant." (fsm-send-sync jc `(:stanza (presence ((from . ,(concat room "/" nick)) ,@(when unavailable '((type . "unavailable")))) (x ((xmlns . ,jabber-muc-xmlns-user)) (item ((jid . ,jid) (role . "participant") (affiliation . "none")))))))) (ert-deftest jabber-test-muc-aff-two-accounts-native-iq () (jabber-test-muc-aff--with-room (jabber-muc--query-affiliations a room) (jabber-muc--query-affiliations b room) (jabber-test-muc-aff--reply a room (jabber-test-muc-aff--requests sent a) "member" '("alice@example.org")) (jabber-test-muc-aff--reply b room (jabber-test-muc-aff--requests sent b) "member" '("bob@example.org")) (should (equal (jabber-test-muc-aff--recipients a room) '("alice@example.org"))) (should (equal (jabber-test-muc-aff--recipients b room) '("bob@example.org"))))) (ert-deftest jabber-test-muc-aff-empty-reduced-and-other-categories () (jabber-test-muc-aff--with-room (jabber-muc--query-affiliations a room) (let ((first (jabber-test-muc-aff--requests sent a))) (jabber-test-muc-aff--reply a room first "member" '("old@example.org" "kept@example.org")) (jabber-test-muc-aff--reply a room first "admin" '("admin@example.org"))) (jabber-muc--query-affiliations a room) (jabber-test-muc-aff--reply a room (jabber-test-muc-aff--requests sent a) "member" '("kept@example.org")) (should (equal (jabber-test-muc-aff--recipients a room) '("admin@example.org" "kept@example.org"))) (jabber-muc--query-affiliations a room) (jabber-test-muc-aff--reply a room (jabber-test-muc-aff--requests sent a) "member" nil) (should (equal (jabber-test-muc-aff--recipients a room) '("admin@example.org"))))) (ert-deftest jabber-test-muc-aff-out-of-order-and-state-copy () (jabber-test-muc-aff--with-room (jabber-muc--query-affiliations a room) (let ((old (jabber-test-muc-aff--requests sent a)) (state (fsm-get-state-data a))) (jabber-sm--drain-pending a state) (should-not (eq state (fsm-get-state-data a))) (jabber-test-muc-aff--reply a room old "owner" '("owner@example.org")) (should (equal (jabber-test-muc-aff--recipients a room) '("owner@example.org"))) (jabber-muc--query-affiliations a room) (jabber-test-muc-aff--reply a room (jabber-test-muc-aff--requests sent a) "owner" nil) (jabber-test-muc-aff--reply a room (jabber-test-muc-aff--requests sent a) "member" '("new@example.org")) (jabber-test-muc-aff--reply a room old "member" '("obsolete@example.org")) (should (equal (jabber-test-muc-aff--recipients a room) '("new@example.org")))))) (ert-deftest jabber-test-muc-aff-foreign-response-keeps-native-request () (jabber-test-muc-aff--with-room (jabber-muc--query-affiliations a room) (let* ((requests (jabber-test-muc-aff--requests sent a)) (id (cdr (assoc "member" requests)))) (jabber-test-muc-aff--reply b room requests "member" '("foreign@example.org")) (should (assoc id jabber-open-info-queries)) (jabber-test-muc-aff--reply a room requests "member" '("foreign@example.org") "evil@example.org") (should (assoc id jabber-open-info-queries)) (should-not (jabber-test-muc-aff--recipients a room)) (fsm-send-sync a `(:stanza (iq ((type . "result") (from . ,room) (id . ,id)) (query ((xmlns . "wrong-namespace")))))) (should (assoc id jabber-open-info-queries)) (jabber-test-muc-aff--reply a room requests "member" '("valid@example.org")) (should-not (assoc id jabber-open-info-queries)) (should (equal (jabber-test-muc-aff--recipients a room) '("valid@example.org")))))) (ert-deftest jabber-test-muc-aff-leave-rejoin-late-result () (jabber-test-muc-aff--with-room (jabber-muc--query-affiliations a room) (let ((old (jabber-test-muc-aff--requests sent a))) (jabber-muc-remove-groupchat room a) (jabber-test-muc-aff--reply a room old "member" '("retired@example.org")) (should-not (jabber-test-muc-aff--recipients a room)) (jabber-muc-add-groupchat room "successor" a) (jabber-muc--query-affiliations a room) (jabber-test-muc-aff--reply a room (jabber-test-muc-aff--requests sent a) "member" nil) (jabber-test-muc-aff--reply a room old "admin" '("retired@example.org")) (should-not (jabber-test-muc-aff--recipients a room))))) (ert-deftest jabber-test-muc-aff-reconnect-account-and-transport () (dolist (change '((:connection . replacement) (:session-id . "new-stream") (:username . "new-account"))) (jabber-test-muc-aff--with-room (jabber-muc--query-affiliations a room) (let ((old (jabber-test-muc-aff--requests sent a))) (jabber-test-muc-aff--reply a room old "member" '("old@example.org")) (plist-put (fsm-get-state-data a) (car change) (cdr change)) (should-not (jabber-test-muc-aff--recipients a room)) (jabber-muc--query-affiliations a room) (jabber-test-muc-aff--reply a room (jabber-test-muc-aff--requests sent a) "member" nil) (jabber-test-muc-aff--reply a room old "admin" '("old@example.org")) (should-not (jabber-test-muc-aff--recipients a room)))))) (ert-deftest jabber-test-muc-aff-current-occupants-and-offline-members () (jabber-test-muc-aff--with-room (jabber-test-muc-aff--presence a room "shared" "alice@example.org/a") (jabber-test-muc-aff--presence b room "shared" "bob@example.org/b") (jabber-muc--query-affiliations a room) (jabber-test-muc-aff--reply a room (jabber-test-muc-aff--requests sent a) "member" '("offline@example.org")) (should (equal (jabber-test-muc-aff--recipients a room) '("alice@example.org" "offline@example.org"))) (should (equal (jabber-test-muc-aff--recipients b room) '("bob@example.org"))) (jabber-test-muc-aff--presence a room "shared" "alice@example.org/a" t) (should (equal (jabber-test-muc-aff--recipients a room) '("offline@example.org"))) (should (equal (jabber-test-muc-aff--recipients b room) '("bob@example.org"))))) (ert-deftest jabber-test-muc-aff-disconnect-reconnect-native-lifecycle () (jabber-test-muc-aff--with-room (jabber-muc--query-affiliations a room) (jabber-muc--query-affiliations b room) (let ((old (jabber-test-muc-aff--requests sent a))) (jabber-test-muc-aff--reply b room (jabber-test-muc-aff--requests sent b) "member" '("bob@example.org")) (jabber-muc--session-reset a) (should-not (gethash (list a room) jabber-muc--room-jids)) (jabber-test-muc-aff--reply a room old "member" '("retired@example.org")) (should-not (gethash (list a room) jabber-muc--room-jids)) (should (equal (jabber-test-muc-aff--recipients b room) '("bob@example.org"))) (plist-put (fsm-get-state-data a) :connection (list 'replacement)) (plist-put (fsm-get-state-data a) :session-id "successor-stream") (jabber-muc-add-groupchat room "successor" a) (jabber-muc--query-affiliations a room) (jabber-test-muc-aff--reply a room (jabber-test-muc-aff--requests sent a) "member" '("new@example.org")) (jabber-test-muc-aff--reply a room old "admin" '("retired@example.org")) (should (equal (jabber-test-muc-aff--recipients a room) '("new@example.org")))))) (ert-deftest jabber-test-muc-aff-sender-scope-and-revoked-inference () (jabber-test-muc-aff--with-room (jabber-test-muc-aff--presence a room "shared" "alice@example.org/a") (jabber-test-muc-aff--presence b room "shared" "bob@example.org/b") (let ((xml `(message ((from . ,(concat room "/shared")) (type . "groupchat"))))) (should (equal (jabber-omemo--resolve-sender-jid xml a) "alice@example.org")) (should (equal (jabber-omemo--resolve-sender-jid xml b) "bob@example.org")) (jabber-muc-remove-groupchat room a) (should-not (jabber-omemo--resolve-sender-jid xml a))) (jabber-test-muc-aff--presence b room "unknown" nil) (jabber-muc--query-affiliations b room) (jabber-test-muc-aff--reply b room (jabber-test-muc-aff--requests sent b) "member" '("offline@example.org")) (let ((xml `(message ((from . ,(concat room "/unknown")) (type . "groupchat"))))) (should (equal (jabber-omemo--resolve-sender-jid xml b) "offline@example.org")) (jabber-muc--query-affiliations b room) (jabber-test-muc-aff--reply b room (jabber-test-muc-aff--requests sent b) "member" nil) (should-not (jabber-omemo--resolve-sender-jid xml b))))) (ert-deftest jabber-test-muc-aff-pending-occupants-survive-self-presence () (jabber-test-muc-aff--with-room (jabber-muc-remove-groupchat room a) (let ((attempt (jabber-muc--start-attempt a room "self-a"))) (unwind-protect (cl-letf (((symbol-function 'jabber-mam-muc-joined) #'ignore) ((symbol-function 'jabber-bookmarks-auto-add-maybe) #'ignore)) (jabber-test-muc-aff--presence a room "early" "early@example.org/device") (should-not (jabber-test-muc-aff--recipients a room)) (jabber-test-muc-aff--presence a room "self-a" "a@example.org/device") (should (equal (jabber-test-muc-aff--recipients a room) '("a@example.org" "early@example.org")))) (when (timerp (plist-get attempt :timer)) (cancel-timer (plist-get attempt :timer))))))) (ert-deftest jabber-test-muc-aff-callback-cannot-recreate-or-replay () (jabber-test-muc-aff--with-room (jabber-muc--query-affiliations a room) (let* ((requests (jabber-test-muc-aff--requests sent a)) (id (cdr (assoc "member" requests))) (callback (nth 1 (assoc id jabber-open-info-queries))) (xml `(iq ((from . ,room) (type . "result")) (query ((xmlns . ,jabber-muc-xmlns-admin)) (item ((jid . "obsolete@example.org") (affiliation . "member"))))))) (jabber-test-muc-aff--reply a room requests "member" nil) (funcall (car callback) a xml (cdr callback)) (should-not (jabber-test-muc-aff--recipients a room)) (jabber-muc-remove-groupchat room a) (funcall (car callback) a xml (cdr callback)) (should-not (gethash (list a room) jabber-muc--room-jids))))) (ert-deftest jabber-test-muc-aff-blocking-uses-owned-recipients () (jabber-test-muc-aff--with-room (plist-put (fsm-get-state-data a) :blocking-list '("blocked@example.org")) (jabber-test-muc-aff--presence a room "shared" "blocked@example.org/device") (jabber-test-muc-aff--presence b room "shared" "allowed@example.org/device") (should-error (jabber-omemo--check-blocking a room t) :type 'user-error) (should-not (jabber-omemo--check-blocking b room t)) (jabber-test-muc-aff--presence a room "shared" "blocked@example.org/device" t) (should-not (jabber-omemo--check-blocking a room t)))) (ert-deftest jabber-test-muc-aff-offline-nick-is-not-an-occupant () (jabber-test-muc-aff--with-room (jabber-muc--query-affiliations a room) (fsm-send-sync a `(:stanza (iq ((type . "result") (from . ,room) (id . ,(cdr (assoc "member" (jabber-test-muc-aff--requests sent a))))) (query ((xmlns . ,jabber-muc-xmlns-admin)) (item ((jid . "offline@example.org") (nick . "absent") (affiliation . "member"))))))) (should (equal (jabber-test-muc-aff--recipients a room) '("offline@example.org"))) (should-not (jabber-omemo--resolve-sender-jid `(message ((from . ,(concat room "/absent")) (type . "groupchat"))) a)) (jabber-muc--query-affiliations a room) (jabber-test-muc-aff--reply a room (jabber-test-muc-aff--requests sent a) "member" nil) (should-not (jabber-test-muc-aff--recipients a room)))) (ert-deftest jabber-test-muc-aff-inflight-send-rechecks-before-wrapping () (dolist (retire '(nil snapshot membership)) (jabber-test-muc-aff--with-room (jabber-muc--query-affiliations a room) (jabber-test-muc-aff--reply a room (jabber-test-muc-aff--requests sent a) "member" '("peer@example.org")) (let ((jabber-group room) (jabber-buffer-connection a) (jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (wrapped 0) (failed 0) continuation) (cl-letf (((symbol-function 'jabber-chat--capture-input-owner) (lambda () (lambda () t))) ((symbol-function 'jabber-omemo--ensure-sessions-multi) (lambda (_jc _jids callback) (setq continuation callback))) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc _jid callback) (funcall callback nil))) ((symbol-function 'jabber-omemo-encrypt-message) (lambda (_) (cl-incf wrapped) '(:iv "iv" :key "key" :payload "payload"))) ((symbol-function 'jabber-omemo--build-encrypted-xml) (lambda (&rest _) '(encrypted nil)))) (jabber-omemo--send-muc a "correction" '((replace ((id . "original")))) nil (lambda (_reason) (cl-incf failed))) (pcase retire ('snapshot (jabber-muc--query-affiliations a room) (jabber-test-muc-aff--reply a room (jabber-test-muc-aff--requests sent a) "member" nil)) ('membership (jabber-muc-remove-groupchat room a) (jabber-muc-add-groupchat room "successor" a) (jabber-muc--query-affiliations a room) (jabber-test-muc-aff--reply a room (jabber-test-muc-aff--requests sent a) "member" '("peer@example.org")))) (funcall continuation '((7 "a@example.org" "peer@example.org" session))) (should (= wrapped (if retire 0 1))) (should (= failed (if retire 1 0)))))))) (defun jabber-test-muc-aff--resume (jc) "Deliver a successful native SM resume on a replacement transport for JC." (let ((jabber-post-resume-hooks nil)) (plist-put (fsm-get-state-data jc) :sm-enabled t) (plist-put (fsm-get-state-data jc) :sm-id "resume-id") (plist-put (fsm-get-state-data jc) :sm-resuming t) (plist-put (fsm-get-state-data jc) :connection (list 'resumed-transport)) ;; A real resumed connection receives a new stream header before . (put jc :state :connected) (let ((jabber-use-sasl t)) (fsm-send-sync jc '(:stream-start "replacement-stream" "1.0"))) (should (equal (plist-get (fsm-get-state-data jc) :session-id) "replacement-stream")) (put jc :state :sm-resume) (cl-letf (((symbol-function 'jabber-sm--start-r-timer) (lambda (_jc data) data)) ((symbol-function 'jabber-sm--schedule-drain) #'ignore)) (fsm-send-sync jc '(:stanza (resumed ((xmlns . "urn:xmpp:sm:3") (h . "0") (previd . "resume-id")))))) (should (eq (get jc :state) :session-established)))) (defun jabber-test-muc-aff--sender (jc room nick) "Resolve NICK's native encrypted sender identity in ROOM on JC." (jabber-omemo--resolve-sender-jid `(message ((from . ,(concat room "/" nick)) (type . "groupchat"))) jc)) (ert-deftest jabber-test-muc-aff-resume-ready-identities () "Resume retains current identities, not old query or membership authority." (jabber-test-muc-aff--with-room (jabber-muc--start-attempt a room "self-a") (jabber-test-muc-aff--presence a room "self-a" nil) (jabber-test-muc-aff--presence a room "online" "online@example.org/device") (jabber-test-muc-aff--presence b room "online" "other@example.org/device") (jabber-muc--query-affiliations a room) (jabber-muc--query-affiliations b room) (let ((old (jabber-test-muc-aff--requests sent a)) (other (jabber-test-muc-aff--requests sent b)) (membership (assq a (jabber-muc-room-entries room))) (record (jabber-muc--identity-record a room))) (jabber-test-muc-aff--reply a room old "member" '("offline@example.org")) (jabber-test-muc-aff--resume a) (should (eq membership (assq a (jabber-muc-room-entries room)))) (should (jabber-sm--room-ready-p (fsm-get-state-data a) room)) (should (equal (jabber-test-muc-aff--recipients a room) '("offline@example.org" "online@example.org"))) (should (equal (jabber-test-muc-aff--sender a room "online") "online@example.org")) (should-not (eq record (jabber-muc--identity-record a room))) (jabber-test-muc-aff--presence a room "new" "new@example.org/device") (jabber-test-muc-aff--reply a room old "admin" '("stale@example.org")) (should (equal (jabber-test-muc-aff--recipients a room) '("new@example.org" "offline@example.org" "online@example.org"))) ;; Another account's still-current query and occupant survive the transfer. (jabber-test-muc-aff--reply b room other "member" '("other-offline@example.org")) (should (equal (jabber-test-muc-aff--recipients b room) '("other-offline@example.org" "other@example.org"))) (jabber-muc--query-affiliations a room) (jabber-test-muc-aff--reply a room (jabber-test-muc-aff--requests sent a) "member" nil) (jabber-test-muc-aff--presence a room "online" "online@example.org/device" t) (jabber-test-muc-aff--presence a room "new" "new@example.org/device" t) (should-not (jabber-test-muc-aff--recipients a room)) (should-not (jabber-test-muc-aff--sender a room "online")) (jabber-muc-remove-groupchat room a) (jabber-muc-add-groupchat room "successor" a) (jabber-test-muc-aff--reply a room old "owner" '("stale@example.org")) (should-not (jabber-test-muc-aff--recipients a room))))) (ert-deftest jabber-test-muc-aff-resume-pending-identities () "A pending join transfers early occupants but cannot send until confirmed." (jabber-test-muc-aff--with-room (jabber-muc-remove-groupchat room a) (jabber-muc--start-attempt a room "self-a") (unwind-protect (cl-letf (((symbol-function 'jabber-mam-muc-joined) #'ignore) ((symbol-function 'jabber-bookmarks-auto-add-maybe) #'ignore)) (jabber-test-muc-aff--presence a room "early" "early@example.org/device") (let ((old (jabber-sm--room-attempt (fsm-get-state-data a) room))) (jabber-test-muc-aff--resume a) (should-not (jabber-muc--attempt-current-p a room old t)) (should-not (jabber-test-muc-aff--recipients a room)) (jabber-test-muc-aff--presence a room "later" "later@example.org/device") (jabber-test-muc-aff--presence a room "self-a" nil) (should (equal (jabber-test-muc-aff--recipients a room) '("early@example.org" "later@example.org"))) (should (equal (jabber-test-muc-aff--sender a room "early") "early@example.org")) (jabber-test-muc-aff--presence a room "early" "early@example.org/device" t) (jabber-test-muc-aff--presence a room "later" "later@example.org/device" t) (should-not (jabber-test-muc-aff--recipients a room)))) (let ((timer (plist-get (jabber-sm--room-attempt (fsm-get-state-data a) room) :timer))) (when (timerp timer) (cancel-timer timer)))))) (ert-deftest jabber-test-muc-aff-resume-rejects-retired-owners () "Resume cannot bless another account, session, transport or room lifetime." (dolist (change '(account session transport membership)) (jabber-test-muc-aff--with-room (jabber-muc--start-attempt a room "self-a") (jabber-test-muc-aff--presence a room "self-a" nil) (jabber-test-muc-aff--presence a room "old" "old@example.org/device") (jabber-muc--query-affiliations a room) (let ((old (jabber-test-muc-aff--requests sent a))) (jabber-test-muc-aff--reply a room old "member" '("offline@example.org")) (pcase change ('account (plist-put (fsm-get-state-data a) :username "replacement")) ('session (plist-put (jabber-muc--identity-record a room) :session "unowned")) ('transport (plist-put (jabber-muc--identity-record a room) :transport 'unowned)) ('membership (jabber-muc-remove-groupchat room a) (jabber-muc-add-groupchat room "replacement" a))) (jabber-test-muc-aff--resume a) (jabber-test-muc-aff--reply a room old "admin" '("stale@example.org")) (should-not (jabber-test-muc-aff--recipients a room)) (should-not (jabber-test-muc-aff--sender a room "old")))))) (ert-deftest jabber-test-muc-aff-failed-resume-retires-identities () "The native failed-resume fresh-bind path retires the old identity view." (jabber-test-muc-aff--with-room (let ((jabber-lifecycle-session-reset-functions '(jabber-muc--session-reset))) (jabber-muc--start-attempt a room "self-a") (jabber-test-muc-aff--presence a room "self-a" nil) (jabber-test-muc-aff--presence a room "old" "old@example.org/device") (jabber-test-muc-aff--presence b room "old" "other@example.org/device") (jabber-muc--query-affiliations a room) (let ((old (jabber-test-muc-aff--requests sent a))) (jabber-test-muc-aff--reply a room old "member" '("offline@example.org")) (put a :state :sm-resume) (plist-put (fsm-get-state-data a) :stream-features '(features () (bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind"))))) (cl-letf (((symbol-function 'jabber--send-bind-request) #'ignore)) (fsm-send-sync a '(:stanza (failed ((xmlns . "urn:xmpp:sm:3")))))) (should-not (gethash (list a room) jabber-muc--room-jids)) (should-not (jabber-test-muc-aff--recipients a room)) (should (equal (jabber-test-muc-aff--recipients b room) '("other@example.org"))) (put a :state :session-established) (jabber-muc-add-groupchat room "successor" a) (jabber-test-muc-aff--reply a room old "admin" '("stale@example.org")) (should-not (jabber-test-muc-aff--recipients a room)))))) (ert-deftest jabber-test-muc-aff-concurrent-native-nick-retirement () "Foreign 303 and self confirmation retire aliases without settling our lease." (let ((send (symbol-function 'jabber-send-sexp))) (dolist (pending '(nil t resume)) (jabber-test-muc-aff--with-room (jabber-muc--start-attempt a room "self-a") (jabber-test-muc-aff--presence a room "self-a" "a@example.org/device") (jabber-test-muc-aff--presence a room "guest" "guest@example.org/device") (jabber-test-muc-aff--presence b room "guest" "other@example.org/device") (when pending (cl-letf (((symbol-function 'jabber-send-sexp) send) ((symbol-function 'jabber-send-sexp--raw) (lambda (&rest _) t))) (jabber-muc-nick a room "new-self"))) (when (eq pending 'resume) (jabber-test-muc-aff--resume a)) (let ((attempt (jabber-sm--room-attempt (fsm-get-state-data a) room))) (unwind-protect (progn (fsm-send-sync a `(:stanza (presence ((from . ,(concat room "/guest")) (type . "unavailable")) (x ((xmlns . ,jabber-muc-xmlns-user)) (item ((nick . "guest-new") (affiliation . "none"))) (status ((code . "303"))))))) (should (eq attempt (jabber-sm--room-attempt (fsm-get-state-data a) room))) (should (eq (plist-get attempt :status) (if pending 'pending 'ready))) (should-not (jabber-test-muc-aff--sender a room "guest")) (jabber-test-muc-aff--presence a room "guest-new" "guest@example.org/device") (should (equal (jabber-test-muc-aff--sender a room "guest-new") "guest@example.org")) (jabber-test-muc-aff--presence a room "guest-new" "guest@example.org/device" t) (when pending ;; Some servers confirm without a preceding self 303. (jabber-test-muc-aff--presence a room "new-self" "a@example.org/device") (should-not (jabber-test-muc-aff--sender a room "self-a")) (should (equal (jabber-test-muc-aff--sender a room "new-self") "a@example.org"))) (should (jabber-sm--room-ready-p (fsm-get-state-data a) room)) (should-not (jabber-test-muc-aff--sender a room "guest-new")) (should (equal (jabber-test-muc-aff--recipients a room) '("a@example.org"))) (should (equal (jabber-test-muc-aff--recipients b room) '("other@example.org"))) (should (equal (jabber-test-muc-aff--sender b room "guest") "other@example.org"))) (when (timerp (plist-get attempt :timer)) (cancel-timer (plist-get attempt :timer))))))))) (ert-deftest jabber-test-muc-aff-native-self-303-retires-only-alias () "Self 303 retires its alias, never the lease or another account's occupant." (let ((send (symbol-function 'jabber-send-sexp))) (dolist (self-status '(nil t)) (jabber-test-muc-aff--with-room (jabber-muc--start-attempt a room "self-a") (jabber-test-muc-aff--presence a room "self-a" "a@example.org/device") (jabber-test-muc-aff--presence b room "self-a" "other@example.org/device") (cl-letf (((symbol-function 'jabber-send-sexp) send) ((symbol-function 'jabber-send-sexp--raw) (lambda (&rest _) t))) (jabber-muc-nick a room "new-self")) (let ((attempt (jabber-sm--room-attempt (fsm-get-state-data a) room)) (membership (assq a (jabber-muc-room-entries room)))) (unwind-protect (progn (fsm-send-sync a `(:stanza (presence ((from . ,(concat room "/self-a")) (type . "unavailable")) (x ((xmlns . ,jabber-muc-xmlns-user)) (item ((nick . "new-self"))) ,@(when self-status '((status ((code . "110"))))) (status ((code . "303"))))))) (should (eq attempt (jabber-sm--room-attempt (fsm-get-state-data a) room))) (should (eq membership (assq a (jabber-muc-room-entries room)))) (should (eq (plist-get attempt :status) 'pending)) (should-not (jabber-test-muc-aff--sender a room "self-a")) (jabber-test-muc-aff--presence a room "new-self" "a@example.org/device") (should (jabber-sm--room-ready-p (fsm-get-state-data a) room)) (should (equal (jabber-test-muc-aff--sender a room "new-self") "a@example.org")) (should (equal (jabber-test-muc-aff--sender b room "self-a") "other@example.org"))) (when (timerp (plist-get attempt :timer)) (cancel-timer (plist-get attempt :timer))))))))) (provide 'jabber-test-muc-affiliations) ;;; jabber-test-muc-affiliations.el ends here emacs-jabber-0.15.1/tests/jabber-test-muc.el000066400000000000000000011455231527111033600205730ustar00rootroot00000000000000;;; 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-silent-mode nil) (defvar jabber-current-status nil) (defvar jabber-current-show nil) (defvar jabber-current-priority nil) (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) (require 'jabber-omemo) (defmacro jabber-test-muc-with-active-jc (account &rest body) "Run BODY with ACCOUNT active, restoring its symbol properties afterward." (declare (indent 1)) `(let* ((account ,account) (properties (copy-sequence (symbol-plist account))) (jabber-connections (list account))) (unwind-protect (progn (put account :state :session-established) (put account :state-data '(:username "test" :server "example.org")) ,@body) (setplist account properties)))) (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 :test #'equal)) (jabber-jid-obarray (make-vector 127 0))) (puthash (list 'fake-jc "room@conference.example.com") "mynick" jabber-pending-groupchats) (let ((msg '(message ((from . "room@conference.example.com") (type . "error")) (error ((type . "cancel")))))) (should (jabber-muc-message-p msg 'fake-jc)) (should-not (jabber-muc-message-p msg 'other-jc)) (should-not (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 :test #'equal)) (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 :test #'equal)) (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 :test #'equal)) (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 :test #'equal)) (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 :test #'equal)) (jabber-jid-obarray (make-vector 127 0))) (puthash (list 'fake-jc "room@conference.example.com") "mynick" jabber-pending-groupchats) (let ((pres '(presence ((from . "room@conference.example.com/mynick") (type . "error")) (error ((type . "cancel")))))) (should (jabber-muc-presence-p pres 'fake-jc)) (should-not (jabber-muc-presence-p pres 'other-jc)) (should-not (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." (jabber-test-muc-with-active-jc 'fake-jc (let ((join-args nil)) (cl-letf (((symbol-function 'jabber-muc--send-join-presence) (lambda (jc group nickname password popup &optional auto-configure _request) (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 'fake-jc "room@conference.example.com" "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 'fake-jc "room@conference.example.com" "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." (jabber-test-muc-with-active-jc 'fake-jc (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 :test #'equal)) (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." (jabber-test-muc-with-active-jc 'jc (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) (seq-take args 5)))))) (ert-deftest jabber-test-muc-prompted-password-survives-self-ping-rejoin () "A prompted room password is retained for forced self-ping rejoin." (jabber-test-muc-with-active-jc 'jc (let ((jabber-muc--session-passwords (make-hash-table :test #'equal)) (jabber-pending-groupchats (make-hash-table :test #'equal)) (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 &rest _) (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." (jabber-test-muc-with-active-jc 'jc (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 _request) (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." (jabber-test-muc-with-active-jc 'jc (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 _request) (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." (jabber-test-muc-with-active-jc 'jc (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) (seq-take sent 5)))))) (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-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 nil "room@example.org" "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 :test #'equal)) (jabber-jid-obarray (make-vector 127 0)) (timer-scheduled nil)) (cl-letf (((symbol-function 'run-with-timer) (lambda (_secs _repeat fn &rest args) (setq timer-scheduled (cons fn args)) 'fake-timer)) ((symbol-function 'jabber-muc--autojoin-next) (lambda (jc) (should (eq jc 'fake-jc)) (setq timer-scheduled t))) ((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 (consp timer-scheduled)) (apply (car timer-scheduled) (cdr timer-scheduled))) (should (eq timer-scheduled t)))) ;;; 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 (&optional _frame) (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 (&optional _frame) (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 &optional _jc) "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))))) (defmacro jabber-test-muc-with-native-intent (&rest body) "Run BODY with isolated native join state and captured synthetic sends." (declare (indent 0)) `(let ((jc (make-symbol "native-jc")) (other (make-symbol "native-other")) (room "room@example.org") (jabber-db-path nil) (jabber-current-status nil) (jabber-current-show nil) (jabber-current-priority nil) (jabber-muc-disable-disco-check nil) (jabber-muc--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--nonanonymous-rooms (make-hash-table :test #'equal)) (jabber-pending-groupchats (make-hash-table :test #'equal)) (jabber-jid-obarray (make-vector 127 0)) (jabber-bookmarks-auto-add nil) replies sent) (let ((jabber-connections (list jc other))) (dolist (account (list jc other)) (put account :state :session-established) (put account :state-data (list :connection (make-symbol "transport") :session-id "session"))) (cl-letf (((symbol-function 'jabber-disco-get-info) (lambda (account _group _node callback closure) (setq replies (append replies (list (lambda (result) (funcall callback account closure result))))))) ((symbol-function 'jabber-muc--validate-disco-result) (lambda (result) (or result '(:status ok)))) ((symbol-function 'jabber-get-conference-data) #'ignore) ((symbol-function 'jabber-muc--autojoin-dequeue) #'ignore) ((symbol-function 'jabber-muc-create-buffer) (lambda (&rest _) (current-buffer))) ((symbol-function 'switch-to-buffer) #'ignore) ((symbol-function 'jabber-presence-children) #'ignore) ((symbol-function 'jabber-connection-bare-jid) (lambda (account) (symbol-name account))) ((symbol-function 'jabber-send-sexp) (lambda (account stanza &rest _) (push (list account (jabber-xml-get-attribute stanza 'to) (jabber-xml-get-attribute stanza 'type)) sent)))) ,@body)))) (ert-deftest jabber-test-muc-native-intent-latest-reply-orders () "Only the latest native request sends, in either discovery reply order." (dolist (order '((0 1) (1 0))) (jabber-test-muc-with-native-intent (jabber-muc-join jc room "old") (jabber-muc-join jc room "new") (dolist (index order) (funcall (nth index replies) nil)) (should (equal sent (list (list jc "room@example.org/new" nil))))))) (ert-deftest jabber-test-muc-native-intent-prompt-reentry () "Password and create prompts cannot revive a superseded request." (dolist (result '((:status ok :features ("muc_passwordprotected")) (:status not-found))) (jabber-test-muc-with-native-intent (cl-letf (((symbol-function 'read-passwd) (lambda (&rest _) (jabber-muc-join jc room "new") "secret")) ((symbol-function 'y-or-n-p) (lambda (&rest _) (jabber-muc-join jc room "new") t))) (jabber-muc-join jc room "old") (funcall (car replies) result) (should-not sent) (funcall (cadr replies) nil) (should (equal sent (list (list jc "room@example.org/new" nil)))))))) (ert-deftest jabber-test-muc-native-intent-retirement () "Direct send, leave and logical reset retire outstanding discovery." (dolist (action '(direct leave reset)) (jabber-test-muc-with-native-intent (jabber-muc-join jc room "old") (pcase action ('direct (jabber-muc-join-3 jc room "direct" nil nil)) ('leave (jabber-muc-leave jc room)) ('reset (jabber-muc--session-reset jc))) (let ((before (copy-tree sent))) (funcall (car replies) nil) (should (equal sent before)))))) (ert-deftest jabber-test-muc-native-intent-context-replaced () "A replaced transport or logical session blocks late and nested sends." (dolist (field '(:connection :session-id :nil-entry-token)) (dolist (during-prompt '(nil t)) (jabber-test-muc-with-native-intent (cl-flet ((replace-context () (put jc :state-data (plist-put (fsm-get-state-data jc) field (make-symbol "successor"))))) (cl-letf (((symbol-function 'read-passwd) (lambda (&rest _) (replace-context) "secret"))) (jabber-muc-join jc room "old") (unless during-prompt (replace-context)) (funcall (car replies) (when during-prompt '(:status ok :features ("muc_passwordprotected")))) (should-not sent))))))) (ert-deftest jabber-test-muc-native-intent-independent-scopes () "A newer request leaves another room and another account untouched." (jabber-test-muc-with-native-intent (jabber-muc-join jc room "old") (jabber-muc-join other room "other") (jabber-muc-join jc "second@example.org" "second") (jabber-muc-join jc room "new") (dolist (reply replies) (funcall reply nil)) (should (equal (reverse sent) (list (list other "room@example.org/other" nil) (list jc "second@example.org/second" nil) (list jc "room@example.org/new" nil)))))) (ert-deftest jabber-test-muc-native-intent-joined-preserved () "An already joined command opens, syncs and pings without new presence." (jabber-test-muc-with-native-intent (let (effects) (jabber-muc-join jc room "old") (jabber-muc-join-set room jc "joined") (cl-letf (((symbol-function 'jabber-muc-create-buffer) (lambda (&rest _) (current-buffer))) ((symbol-function 'switch-to-buffer) (lambda (&rest _) (push 'open effects))) ((symbol-function 'jabber-mam-muc-joined) (lambda (&rest _) (push 'sync effects))) ((symbol-function 'jabber-muc--self-ping-one) (lambda (&rest _) (push 'ping effects)))) (jabber-muc-join jc room "joined" t)) (funcall (car replies) nil) (should-not sent) (should (equal effects '(ping sync open))) (should (equal (jabber-muc-nickname room jc) "joined"))))) (ert-deftest jabber-test-muc-native-intent-legacy-context () "Legacy callback aliases capture context before prompting." (jabber-test-muc-with-native-intent (cl-letf (((symbol-function 'read-passwd) (lambda (&rest _) (put jc :state-data '(:connection replacement)) "secret"))) (jabber-muc-join-2 jc (list room "old" nil) '(:status ok :features ("muc_passwordprotected"))) (should-not sent)))) (ert-deftest jabber-test-muc-native-intent-no-disco-reentry () "A no-disco password prompt cannot replace a nested newer join." (jabber-test-muc-with-native-intent (let ((jabber-muc-disable-disco-check t)) (cl-letf (((symbol-function 'read-passwd) (lambda (&rest _) (jabber-muc-join jc room "new") "old-secret"))) (jabber-muc-join jc room "old" t)) (should (equal sent (list (list jc "room@example.org/new" nil))))))) (ert-deftest jabber-test-muc-native-intent-pending-reply-orders () "Latest discovery also wins while an earlier join presence is pending." (dolist (order '((0 1) (1 0))) (jabber-test-muc-with-native-intent (jabber-muc-join-3 jc room "pending" nil nil) (setq sent nil) (jabber-muc-join jc room "old") (jabber-muc-join jc room "new") (dolist (index order) (funcall (nth index replies) nil)) (should (equal sent (list (list jc "room@example.org/new" nil))))))) (ert-deftest jabber-test-muc-native-intent-completion-retires-owner () "Completion and cancellation release only the request that completed." (dolist (outcome '(success not-conference quit error)) (jabber-test-muc-with-native-intent (cl-letf (((symbol-function 'read-passwd) (lambda (&rest _) (signal outcome nil)))) (jabber-muc-join jc room "nick") (condition-case nil (funcall (car replies) (pcase outcome ('success '(:status ok)) ('not-conference '(:status not-conference)) (_ '(:status ok :features ("muc_passwordprotected"))))) ((error quit) nil))) (should-not (get jc 'jabber-muc--join-intents))))) (ert-deftest jabber-test-muc-native-intent-construction-successor () "Real presence hooks cannot hand off an old join after a newer one." (let ((dispatcher (symbol-function 'jabber-presence-children))) (dolist (entry '(disco no-disco direct)) (dolist (complete '(nil t)) (jabber-test-muc-with-native-intent (let ((jabber-presence-element-functions (list (lambda (_account) (let ((jabber-presence-element-functions nil) (jabber-muc-disable-disco-check nil)) (jabber-muc-join jc room "new") (when complete (funcall (car (last replies)) nil))) nil)))) (cl-letf (((symbol-function 'jabber-presence-children) dispatcher)) (pcase entry ('disco (jabber-muc-join jc room "old") (funcall (car replies) nil)) ('no-disco (let ((jabber-muc-disable-disco-check t)) (jabber-muc-join jc room "old"))) ('direct (jabber-muc-join-3 jc room "old" "old-secret" nil))) (unless complete (should-not sent) (let ((jabber-presence-element-functions nil)) (funcall (car (last replies)) nil))))) (should (equal sent (list (list jc "room@example.org/new" nil)))) (should (equal (gethash (list jc room) jabber-pending-groupchats) "new")) (should-not (jabber-muc--session-password jc room)) (should-not (get jc 'jabber-muc--join-intents))))))) (ert-deftest jabber-test-muc-native-intent-construction-cancelled () "Context changes and cancellation in real presence hooks prevent writes." (let ((dispatcher (symbol-function 'jabber-presence-children))) (dolist (entry '(disco no-disco direct)) (dolist (action '(:connection :session-id :nil-entry-token leave reset)) (jabber-test-muc-with-native-intent (let ((jabber-presence-element-functions (list (lambda (_account) (pcase action ('leave (jabber-muc-leave jc room)) ('reset (jabber-muc--session-reset jc)) (_ (put jc :state-data (plist-put (fsm-get-state-data jc) action (make-symbol "replacement"))))) nil)))) (cl-letf (((symbol-function 'jabber-presence-children) dispatcher) ((symbol-function 'read-passwd) (lambda (&rest _) "old-secret"))) (pcase entry ('disco (jabber-muc-join jc room "old") (funcall (car replies) '(:status ok :features ("muc_passwordprotected")))) ('no-disco (let ((jabber-muc-disable-disco-check t)) (jabber-muc-join jc room "old" t))) ('direct (jabber-muc-join-3 jc room "old" "old-secret" nil))))) (should-not (seq-find (lambda (send) (null (nth 2 send))) sent)) (should-not (gethash (list jc room) jabber-pending-groupchats)) (should-not (jabber-muc--session-password jc room)) (should-not (get jc 'jabber-muc--join-intents))))))) (defun jabber-test-muc-native-create-completion (phase action) "Exercise native creation interrupted at PHASE by ACTION." (require 'jabber-bookmarks) (let ((dispatcher (symbol-function 'jabber-presence-children))) (jabber-test-muc-with-native-intent (with-temp-buffer (let ((buffer (current-buffer)) (jabber-bookmarks (make-hash-table :test #'equal)) publications callbacks opened created interrupted) (cl-labels ((interrupt (where) (when (and (eq phase where) (not interrupted)) (setq interrupted t) (pcase action ('join (jabber-muc-join jc room "new")) ('leave (jabber-muc-leave jc room)) ('reset (jabber-muc--session-reset jc)) ((or 'error 'quit) (jabber-muc-join jc room "new") (signal action nil)))))) (let ((jabber-presence-element-functions (list (lambda (_) (interrupt 'presence) nil)))) (cl-letf (((symbol-function 'jabber-presence-children) dispatcher) ((symbol-function 'jabber-bookmarks--legacy-p) (lambda (_) nil)) ((symbol-function 'jabber-bookmarks2--publish) (lambda (_jc bookmark success _failure) (push bookmark publications) (push success callbacks))) ((symbol-function 'jabber-bookmarks--refresh-buffer) #'ignore) ((symbol-function 'jabber-send-sexp) (lambda (account stanza &rest _) (push (list account (jabber-xml-get-attribute stanza 'to) (jabber-xml-get-attribute stanza 'type)) sent) (interrupt 'send))) ((symbol-function 'jabber-muc-create-buffer) (lambda (account target) (setq created t) (with-current-buffer buffer (setq-local jabber-buffer-connection account) (setq-local jabber-group target)) (interrupt 'buffer) buffer)) ((symbol-function 'switch-to-buffer) (lambda (&rest _) (setq opened t) (interrupt 'switch)))) (let ((caught nil)) (condition-case err (jabber-muc-create jc room "old") ((error quit) (setq caught (car err)))) (should (eq caught (and (memq action '(error quit)) action)))) (if phase (progn (should-not publications) (should-not jabber-muc--auto-configure) (when (memq phase '(presence send buffer)) (should-not opened)) (when (eq phase 'presence) (should-not created))) (should opened) (should jabber-muc--auto-configure) (should (equal (mapcar (lambda (bm) (plist-get bm :nick)) publications) '("old")))) ;; Only real transport handoffs may have a success callback. (dolist (callback callbacks) (funcall callback jc nil nil)) (let ((jabber-presence-element-functions nil)) (dolist (reply replies) (funcall reply nil))) (cond ((or (eq action 'join) (memq action '(error quit))) (should (equal (gethash (list jc room) jabber-pending-groupchats) "new")) (should (equal (car sent) (list jc "room@example.org/new" nil)))) ((null phase) (should (equal (gethash (list jc room) jabber-pending-groupchats) "old"))) ((eq phase 'presence) (should-not (seq-find (lambda (send) (null (nth 2 send))) sent))))) (should-not (get jc 'jabber-muc--join-intents))))))))) (ert-deftest jabber-test-muc-native-create-construction-cancelled () "An obsolete create never publishes a bookmark that can revive it." (dolist (action '(join leave reset)) (jabber-test-muc-native-create-completion 'presence action))) (ert-deftest jabber-test-muc-native-create-post-callback-cancelled () "Send and UI reentry suppress obsolete configuration and publication." (dolist (phase '(send buffer switch)) (dolist (action '(join leave reset)) (jabber-test-muc-native-create-completion phase action)))) (ert-deftest jabber-test-muc-native-create-errors-preserve-successor () "Errors and quits propagate without retiring a nested successor." (dolist (phase '(presence send buffer switch)) (dolist (action '(error quit)) (jabber-test-muc-native-create-completion phase action)))) (ert-deftest jabber-test-muc-native-create-success () "Successful creation opens, configures and publishes through real callbacks." (jabber-test-muc-native-create-completion nil nil)) (defmacro jabber-test-muc-with-native-room (&rest body) "Run BODY with real native buffers and isolated external effects." (declare (indent 0)) `(let* ((jc (make-symbol "room-a")) (other (make-symbol "room-b")) (room "native@example.org") (jabber-connections (list jc other)) (jabber-db-path nil) (jabber-groupchat-buffer-format " *native-%n-%a*") (jabber-buffer-registry--buffers (make-hash-table :test #'equal)) (jabber-muc--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--nonanonymous-rooms (make-hash-table :test #'equal)) (jabber-muc-participants nil) (jabber-pending-groupchats (make-hash-table :test #'equal)) (jabber-jid-obarray (make-vector 127 0)) (jabber-bookmarks-auto-add nil) (jabber-presence-element-functions nil) (jabber-chat-mode-hook nil) (before (buffer-list)) sent published config) (dolist (account jabber-connections) (put account :state :session-established) (put account :state-data (list :connection (make-symbol "transport") :session-id "session" :username (symbol-name account) :server "example.org"))) (save-window-excursion (unwind-protect (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (account stanza &rest _) (push (list account stanza) sent))) ((symbol-function 'jabber-send-iq) (lambda (account target type query callback context &rest _) (when (equal (jabber-xml-get-attribute query 'xmlns) jabber-muc-xmlns-owner) (push (list account target type callback context jabber-muc--auto-configure) config)))) ((symbol-function 'jabber-bookmarks--publish-one) (lambda (&rest args) (push args published))) ((symbol-function 'jabber-mam-muc-joined) #'ignore) ((symbol-function 'run-with-timer) #'ignore)) ,@body) (dolist (buffer (seq-difference (buffer-list) before)) (when (buffer-live-p buffer) (kill-buffer buffer))))))) (defun jabber-test-muc-native-201 (jc room) "Deliver real self-presence creating ROOM on JC." (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/nick"))) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((affiliation . "owner") (role . "moderator"))) (status ((code . "110"))) (status ((code . "201"))))))) (ert-deftest jabber-test-muc-native-room-collision () "Real constructor rejects a foreign arm before any rebind or handoff." (jabber-test-muc-with-native-room (let ((jabber-groupchat-buffer-format " *native-%n*")) (jabber-muc-create jc room "nick") (let* ((buffer (jabber-muc-find-buffer room jc)) (arm (buffer-local-value 'jabber-muc--auto-configure buffer)) (keys (buffer-local-value 'jabber-buffer-registry--keys buffer))) (should-error (jabber-muc-create other room "other") :type 'user-error) (should-error (jabber-muc-create-buffer other room) :type 'user-error) (should (eq arm (buffer-local-value 'jabber-muc--auto-configure buffer))) (should (eq jc (buffer-local-value 'jabber-buffer-connection buffer))) (should (equal keys (buffer-local-value 'jabber-buffer-registry--keys buffer))) (should (= (length sent) 1)) (should (= (length published) 1)) (should-not (get other 'jabber-muc--join-intents)) ;; Historical aliases can route presence without constructing a buffer. (jabber-buffer-registry-register 'muc (jabber-muc--buffer-key other room) buffer) (jabber-test-muc-native-201 other room) (should-not config) (should (eq arm (buffer-local-value 'jabber-muc--auto-configure buffer))) (jabber-test-muc-native-201 jc room) (should (= (length config) 1)) (should (eq (caar config) jc)) (should-not (nth 5 (car config))) (jabber-test-muc-native-201 jc room) (should (= (length config) 1)) (jabber-muc-create other room "retry") (should (= (length published) 2)) (jabber-test-muc-native-201 other room) (should (= (length config) 2)))))) (ert-deftest jabber-test-muc-native-room-progress () "201 during send, constructor reentry or real switching is positive progress." (dolist (phase '(send constructor switch)) (jabber-test-muc-with-native-room (let ((send (symbol-function 'jabber-send-sexp)) fired) (cl-labels ((deliver () (unless fired (setq fired t) (when (eq phase 'constructor) (jabber-muc-create-buffer jc room)) (jabber-test-muc-native-201 jc room)))) (let ((buffer-list-update-hook (when (eq phase 'switch) (list (lambda () (when (and (equal jabber-group room) (eq jabber-buffer-connection jc) sent) (deliver))))))) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (account stanza &rest _) (funcall send account stanza) (unless (eq phase 'switch) (deliver))))) (jabber-muc-create jc room "nick"))) (should fired) (should (= (length config) 1)) (should-not (nth 5 (car config))) (should (= (length published) 1)) (with-current-buffer (jabber-muc-find-buffer room jc) (should-not jabber-muc--auto-configure)) (should-not (get jc 'jabber-muc--join-intents))))))) (ert-deftest jabber-test-muc-native-room-origin () "Notice reentry cannot change the account or room of a config request." (dolist (manual '(nil t manual)) (jabber-test-muc-with-native-room (jabber-muc-create jc room "nick") (let* ((buffer (jabber-muc-find-buffer room jc)) (insert (symbol-function 'jabber-chat-ewoc-enter))) (with-current-buffer buffer (when manual (setq jabber-muc--auto-configure manual))) (cl-letf (((symbol-function 'jabber-chat-ewoc-enter) (lambda (&rest args) (prog1 (apply insert args) (setq jabber-buffer-connection other jabber-group "another@example.org"))))) (jabber-test-muc-native-201 jc room)) (should (= (length config) 1)) (should (eq (caar config) jc)) (should (equal (cadar config) room)) (should (equal (nth 4 (car config)) (list buffer room))) (should-not (nth 5 (car config))))))) (ert-deftest jabber-test-muc-native-room-setup-collision () "Setup reentry cannot install a foreign arm before a final rebind." (jabber-test-muc-with-native-room (let ((setup (symbol-function 'jabber-chat-mode-setup)) foreign) (cl-letf (((symbol-function 'jabber-chat-mode-setup) (lambda (&rest args) (apply setup args) (setq foreign (list 'jabber-muc--config-arm other room)) (setq jabber-muc--auto-configure foreign jabber-buffer-connection other)))) (should-error (jabber-muc-create jc room "nick") :type 'user-error)) (with-current-buffer (get-buffer (jabber-muc-get-buffer room jc)) (should (eq jabber-buffer-connection other)) (should (eq jabber-muc--auto-configure foreign)) (should-not jabber-buffer-registry--keys)) (should-not sent) (should-not published)))) (ert-deftest jabber-test-muc-native-intent-joined-constructor-reentry () "A joined room's yielding constructor cannot open a superseded intent." (jabber-test-muc-with-native-intent (jabber-muc-join-set room jc "joined") (let (effects) (cl-letf (((symbol-function 'jabber-muc-create-buffer) (lambda (&rest _) (jabber-muc-leave jc room) (current-buffer))) ((symbol-function 'switch-to-buffer) (lambda (&rest _) (push 'open effects))) ((symbol-function 'jabber-mam-muc-joined) (lambda (&rest _) (push 'sync effects))) ((symbol-function 'jabber-muc--self-ping-one) (lambda (&rest _) (push 'ping effects)))) (jabber-muc-join jc room "joined" t)) (should-not effects)))) (ert-deftest jabber-test-muc-native-constructor-entry-effects () "Reject foreign permission before mode callbacks, not merely final rebind." (jabber-test-muc-with-native-room (let* ((buffer (get-buffer-create (jabber-muc-get-buffer room jc))) (arm (list 'jabber-muc--config-arm other room)) entered (jabber-chat-mode-hook (list (lambda () (setq entered t))))) (with-current-buffer buffer (setq-local jabber-muc--auto-configure arm) (setq-local jabber-buffer-connection other)) (condition-case nil (jabber-muc-create-buffer jc room) (user-error nil)) (should-not entered) (should (eq arm (buffer-local-value 'jabber-muc--auto-configure buffer))) (should (eq other (buffer-local-value 'jabber-buffer-connection buffer))) (should-not (buffer-local-value 'jabber-buffer-registry--keys buffer))))) (ert-deftest jabber-test-muc-native-create-arm-unwind () "Old cancellation, error and quit preserve a new create's exact permission." (dolist (successor '(nil completed)) (dolist (condition '(nil error quit)) (jabber-test-muc-with-native-room (let ((send (symbol-function 'jabber-send-sexp)) fired new-arm caught) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (account stanza &rest _) (funcall send account stanza) (unless fired (setq fired t) (when successor (jabber-muc-create jc room "successor") (setq new-arm (buffer-local-value 'jabber-muc--auto-configure (jabber-muc-find-buffer room jc)))) (when condition (signal condition '("old-create" detail))))))) (condition-case err (jabber-muc-create jc room "old") ((error quit) (setq caught err)))) (should (equal caught (and condition (list condition "old-create" 'detail)))) (with-current-buffer (jabber-muc-find-buffer room jc) (if successor (should (eq jabber-muc--auto-configure new-arm)) (should (eq (not jabber-muc--auto-configure) (and condition t))))) (should-not (cdr (assoc room (get jc 'jabber-muc--join-intents)))) (should (= (length published) (if successor 1 (if condition 0 1))))))))) (ert-deftest jabber-test-muc-native-consumed-unwind () "Consumed permissions stay consumed across later native cancellation." (dolist (action '(join leave reset error quit)) (jabber-test-muc-with-native-room (let ((send (symbol-function 'jabber-send-sexp)) fired caught) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (account stanza &rest _) (funcall send account stanza) (unless fired (setq fired t) (jabber-test-muc-native-201 jc room) (pcase action ('join (let ((jabber-muc-disable-disco-check t)) (jabber-muc-join jc room "new"))) ('leave (jabber-muc-leave jc room)) ('reset (jabber-muc--session-reset jc)) (_ (signal action '("consumed" detail)))))))) (condition-case err (jabber-muc-create jc room "old") ((error quit) (setq caught err)))) (should (equal caught (and (memq action '(error quit)) (list action "consumed" 'detail)))) (should (= (length config) 1)) (should-not (nth 5 (car config))) (should-not published) (with-current-buffer (jabber-muc-find-buffer room jc) (should-not jabber-muc--auto-configure)) (jabber-test-muc-native-201 jc room) (should (= (length config) 1)))))) (ert-deftest jabber-test-muc-native-permission-invalidation () "Ordinary join, leave and reset clear only matching package permissions." (dolist (kind '(nil t manual owned foreign-account foreign-room)) (dolist (action '(join leave reset)) (jabber-test-muc-with-native-room (let* ((buffer (jabber-muc-create-buffer jc room)) (arm (pcase kind ('owned (list 'jabber-muc--config-arm jc room)) ('foreign-account (list 'jabber-muc--config-arm other room)) ('foreign-room (list 'jabber-muc--config-arm jc "else@example.org")) (_ kind)))) (with-current-buffer buffer (setq jabber-muc--auto-configure arm)) (pcase action ('join (let ((jabber-muc-disable-disco-check t)) (if (memq kind '(foreign-account foreign-room)) (should-error (jabber-muc-join jc room "new") :type 'user-error) (jabber-muc-join jc room "new")))) ('leave (jabber-muc-leave jc room)) ('reset (jabber-muc--session-reset jc))) (with-current-buffer buffer (should (eq jabber-muc--auto-configure (if (or (eq kind 'owned) (and (eq kind 'foreign-room) (eq action 'reset))) nil arm))))))))) (ert-deftest jabber-test-muc-native-scope-collisions () "Rendered collisions reject ordinary popup joins without bookkeeping." (dolist (scope '(account equal-account room)) (jabber-test-muc-with-native-room (let ((jabber-groupchat-buffer-format " *native-collision*")) (when (eq scope 'equal-account) (put other :state-data (copy-sequence (fsm-get-state-data jc)))) (jabber-muc-create jc room "first") (let* ((target (if (eq scope 'room) "else@example.org" room)) (account (if (eq scope 'room) jc other)) (buffer (jabber-muc-find-buffer room jc)) (arm (buffer-local-value 'jabber-muc--auto-configure buffer)) (pending (copy-hash-table jabber-pending-groupchats)) (passwords (copy-hash-table jabber-muc--session-passwords)) opened) (cl-letf (((symbol-function 'switch-to-buffer) (lambda (&rest _) (setq opened t)))) (should-error (jabber-muc--send-join-presence account target "second" "secret" t) :type 'user-error) (should-error (jabber-muc-create account target "second") :type 'user-error)) (should-not opened) (dolist (tables (list (cons pending jabber-pending-groupchats) (cons passwords jabber-muc--session-passwords))) (should (= (hash-table-count (car tables)) (hash-table-count (cdr tables)))) (maphash (lambda (key value) (should (equal value (gethash key (cdr tables) :missing)))) (car tables))) (should (eq arm (buffer-local-value 'jabber-muc--auto-configure buffer))) (should-not (get account 'jabber-muc--join-intents)) (should (= (length sent) 1)) (should (= (length published) 1))))))) (ert-deftest jabber-test-muc-native-default-scope-progress () "Default names separate active accounts and ordinary popup joins still open." (jabber-test-muc-with-native-room (let ((jabber-groupchat-buffer-format (default-value 'jabber-groupchat-buffer-format))) (jabber-muc-create jc room "first") (jabber-muc-create other room "second") (should-not (eq (jabber-muc-find-buffer room jc) (jabber-muc-find-buffer room other))) (jabber-test-muc-native-201 jc room) (jabber-test-muc-native-201 other room) (should (equal (mapcar #'car (reverse config)) (list jc other))) (should (= (length published) 2)) (jabber-muc--send-join-presence jc "ordinary@example.org" "nick" nil t) (should (eq (current-buffer) (jabber-muc-find-buffer "ordinary@example.org" jc)))))) (ert-deftest jabber-test-muc-native-setup-successor () "Same-scope setup reentry leaves only the nested create's send and arm." (jabber-test-muc-with-native-room (let ((setup (symbol-function 'jabber-chat-mode-setup)) fired arm) (cl-letf (((symbol-function 'jabber-chat-mode-setup) (lambda (&rest args) (apply setup args) (unless fired (setq fired t) (jabber-muc-create jc room "new") (setq arm jabber-muc--auto-configure))))) (jabber-muc-create jc room "old")) (should fired) (should (= (length sent) 1)) (should (equal (jabber-xml-get-attribute (cadar sent) 'to) (concat room "/new"))) (should (= (length published) 1)) (should-not (get jc 'jabber-muc--join-intents)) (with-current-buffer (jabber-muc-find-buffer room jc) (should (eq arm jabber-muc--auto-configure)))))) (ert-deftest jabber-test-muc-native-config-callback-progress () "Immediate config results retain authority when real form UI reenters." (dolist (outcome '(success error join create)) (jabber-test-muc-with-native-room (let ((send (symbol-function 'jabber-send-sexp)) (iq (symbol-function 'jabber-send-iq)) (open (symbol-function 'jabber-xdata-form-open)) fired form-opened effects) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (account stanza &rest _) (funcall send account stanza) (push (list 'send account (jabber-xml-get-attribute stanza 'to)) effects) (unless fired (setq fired t) (jabber-test-muc-native-201 jc room)))) ((symbol-function 'jabber-send-iq) (lambda (account target type query callback context &rest rest) (apply iq account target type query callback context rest) (when (equal (jabber-xml-get-attribute query 'xmlns) jabber-muc-xmlns-owner) (should-not jabber-muc--auto-configure) (push (list 'config account target) effects) (if (eq outcome 'error) (funcall (car rest) account '(iq ((type . "error")) (error ((type . "cancel")) (forbidden ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))) (cadr rest)) (funcall callback account `(iq ((type . "result")) (query ((xmlns . ,jabber-muc-xmlns-owner)) (x ((xmlns . ,jabber-xdata-xmlns) (type . "form")) (field ((var . "name") (type . "text-single")) (value () "Room"))))) context))))) ((symbol-function 'jabber-muc--room-created-message) (lambda () (ert-fail "Automatic configuration fell back to a manual notice"))) ((symbol-function 'jabber-xdata-form-open) (lambda (&rest args) (prog1 (apply open args) (setq form-opened t) (push (list 'form jc room) effects) (pcase outcome ('join (let ((jabber-muc-disable-disco-check t)) (jabber-muc-join jc room "new"))) ('create (jabber-muc-create jc room "new"))))))) (jabber-muc-create jc room "old")) (should (eq form-opened (not (eq outcome 'error)))) (should (equal (seq-take (reverse effects) 2) (list (list 'send jc (concat room "/old")) (list 'config jc room)))) (should (= (length config) 1)) (should (eq (caar config) jc)) (should (equal (cadar config) room)) (should (= (length published) (if (eq outcome 'join) 0 1))) (when (eq outcome 'create) (should (equal (nth 2 (car published)) "new"))) (with-current-buffer (jabber-muc-find-buffer room jc) (if (eq outcome 'create) (should (eq (car-safe jabber-muc--auto-configure) 'jabber-muc--config-arm)) (should-not jabber-muc--auto-configure))))))) (ert-deftest jabber-test-muc-native-inverse-event-origin () "Foreign events cannot steal an arm by rebinding locals during notices." (dolist (phase '(delta status)) (dolist (manual '(nil t manual)) (jabber-test-muc-with-native-room (jabber-muc-create jc room "old") (let* ((buffer (jabber-muc-find-buffer room jc)) (arm (buffer-local-value 'jabber-muc--auto-configure buffer)) (insert (symbol-function 'jabber-chat-ewoc-enter)) (notice (symbol-function 'jabber-muc--insert-notice)) rebound effects) (jabber-buffer-registry-register 'muc (jabber-muc--buffer-key other room) buffer) (with-current-buffer buffer (setq jabber-buffer-connection other) (when manual (setq jabber-muc--auto-configure manual))) (cl-labels ((rebind () (setq rebound t jabber-buffer-connection jc jabber-group "wrong@example.org") (push (list 'rebind other room) effects))) (cl-letf (((symbol-function 'jabber-chat-ewoc-enter) (lambda (&rest args) (prog1 (apply insert args) (when (eq phase 'delta) (rebind))))) ((symbol-function 'jabber-muc--insert-notice) (lambda (&rest args) (prog1 (apply notice args) (when (eq phase 'status) (rebind)))))) (jabber-muc-process-presence other `(presence ((from . ,(concat room "/nick"))) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((affiliation . "owner") (role . "moderator"))) (status ((code . "110"))) (status ((code . "170"))) (status ((code . "201")))))))) (should rebound) (should effects) (if manual (progn (should (= (length config) 1)) (should (eq (caar config) other)) (should (equal (cadar config) room)) (should (equal (nth 4 (car config)) (list buffer room))) (should-not (nth 5 (car config)))) (should-not config) (should (eq arm (buffer-local-value 'jabber-muc--auto-configure buffer))))))))) (ert-deftest jabber-test-muc-native-pending-create-arm-cleanup () "Stale cleanup while a new create is still sending preserves its owner." (jabber-test-muc-with-native-room (let ((send (symbol-function 'jabber-send-sexp)) old checked) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (account stanza &rest _) (funcall send account stanza) (if (null old) (progn (setq old (cdr (assoc room (get jc 'jabber-muc--join-intents)))) (jabber-muc-create jc room "new")) (let* ((owner (cdr (assoc room (get jc 'jabber-muc--join-intents)))) (buffer (jabber-muc-find-buffer room jc)) (arm (buffer-local-value 'jabber-muc--auto-configure buffer))) (should-not (eq old owner)) (should-not (eq (aref old 6) arm)) ;; Exercise the actual stale cleanup boundary while the ;; successor's public sender has not returned. (should (eq (jabber-muc--with-intent old (ert-fail "Stale body")) :cancelled)) (should (eq owner (cdr (assoc room (get jc 'jabber-muc--join-intents))))) (should (eq arm (buffer-local-value 'jabber-muc--auto-configure buffer))) (setq checked t)))))) (jabber-muc-create jc room "old")) (should checked) (should (= (length published) 1)) (should-not (get jc 'jabber-muc--join-intents))))) (ert-deftest jabber-test-muc-native-manual-error-unwind () "Error and quit never claim or erase pre-existing manual permissions." (dolist (manual '(t manual)) (dolist (condition '(error quit)) (jabber-test-muc-with-native-room (let ((buffer (jabber-muc-create-buffer jc room)) caught) (with-current-buffer buffer (setq jabber-muc--auto-configure manual)) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (&rest _) (signal condition '("manual" detail))))) (condition-case err (jabber-muc-create jc room "old") ((error quit) (setq caught err)))) (should (equal caught (list condition "manual" 'detail))) (should (eq manual (buffer-local-value 'jabber-muc--auto-configure buffer))) (should-not published) (should-not (get jc 'jabber-muc--join-intents))))))) (ert-deftest jabber-test-muc-native-status-event-origin () "Matching and manual permissions use event authority after status notices." (dolist (manual '(nil t manual)) (jabber-test-muc-with-native-room (jabber-muc-create jc room "old") (let ((buffer (jabber-muc-find-buffer room jc)) (insert (symbol-function 'jabber-muc--insert-notice)) (iq (symbol-function 'jabber-send-iq)) effects) (with-current-buffer buffer (when manual (setq jabber-muc--auto-configure manual))) (cl-letf (((symbol-function 'jabber-muc--insert-notice) (lambda (&rest args) (prog1 (apply insert args) (setq jabber-buffer-connection other jabber-group "wrong@example.org") (push (list 'notice jc room) effects)))) ((symbol-function 'jabber-send-iq) (lambda (account target type query &rest args) (when (equal (jabber-xml-get-attribute query 'xmlns) jabber-muc-xmlns-owner) (push (list 'config account target) effects)) (apply iq account target type query args)))) (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/nick"))) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((affiliation . "owner") (role . "moderator"))) (status ((code . "110"))) (status ((code . "170"))) (status ((code . "201"))))))) (should (equal (reverse effects) (list (list 'notice jc room) (list 'config jc room)))) (should (= (length config) 1)) (should (equal (nth 4 (car config)) (list buffer room))) (should-not (nth 5 (car config))))))) (ert-deftest jabber-test-muc-native-discovery-submission-unwind () "Submission failures propagate intact and cannot leave a live callback." (dolist (condition '(error quit)) (jabber-test-muc-with-native-intent (let ((submit (symbol-function 'jabber-disco-get-info)) caught) (cl-letf (((symbol-function 'jabber-disco-get-info) (lambda (&rest args) (apply submit args) (signal condition '("submission" detail))))) (condition-case err (jabber-muc-join jc room "old") ((error quit) (setq caught err)))) (should (equal caught (list condition "submission" 'detail))) (should-not (get jc 'jabber-muc--join-intents)) (funcall (car replies) nil) (should-not sent) (should-not (gethash (list jc room) jabber-pending-groupchats)))))) (ert-deftest jabber-test-muc-native-repeated-discovery () "A completed native closure stays inert even after a new reservation." (jabber-test-muc-with-native-intent (jabber-muc-join jc room "old") (funcall (car replies) nil) (funcall (car replies) nil) (should (= (length sent) 1)) (jabber-muc-join jc room "new") (let ((owner (cdr (assoc room (get jc 'jabber-muc--join-intents))))) (funcall (car replies) nil) (should (eq owner (cdr (assoc room (get jc 'jabber-muc--join-intents)))))) (funcall (cadr replies) nil) (funcall (cadr replies) nil) (should (equal (reverse sent) (list (list jc "room@example.org/old" nil) (list jc "room@example.org/new" nil)))))) (ert-deftest jabber-test-muc-native-eligibility-yields () "Loss of active eligibility fences discovery, prompts and construction." (let ((dispatcher (symbol-function 'jabber-presence-children))) (dolist (phase '(discovery password create presence)) (dolist (action '(remove terminal register)) (jabber-test-muc-with-native-intent (cl-labels ((invalidate () (pcase action ('remove (setq jabber-connections (delq jc jabber-connections))) ('terminal (put jc :state :disconnected)) ('register (put jc :state-data (plist-put (fsm-get-state-data jc) :registerp t)))))) (let ((jabber-silent-mode nil) (jabber-presence-element-functions (list (lambda (_) (invalidate) nil)))) (cl-letf (((symbol-function 'read-passwd) (lambda (&rest _) (invalidate) "secret")) ((symbol-function 'y-or-n-p) (lambda (&rest _) (invalidate) t)) ((symbol-function 'jabber-presence-children) (if (eq phase 'presence) dispatcher #'ignore))) (jabber-muc-join jc room "old") (when (eq phase 'discovery) (invalidate)) (funcall (car replies) (pcase phase ('password '(:status ok :features ("muc_passwordprotected" "muc_nonanonymous"))) ('create '(:status not-found)) (_ nil)))))) (should-not sent) (should-not (get jc 'jabber-muc--join-intents)) (should-not (gethash room jabber-muc--nonanonymous-rooms)) (should-not (jabber-muc--session-password jc room)) (should-not (gethash (list jc room) jabber-pending-groupchats))))))) (ert-deftest jabber-test-muc-native-create-prompt-outcomes () "Silent creation bypasses prompting; decline and quit never hand off." (dolist (outcome '(silent accept decline error quit)) (jabber-test-muc-with-native-intent (let ((jabber-silent-mode (eq outcome 'silent)) prompted caught) (cl-letf (((symbol-function 'y-or-n-p) (lambda (&rest _) (setq prompted t) (pcase outcome ((or 'error 'quit) (signal outcome '("create-prompt" detail))) (_ (eq outcome 'accept)))))) (jabber-muc-join jc room "nick") (condition-case err (funcall (car replies) '(:status not-found)) ((error quit) (setq caught err)))) (should (eq prompted (not (eq outcome 'silent)))) (should (equal caught (pcase outcome ('decline '(error "Non-existent groupchat")) ((or 'error 'quit) (list outcome "create-prompt" 'detail))))) (should (= (length sent) (if (memq outcome '(silent accept)) 1 0))) (should-not (get jc 'jabber-muc--join-intents)) (let ((before (copy-tree sent))) (funcall (car replies) '(:status not-found)) (should (equal sent before))))))) (ert-deftest jabber-test-muc-native-legacy-publication () "Legacy transport and success retain native ownership after publication." (require 'jabber-bookmarks) (let ((publish (symbol-function 'jabber-bookmarks--publish-one))) (dolist (phase '(nil presence send buffer switch publication)) (jabber-test-muc-with-native-room (let ((jabber-bookmarks (make-hash-table :test #'equal)) (jabber-bookmarks--legacy-accounts (make-hash-table :test #'equal)) (jabber-muc-disable-disco-check t) (send (symbol-function 'jabber-send-sexp)) (create (symbol-function 'jabber-muc-create-buffer)) (switch (symbol-function 'switch-to-buffer)) callbacks storage interrupted) (puthash (jabber-connection-bare-jid jc) t jabber-bookmarks--legacy-accounts) (cl-labels ((interrupt (where) (when (and (eq where phase) (not interrupted)) (setq interrupted t) (jabber-muc-join jc room "new")))) (let ((jabber-presence-element-functions (list (lambda (_) (interrupt 'presence) nil)))) (cl-letf (((symbol-function 'jabber-bookmarks--publish-one) publish) ((symbol-function 'jabber-bookmarks--refresh-buffer) #'ignore) ((symbol-function 'jabber-private-set) (lambda (account xml callback context &rest _) (push (list account xml) storage) (push (lambda () (funcall callback account nil context)) callbacks) (interrupt 'publication))) ((symbol-function 'jabber-send-sexp) (lambda (&rest args) (prog1 (apply send args) (interrupt 'send)))) ((symbol-function 'jabber-muc-create-buffer) (lambda (&rest args) (prog1 (apply create args) (interrupt 'buffer)))) ((symbol-function 'switch-to-buffer) (lambda (&rest args) (prog1 (apply switch args) (interrupt 'switch))))) (jabber-muc-create jc room "old") (should (= (length storage) (if (memq phase '(nil publication)) 1 0))) (when storage (should (eq (caar storage) jc)) (should (equal (cadar storage) `(storage ((xmlns . ,jabber-bookmarks-xmlns)) (conference ((jid . ,room) (autojoin . "1")) (nick () "old")))))) ;; Complete the real legacy save-all/publish-one/maybe-join chain. (dolist (callback callbacks) (funcall callback)) (should (equal (mapcar (lambda (entry) (jabber-xml-get-attribute (cadr entry) 'to)) (reverse sent)) (pcase phase ('nil (list (concat room "/old"))) ((or 'presence 'buffer) (list (concat room "/new"))) ('publication (list (concat room "/old") (concat room "/new"))) (_ (list (concat room "/old") (concat room "/new"))))))))) (should-not (get jc 'jabber-muc--join-intents))))))) (defmacro jabber-test-muc-with-recovery (&rest body) "Run BODY with synthetic recovery state and captured transport/timers." (declare (indent 0)) `(let* ((jc (make-symbol "recover")) (jabber-db-path nil) (jabber-connections (list jc)) (jabber-auto-reconnect t) (jabber-sm-max-in-flight nil) (jabber-muc-autojoin nil) (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-pending-groupchats (make-hash-table :test #'equal)) (jabber-muc-participants nil) (jabber-muc--autojoin-queue nil) (jabber-muc--autojoin-pending nil) (jabber-muc--autojoin-disco-count nil) (jabber-muc--autojoin-timer nil) (room "room@example.org") (failed 0) sent timers drains) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data (list :connection (make-symbol "transport") :session-id "stream" :ever-session-established t :sm-fresh-recovery t :sm-pending-queue (list (list :stanza `(message ((to . ,room) (type . "groupchat") (id . "old")) (body () "ciphertext")) :retained-room room :failure (lambda (_) (cl-incf failed)))))) (puthash "self@example.org" (list (list room "self" "synthetic-secret")) jabber-muc--rooms-before-disconnect) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "self@example.org")) ((symbol-function 'jabber-send-sexp--raw) (lambda (_jc stanza) (push stanza sent))) ((symbol-function 'jabber-presence-children) (lambda (_) nil)) ((symbol-function 'jabber-get-bookmarks) #'ignore) ((symbol-function 'jabber-disco-get-items) #'ignore) ((symbol-function 'jabber-sm--schedule-drain) (lambda (c sd) (push (list c sd) drains))) ((symbol-function 'run-with-timer) (lambda (delay _repeat fn &rest args) (push (list delay fn args) timers) nil)) ((symbol-function 'jabber-mam-muc-joined) #'ignore) ((symbol-function 'jabber-bookmarks-auto-add-maybe) #'ignore) ((symbol-function 'jabber-muc-find-buffer) (lambda (&rest _) nil)) ((symbol-function 'jabber-muc-get-buffer) (lambda (&rest _) " *missing-test-room*"))) ,@body))) (ert-deftest jabber-test-muc-recovery-first-bind-without-sm () "First bind without SM must retain its account after ordinary loss." (jabber-test-muc-with-recovery (let ((jabber-lifecycle-session-bootstrap-functions '(jabber-muc-autojoin)) (jabber-lifecycle-session-reset-functions '(jabber-muc--session-reset jabber-omemo--session-reset)) (jabber-lifecycle-connection-list-changed-functions nil) (jabber-lost-connection-hooks nil)) (clrhash jabber-muc--rooms-before-disconnect) (put jc :state :bind) (put jc :state-data (list :connection 'initial :username "self" :server "example.org")) (fsm-send-sync jc '(:bind-success (iq () (bind () (jid () "self@example.org/test"))))) (should (eq (get jc :state) :session-established)) (fsm-send-sync jc '(:connection-dead initial "test loss")) (should-not (plist-get (fsm-get-state-data jc) :terminalized)) (should (memq jc jabber-connections)) (should (plist-get (fsm-get-state-data jc) :ever-session-established))))) (ert-deftest jabber-test-muc-recovery-first-bind-establishes-retry () "Real first bind survives empty or silent bookmarks and the next loss." (dolist (reply '(nil t)) (jabber-test-muc-with-recovery (let* ((jabber-lifecycle-session-bootstrap-functions '(jabber-muc-autojoin)) (jabber-lifecycle-session-reset-functions '(jabber-muc--session-reset jabber-omemo--session-reset)) (jabber-lifecycle-connection-list-changed-functions nil) (jabber-lost-connection-hooks nil) (entry (list :stanza '(message ((to . "peer@example.org"))) :failure (lambda (_) (cl-incf failed))))) (clrhash jabber-muc--rooms-before-disconnect) (put jc :state :bind) (put jc :state-data (plist-put (jabber-sm--reset (list :connection 'initial :username "self" :server "example.org" :stream-features '(features () (sm ((xmlns . "urn:xmpp:sm:3")))))) :sm-pending-queue (list entry))) (cl-letf (((symbol-function 'jabber-send-string) #'ignore) ((symbol-function 'jabber-get-bookmarks) (lambda (c callback) (when reply (funcall callback c nil))))) (fsm-send-sync jc '(:bind-success (iq () (bind () (jid () "self@example.org/test"))))) (should (eq (get jc :state) :sm-enable)) (fsm-send-sync jc '(:stanza (enabled ((xmlns . "urn:xmpp:sm:3") (id . "first") (resume . "true")))))) (should (eq (get jc :state) :session-established)) (should (plist-get (fsm-get-state-data jc) :ever-session-established)) (should (eq (cadar drains) (fsm-get-state-data jc))) (apply #'jabber-sm--drain-pending (car drains)) (should (equal sent (list (plist-get entry :stanza)))) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue)) ;; The next accepted work has not yet reached its scheduled drain. (plist-put (fsm-get-state-data jc) :sm-pending-queue (list entry)) (fsm-send-sync jc '(:connection-dead initial "test loss")) (should-not (plist-get (fsm-get-state-data jc) :terminalized)) (should (memq jc jabber-connections)) (should (memq entry (plist-get (fsm-get-state-data jc) :sm-pending-queue))) (should (= failed 0)))))) (ert-deftest jabber-test-muc-recovery-first-bind-bootstrap-successor () "Bootstrap cannot bless or drain a replacement transport or session." (dolist (replacement '(:connection :session-id)) (jabber-test-muc-with-recovery (let* (successor established (jabber-lifecycle-session-bootstrap-functions (list (lambda (c) (setq established (plist-get (fsm-get-state-data c) :ever-session-established)) (jabber-muc-autojoin c) (setq successor (list :connection 'initial :session-id "first")) (setq successor (plist-put successor replacement 'successor)) (put c :state-data successor))))) (clrhash jabber-muc--rooms-before-disconnect) (put jc :state :bind) (put jc :state-data (list :connection 'initial :session-id "first")) (fsm-send-sync jc '(:bind-success (iq () (bind () (jid () "self@example.org/test"))))) (should established) (should (eq successor (fsm-get-state-data jc))) (should-not (plist-get successor :ever-session-established)) (should-not drains))))) (defun jabber-test-muc--retired-presence (outcome) "Check late self-presence after OUTCOME and explicit retry permission." (dolist (codes '(nil ("110"))) (jabber-test-muc-with-recovery (jabber-muc-autojoin jc) (let ((old (jabber-sm--room-attempt (fsm-get-state-data jc) room)) (presence `(presence ((from . ,(concat room "/self"))) (x ((xmlns . "http://jabber.org/protocol/muc#user")) ,@(mapcar (lambda (code) `(status ((code . ,code)))) codes))))) (if (eq outcome 'leave) (progn (jabber-muc-process-presence jc presence) (jabber-muc-leave jc room)) (jabber-muc--fail-attempt jc room old "Room join timed out")) (should-not (jabber-muc-joined-p room jc)) (let ((participants (copy-tree jabber-muc-participants)) (saved (copy-tree (gethash "self@example.org" jabber-muc--rooms-before-disconnect))) (drains nil)) (jabber-muc-process-presence jc presence) (if (eq outcome 'leave) (progn ;; Departure withdrew the permission; nothing reopens it. (should-not (jabber-muc-joined-p room jc)) (should (eq (plist-get (jabber-sm--room-attempt (fsm-get-state-data jc) room) :status) 'failed)) (should-not (jabber-sm--room-ready-p (fsm-get-state-data jc) room)) (should (equal participants jabber-muc-participants)) (should-not drains)) ;; Only the request expired: the room still admits us, and the ;; admission is leased so later transitions keep working. (should (jabber-muc-joined-p room jc)) (should (jabber-sm--room-ready-p (fsm-get-state-data jc) room))) (should (equal saved (gethash "self@example.org" jabber-muc--rooms-before-disconnect)))) (jabber-muc--send-join-presence jc room "self" nil nil) (should-not (eq (plist-get old :token) (plist-get (jabber-sm--room-attempt (fsm-get-state-data jc) room) :token))) (jabber-muc-process-presence jc presence) (should (jabber-muc-joined-p room jc)) (should (jabber-sm--room-ready-p (fsm-get-state-data jc) room)))))) (ert-deftest jabber-test-muc-recovery-late-presence-after-leave () "Leave retires permission even for late 110 or exact-nick confirmation." (jabber-test-muc--retired-presence 'leave)) (ert-deftest jabber-test-muc-recovery-late-presence-after-timeout () "An expired deadline leaves the room admissible and leases the admission." (jabber-test-muc--retired-presence 'timeout)) (ert-deftest jabber-test-muc-bare-room-presence-is-not-departure () "Non-error presence from the bare room JID never ends our membership. Prosody lists absent affiliated members to admins this way, before our own self-presence during a join and later on affiliation changes." (jabber-test-muc-with-recovery (cl-flet ((bare (type) (jabber-muc-process-presence jc `(presence ((from . ,room) ,@(when type `((type . ,type)))) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((affiliation . "member") (role . "none") (jid . "absent@example.org")))))))) (jabber-muc-autojoin jc) (bare "unavailable") (should (eq (plist-get (jabber-sm--room-attempt (fsm-get-state-data jc) room) :status) 'pending)) (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/self"))) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((affiliation . "admin") (role . "moderator"))) (status ((code . "110")))))) (should (jabber-muc-joined-p room jc)) (let ((participants (copy-tree jabber-muc-participants))) (dolist (type '("unavailable" nil)) (bare type) (should (jabber-muc-joined-p room jc)) (should (jabber-sm--room-ready-p (fsm-get-state-data jc) room)) (should (equal participants jabber-muc-participants)))) (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/self")) (type . "unavailable")) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((affiliation . "admin") (role . "none"))) (status ((code . "110")))))) (should-not (jabber-muc-joined-p room jc))))) (ert-deftest jabber-test-muc-absent-member-is-not-announced () "Unavailable presence for a nickname never seen in the room is silent. Prosody lists absent members with reserved nicknames this way." (let ((room "room@example.org") (jabber-muc-participants (list (list "room@example.org" (list "alice" 'role "participant")))) notices) (with-temp-buffer (cl-letf (((symbol-function 'jabber-muc-find-buffer) (lambda (&rest _) (current-buffer))) ((symbol-function 'jabber-chat-ewoc-enter) (lambda (data) (push (cadr data) notices))) ((symbol-function 'jabber-maybe-print-rare-time) #'ignore) ((symbol-function 'jabber-muc--identity-occupant) #'ignore)) (jabber-muc--process-other-leave 'jc room "absent" nil nil nil nil) (should-not notices) (jabber-muc--process-other-leave 'jc room "alice" nil nil nil nil) (should (equal notices '("alice has left the chatroom"))) (should-not (jabber-muc-participant-plist room "alice")))))) (ert-deftest jabber-test-muc-recovery-retired-nick-rejection () "Late modern or legacy nick errors cannot reopen a retired lease. An expired nickname handshake is not a withdrawal: the room keeps the membership and the nickname the server last confirmed." (dolist (outcome '(timeout leave)) (dolist (error-node '((error ((type . "cancel")) (conflict ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))) (error ((type . "modify")) (not-acceptable ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))) (error ((type . "cancel") (code . "409"))) (error ((type . "modify") (code . "406"))))) (dolist (codes '(nil ("110"))) (jabber-test-muc-with-recovery (jabber-muc-autojoin jc) (jabber-muc--process-enter jc room "self" (jabber-jid-symbol room) '("110") nil nil nil "self") (jabber-muc-nick jc room "new") (let ((old (jabber-sm--room-attempt (fsm-get-state-data jc) room)) (left (eq outcome 'leave))) (if left (jabber-muc-leave jc room) (let ((timer (cl-find jabber-muc-autojoin-timeout timers :key #'car))) (apply (cadr timer) (nth 2 timer)))) (should (= failed 1)) (let ((saved (copy-tree (gethash "self@example.org" jabber-muc--rooms-before-disconnect)))) (setq drains nil sent nil) (dotimes (_ 2) (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/new")) (type . "error")) ,error-node)) (when left (should (eq (plist-get (jabber-sm--room-attempt (fsm-get-state-data jc) room) :status) 'failed))) (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/self"))) (x ((xmlns . "http://jabber.org/protocol/muc#user")) ,@(mapcar (lambda (c) `(status ((code . ,c)))) codes)))) (if left (progn (should-not (jabber-muc-joined-p room jc)) (should-not (jabber-sm--room-ready-p (fsm-get-state-data jc) room)) (should-not drains)) (should (jabber-muc-joined-p room jc)) (should (equal (jabber-muc-nickname room jc) "self")) (should (jabber-sm--room-ready-p (fsm-get-state-data jc) room))) (should (equal saved (gethash "self@example.org" jabber-muc--rooms-before-disconnect))) (jabber-sm--drain-pending jc (fsm-get-state-data jc)) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (should-not sent) (should (= failed 1)))) (jabber-muc--send-join-presence jc room "self" nil nil) (should-not (eq (plist-get old :token) (plist-get (jabber-sm--room-attempt (fsm-get-state-data jc) room) :token))) (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/self"))) (x ((xmlns . "http://jabber.org/protocol/muc#user"))))) (should (jabber-muc-joined-p room jc)) (should (jabber-sm--room-ready-p (fsm-get-state-data jc) room)) (should (= failed 1)))))))) (ert-deftest jabber-test-muc-recovery-nick-303-intermediate () "303 cannot settle a pending join or native nick operation, even sans 110." (dolist (native '(nil t)) (dolist (codes '(("303") ("303" "110"))) (jabber-test-muc-with-recovery (let* ((jabber-omemo--sent-muc-plaintexts (make-hash-table :test #'equal)) (entry (car (plist-get (fsm-get-state-data jc) :sm-pending-queue))) (stanza (plist-get entry :stanza)) (failure (plist-get entry :failure)) (key (list jc room (concat room "/self") "old")) (success 0)) (plist-put entry :success (lambda () (cl-incf success))) (plist-put entry :echo-key key) (puthash key "synthetic" jabber-omemo--sent-muc-plaintexts) (jabber-muc-autojoin jc) (when native (jabber-muc--process-enter jc room "self" (jabber-jid-symbol room) '("110") nil nil nil "self") (jabber-muc-nick jc room "new")) (let* ((attempt (jabber-sm--room-attempt (fsm-get-state-data jc) room)) (token (plist-get attempt :token)) (timer (cl-find jabber-muc-autojoin-timeout timers :key #'car)) (password (jabber-muc--session-password jc room)) (transport (plist-get (fsm-get-state-data jc) :connection))) (setq drains nil sent nil) ;; Native intent already owns "new". A recovery join owns "self"; ;; an item naming "assigned" is not authority to change that intent. (dolist (control '(owned foreign wrong-target stale)) (when (eq control 'stale) (plist-put (fsm-get-state-data jc) :connection 'stale)) (jabber-muc-process-presence jc `(presence ((from . ,(concat room (if (eq control 'foreign) "/foreign" "/self"))) (type . "unavailable")) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((nick . ,(if (eq control 'wrong-target) "wrong" (if native "new" "assigned"))))) ,@(mapcar (lambda (c) `(status ((code . ,c)))) codes)))) (plist-put (fsm-get-state-data jc) :connection transport) (should (= failed 0)) (should (eq attempt (jabber-sm--room-attempt (fsm-get-state-data jc) room))) (should (eq token (plist-get attempt :token))) (should (eq timer (cl-find jabber-muc-autojoin-timeout timers :key #'car))) (should (equal password (jabber-muc--session-password jc room))) (should (eq entry (car (plist-get (fsm-get-state-data jc) :sm-pending-queue)))) (should (eq failure (plist-get entry :failure))) (should (eq key (plist-get entry :echo-key))) (should (equal (gethash key jabber-omemo--sent-muc-plaintexts) "synthetic")) (should-not (jabber-sm--room-ready-p (fsm-get-state-data jc) room)) (should-not drains)) (jabber-muc-process-presence jc `(presence ((from . ,(concat room (if native "/new" "/self")))) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (status ((code . "210")))))) (jabber-sm--drain-pending jc (fsm-get-state-data jc)) (should-not sent) (should-not (jabber-sm--room-ready-p (fsm-get-state-data jc) room)) (jabber-muc-process-presence jc `(presence ((from . ,(concat room (if native "/new" "/assigned")))) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (status ((code . "110")))))) (dotimes (_ 2) (jabber-sm--drain-pending jc (fsm-get-state-data jc))) (should (equal sent (list stanza))) (should (= success 1)) (should (= failed 0)))))))) (ert-deftest jabber-test-muc-recovery-live-nick-rejection () "Valid prior membership survives modern and legacy nickname rejection." (dolist (error-node '((error ((type . "cancel")) (conflict ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))) (error ((type . "modify")) (not-acceptable ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))) (error ((type . "cancel") (code . "409"))) (error ((type . "modify") (code . "406"))))) (jabber-test-muc-with-recovery (jabber-muc-autojoin jc) (jabber-muc--process-enter jc room "self" (jabber-jid-symbol room) '("110") nil nil nil "self") (jabber-muc-nick jc room "new") (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/new")) (type . "error")) ,error-node)) (should (equal (jabber-muc-nickname room jc) "self")) (should (jabber-sm--room-ready-p (fsm-get-state-data jc) room)) (should (= failed 0))))) (ert-deftest jabber-test-muc-recovery-independent-bootstrap-retries () "Silent bookmarks and disco cannot strand a password room after retries." (jabber-test-muc-with-recovery (dotimes (_ 2) (jabber-muc--session-reset jc) (should (equal (gethash "self@example.org" jabber-muc--rooms-before-disconnect) (list (list room "self" "synthetic-secret"))))) (jabber-muc-autojoin jc) (should (equal (car sent) `(presence ((to . ,(concat room "/self"))) (x ((xmlns . "http://jabber.org/protocol/muc")) (history ((maxchars . "0"))) (password () "synthetic-secret"))))) (should (plist-get (car (plist-get (fsm-get-state-data jc) :sm-pending-queue)) :retained-room)) (should (cl-find jabber-muc-autojoin-timeout timers :key #'car)) (plist-put (fsm-get-state-data jc) :disconnection-expected t) (jabber-muc--session-reset jc) (should-not (gethash "self@example.org" jabber-muc--rooms-before-disconnect)))) (ert-deftest jabber-test-muc-recovery-confirmation-and-order () "Only owned self-presence releases retained room bytes, with SM disabled." (dolist (codes '(nil ("110") ("110" "210"))) (jabber-test-muc-with-recovery (let ((original (jabber-sm--pending-stanza (car (plist-get (fsm-get-state-data jc) :sm-pending-queue))))) (jabber-muc-autojoin jc) (jabber-muc--process-enter jc room "stranger" (jabber-jid-symbol room) '("210") nil nil nil "stranger") (jabber-sm--drain-pending jc (fsm-get-state-data jc)) (should (= (length sent) 1)) ;; A legitimate drain replaces the plist during the pending join. (jabber-muc--process-enter jc room (if (member "210" codes) "assigned" "self") (jabber-jid-symbol room) codes nil nil nil "foreign") (should drains) (jabber-sm--drain-pending jc (fsm-get-state-data jc)) (should (eq (car sent) original)) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (should (= failed 0)))))) (ert-deftest jabber-test-muc-recovery-only-room-timeout-once () "The last room's timeout detaches ownership before callbacks and fires once. The room stays rejoinable: a deadline fails retained stanzas without discarding the saved nickname and password a reconnect needs." (jabber-test-muc-with-recovery (jabber-muc-autojoin jc) (let ((timer (cl-find jabber-muc-autojoin-timeout timers :key #'car))) (should timer) (plist-put (car (plist-get (fsm-get-state-data jc) :sm-pending-queue)) :failure (lambda (_) (cl-incf failed) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue)))) (dotimes (_ 2) (apply (cadr timer) (nth 2 timer))) (should (= failed 1)) (should (equal (gethash "self@example.org" jabber-muc--rooms-before-disconnect) (list (list room "self" "synthetic-secret"))))))) (ert-deftest jabber-test-muc-recovery-stale-timeout-and-send-failure () "An old attempt cannot fail or release a new transport's room." (jabber-test-muc-with-recovery (let (send-failure) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (_jc _stanza &optional _success failure) (setq send-failure failure)))) (jabber-muc-autojoin jc)) (let ((timer (cl-find jabber-muc-autojoin-timeout timers :key #'car))) (should timer) (should send-failure) (plist-put (fsm-get-state-data jc) :connection (make-symbol "next")) (jabber-muc--session-reset jc) (jabber-muc-autojoin jc) (jabber-pre-filter (make-symbol "old-transport") "" jc) (funcall send-failure "old failure") (apply (cadr timer) (nth 2 timer)) (should (= failed 0)) (should (plist-get (car (plist-get (fsm-get-state-data jc) :sm-pending-queue)) :retained-room)))))) (ert-deftest jabber-test-muc-recovery-room-error () "Join errors and unavailable fail only that room, not eligible direct work." (dolist (type '("error" "unavailable")) (jabber-test-muc-with-recovery (let ((direct (list :stanza '(message ((to . "peer@example.org"))))) (other (list :stanza '(message ((to . "elsewhere@example.org"))) :retained-room "elsewhere@example.org"))) (plist-put (fsm-get-state-data jc) :sm-pending-queue (append (plist-get (fsm-get-state-data jc) :sm-pending-queue) (list direct other))) (puthash "self@example.org" (append (gethash "self@example.org" jabber-muc--rooms-before-disconnect) '(("elsewhere@example.org" "other" nil))) jabber-muc--rooms-before-disconnect) (jabber-muc-autojoin jc) (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/self")) (type . ,type)) (x ((xmlns . "http://jabber.org/protocol/muc#user"))) ,@(when (equal type "error") '((error ((type . "auth")) (not-authorized ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))))))) (should (= failed 1)) (should (equal (plist-get (fsm-get-state-data jc) :sm-pending-queue) (list direct other))))))) (ert-deftest jabber-test-muc-recovery-echo-rekey-before-handoff () "Rekey exact queued and handed-off ciphertext echoes before release." (require 'jabber-omemo) (dolist (handed-off '(nil t)) (dolist (terminal '(nil t)) (jabber-test-muc-with-recovery (let ((jabber-omemo--sent-muc-plaintexts (make-hash-table :test #'equal)) (jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (other (make-symbol "other-account")) (encrypted 0) (completed 0) original key) (put jc :state-data (append (list :connection (make-symbol "old") :sm-enabled t :ever-session-established t) (jabber-sm--reset nil))) (let ((jabber-sm-max-in-flight (unless handed-off 0))) (cl-letf (((symbol-function 'jabber-muc-nickname) (lambda (&rest _) "self")) ((symbol-function 'jabber-omemo-encrypt-message) (lambda (_) (cl-incf encrypted) 'synthetic-ciphertext)) ((symbol-function 'jabber-omemo--build-encrypted-xml) (lambda (&rest _) '(encrypted ((xmlns . "eu.siacs.conversations.axolotl")) (payload () "fixed-wire-bytes"))))) (jabber-omemo--send-encrypted-muc jc "synthetic plaintext" room nil nil "old" nil (lambda () (cl-incf completed)) (lambda (_) (cl-incf failed))))) (setq key (car (hash-table-keys jabber-omemo--sent-muc-plaintexts))) (setq original (if handed-off (car sent) (jabber-sm--pending-stanza (car (plist-get (fsm-get-state-data jc) :sm-pending-queue))))) (should key) (should original) (should (= failed 0)) (put jc :state-data (jabber-sm--handle-failed-resume (fsm-get-state-data jc) '(failed ()))) (plist-put (fsm-get-state-data jc) :connection (make-symbol "fresh")) (let* ((foreign (list other room (concat room "/self") "old")) (occupant (list jc room (concat room "/stranger") "old")) (unretained (list jc room (concat room "/self") "unretained")) (new-key (list jc room (concat room "/assigned") "old"))) (dolist (k (list foreign occupant unretained)) (puthash k "unrelated" jabber-omemo--sent-muc-plaintexts)) (jabber-muc-autojoin jc) (setq sent nil) (jabber-muc--process-enter jc room "assigned" (jabber-jid-symbol room) '("110" "210") nil nil nil "self") (should (equal (gethash new-key jabber-omemo--sent-muc-plaintexts) "synthetic plaintext")) (should-not (gethash (list jc room (concat room "/self") "old") jabber-omemo--sent-muc-plaintexts)) (if terminal (progn (jabber-sm--fail-pending (plist-get (fsm-get-state-data jc) :sm-pending-queue) "cancelled") (unless handed-off (should-not (gethash new-key jabber-omemo--sent-muc-plaintexts))) ;; Handed-off operations have no callback; terminal reset owns echoes. (put jc :state-data (list :disconnection-expected t)) (jabber-omemo--session-reset jc) (should-not (gethash new-key jabber-omemo--sent-muc-plaintexts))) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc stanza) (should (equal (gethash new-key jabber-omemo--sent-muc-plaintexts) "synthetic plaintext")) (should (eq stanza original)) (push stanza sent)))) (jabber-sm--drain-pending jc (fsm-get-state-data jc))) (should (equal sent (list original))) (dolist (k (list foreign occupant unretained)) (should (equal (gethash k jabber-omemo--sent-muc-plaintexts) "unrelated"))))) (should (= encrypted 1)) (should (= completed (if (or handed-off (not terminal)) 1 0))) (should (= failed (if (and terminal (not handed-off)) 1 0))) (should key)))))) (ert-deftest jabber-test-muc-recovery-timeout-removes-only-owned-echo () "A room failure also removes a finished operation's exact retained echo." (require 'jabber-omemo) (jabber-test-muc-with-recovery (let* ((jabber-omemo--sent-muc-plaintexts (make-hash-table :test #'equal)) (other (make-symbol "other-account")) (key (list jc room (concat room "/self") "old")) (foreign (list other room (concat room "/self") "old"))) (puthash key "synthetic" jabber-omemo--sent-muc-plaintexts) (puthash foreign "synthetic-other" jabber-omemo--sent-muc-plaintexts) (let ((entry (car (plist-get (fsm-get-state-data jc) :sm-pending-queue)))) (plist-put entry :failure nil) (plist-put entry :stanza `(message ((to . ,room) (type . "groupchat") (id . "old")) (encrypted ((xmlns . "eu.siacs.conversations.axolotl")))))) (jabber-muc-autojoin jc) (let ((timer (cl-find jabber-muc-autojoin-timeout timers :key #'car))) (apply (cadr timer) (nth 2 timer))) (should-not (gethash key jabber-omemo--sent-muc-plaintexts)) (should (equal (gethash foreign jabber-omemo--sent-muc-plaintexts) "synthetic-other"))))) (ert-deftest jabber-test-muc-recovery-error-callback-preserves-successor () "A failure callback's successor password and queue survive old room cleanup." (jabber-test-muc-with-recovery (jabber-muc-autojoin jc) (let ((next (list :stanza '(message ((id . "successor")))))) (plist-put (car (plist-get (fsm-get-state-data jc) :sm-pending-queue)) :failure (lambda (_) (cl-incf failed) (put jc :state-data (list :connection (make-symbol "successor") :sm-pending-queue (list next))) (jabber-muc--remember-password jc room "successor-secret"))) (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/self")) (type . "error")) (error ((type . "auth")) (not-authorized ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))))) (should (= failed 1)) (should (equal (gethash (list jc room) jabber-muc--session-passwords) "successor-secret")) (should (equal (plist-get (fsm-get-state-data jc) :sm-pending-queue) (list next)))))) (ert-deftest jabber-test-muc-rejoin-snapshots-are-account-scoped () "Two accounts recovering the same room cannot settle each other's work." (jabber-test-muc-with-recovery (let* ((other (make-symbol "second")) (jabber-connections (list jc other)) (second-snapshot (list (list room "second" "other-secret"))) (other-failed 0)) (put other :name 'jabber-connection) (put other :state :session-established) (put other :state-data (copy-tree (fsm-get-state-data jc))) (plist-put (fsm-get-state-data other) :connection (make-symbol "second-transport")) (plist-put (car (plist-get (fsm-get-state-data other) :sm-pending-queue)) :failure (lambda (_) (cl-incf other-failed))) (puthash "second@example.org" second-snapshot jabber-muc--rooms-before-disconnect) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (c) (if (eq c jc) "self@example.org" "second@example.org")))) (jabber-muc-autojoin jc) (jabber-muc-autojoin other) (let ((second-state (copy-tree (fsm-get-state-data other)))) (jabber-muc--process-enter jc room "assigned" (jabber-jid-symbol room) '("110" "210") nil nil nil "second") (should (equal (fsm-get-state-data other) second-state)) (should (equal (gethash "second@example.org" jabber-muc--rooms-before-disconnect) second-snapshot)) (should (equal (gethash (list other room) jabber-muc--session-passwords) "other-secret")) (should (= other-failed 0))))))) (ert-deftest jabber-test-muc-recovery-no-duplicate-bookmark-join () "Late bookmarks and configured autojoin never duplicate the retained join." (jabber-test-muc-with-recovery (let ((jabber-muc-autojoin (list room)) callback) (cl-letf (((symbol-function 'jabber-get-bookmarks) (lambda (_jc fn) (setq callback fn)))) (jabber-muc-autojoin jc)) (funcall callback jc (list (list :jid room :autojoin t :nick "bookmark"))) (should (= (length sent) 1)) (should-not (cdr (assq jc jabber-muc--autojoin-pending))) (jabber-muc--process-enter jc room "self" (jabber-jid-symbol room) '("110") nil nil nil "self") (funcall callback jc (list (list :jid room :autojoin t))) (should (= (length sent) 1)) (plist-put (fsm-get-state-data jc) :connection (make-symbol "successor")) (funcall callback jc '((:jid "stale@example.org" :autojoin t))) (should-not (cdr (assq jc jabber-muc--autojoin-pending)))))) (ert-deftest jabber-test-muc-recovery-join-bypasses-sm-capacity () "A full fresh SM window cannot block the presence needed to release it." (jabber-test-muc-with-recovery (let ((jabber-sm-max-in-flight 0)) (put jc :state-data (append (fsm-get-state-data jc) (jabber-sm--reset nil))) (plist-put (fsm-get-state-data jc) :sm-enabled t) (jabber-muc-autojoin jc) (should (eq (caar sent) 'presence))))) (ert-deftest jabber-test-muc-recovery-does-not-advance-unrelated-autojoin () "Recovery confirmation/error cannot schedule a stale unrelated room join." (jabber-test-muc-with-recovery (jabber-muc-autojoin jc) (let ((jabber-muc--autojoin-queue (list (list jc '(0 "normal@example.org" . "nick"))))) (jabber-muc--process-enter jc room "self" (jabber-jid-symbol room) '("110") nil nil nil "self") (should-not (cl-find 0 timers :key #'car)) (jabber-muc--autojoin-disco-callback jc (cons room "stale-nick") nil) (should-not (jabber-muc--autojoin-queued-p jc room))))) (ert-deftest jabber-test-muc-recovery-pending-join-survives-sm-resume () "Resume transfers a pending join lease without another join or early replay." (dolist (confirm '(nil t)) (jabber-test-muc-with-recovery (let ((jabber-post-resume-hooks nil)) (put jc :state-data (append (fsm-get-state-data jc) (jabber-sm--reset nil))) (plist-put (fsm-get-state-data jc) :sm-enabled t) (plist-put (fsm-get-state-data jc) :sm-id "s1") (jabber-muc-autojoin jc) (let ((old-timer (cl-find jabber-muc-autojoin-timeout timers :key #'car)) (join (car sent)) (original (jabber-sm--pending-stanza (car (plist-get (fsm-get-state-data jc) :sm-pending-queue))))) (put jc :state :sm-resume) (plist-put (fsm-get-state-data jc) :connection (make-symbol "resumed-transport")) ;; The original timeout may elapse during the outage. (apply (cadr old-timer) (nth 2 old-timer)) (cl-letf (((symbol-function 'jabber-sm--start-r-timer) (lambda (_jc data) data))) (fsm-send-sync jc '( :stanza (resumed ((xmlns . "urn:xmpp:sm:3") (h . "0") (previd . "s1")))))) (should (eq (get jc :state) :session-established)) (should (= (length sent) 1)) (jabber-sm--drain-pending jc (fsm-get-state-data jc)) ;; The unacknowledged join is replayed, never regenerated. (should (equal sent (list join join))) (apply (cadr old-timer) (nth 2 old-timer)) (should (= failed 0)) (if confirm (progn (jabber-muc--process-enter jc room "assigned" (jabber-jid-symbol room) '("110" "210") nil nil nil "self") (jabber-sm--drain-pending jc (fsm-get-state-data jc)) (should (eq (car sent) original))) (let ((timer (cl-find jabber-muc-autojoin-timeout timers :key #'car))) (apply (cadr timer) (nth 2 timer))) (should (= failed 1))) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue))))))) (ert-deftest jabber-test-muc-recovery-explicit-retry-compatible-confirmation () "A settled recovery cannot veto a new native join without status 110." (dolist (failure '(timeout error)) (jabber-test-muc-with-recovery (let ((send (symbol-function 'jabber-send-sexp)) old-failure) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (c stanza &optional success failed-send) (setq old-failure failed-send) (funcall send c stanza success failed-send)))) (jabber-muc-autojoin jc)) (let ((old-timer (cl-find jabber-muc-autojoin-timeout timers :key #'car))) (if (eq failure 'timeout) (apply (cadr old-timer) (nth 2 old-timer)) (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/self")) (type . "error")) (error ((type . "auth")) (not-authorized ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))))) (should (= failed 1)) (jabber-muc--send-join-presence jc room "retry" nil nil) (let ((before drains)) (funcall old-failure "late failure") (apply (cadr old-timer) (nth 2 old-timer)) (should (eq drains before))) (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/retry"))) (x ((xmlns . "http://jabber.org/protocol/muc#user")))))) (should (jabber-muc-joined-p room jc)) (should (equal (jabber-muc-nickname room jc) "retry")) (should (= failed 1)))))) (ert-deftest jabber-test-muc-recovery-pending-retry-preserves-echo-owner () "A pending native nickname retry replaces the lease, not ciphertext identity." (jabber-test-muc-with-recovery (let* ((jabber-omemo--sent-muc-plaintexts (make-hash-table :test #'equal)) (key (list jc room (concat room "/self") "old")) (stanza `(message ((to . ,room) (type . "groupchat") (id . "old")) (encrypted ((xmlns . "eu.siacs.conversations.axolotl"))))) (entry (car (plist-get (fsm-get-state-data jc) :sm-pending-queue))) (send (symbol-function 'jabber-send-sexp)) old-failure) (plist-put entry :stanza stanza) (puthash key "synthetic" jabber-omemo--sent-muc-plaintexts) (cl-letf (((symbol-function 'jabber-send-sexp) (lambda (c xml &optional success failure) (setq old-failure failure) (funcall send c xml success failure)))) (jabber-muc-autojoin jc)) (let ((old-timer (cl-find jabber-muc-autojoin-timeout timers :key #'car)) (old-attempt (jabber-sm--room-attempt (fsm-get-state-data jc) room))) (jabber-muc--send-join-presence jc room "retry" nil nil) (let ((new-attempt (jabber-sm--room-attempt (fsm-get-state-data jc) room)) (new-timer (cl-find jabber-muc-autojoin-timeout timers :key #'car))) (should-not (eq (plist-get old-attempt :token) (plist-get new-attempt :token))) (should-not (eq old-timer new-timer)) (should (equal (car new-timer) jabber-muc-autojoin-timeout)) (funcall old-failure "stale send failure") (apply (cadr old-timer) (nth 2 old-timer)) (should (eq new-attempt (jabber-sm--room-attempt (fsm-get-state-data jc) room))) (should (eq key (car (hash-table-keys jabber-omemo--sent-muc-plaintexts))))) (should (= failed 0)) (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/retry"))) (x ((xmlns . "http://jabber.org/protocol/muc#user")))))) (should (jabber-muc-joined-p room jc)) (should (equal (gethash (list jc room (concat room "/retry") "old") jabber-omemo--sent-muc-plaintexts) "synthetic")) (jabber-sm--drain-pending jc (fsm-get-state-data jc)) (should (eq (car sent) stanza))))) (ert-deftest jabber-test-muc-recovery-error-preserves-same-transport-successor () "Old error cleanup cannot erase a callback's same-session room retry." (jabber-test-muc-with-recovery (jabber-muc-autojoin jc) (plist-put (car (plist-get (fsm-get-state-data jc) :sm-pending-queue)) :failure (lambda (_) (cl-incf failed) (jabber-muc--send-join-presence jc room "retry" "successor-secret" nil))) (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/self")) (type . "error")) (error ((type . "auth")) (not-authorized ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")))))) (should (= failed 1)) (should (equal (jabber-muc--session-password jc room) "successor-secret")) (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/retry"))) (x ((xmlns . "http://jabber.org/protocol/muc#user"))))) (should (jabber-muc-joined-p room jc)))) (ert-deftest jabber-test-muc-recovery-ready-retry-tail () "Membership confirmation cannot release ownership of the undrained tail." (dolist (trigger '(join ping nick)) (dolist (outcome '(confirm timeout error leave)) (jabber-test-muc-with-recovery (let* ((jabber-omemo--sent-muc-plaintexts (make-hash-table :test #'equal)) (key (list jc room (concat room "/self") "old")) (entry (car (plist-get (fsm-get-state-data jc) :sm-pending-queue))) (stanza `(message ((to . ,room) (type . "groupchat") (id . "old")) (encrypted ((xmlns . "eu.siacs.conversations.axolotl"))))) (success 0)) (plist-put entry :stanza stanza) (plist-put entry :success (lambda () (cl-incf success))) (puthash key "synthetic" jabber-omemo--sent-muc-plaintexts) ;; Native sender rather than bootstrap makes the ready/retry race ;; observable even on the accepted B foundation. (jabber-muc--send-join-presence jc room "self" "secret" nil) (jabber-muc--process-enter jc room "assigned" (jabber-jid-symbol room) '("110" "210") nil nil nil "self") (pcase trigger ('join (jabber-muc--send-join-presence jc room "retry" "secret" nil)) ('ping (jabber-muc--self-ping-failed jc '(iq () (error () (not-acceptable ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))) (cons room "assigned"))) ('nick (jabber-muc-nick jc room "retry") (let* ((attempt (jabber-sm--room-attempt (fsm-get-state-data jc) room)) (token (plist-get attempt :token)) (timer (cl-find jabber-muc-autojoin-timeout timers :key #'car)) (password (jabber-muc--session-password jc room))) (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/assigned")) (type . "unavailable")) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (item ((nick . "retry"))) (status ((code . "110"))) (status ((code . "303")))))) (should (eq attempt (jabber-sm--room-attempt (fsm-get-state-data jc) room))) (should (eq token (plist-get attempt :token))) (should (eq timer (cl-find jabber-muc-autojoin-timeout timers :key #'car))) (should (equal password (jabber-muc--session-password jc room))) (should-not (jabber-sm--room-ready-p (fsm-get-state-data jc) room))))) (setq sent nil) (jabber-sm--drain-pending jc (fsm-get-state-data jc)) (should-not sent) (should (= failed 0)) (should (equal (gethash (list jc room (concat room "/assigned") "old") jabber-omemo--sent-muc-plaintexts) "synthetic")) (should (eq key (car (hash-table-keys jabber-omemo--sent-muc-plaintexts)))) (pcase outcome ('confirm (jabber-muc--process-enter jc room "second" (jabber-jid-symbol room) '("110" "210") nil nil nil "retry") (should (equal (nth 2 key) (concat room "/second"))) (jabber-sm--drain-pending jc (fsm-get-state-data jc)) (should (equal sent (list stanza))) (should (= success 1))) ('timeout (let ((timer (cl-find jabber-muc-autojoin-timeout timers :key #'car))) (should timer) (apply (cadr timer) (nth 2 timer)))) ('error (jabber-muc-process-presence jc `(presence ((from . ,(concat room "/retry")) (type . "error")) (x ((xmlns . "http://jabber.org/protocol/muc#user")) (status ((code . "110"))))))) ('leave (jabber-muc-leave jc room))) (unless (eq outcome 'confirm) (should (= failed 1)) (should (= success 0)) (should (= (hash-table-count jabber-omemo--sent-muc-plaintexts) 0))) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue))))))) (ert-deftest jabber-test-muc-recovery-missing-intent-fails-tail () "Missing or unusable saved nick settles only its owned room visibly." (dolist (nick '(absent nil "")) (jabber-test-muc-with-recovery (if (eq nick 'absent) (clrhash jabber-muc--rooms-before-disconnect) (puthash "self@example.org" (list (list room nick nil)) jabber-muc--rooms-before-disconnect)) (jabber-muc-autojoin jc) (should (= failed 1)) (should-not sent) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue))))) (ert-deftest jabber-test-muc-recovery-stale-native-disco () "A delayed native disco reply cannot replace a same-stream successor." (jabber-test-muc-with-recovery (let (callback closure) (cl-letf (((symbol-function 'jabber-disco-get-info) (lambda (_jc _group _node fn data) (setq callback fn closure data)))) (jabber-muc-join jc room "old" nil)) (jabber-muc--send-join-presence jc room "new" "new-secret" nil) (let ((attempt (jabber-sm--room-attempt (fsm-get-state-data jc) room))) (setq sent nil) (funcall callback jc closure '((["room" "conference"]) nil)) (should-not sent) (should (eq attempt (jabber-sm--room-attempt (fsm-get-state-data jc) room))) (should (equal (jabber-muc--session-password jc room) "new-secret")))))) (ert-deftest jabber-test-muc-recovery-stale-autojoin-generation () "Old disco and bookmarks cannot feed a same-transport autojoin successor." (jabber-test-muc-with-recovery (let ((jabber-muc-autojoin '("other@example.org")) callbacks bookmarks) (cl-letf (((symbol-function 'jabber-disco-get-items) (lambda (c _group _node fn data) (push (list fn c data) callbacks))) ((symbol-function 'jabber-get-bookmarks) (lambda (_jc fn) (push fn bookmarks)))) (jabber-muc-autojoin jc) (let ((old (car callbacks)) (old-bookmark (car bookmarks))) (jabber-muc-autojoin jc) (funcall (car old) (cadr old) (nth 2 old) nil) (funcall old-bookmark jc '((:jid "stale@example.org" :autojoin t))) (should-not jabber-muc--autojoin-queue) (should (= (cdr (assq jc jabber-muc--autojoin-disco-count)) 1)) (should (= (length callbacks) 2))))))) (ert-deftest jabber-test-muc-recovery-enter-hook-successor () "Presence, MAM and bookmark hooks cannot let old confirmation bless a retry." (dolist (hook '(jabber-message-correct--muc-presence-enter jabber-mam-muc-joined jabber-bookmarks-auto-add-maybe)) (jabber-test-muc-with-recovery (jabber-muc-autojoin jc) (cl-letf (((symbol-function hook) (lambda (&rest _) (jabber-muc--send-join-presence jc room "retry" "next" nil)))) (jabber-muc--process-enter jc room "self" (jabber-jid-symbol room) '("110") nil nil nil "self")) (should-not (jabber-sm--room-ready-p (fsm-get-state-data jc) room)) (should (equal (plist-get (jabber-sm--room-attempt (fsm-get-state-data jc) room) :nick) "retry"))))) (ert-deftest jabber-test-muc-recovery-real-raw-logger-retry () "A same-stream retry inside real XML logging invalidates selected bytes." (let ((raw (symbol-function 'jabber-send-sexp--raw))) (jabber-test-muc-with-recovery (let* ((entry (car (plist-get (fsm-get-state-data jc) :sm-pending-queue))) (original (plist-get entry :stanza)) (completed 0) wire logged (jabber-debug-log-xml t) (jabber-stanza-log-function (lambda (c _direction stanza) (when (eq stanza original) (push stanza logged) (when (= (length logged) 1) (jabber-muc--send-join-presence c room "retry" "secret" nil)))))) (plist-put entry :success (lambda () (cl-incf completed))) (plist-put (fsm-get-state-data jc) :send-function (lambda (_transport bytes) (push bytes wire))) (cl-letf (((symbol-function 'jabber-send-sexp--raw) raw)) (jabber-muc-autojoin jc) (jabber-muc--process-enter jc room "self" (jabber-jid-symbol room) '("110") nil nil nil "self") (setq wire nil) (jabber-sm--drain-pending jc (fsm-get-state-data jc)) (should (= (length wire) 1)) (should (string-prefix-p " (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 (list peer-did account peer 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-preserves-literal-bytes () "Upload ciphertext must decrypt to the literal source file bytes." (dolist (suffix '(".bin" ".targz" ".gz" ".tgz")) (let* ((source (make-temp-file "jabber-upload-bytes-" nil suffix)) (jabber-chat-encryption 'omemo) (payload (unibyte-string 0 1 10 13 127 128 254 255)) result) (unwind-protect (progn ;; For compressed suffixes, create a real compressed input file. (with-temp-file source (set-buffer-multibyte nil) (insert payload)) (let ((original (with-temp-buffer (set-buffer-multibyte nil) (insert-file-contents-literally source) (buffer-string)))) (setq result (jabber-omemo--httpupload-transform source #'identity)) (let* ((ciphertext (with-temp-buffer (set-buffer-multibyte nil) (insert-file-contents-literally (car result)) (buffer-string))) (url (funcall (cdr result) (concat "https://example.org/file" suffix))) (parsed (jabber-chat--parse-aesgcm-url url))) (should-not (file-exists-p (car result))) (should (equal original (jabber-omemo-aesgcm-decrypt (plist-get parsed :key) (plist-get parsed :iv) ciphertext))) (should (= (length ciphertext) (+ 16 (length original))))))) (delete-file source) (when (and result (file-exists-p (car result))) (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 "me@example.com" "peer100@example.com" fake-ptr-100) (200 "me@example.com" "peer200@example.com" fake-ptr-200) (300 "me@example.com" "peer300@example.com" fake-ptr-300)))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@example.com")) ((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 "me@example.com" "peer@example.com" fake-ptr-100)))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@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 "me@example.com" "peer@example.com" fake-ptr-100)))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "me@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-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 "me@example.com" "peer@example.com" 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))))) ;;; Group 15: Heartbeat persist-before-send (ert-deftest jabber-test-omemo-message-decrypt-stanza-persists-heartbeat () "decrypt-stanza persists the post-heartbeat session before sending it. After nr reaches 53, reloading the stored blob and calling `jabber-omemo-heartbeat' again must return nil. The in-memory session and the database blob must serialize identically." (jabber-test-omemo-message-with-db (let* ((alice-store (jabber-omemo-deserialize-store (jabber-omemo-setup-store))) (bob-store (jabber-omemo-deserialize-store (jabber-omemo-setup-store))) (account "bob@example.com") (peer "alice@example.com") (our-did 42) (peer-did 99) (sent 0) (bundle (jabber-omemo-get-bundle bob-store)) (pk (car (plist-get bundle :pre-keys))) (alice-session (jabber-omemo-initiate-session alice-store (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)))) (puthash account bob-store jabber-omemo--stores) (puthash account our-did jabber-omemo--device-ids) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) account)) ((symbol-function 'jabber-omemo--note-consumed-prekey) #'ignore) ((symbol-function 'jabber-omemo--send-heartbeat) (lambda (&rest _) (cl-incf sent)))) (dotimes (i 53) (let* ((enc (jabber-omemo-encrypt-message (encode-coding-string (format "m%d" i) 'utf-8))) (encrypted-key (jabber-omemo-encrypt-key alice-session (plist-get enc :key))) (xml-data `(message ((from . ,(concat peer "/phone")) (type . "chat")))) (parsed (list :sid peer-did :iv (plist-get enc :iv) :payload (plist-get enc :ciphertext) :keys (list (cons our-did (list :data (plist-get encrypted-key :data) :pre-key-p (plist-get encrypted-key :pre-key-p))))))) (jabber-omemo--decrypt-stanza 'fake-jc xml-data parsed)))) (should (= 1 sent)) (let* ((live (gethash (jabber-omemo--session-key account peer peer-did) jabber-omemo--sessions)) (blob (jabber-omemo-store-load-session account peer peer-did)) (reloaded (jabber-omemo-deserialize-session blob))) (should (equal (jabber-omemo-serialize-session live) blob)) (should-not (jabber-omemo-heartbeat reloaded bob-store)))))) (ert-deftest jabber-test-omemo-message-fresh-recovery-owns-ciphertext () "Encrypted sends survive reset and two bind losses without reencryption." (dolist (source '(:sm-resume :bind)) (dolist (later '(nil ack plain)) (dolist (terminal '(nil t)) (let* ((jc (make-symbol "encrypted-recovery")) (jabber-connections (list jc)) (jabber-auto-reconnect t) (jabber-sm-max-in-flight 1) (jabber-lost-connection-hooks nil) (jabber-lifecycle-connection-list-changed-functions nil) (jabber-lifecycle-session-bootstrap-functions nil) (jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (jabber-omemo--sent-muc-plaintexts (make-hash-table :test #'equal)) (jabber-chatting-with "peer@example.org") (state (jabber-sm--reset nil)) (successes 0) (failures 0) (abandoned 0) (encrypted 0) (resets 0) (jabber-lifecycle-session-reset-functions (list (lambda (connection) (cl-incf resets) (jabber-omemo--session-reset connection)))) cipher sent) (dolist (pair `((:connection . transport) (:ever-session-established . t) (:sm-enabled . t) (:sm-id . "old") (:sm-outbound-count . 1) (:sm-resuming . t) (:stream-features . (features () (bind ((xmlns . ,jabber-bind-xmlns))))))) (setq state (plist-put state (car pair) (cdr pair)))) (put jc :name 'jabber-connection) (put jc :state source) (put jc :state-data state) (unwind-protect (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "self@example.org")) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc _jid callback) (funcall callback '((1 . session))))) ((symbol-function 'jabber-omemo-encrypt-message) (lambda (_body) (cl-incf encrypted) 'ciphertext)) ((symbol-function 'jabber-omemo--build-encrypted-xml) (lambda (&rest _) '(encrypted ((xmlns . "eu.siacs.conversations.axolotl"))))) ((symbol-function 'jabber-chat--run-send-hooks) #'ignore) ((symbol-function 'jabber-omemo--send-failed) #'ignore) ((symbol-function 'jabber-send-sexp--raw) (lambda (_jc stanza) (push stanza sent))) ((symbol-function 'jabber--send-bind-request) #'ignore) ((symbol-function 'jabber-send-stream-header) #'ignore) ((symbol-function 'jabber-send-string) #'ignore) ((symbol-function 'jabber-sm--schedule-drain) #'ignore)) (jabber-omemo--send-chat jc "synthetic" '((replace ((id . "old")))) (lambda () (cl-incf successes)) (lambda (_reason) (cl-incf failures))) (setq cipher (jabber-sm--pending-stanza (car (plist-get state :sm-pending-queue)))) (should cipher) (jabber-omemo--send-operation-register jc nil (lambda (_reason) (cl-incf abandoned))) (fsm-send-sync jc (list :stanza (if (eq source :bind) (plist-get state :stream-features) '(failed ((xmlns . "urn:xmpp:sm:3")))))) (should (= failures 0)) (should (= abandoned 1)) (dotimes (_ 2) (fsm-send-sync jc '(:bind-failure (iq ((type . "error")) (error ((type . "cancel")) (not-allowed ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))))) (should-not (get jc :state)) (should (= failures 0)) (should (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (fsm-stop-timer jc) ;; Model the next authenticated transport; binding remains real FSM. (put jc :state :bind) (plist-put (fsm-get-state-data jc) :connection 'next-transport)) (should (= resets 1)) (when later (when (eq later 'ack) (plist-put (fsm-get-state-data jc) :stream-features `(features () (sm ((xmlns . ,jabber-sm-xmlns)))))) (fsm-send-sync jc '(:bind-success (iq () (bind () (jid () "self@example.org/test"))))) (when (eq later 'ack) (cl-letf (((symbol-function 'jabber-send-string) #'ignore)) (fsm-send-sync jc '(:stanza (enabled ((xmlns . "urn:xmpp:sm:3"))))))) (fsm-send-sync jc '(:connection-dead next-transport "synthetic later loss")) (should (= resets 2)) (should (= failures 0)) (should (= abandoned 1)) (fsm-stop-timer jc) (put jc :state :bind) (plist-put (fsm-get-state-data jc) :connection 'final-transport) (plist-put (fsm-get-state-data jc) :stream-features nil)) (if terminal (progn (jabber-disconnect-one jc) (jabber-disconnect-one jc) (should (= failures 1)) (should (= successes 0)) (should-not sent)) (fsm-send-sync jc '(:bind-success (iq () (bind () (jid () "self@example.org/test"))))) (let ((jabber-sm-max-in-flight nil)) (jabber-sm--drain-pending jc (fsm-get-state-data jc))) (should (equal sent (list cipher))) (should (= successes 1)) (should (= failures 0))) (should (= encrypted 1))) (fsm-stop-timer jc))))))) (ert-deftest jabber-test-omemo-message-fresh-room-echo-ownership () "Retain exact echoes for queued and already handed-off room ciphertext." (dolist (later '(nil ack plain)) (dolist (queued '(nil t)) (let* ((jc (make-symbol "room-owner")) (other (make-symbol "other")) (jabber-connections (list jc)) (jabber-auto-reconnect t) (jabber-sm-max-in-flight (and queued 0)) (jabber-group "room@example.org") (jabber-muc--rooms-before-disconnect (make-hash-table :test #'equal)) (jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (jabber-omemo--sent-muc-plaintexts (make-hash-table :test #'equal)) (jabber-lifecycle-session-reset-functions '(jabber-omemo--session-reset)) (jabber-lost-connection-hooks nil) (jabber-lifecycle-session-bootstrap-functions nil) (jabber-lifecycle-connection-list-changed-functions nil) (state (jabber-sm--reset nil)) (successes 0) (failures 0) (encrypted 0) key stanza) (setq state (plist-put state :sm-enabled t)) (setq state (plist-put state :connection 'transport)) (setq state (plist-put state :ever-session-established t)) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) "self@example.org")) ((symbol-function 'jabber-muc-nickname) (lambda (&rest _) "self")) ((symbol-function 'jabber-omemo--muc-participant-jids) (lambda (&rest _) '("peer@example.org"))) ((symbol-function 'jabber-omemo--ensure-sessions-multi) (lambda (_jc _jids callback) (funcall callback '((1 . session))))) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc _jid callback) (funcall callback nil))) ((symbol-function 'jabber-omemo-encrypt-message) (lambda (_body) (cl-incf encrypted) 'ciphertext)) ((symbol-function 'jabber-omemo--build-encrypted-xml) (lambda (&rest _) '(encrypted ((xmlns . "eu.siacs.conversations.axolotl"))))) ((symbol-function 'jabber-chat--run-send-hooks) #'ignore) ((symbol-function 'jabber-omemo--send-failed) #'ignore) ((symbol-function 'jabber-send-sexp--raw) #'ignore)) (jabber-omemo--send-muc jc "synthetic" nil (lambda () (cl-incf successes)) (lambda (_reason) (cl-incf failures))) (setq key (car (hash-table-keys jabber-omemo--sent-muc-plaintexts))) (setq stanza (if queued (jabber-sm--pending-stanza (car (plist-get state :sm-pending-queue))) (cdar (plist-get state :sm-outbound-queue)))) (should stanza) (dolist (foreign (list (list other jabber-group (nth 2 key) (nth 3 key)) (list jc jabber-group "room@example.org/foreign" (nth 3 key)) (list jc "elsewhere@example.org" (nth 2 key) (nth 3 key)) (list jc jabber-group (nth 2 key) "unretained"))) (puthash foreign "synthetic" jabber-omemo--sent-muc-plaintexts)) (put jc :state-data (jabber-sm--handle-failed-resume state '(failed ()))) ;; MUC reset may run before OMEMO; use its existing exact-account snapshot. (puthash "self@example.org" (list (list jabber-group "self" nil)) jabber-muc--rooms-before-disconnect) (cl-letf (((symbol-function 'jabber-muc-nickname) (lambda (&rest _) nil))) (jabber-omemo--session-reset jc)) (when later (put jc :state :bind) (plist-put (fsm-get-state-data jc) :stream-features (when (eq later 'ack) `(features () (sm ((xmlns . ,jabber-sm-xmlns)))))) (cl-letf (((symbol-function 'jabber-send-string) #'ignore) ((symbol-function 'jabber-sm--schedule-drain) #'ignore)) (fsm-send-sync jc '(:bind-success (iq () (bind () (jid () "self@example.org/test"))))) (when (eq later 'ack) (fsm-send-sync jc '(:stanza (enabled ((xmlns . "urn:xmpp:sm:3")))))) (fsm-send-sync jc '(:connection-dead transport "synthetic later loss"))) (fsm-stop-timer jc)) (should (equal (gethash key jabber-omemo--sent-muc-plaintexts) "synthetic")) (should (= (hash-table-count jabber-omemo--sent-muc-plaintexts) 2)) (should (= failures 0)) (should (= successes (if queued 0 1))) (let ((jabber-sm-max-in-flight nil)) (jabber-sm--drain-pending jc (fsm-get-state-data jc))) (should (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (should (= encrypted 1)) (plist-put (fsm-get-state-data jc) :session-reset-done t) (jabber-disconnect-one jc) (jabber-disconnect-one jc) (should-not (gethash key jabber-omemo--sent-muc-plaintexts)) (should (= (hash-table-count jabber-omemo--sent-muc-plaintexts) 1)) (should (= failures (if queued 1 0)))))))) (ert-deftest jabber-test-omemo-message-fresh-recovery-later-session-loss () "A later nonresumable loss reconverts owned work before reset effects." (dolist (sm '(t nil)) (let* ((jc (make-symbol "later-loss")) (jabber-connections (list jc)) (jabber-auto-reconnect t) (jabber-sm-max-in-flight 1) (jabber-lost-connection-hooks nil) (jabber-lifecycle-session-bootstrap-functions nil) (jabber-lifecycle-connection-list-changed-functions nil) (jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (jabber-omemo--sent-muc-plaintexts (make-hash-table :test #'equal)) (resets 0) (failed 0) sent (jabber-lifecycle-session-reset-functions (list (lambda (c) (cl-incf resets) (jabber-omemo--session-reset c)))) (direct '(message ((id . "direct-old")))) (room '(message ((type . "groupchat") (to . "room@example.org") (id . "room-new")))) (state (jabber-sm--reset nil))) (setq state (plist-put state :connection 'transport)) (setq state (plist-put state :ever-session-established t)) (setq state (plist-put state :stream-features `(features () (bind ((xmlns . ,jabber-bind-xmlns))) ,@(when sm `((sm ((xmlns . ,jabber-sm-xmlns)))))))) (setq state (jabber-sm--enqueue-pending state direct)) (put jc :name 'jabber-connection) (put jc :state :sm-resume) (put jc :state-data state) (unwind-protect (cl-letf (((symbol-function 'jabber--send-bind-request) #'ignore) ((symbol-function 'jabber-send-string) #'ignore) ((symbol-function 'jabber-sm--schedule-drain) #'ignore) ((symbol-function 'jabber-send-sexp--raw) (lambda (_jc stanza) (push stanza sent)))) (fsm-send-sync jc '(:stanza (failed ((xmlns . "urn:xmpp:sm:3"))))) (fsm-send-sync jc '(:bind-success (iq () (bind () (jid () "self@example.org/test"))))) (when sm (fsm-send-sync jc '(:stanza (enabled ((xmlns . "urn:xmpp:sm:3")))))) (should (eq (get jc :state) :session-established)) (jabber-sm--drain-pending jc (fsm-get-state-data jc)) (should (equal sent (list direct))) (jabber-omemo--send-operation-register jc nil (lambda (_) (cl-incf failed))) (if sm (jabber-send-sexp jc room) ;; No SM backpressure: model work already accepted but not drained. (put jc :state-data (jabber-sm--enqueue-pending (fsm-get-state-data jc) room))) (fsm-send-sync jc '(:connection-dead transport "synthetic loss")) (should (= resets 2)) (should (= failed 1)) (should (= (plist-get (fsm-get-state-data jc) :sm-outbound-count) 0)) (should-not (plist-get (fsm-get-state-data jc) :sm-outbound-queue)) (should (equal (mapcar #'jabber-sm--pending-stanza (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (if sm (list direct room) (list room)))) (dotimes (_ 2) (fsm-stop-timer jc) (put jc :state :bind) (plist-put (fsm-get-state-data jc) :connection 'next-transport) (fsm-send-sync jc '(:bind-failure (iq ((type . "error")) (error ((type . "cancel")) (not-allowed ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))))) (should (= resets 2)) (should (= failed 1)) (should (plist-get (fsm-get-state-data jc) :sm-pending-queue))) (fsm-stop-timer jc) (put jc :state :bind) (plist-put (fsm-get-state-data jc) :connection 'next-transport) (fsm-send-sync jc '(:bind-success (iq () (bind () (jid () "self@example.org/test"))))) (when sm (fsm-send-sync jc '(:stanza (enabled ((xmlns . "urn:xmpp:sm:3")))))) (setq sent nil) (jabber-sm--drain-pending jc (fsm-get-state-data jc)) (should (equal sent (and sm (list direct)))) (let ((jabber-sm-max-in-flight nil)) (jabber-sm--drain-pending jc (fsm-get-state-data jc))) (should (equal sent (and sm (list direct)))) (should (equal (mapcar #'jabber-sm--pending-stanza (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (list room)))) (fsm-stop-timer jc))))) (ert-deftest jabber-test-omemo-message-upload-encryption-failure-stops-slot () "Selected encryption must fail before slot allocation or plaintext upload." (require 'jabber-httpupload) (dolist (failure '(read encrypt write)) (let* ((temporary-file-directory (make-temp-file "jabber-upload-failure-" t)) (file (make-temp-file "attachment-" nil nil "private bytes")) (jabber-chat-encryption 'omemo) (jabber-httpupload-support '((fake-jc . "upload.example"))) (jabber-httpupload-pre-upload-transform #'jabber-omemo--httpupload-transform) (native-comp-enable-subr-trampolines nil) (read-file (symbol-function 'insert-file-contents-literally)) (encrypt (symbol-function 'jabber-omemo-aesgcm-encrypt)) (write-file (symbol-function 'write-region)) slots uploads) (unwind-protect (cl-letf (((symbol-function 'insert-file-contents-literally) (lambda (&rest args) (if (eq failure 'read) (error "Read failed") (apply read-file args)))) ((symbol-function 'jabber-omemo-aesgcm-encrypt) (lambda (bytes) (if (eq failure 'encrypt) (error "Encryption/RNG failed") (funcall encrypt bytes)))) ((symbol-function 'write-region) (lambda (&rest args) (if (eq failure 'write) (error "Write failed") (apply write-file args)))) ((symbol-function 'jabber-send-iq) (lambda (&rest _) (push t slots))) ((symbol-function 'jabber-httpupload-put-file-curl) (lambda (&rest _) (push t uploads)))) (should-error (jabber-httpupload--upload 'fake-jc file #'ignore)) (should-not slots) (should-not uploads) (should (equal (directory-files temporary-file-directory nil directory-files-no-dot-files-regexp) (list (file-name-nondirectory file))))) (delete-directory temporary-file-directory t))))) (ert-deftest jabber-test-omemo-message-colliding-device-trust () "Peer identity must survive session acquisition and trust filtering." (jabber-test-omemo-message-with-db (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.com")) ((symbol-function 'jabber-omemo--get-device-id) (lambda (_) 99))) (dolist (peer '("good@example.com" "bad@example.com")) (puthash (jabber-omemo--session-key "me@example.com" peer 7) (intern peer) jabber-omemo--sessions) (jabber-omemo-store-save-trust "me@example.com" peer 7 "identity" (if (equal peer "bad@example.com") -1 2))) (let (sessions) (jabber-omemo--ensure-sessions-for-ids 'fake-jc "bad@example.com" '(7) (lambda (value) (setq sessions value))) (should sessions) (should-not (jabber-omemo--trusted-sessions 'fake-jc sessions)))))) (ert-deftest jabber-test-omemo-message-peer-device-may-match-own-id () "Self exclusion requires the own JID as well as the numeric device ID." (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.com")) ((symbol-function 'jabber-omemo--get-device-id) (lambda (_) 7)) ((symbol-function 'jabber-omemo--get-session) (lambda (&rest _) 'session))) (let (peer own) (jabber-omemo--ensure-sessions-for-ids 'fake-jc "peer@example.com" '(7) (lambda (value) (setq peer value))) (jabber-omemo--ensure-sessions-for-ids 'fake-jc "me@example.com" '(7) (lambda (value) (setq own value))) (should peer) (should-not own)))) (ert-deftest jabber-test-omemo-message-colliding-multi-peer-native () "Merged native sessions retain peer, account and persistence ownership." (jabber-test-omemo-message-with-db (let* ((account "me@example.com") (peers '("one@example.com" "two@example.com" "me@example.com")) (stores (mapcar (lambda (_) (jabber-omemo-deserialize-store (jabber-omemo-setup-store))) peers)) sessions) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) account)) ((symbol-function 'jabber-blocking-ready-p) (lambda (&rest _) t)) ((symbol-function 'jabber-blocking-blocked-p) (lambda (&rest _) nil))) (puthash account 99 jabber-omemo--device-ids) (cl-mapc (lambda (peer store) (jabber-omemo--establish-session 'fake-jc peer 7 (jabber-omemo-get-bundle store)) (puthash (jabber-omemo--device-list-key account peer) '(7) jabber-omemo--device-lists)) peers stores) (jabber-omemo--ensure-sessions-multi 'fake-jc peers (lambda (value) (setq sessions value))) (should (= 3 (length sessions))) (let* ((enc (jabber-omemo-encrypt-message "hello")) (xml (jabber-omemo--build-encrypted-xml 'fake-jc sessions enc)) (header (car (jabber-xml-get-children xml 'header))) (keys (jabber-xml-get-children header 'key))) (should (= 3 (length keys))) (cl-mapc (lambda (entry key) (let* ((peer (nth 2 entry)) (store (nth (cl-position peer peers :test #'equal) stores)) (receiver (jabber-omemo-make-session))) (should (equal (jabber-omemo-decrypt-key receiver store t (base64-decode-string (car (jabber-xml-node-children key)))) (plist-get enc :key))) (should (equal (jabber-omemo-serialize-session (nth 3 entry)) (jabber-omemo-store-load-session account peer 7))))) sessions keys) (jabber-omemo-store-set-trust account "one@example.com" 7 -1) (let* ((before (jabber-omemo-store-load-session account "one@example.com" 7)) (filtered (jabber-omemo--build-encrypted-xml 'fake-jc sessions enc))) (should (= 2 (length (jabber-xml-get-children (car (jabber-xml-get-children filtered 'header)) 'key)))) (should (equal before (jabber-omemo-store-load-session account "one@example.com" 7)))) (should-error (jabber-omemo--build-encrypted-xml 'other-jc (list (list 7 "other@example.com" "one@example.com" (nth 3 (car sessions)))) enc) :type 'user-error) ;; A pending send must not restore a device deleted in the meantime. (jabber-omemo--delete-session account (nth 2 (car sessions)) 7 t) (should-error (jabber-omemo--build-encrypted-xml 'fake-jc sessions enc) :type 'user-error) (should-not (jabber-omemo-store-load-session account (nth 2 (car sessions)) 7))))))) (ert-deftest jabber-test-omemo-message-upload-native-and-plain () "Upload uses ciphertext when selected and plaintext only when intentional." (require 'jabber-httpupload) (dolist (encryption '(omemo nil)) (let* ((file (make-temp-file "jabber-upload-native-" nil nil "private bytes")) (jabber-chat-encryption encryption) (jabber-httpupload-support '((fake-jc . "upload.example"))) (jabber-httpupload-max-file-size nil) (jabber-httpupload-pre-upload-transform #'jabber-omemo--httpupload-transform) uploaded-path uploaded-bytes url (jabber-httpupload-upload-function (lambda (path _headers _url callback arg &optional _ignore) (setq uploaded-path path uploaded-bytes (with-temp-buffer (set-buffer-multibyte nil) (insert-file-contents-literally path) (buffer-string))) (funcall callback arg) t))) (unwind-protect (cl-letf (((symbol-function 'jabber-send-iq) (lambda (jc _to _type _request success &rest _) (funcall success jc '(iq () (slot ((xmlns . "urn:xmpp:http:upload:0")) (put ((url . "https://upload.example/put"))) (get ((url . "https://upload.example/get"))))) nil))) ((symbol-function 'jabber-httpupload-ignore-certificate) #'ignore)) (jabber-httpupload--upload 'fake-jc file (lambda (value) (setq url value))) (if encryption (progn (should-not (equal uploaded-bytes "private bytes")) (should-not (equal uploaded-path file)) (should (string-prefix-p "aesgcm://" url)) (should-not (file-exists-p uploaded-path))) (should (equal uploaded-path file)) (should (equal uploaded-bytes "private bytes")) (should (equal url "https://upload.example/get"))) (should (file-exists-p file))) (delete-file file))))) (defun jabber-test-omemo-message--cold-upload (encryption change &optional failure) "Exercise cold upload with ENCRYPTION, then CHANGE the source chat. Inject FAILURE after discovery starts, before the upload service replies." (require 'jabber-httpupload) (let* ((temporary-file-directory (make-temp-file "jabber-cold-upload-" t)) (file (make-temp-file "attachment-" nil nil "private bytes")) (chat (generate-new-buffer " *jabber-upload-chat*")) (dispatch (generate-new-buffer " *jabber-upload-dispatch*")) (jc (make-symbol "upload")) (jabber-connections (list jc)) (jabber-httpupload-support nil) (jabber-httpupload-max-file-size nil) (jabber-disco-info-cache (make-hash-table :test #'equal)) (jabber-disco-items-cache (make-hash-table :test #'equal)) (jabber-open-info-queries nil) (jabber-httpupload-pre-upload-transform nil) (native-comp-enable-subr-trampolines nil) (read-file (symbol-function 'insert-file-contents-literally)) (encrypt (symbol-function 'jabber-omemo-aesgcm-encrypt)) (write-file (symbol-function 'write-region)) (transforms 0) sent uploaded-path uploaded-bytes url (jabber-httpupload-upload-function (lambda (path _headers _url callback arg &optional _ignore) (setq uploaded-path path uploaded-bytes (with-temp-buffer (set-buffer-multibyte nil) (insert-file-contents-literally path) (buffer-string))) (funcall callback arg) t))) (put jc :state :session-established) (put jc :state-data (list :server "example.com" :username "upload" :resource "test" :connection (make-symbol "transport") :session-id "upload-stream")) (unwind-protect (cl-letf (((symbol-function 'jabber-caps-get-cached) #'ignore) ((symbol-function 'jabber-httpupload-ignore-certificate) #'ignore) ((symbol-function 'jabber-send-sexp) (lambda (_jc stanza &rest _) (push stanza sent)))) (with-current-buffer chat (setq-local jabber-chat-encryption encryption) ;; Retain the existing two-argument hook contract, including a ;; buffer-local custom hook rather than only the OMEMO symbol. (setq-local jabber-httpupload-pre-upload-transform (lambda (path callback) (cl-incf transforms) (jabber-omemo--httpupload-transform path callback))) (jabber-httpupload--upload jc file (lambda (value) (setq url value)))) (should (= (length sent) 1)) (should (= transforms 0)) (pcase change ('close (kill-buffer chat)) ('mode (with-current-buffer chat (fundamental-mode))) ('toggle (with-current-buffer chat (setq jabber-chat-encryption (if encryption nil 'omemo))))) (with-current-buffer dispatch ;; A callback buffer can even have the opposite selection. (setq-local jabber-chat-encryption (if encryption nil 'omemo)) (cl-labels ((reply (from payload) (jabber-process-iq jc `(iq ((type . "result") (from . ,from) (id . ,(jabber-xml-get-attribute (car sent) 'id))) ,payload)))) (reply "example.com" '(query ((xmlns . "http://jabber.org/protocol/disco#items")) (item ((jid . "upload.example"))))) (should (= (length sent) 2)) (cl-letf (((symbol-function 'insert-file-contents-literally) (lambda (&rest args) (if (eq failure 'read) (error "Read failed") (apply read-file args)))) ((symbol-function 'jabber-omemo-aesgcm-encrypt) (lambda (bytes) (if (eq failure 'encrypt) (error "Encryption failed") (funcall encrypt bytes)))) ((symbol-function 'write-region) (lambda (&rest args) (if (eq failure 'write) (error "Write failed") (apply write-file args))))) (let ((info '(query ((xmlns . "http://jabber.org/protocol/disco#info")) (feature ((var . "urn:xmpp:http:upload:0")))))) (if failure (should-error (reply "upload.example" info)) (reply "upload.example" info)))) (should (= transforms 1)) (if failure (progn (should (= (length sent) 2)) (should-not uploaded-path) (should-not url)) (should (= (length sent) 3)) (should (eq 'request (car (jabber-iq-query (car sent))))) (reply "upload.example" '(slot ((xmlns . "urn:xmpp:http:upload:0")) (put ((url . "https://upload.example/put"))) (get ((url . "https://upload.example/get"))))) (if encryption (progn (should-not (equal uploaded-path file)) (should-not (equal uploaded-bytes "private bytes")) (should (string-prefix-p "aesgcm://" url)) (should-not (file-exists-p uploaded-path)) (let ((parts (jabber-chat--parse-aesgcm-url url))) (should (equal (jabber-omemo-aesgcm-decrypt (plist-get parts :key) (plist-get parts :iv) uploaded-bytes) "private bytes")))) (should (equal uploaded-path file)) (should (equal uploaded-bytes "private bytes")) (should (equal url "https://upload.example/get")))))) (unless failure (should-not jabber-open-info-queries)) (should (equal (directory-files temporary-file-directory nil directory-files-no-dot-files-regexp) (list (file-name-nondirectory file))))) (when (buffer-live-p chat) (kill-buffer chat)) (kill-buffer dispatch) (delete-directory temporary-file-directory t)))) (ert-deftest jabber-test-omemo-message-cold-upload-retains-selection () "Cold native IQ discovery cannot downgrade an accepted encrypted upload." (dolist (change '(close mode toggle)) (jabber-test-omemo-message--cold-upload 'omemo change))) (ert-deftest jabber-test-omemo-message-cold-upload-plaintext-control () "A deliberately plaintext upload keeps its original selection and hook." (dolist (change '(close mode toggle)) (jabber-test-omemo-message--cold-upload nil change))) (ert-deftest jabber-test-omemo-message-cold-upload-failures-stop-slot () "Selected failures after held discovery must cause no slot or HTTP effects." (dolist (failure '(read encrypt write)) (dolist (change '(close mode toggle)) (jabber-test-omemo-message--cold-upload 'omemo change failure)))) (ert-deftest jabber-test-omemo-message-malformed-bundle-settles-send () "A malformed asynchronous bundle fails the real send operation once." (let ((jabber-omemo--pending-send-operations (make-hash-table :test #'eq)) (jabber-omemo--device-lists (make-hash-table :test #'equal)) (jabber-chatting-with "peer@example.com") (failures 0) (encrypted 0) reply) (puthash (jabber-omemo--device-list-key "me@example.com" "peer@example.com") '(7) jabber-omemo--device-lists) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.com")) ((symbol-function 'jabber-blocking-ready-p) (lambda (&rest _) t)) ((symbol-function 'jabber-blocking-blocked-p) (lambda (&rest _) nil)) ((symbol-function 'jabber-omemo--get-device-id) (lambda (_) 99)) ((symbol-function 'jabber-omemo--get-session) #'ignore) ((symbol-function 'jabber-omemo--display-pending) #'ignore) ((symbol-function 'jabber-omemo--send-failed) #'ignore) ((symbol-function 'jabber-omemo--send-encrypted) (lambda (&rest _) (cl-incf encrypted))) ((symbol-function 'jabber-omemo--request-peer) (lambda (_jc _jid _node success _failure _callback) (setq reply success)))) (jabber-omemo--send-chat 'fake-jc "hello" nil #'ignore (lambda (_) (cl-incf failures))) (should (gethash 'fake-jc jabber-omemo--pending-send-operations)) (funcall reply nil '(iq () (pubsub () (items () (item () (bundle () (signedPreKeyPublic () "%%%%") (signedPreKeySignature () "YQ==") (identityKey () "YQ==")))))) nil) (should (= failures 1)) (should (= encrypted 0)) (should-not (gethash 'fake-jc jabber-omemo--pending-send-operations))))) ;;; Interactive attachment settlement (require 'jabber-chat-commands) (defun jabber-test-omemo--attachment-reply (jc request payload) "Deliver PAYLOAD through native IQ dispatch for JC and REQUEST." (jabber-process-iq jc (with-temp-buffer (insert (format "%s" (jabber-xml-get-attribute request 'to) (jabber-xml-get-attribute request 'id) payload)) (car (xml-parse-region (point-min) (point-max)))))) (defconst jabber-test-omemo--attachment-info "") (defconst jabber-test-omemo--attachment-slot "") (defun jabber-test-omemo--attachment-slots (wire) "Count slot requests in WIRE." (cl-count-if (lambda (stanza) (eq (car (jabber-iq-query stanza)) 'request)) wire)) (defun jabber-test-omemo--attachment-case (cold failure &optional terminal-check replay) "Exercise COLD discovery and FAILURE with optional TERMINAL-CHECK or REPLAY." (let* ((temporary-file-directory (make-temp-file "jabber-test-omemo-attachment-" t)) (file (make-temp-file "selected-" nil ".txt" "private attachment bytes")) (chat (generate-new-buffer " *jabber-test-omemo-attachment-chat*")) (dispatch (generate-new-buffer " *jabber-test-omemo-attachment-dispatch*")) (jc (make-symbol "attachment")) (jabber-connections (list jc)) (jabber-httpupload-support (unless cold (list (cons jc "upload.example.invalid")))) (jabber-httpupload-max-file-size nil) (jabber-httpupload--discoveries nil) (jabber-disco-info-cache (make-hash-table :test #'equal)) (jabber-disco-items-cache (make-hash-table :test #'equal)) (jabber-open-info-queries nil) (jabber-chat-display-help-at-point nil) (jabber-chat-mode-hook nil) (jabber-httpupload-pre-upload-transform #'jabber-omemo--httpupload-transform) (command-history nil) (native-comp-enable-subr-trampolines nil) (read-original (symbol-function 'insert-file-contents-literally)) (write-original (symbol-function 'write-region)) (encrypt-original (symbol-function 'jabber-omemo-aesgcm-encrypt)) (fault failure) (uploads 0) (selections 0) wire pending-error info-request uploaded-bytes uploaded-path (jabber-httpupload-upload-function (lambda (path _headers _put callback arg &optional _ignore) (cl-incf uploads) (setq uploaded-path path uploaded-bytes (with-temp-buffer (set-buffer-multibyte nil) (insert-file-contents-literally path) (buffer-string))) (funcall callback arg) t))) (put jc :state :session-established) (put jc :state-data (list :server "example.invalid" :username "attachment" :resource "test" :connection (make-symbol "transport") :session-id "attachment-stream")) (unwind-protect (cl-letf (((symbol-function 'read-file-name) (lambda (&rest _) (cl-incf selections) file)) ((symbol-function 'jabber-send-sexp) (lambda (_owner stanza &rest _) (push stanza wire))) ((symbol-function 'jabber-caps-get-cached) #'ignore) ((symbol-function 'jabber-httpupload-ignore-certificate) #'ignore) ((symbol-function 'make-network-process) (lambda (&rest _) (error "Network forbidden"))) ((symbol-function 'url-retrieve) (lambda (&rest _) (error "HTTP forbidden"))) ((symbol-function 'insert-file-contents-literally) (lambda (&rest args) (if (and (eq fault 'read) (equal (car args) file)) (error "Injected attachment read failure") (apply read-original args)))) ((symbol-function 'write-region) (lambda (&rest args) (if (eq fault 'write) (error "Injected ciphertext write failure") (apply write-original args)))) ((symbol-function 'jabber-omemo-aesgcm-encrypt) (lambda (bytes) (pcase fault ('encrypt (error "Injected encryption failure")) ('rng (error "Injected random generation failure")) (_ (funcall encrypt-original bytes)))))) (with-current-buffer chat (jabber-chat-mode) (setq-local jabber-buffer-connection jc) (setq-local jabber-chat-encryption (if (eq failure 'plaintext) 'plaintext 'omemo)) (setq-local jabber-point-insert (copy-marker (point-min))) (insert "Unicode draft λ with an earlier https://existing.invalid/file") (setq-local jabber-httpupload--pending-url "https://existing.invalid/file") (goto-char (+ (point-min) 5)) (condition-case err ;; Force ordinary command history recording despite scripted minibuffer. (call-interactively #'jabber-chat-attach-file t) (error (setq pending-error (error-message-string err))))) (when cold (should-not pending-error) (should (= (length wire) 1)) (with-current-buffer dispatch (setq-local jabber-chat-encryption 'plaintext) (jabber-test-omemo--attachment-reply jc (car wire) "") (setq info-request (car wire)) (condition-case err (jabber-test-omemo--attachment-reply jc info-request jabber-test-omemo--attachment-info) (error (setq pending-error (error-message-string err)))))) (if (memq failure '(read write encrypt rng)) (progn (should (equal pending-error (pcase failure ('read "Injected attachment read failure") ('write "Injected ciphertext write failure") ('encrypt "Injected encryption failure") ('rng "Injected random generation failure")))) (should (= (jabber-test-omemo--attachment-slots wire) 0)) (should (= uploads 0)) (with-current-buffer chat (should (equal (buffer-string) "Unicode draft λ with an earlier https://existing.invalid/file")) (should (= (point) (+ (point-min) 5))) (should (equal jabber-httpupload--pending-url "https://existing.invalid/file"))) (should (file-exists-p file)) (should (equal (with-temp-buffer (funcall read-original file) (buffer-string)) "private attachment bytes")) (should (equal (car command-history) `(jabber-chat-attach-file ,file))) (when terminal-check ;; A failed operation may not remain owned by an outstanding IQ. (should-not jabber-open-info-queries)) (should-not jabber-httpupload--discoveries) (setq fault nil) (if replay (progn (with-current-buffer dispatch (jabber-test-omemo--attachment-reply jc info-request jabber-test-omemo--attachment-info)) (when (> (jabber-test-omemo--attachment-slots wire) 0) (with-current-buffer dispatch (jabber-test-omemo--attachment-reply jc (car wire) jabber-test-omemo--attachment-slot))) ;; Closure acceptance: a repeated result may not restart failed work. (should (= (jabber-test-omemo--attachment-slots wire) 0)) (should (= uploads 0)) (with-current-buffer chat (should (equal (buffer-string) "Unicode draft λ with an earlier https://existing.invalid/file")) (should (equal jabber-httpupload--pending-url "https://existing.invalid/file")))) ;; Explicit retry uses the expression retained by command history. (with-current-buffer chat (eval (car command-history) t)) (should (= selections 1)) (should (= (jabber-test-omemo--attachment-slots wire) 1)) (with-current-buffer dispatch (jabber-test-omemo--attachment-reply jc (car wire) jabber-test-omemo--attachment-slot)) (should (= uploads 1)) (should-not jabber-open-info-queries))) (should-not pending-error) (should (= (jabber-test-omemo--attachment-slots wire) 1)) (with-current-buffer dispatch (jabber-test-omemo--attachment-reply jc (car wire) jabber-test-omemo--attachment-slot)) (should (= uploads 1)) (should-not jabber-open-info-queries)) (unless (or terminal-check replay) (with-current-buffer chat (let ((url jabber-httpupload--pending-url)) (should (string-suffix-p url (buffer-string))) (if (eq failure 'plaintext) (progn (should (equal uploaded-path file)) (should (equal uploaded-bytes "private attachment bytes"))) (should-not (equal uploaded-path file)) (should-not (file-exists-p uploaded-path)) (should-not (equal uploaded-bytes "private attachment bytes")) (let ((parts (jabber-chat--parse-aesgcm-url url))) (should (equal (jabber-omemo-aesgcm-decrypt (plist-get parts :key) (plist-get parts :iv) uploaded-bytes) "private attachment bytes")))) ;; Native deferred-send OOB consumer attaches once, then retires URL. (should (equal (jabber-httpupload--send-hook (buffer-string) "probe") `((x ((xmlns . ,jabber-oob-xmlns)) (url () ,url))))) (should-not jabber-httpupload--pending-url) (should-not (jabber-httpupload--send-hook (buffer-string) "probe2")))))) (kill-buffer chat) (kill-buffer dispatch) (delete-directory temporary-file-directory t)))) (dolist (cold '(nil t)) (dolist (failure '(read write encrypt rng nil plaintext)) (eval `(ert-deftest ,(intern (format "jabber-test-omemo-attachment-observe-%s-%s" (if cold "cold" "cached") failure)) () (jabber-test-omemo--attachment-case ,cold ',failure))))) (dolist (failure '(read write encrypt rng)) (eval `(ert-deftest ,(intern (format "jabber-test-omemo-attachment-terminal-cold-%s" failure)) () (jabber-test-omemo--attachment-case t ',failure t))) (eval `(ert-deftest ,(intern (format "jabber-test-omemo-attachment-replay-cold-%s" failure)) () (jabber-test-omemo--attachment-case t ',failure nil t)))) (provide 'jabber-test-omemo-message) ;;; jabber-test-omemo-message.el ends here emacs-jabber-0.15.1/tests/jabber-test-omemo-module.el000066400000000000000000001330431527111033600223770ustar00rootroot00000000000000;;; 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--session-remote-identity)) (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-all-byte-values-round-trip () "Native crypto consumes every byte value without UTF-8 conversion." (let ((bytes (apply #'unibyte-string (number-sequence 0 255)))) (dolist (functions '((jabber-omemo--encrypt-message jabber-omemo--decrypt-message) (jabber-omemo--aesgcm-encrypt jabber-omemo--aesgcm-decrypt))) (dolist (plaintext (list "" bytes (concat bytes bytes "\0"))) (let* ((encrypted (funcall (car functions) plaintext)) (decrypted (funcall (cadr functions) (plist-get encrypted :key) (plist-get encrypted :iv) (plist-get encrypted :ciphertext)))) (should-not (multibyte-string-p decrypted)) (should (equal plaintext decrypted))))))) (ert-deftest jabber-test-omemo-module-multibyte-utf8-semantics () "Multibyte input still follows the module API's UTF-8 encoding." (let* ((text "Greek: Ελληνικά; NUL: \0; emoji: λ🙂") (encrypted (jabber-omemo--aesgcm-encrypt text))) (should (equal (encode-coding-string text 'utf-8) (jabber-omemo--aesgcm-decrypt (plist-get encrypted :key) (plist-get encrypted :iv) (plist-get encrypted :ciphertext)))))) (ert-deftest jabber-test-omemo-module-non-string-inputs () "The string boundary rejects non-strings rather than coercing sequences." (dolist (input '(nil 42 [0 255] (0 255))) (dolist (function '(jabber-omemo--deserialize-store jabber-omemo--deserialize-session jabber-omemo--legacy-session-blob-p jabber-omemo--encrypt-message jabber-omemo--aesgcm-encrypt)) (should-error (funcall function input) :type 'wrong-type-argument)))) (ert-deftest jabber-test-omemo-module-fixed-size-all-byte-values () "Fixed-size native inputs preserve all byte values, including NUL." (let ((bytes (apply #'unibyte-string (number-sequence 0 255))) (session (jabber-omemo--make-session))) (dotimes (i 8) (let* ((key (substring bytes (* i 32) (* (1+ i) 32))) (entries (list (list i key key)))) (jabber-omemo--session-set-skipped-keys session entries) (should (equal entries (jabber-omemo--session-skipped-keys session))) (should (equal entries (jabber-omemo--session-skipped-keys (jabber-omemo--deserialize-session (jabber-omemo--serialize-session session))))))))) (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))) (ert-deftest jabber-test-omemo-module-refilled-store-varint-round-trip () "Normal pre-key replacement survives the ID 127/128 size boundary." (let ((store (jabber-omemo--deserialize-store (jabber-omemo--setup-store)))) (dotimes (_ 28) (let ((id (caar (plist-get (jabber-omemo--get-bundle store) :pre-keys)))) (should (jabber-omemo--remove-pre-key store id)) (jabber-omemo--refill-pre-keys store))) (let* ((ids (mapcar #'car (plist-get (jabber-omemo--get-bundle store) :pre-keys))) (blob (jabber-omemo--serialize-store store)) (restored (jabber-omemo--deserialize-store blob))) (should (memq 128 ids)) (should (seq-some (lambda (id) (< id 128)) ids)) ;; Compare as a boolean so ERT never prints serialized key material. (should (eq t (string= blob (jabber-omemo--serialize-store restored))))))) ;;; 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)) (defun jabber-test-omemo-module--check-remote-identity (session expected) "Check SESSION exposes only EXPECTED public bytes without changing state." (let* ((before (jabber-omemo--serialize-session session)) (identity (jabber-omemo--session-remote-identity session))) (should (stringp identity)) (should-not (multibyte-string-p identity)) (should (= 33 (length identity))) (should (= #x05 (aref identity 0))) (should (equal expected identity)) ;; The result is a copy, not writable session storage. (aset identity 1 (logxor 1 (aref identity 1))) (should (equal expected (jabber-omemo--session-remote-identity session))) ;; Do not print private serialized session bytes on assertion failure. (should (eq t (string= before (jabber-omemo--serialize-session session)))))) (ert-deftest jabber-test-omemo-module-remote-identity-empty-is-read-only () "An uninitialized session has no identity and remains unchanged." (let* ((session (jabber-omemo--make-session)) (before (jabber-omemo--serialize-session session))) (should-not (jabber-omemo--session-remote-identity session)) (should (eq t (string= before (jabber-omemo--serialize-session session)))) (should-not (jabber-omemo--session-remote-identity (jabber-omemo--deserialize-session before))))) (ert-deftest jabber-test-omemo-module-remote-identity-rejects-non-sessions () "Wrong pointer kinds and non-pointers fail without modifying the store." (let* ((store (jabber-omemo--deserialize-store (jabber-omemo--setup-store))) (before (jabber-omemo--serialize-store store))) (should-error (jabber-omemo--session-remote-identity store) :type 'jabber-omemo-error) (dolist (value '(nil 1 "not a session")) (should-error (jabber-omemo--session-remote-identity value) :type 'wrong-type-argument)) (should (eq t (string= before (jabber-omemo--serialize-store store)))))) (ert-deftest jabber-test-omemo-module-remote-identity-both-ends-preserve-ratchet () "Both ends expose the peer bundle identity, preserving skipped keys." (jabber-test-omemo-module--with-session-pair (let* ((alice-id (plist-get (jabber-omemo--get-bundle alice) :identity-key)) (bob-id (plist-get bundle :identity-key)) (bob-session (jabber-omemo--make-session)) (k1 (make-string 32 ?1)) (k2 (make-string 32 ?2))) (should-not (equal alice-id bob-id)) ;; Initiation verified Bob's signed bundle, even before his first reply. (jabber-test-omemo-module--check-remote-identity alice-session bob-id) (let ((m1 (jabber-omemo--encrypt-key alice-session k1)) (m2 (jabber-omemo--encrypt-key alice-session k2))) (should (equal k2 (jabber-omemo--decrypt-key bob-session bob (plist-get m2 :pre-key-p) (plist-get m2 :data)))) (should (= 1 (length (jabber-omemo--session-skipped-keys bob-session)))) (jabber-test-omemo-module--check-remote-identity bob-session alice-id) ;; Identity and skipped keys survive the native persistence boundary. (let ((restored (jabber-omemo--deserialize-session (jabber-omemo--serialize-session bob-session)))) (jabber-test-omemo-module--check-remote-identity restored alice-id) (should (equal k1 (jabber-omemo--decrypt-key restored bob (plist-get m1 :pre-key-p) (plist-get m1 :data)))) (should-not (jabber-omemo--session-skipped-keys restored)) (let ((reply (jabber-omemo--encrypt-key restored k2))) (should (equal k2 (jabber-omemo--decrypt-key alice-session alice (plist-get reply :pre-key-p) (plist-get reply :data))))) (jabber-test-omemo-module--check-remote-identity alice-session bob-id) (jabber-test-omemo-module--check-remote-identity restored alice-id)))))) (ert-deftest jabber-test-omemo-module-remote-identity-unset-after-failed-auth () "Failed pre-key authentication exposes no identity; valid retry does." (jabber-test-omemo-module--with-session-pair (let* ((session (jabber-omemo--make-session)) (before (jabber-omemo--serialize-session session)) (key (make-string 32 ?K)) (message (jabber-omemo--encrypt-key alice-session key)) (corrupt (copy-sequence (plist-get message :data))) (last (1- (length corrupt)))) (aset corrupt last (logxor 1 (aref corrupt last))) (should-error (jabber-omemo--decrypt-key session bob t corrupt) :type 'jabber-omemo-error) (should-not (jabber-omemo--session-remote-identity session)) (should (eq t (string= before (jabber-omemo--serialize-session session)))) (should (equal key (jabber-omemo--decrypt-key session bob (plist-get message :pre-key-p) (plist-get message :data)))) (jabber-test-omemo-module--check-remote-identity session (plist-get (jabber-omemo--get-bundle alice) :identity-key))))) (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)))))))) ;;; Group: Unloadable module (ert-deftest jabber-test-omemo-module-unloadable-disables-omemo () "A module that cannot be opened disables OMEMO instead of failing load." (let* ((dir (make-temp-file "jabber-omemo-broken" t)) (lisp-dir (file-name-directory (locate-library "jabber-omemo"))) (form `(progn (setq load-path (cons ,dir (delete ,dir load-path))) (setq jabber-db-path nil) (require 'jabber-omemo) (princ (format "%S" jabber-omemo--available))))) (unwind-protect (progn ;; An empty file is found by `require' but rejected by dlopen. (write-region "" nil (expand-file-name (concat "jabber-omemo-core" module-file-suffix) dir) nil 'silent) (with-temp-buffer (let ((status (call-process (expand-file-name invocation-name invocation-directory) nil '(t nil) nil "-Q" "--batch" "--eval" (format "(setq load-path '%S)" (cons lisp-dir load-path)) "--eval" (format "%S" form)))) ;; Standard output only; the warning goes to stderr. (should (equal (list status (buffer-string)) '(0 "unavailable")))))) (delete-directory dir t)))) (provide 'jabber-test-omemo-module) ;;; jabber-test-omemo-module.el ends here emacs-jabber-0.15.1/tests/jabber-test-omemo-own-list.el000066400000000000000000000605531527111033600226730ustar00rootroot00000000000000;;; jabber-test-omemo-own-list.el --- Own OMEMO list safety tests -*- lexical-binding: t; -*- ;; Copyright (C) 2026 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. ;;; Commentary: ;; Exercise the real own-list mutation callers and PubSub response boundary. ;; Native keys, persistence and wire effects use disposable synthetic fixtures. ;;; Code: (require 'ert) (require 'cl-lib) (require 'jabber-omemo) (require 'xml) (defun jabber-test-own-list--result (ids) "Return a successful own device-list response containing IDS." `(iq ((type . "result") (from . "me@example.org")) (pubsub ((xmlns . ,jabber-pubsub-xmlns)) (items ((node . ,jabber-omemo-devicelist-node)) (item ((id . "current")) ,(jabber-omemo--build-device-list-xml ids)))))) (defun jabber-test-own-list--error (condition) "Return an error response with standard stanza CONDITION." `(iq ((type . "error") (from . "me@example.org")) (error ((type . "cancel")) (,condition ((xmlns . ,jabber-stanzas-xmlns)))))) (defmacro jabber-test-own-list--with-fixture (&rest body) "Evaluate BODY with held PubSub callbacks and counted effects." (declare (indent 0) (debug t)) `(let ((state (list :username "me" :server "example.org" :connection (list 'transport) :session-id "stream" :blocking-session (list nil))) (jabber-omemo--device-lists (make-hash-table :test #'equal)) success failure published deleted cleaned persisted deactivated (completed 0)) (cl-letf (((symbol-function 'fsm-get-state-data) (lambda (_) state)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.org")) ((symbol-function 'jabber-omemo--get-device-id) (lambda (_) 222)) ((symbol-function 'jabber-pubsub-request) (lambda (_jc _jid _node ok err) (setq success ok failure err))) ((symbol-function 'jabber-omemo--publish-device-list) (lambda (_jc ids) (push ids published))) ((symbol-function 'jabber-omemo--cleanup-stale-devices) (lambda (_jc ids) (push ids cleaned))) ((symbol-function 'jabber-omemo--delete-bundle-node) (lambda (_jc id) (push id deleted))) ((symbol-function 'jabber-pubsub-delete-node) (lambda (jc _jid node &optional callback _error) (push node deleted) (when callback (funcall callback jc nil nil)))) ((symbol-function 'jabber-omemo-store-save-device) (lambda (_account _jid id) (push id persisted))) ((symbol-function 'jabber-omemo--deactivate-stale-devices) (lambda (_account _jid ids) (push ids deactivated)))) ;; Each journey inspects only the effects relevant to its contract. (ignore success failure published deleted cleaned persisted deactivated completed) ,@body))) (defun jabber-test-own-list--mutate (operation) "Start the own-list mutation named by OPERATION." (pcase operation ('ensure (jabber-omemo--ensure-device-listed 'account)) ('stale (jabber-omemo--remove-stale-devices 'account '(111))) ('remove (jabber-omemo--remove-device 'account 111)))) (ert-deftest jabber-test-own-list-failure-no-destructive-effects () "All own-list mutations refuse uncertain errors without cache or DB changes." (dolist (operation '(ensure stale remove)) (dolist (condition '(service-unavailable remote-server-timeout forbidden internal-server-error feature-not-implemented)) (jabber-test-own-list--with-fixture (jabber-test-own-list--mutate operation) (funcall failure 'account (jabber-test-own-list--error condition) nil) (should-not published) (should-not deleted) (should-not cleaned) (should-not persisted) (should-not deactivated) (should (= (hash-table-count jabber-omemo--device-lists) 0)))))) (ert-deftest jabber-test-own-list-first-install () "A successful empty list or a missing node permits first-install publication." (dolist (missing '(nil t)) (jabber-test-own-list--with-fixture (jabber-omemo--ensure-device-listed 'account) (if missing (funcall failure 'account (jabber-test-own-list--error 'item-not-found) nil) (funcall success 'account (jabber-test-own-list--result nil) nil)) (should (equal published '((222)))) (should (equal cleaned '(nil)))))) (ert-deftest jabber-test-own-list-success-preserves-other-devices () "Fresh publication preserves other IDs; removals filter only selected IDs." (dolist (operation '(ensure stale remove)) (jabber-test-own-list--with-fixture (jabber-test-own-list--mutate operation) (funcall success 'account (jabber-test-own-list--result '(111 333)) nil) (should (equal published (if (eq operation 'ensure) '((222 111 333)) '((333))))) (should (equal (sort persisted #'<) '(111 333))) (should (equal deactivated '((111 333))))))) (ert-deftest jabber-test-own-list-already-listed () "An already listed device requires no publication or stale cleanup." (jabber-test-own-list--with-fixture (jabber-omemo--ensure-device-listed 'account) (funcall success 'account (jabber-test-own-list--result '(111 222)) nil) (should-not published) (should-not cleaned))) (ert-deftest jabber-test-own-list-no-response () "Waiting for a response never publishes or deletes anything." (dolist (operation '(ensure stale remove)) (jabber-test-own-list--with-fixture (jabber-test-own-list--mutate operation) (should success) (should failure) (should-not published) (should-not deleted) (should-not deactivated)))) (ert-deftest jabber-test-own-list-retired-session () "Both success and missing-node replies from a retired session are refused." (dolist (operation '(ensure stale remove)) (dolist (field '(:connection :session-id :blocking-session :username :server)) (dolist (missing '(nil t)) (jabber-test-own-list--with-fixture (jabber-test-own-list--mutate operation) (setq state (plist-put (copy-sequence state) field (list 'replacement))) (if missing (funcall failure 'account (jabber-test-own-list--error 'item-not-found) nil) (funcall success 'account (jabber-test-own-list--result '(111)) nil)) (should-not published) (should-not deleted) (should-not persisted) (should-not deactivated)))))) (ert-deftest jabber-test-own-list-same-session-state-replacement () "Ordinary FSM state copying does not retire a valid own-list response." (jabber-test-own-list--with-fixture (jabber-omemo--ensure-device-listed 'account) (setq state (copy-sequence state)) (funcall success 'account (jabber-test-own-list--result '(111)) nil) (should (equal published '((222 111)))))) (ert-deftest jabber-test-own-list-malformed-result () "Incomplete and malformed payloads cannot authorize destructive mutations." (dolist (xml (list '(iq ((type . "result"))) '(iq ((type . "result")) (pubsub nil (items nil))) (jabber-test-own-list--result '(0)) (jabber-test-own-list--result '(2147483648)) '(iq ((type . "result")) (pubsub ((xmlns . "http://jabber.org/protocol/pubsub")) (items ((node . "wrong"))))))) (jabber-test-own-list--with-fixture (jabber-omemo--ensure-device-listed 'account) (funcall success 'account xml nil) (should-not published) (should-not deactivated)))) (ert-deftest jabber-test-own-list-legacy-peer-callback () "Legacy peer callbacks remain fixed one-argument functions with nil failure." (jabber-test-own-list--with-fixture (jabber-omemo--fetch-device-list 'account "peer@example.net" (lambda (ids) (cl-incf completed) (should-not ids))) (funcall failure 'account (jabber-test-own-list--error 'service-unavailable) nil) (should (= completed 1))) (jabber-test-own-list--with-fixture (jabber-omemo--fetch-device-list 'account "peer@example.net" (lambda (ids) (cl-incf completed) (should (equal ids '(111))))) (funcall success 'account (jabber-test-own-list--result '(111)) nil) (should (= completed 1)))) (ert-deftest jabber-test-own-list-empty-items-and-removals () "Authoritative empty items and missing nodes permit each explicit mutation." (dolist (operation '(ensure stale remove)) (dolist (missing '(nil t)) (jabber-test-own-list--with-fixture (jabber-test-own-list--mutate operation) (if missing (funcall failure 'account (jabber-test-own-list--error 'item-not-found) nil) (funcall success 'account `(iq ((type . "result")) (pubsub ((xmlns . ,jabber-pubsub-xmlns)) (items ((node . ,jabber-omemo-devicelist-node))))) nil)) (should (equal published (if (eq operation 'ensure) '((222)) '(nil)))) (should (eq (not (null deleted)) (not (eq operation 'ensure)))))))) (ert-deftest jabber-test-own-list-failure-preserves-cache-and-completion () "Failed removal preserves a known cache and does not claim completion." (jabber-test-own-list--with-fixture (puthash (jabber-omemo--device-list-key "me@example.org" "me@example.org") '(111 222) jabber-omemo--device-lists) (jabber-omemo--remove-device 'account 111 (lambda () (cl-incf completed))) (funcall failure 'account (jabber-test-own-list--error 'service-unavailable) nil) (should (= completed 0)) (should-not published) (should-not deleted) (should (equal (gethash (jabber-omemo--device-list-key "me@example.org" "me@example.org") jabber-omemo--device-lists) '(111 222))))) (ert-deftest jabber-test-own-list-success-completion-once () "Successful removal completes once, ignoring repeated or opposite replies." (jabber-test-own-list--with-fixture (jabber-omemo--remove-device 'account 111 (lambda () (cl-incf completed))) (funcall success 'account (jabber-test-own-list--result '(111 222)) nil) (should (= completed 1)) (should (equal published '((222)))) (should (= (length deleted) 1)) (funcall success 'account (jabber-test-own-list--result nil) nil) (funcall failure 'account (jabber-test-own-list--error 'item-not-found) nil) (should (= completed 1)) (should (equal published '((222)))) (should (= (length deleted) 1)))) (ert-deftest jabber-test-own-list-error-settles-before-late-success () "A failure cannot be revived into a successful empty snapshot." (jabber-test-own-list--with-fixture (jabber-omemo--ensure-device-listed 'account) (funcall failure 'account (jabber-test-own-list--error 'service-unavailable) nil) (funcall success 'account (jabber-test-own-list--result nil) nil) (should-not published) (should-not deactivated))) (ert-deftest jabber-test-own-list-cancelled-request () "Cancellation retires retained success and error callbacks." (jabber-test-own-list--with-fixture (cl-letf (((symbol-function 'jabber-omemo--request-peer) (lambda (_jc _jid _node ok err cancel) (setq success ok failure err) (funcall cancel nil)))) (jabber-omemo--ensure-device-listed 'account)) (funcall success 'account (jabber-test-own-list--result nil) nil) (funcall failure 'account (jabber-test-own-list--error 'item-not-found) nil) (should-not published) (should-not deactivated))) (ert-deftest jabber-test-own-list-synchronous-unwind () "Error and quit before response admission retire retained callbacks." (dolist (condition '(error quit)) (jabber-test-own-list--with-fixture (cl-letf (((symbol-function 'jabber-pubsub-request) (lambda (_jc _jid _node ok err) (setq success ok failure err) (signal condition nil)))) (let (caught) (condition-case err (jabber-omemo--ensure-device-listed 'account) ((error quit) (setq caught (car err)))) (should (eq caught condition)))) (funcall success 'account (jabber-test-own-list--result nil) nil) (funcall failure 'account (jabber-test-own-list--error 'item-not-found) nil) (should-not published) (should-not deactivated)))) (ert-deftest jabber-test-own-list-foreign-response () "Foreign receiving connections and senders cannot supply own snapshots." (dolist (missing '(nil t)) (dolist (foreign-jc '(nil t)) (jabber-test-own-list--with-fixture (jabber-omemo--ensure-device-listed 'account) (let ((xml (copy-tree (if missing (jabber-test-own-list--error 'item-not-found) (jabber-test-own-list--result nil))))) (unless foreign-jc (setcdr (assq 'from (cadr xml)) "other@example.org")) (funcall (if missing failure success) (if foreign-jc 'other 'account) xml nil)) (should-not published) (should-not deactivated))))) (ert-deftest jabber-test-own-list-malformed-missing-node-error () "Wrong namespaces or conflicting conditions do not establish an absent node." (dolist (xml '((iq ((type . "error")) (error nil (item-not-found ((xmlns . "wrong"))))) (iq ((type . "error")) (error nil (item-not-found ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))) (service-unavailable ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))) (iq ((type . "result")) (error nil (item-not-found ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))))))) (jabber-test-own-list--with-fixture (jabber-omemo--ensure-device-listed 'account) (funcall failure 'account xml nil) (should-not published) (should-not deactivated)))) (ert-deftest jabber-test-own-list-stale-cleanup-session-ownership () "An old bundle comparison cannot initiate a fresh-session list mutation." (let ((cleanup (symbol-function 'jabber-omemo--cleanup-stale-devices))) (dolist (retired '(nil t)) (jabber-test-own-list--with-fixture (let (bundle-callback removals) (cl-letf (((symbol-function 'jabber-omemo--get-store) (lambda (_) 'store)) ((symbol-function 'jabber-omemo-get-bundle) (lambda (_) '(:identity-key "fixture-key"))) ((symbol-function 'jabber-omemo--fetch-bundle) (lambda (_jc _jid _id callback) (setq bundle-callback callback))) ((symbol-function 'jabber-omemo--remove-stale-devices) (lambda (_jc ids) (push ids removals)))) (funcall cleanup 'account '(111)) (setq state (copy-sequence state)) (when retired (plist-put state :connection (list 'successor))) (funcall bundle-callback '(:identity-key "fixture-key")) (should (equal removals (unless retired '((111))))))))))) (ert-deftest jabber-test-own-list-native-iq-failure-boundary () "Real PubSub/IQ dispatch refuses failure for every own-list mutation caller." (let ((request (symbol-function 'jabber-pubsub-request))) (dolist (operation '(ensure stale remove)) (jabber-test-own-list--with-fixture (let ((jabber-open-info-queries nil) wire) (cl-letf (((symbol-function 'jabber-pubsub-request) request) ((symbol-function 'jabber-send-sexp) (lambda (_jc xml) (setq wire xml)))) (jabber-test-own-list--mutate operation) (should (equal (jabber-xml-get-attribute wire 'to) "me@example.org")) (should (equal (jabber-xml-get-attribute wire 'type) "get")) (let ((xml (copy-tree (jabber-test-own-list--error 'service-unavailable)))) (push (cons 'id (jabber-xml-get-attribute wire 'id)) (cadr xml)) (jabber-process-iq 'account xml)) (should-not jabber-open-info-queries) (should-not published) (should-not deleted) (should-not cleaned) (should-not deactivated))))))) (ert-deftest jabber-test-own-list-native-iq-first-install () "Real PubSub/IQ dispatch admits a standard absent-node first installation." (let ((request (symbol-function 'jabber-pubsub-request))) (jabber-test-own-list--with-fixture (let ((jabber-open-info-queries nil) wire) (cl-letf (((symbol-function 'jabber-pubsub-request) request) ((symbol-function 'jabber-send-sexp) (lambda (_jc xml) (setq wire xml)))) (jabber-omemo--ensure-device-listed 'account) (let ((xml (copy-tree (jabber-test-own-list--error 'item-not-found)))) (push (cons 'id (jabber-xml-get-attribute wire 'id)) (cadr xml)) (jabber-process-iq 'account xml)) (should-not jabber-open-info-queries) (should (equal published '((222))))))))) (defun jabber-test-own-list--parse-wire (contents) "Parse a successful own-list IQ containing PubSub CONTENTS." (with-temp-buffer (insert (concat "" contents "")) (car (xml-parse-region (point-min) (point-max))))) (ert-deftest jabber-test-own-list-native-iq-malformed-content () "Malformed content at every snapshot level has no mutation effects." (let* ((request (symbol-function 'jabber-pubsub-request)) (valid (jabber-test-own-list--result '(111 333))) (paths '((pubsub) (pubsub items) (pubsub items item) (pubsub items item list) (pubsub items item list device)))) (dolist (operation '(ensure stale remove)) ;; Text-only items/list reproduce the destructive authoritative-empty bug. ;; Mixed text and unknown children also fail, even with valid device IDs. (dolist (path (cons nil paths)) (dolist (bad-child '("not-an-empty-snapshot" (unknown nil))) (dolist (text-only '(nil t)) (jabber-test-own-list--with-fixture (let ((jabber-open-info-queries nil) (xml (copy-tree valid)) wire) (let ((node xml)) (dolist (name path) (setq node (car (jabber-xml-get-children node name)))) (setcdr (cdr node) (cons bad-child (unless text-only (cddr node))))) (setq xml (with-temp-buffer (insert (jabber-sexp2xml xml)) (car (xml-parse-region (point-min) (point-max))))) (puthash (jabber-omemo--device-list-key "me@example.org" "me@example.org") '(111 222) jabber-omemo--device-lists) (cl-letf (((symbol-function 'jabber-pubsub-request) request) ((symbol-function 'jabber-send-sexp) (lambda (_jc stanza) (setq wire stanza)))) (jabber-test-own-list--mutate operation) (push (cons 'id (jabber-xml-get-attribute wire 'id)) (cadr xml)) (jabber-process-iq 'account xml)) (should-not jabber-open-info-queries) (should-not published) (should-not deleted) (should-not cleaned) (should-not persisted) (should-not deactivated) (should (equal (gethash (jabber-omemo--device-list-key "me@example.org" "me@example.org") jabber-omemo--device-lists) '(111 222))))))))))) (ert-deftest jabber-test-own-list-native-iq-malformed-namespace () "Namespace overrides cannot authorize any own-list mutation." (let ((request (symbol-function 'jabber-pubsub-request))) (dolist (operation '(ensure stale remove)) (dolist (path '((pubsub) (pubsub items) (pubsub items item) (pubsub items item list) (pubsub items item list device))) (dolist (namespace '("urn:wrong" "")) (jabber-test-own-list--with-fixture (let ((jabber-open-info-queries nil) (xml (jabber-test-own-list--result '(111 333))) wire) (let ((node xml)) (dolist (name path) (setq node (car (jabber-xml-get-children node name)))) (setf (alist-get 'xmlns (cadr node)) namespace)) (setq xml (with-temp-buffer (insert (jabber-sexp2xml xml)) (car (xml-parse-region (point-min) (point-max))))) (puthash (jabber-omemo--device-list-key "me@example.org" "me@example.org") '(111 222) jabber-omemo--device-lists) (cl-letf (((symbol-function 'jabber-pubsub-request) request) ((symbol-function 'jabber-send-sexp) (lambda (_jc stanza) (setq wire stanza)))) (jabber-test-own-list--mutate operation) (push (cons 'id (jabber-xml-get-attribute wire 'id)) (cadr xml)) (jabber-process-iq 'account xml)) (should-not jabber-open-info-queries) (should-not published) (should-not deleted) (should-not cleaned) (should-not persisted) (should-not deactivated) (should (equal (gethash (jabber-omemo--device-list-key "me@example.org" "me@example.org") jabber-omemo--device-lists) '(111 222)))))))))) (ert-deftest jabber-test-own-list-native-iq-whitespace-and-inheritance () "Valid whitespace, explicit and inherited namespaces preserve device IDs." (let ((request (symbol-function 'jabber-pubsub-request))) (dolist (operation '(ensure stale remove)) (dolist (contents '("\n\n\n\n\n" "\n" "\n\n\n\n\n \t\r\n\n\n\n\n\n\n" "")) (jabber-test-own-list--with-fixture (let ((jabber-open-info-queries nil) (xml (jabber-test-own-list--parse-wire contents)) wire (ids (when (string-match-p " (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-reset-session-preserves-trust () "Reset removes durable and cached session state but preserves trust." (jabber-test-omemo-protocol-with-db (let ((account "me@example.com") (peer "alice@example.com") (did 7) rebuilt) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) account)) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc jid callback) (should (string= peer jid)) (should-not (jabber-omemo-store-load-session account peer did)) (should-not (gethash (jabber-omemo--session-key account peer did) jabber-omemo--sessions)) (funcall callback (list (list did account peer 'fresh-session)))))) (jabber-omemo-store-save-trust account peer did "identity" 2) (jabber-omemo-store-save-session account peer did "stale-session") (puthash (jabber-omemo--session-key account peer did) 'stale-session jabber-omemo--sessions) (jabber-omemo--reset-session 'fake-jc peer did (lambda (session) (setq rebuilt session))) (should (eq 'fresh-session rebuilt)) (should (= 2 (plist-get (jabber-omemo-store-load-trust account peer did) :trust))))))) (ert-deftest jabber-test-omemo-protocol-reset-clears-state-on-rebuild-failure () "A failed rebuild leaves no old session or legacy skipped keys." (jabber-test-omemo-protocol-with-db (let ((account "me@example.com") (peer "alice@example.com") (did 7) result) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) account)) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (_jc _jid callback) (funcall callback nil)))) (jabber-omemo-store-save-trust account peer did "identity" 2) (jabber-omemo-store-save-session account peer did "stale-session") (sqlite-execute jabber-db--connection "\ INSERT INTO omemo_skipped_keys (account, jid, device_id, dh_key, message_number, message_key, created_at) VALUES (?, ?, ?, 'dh', 3, 'mk', 0)" (list account peer did)) (jabber-omemo--reset-session 'fake-jc peer did (lambda (session) (setq result session))) (should-not result) (should-not (jabber-omemo-store-load-session account peer did)) (should-not (jabber-omemo-store-all-skipped-keys account peer did)) (should (= 2 (plist-get (jabber-omemo-store-load-trust account peer did) :trust))))))) (ert-deftest jabber-test-omemo-protocol-establish-session-preserves-trust () "Re-establishing a session preserves verified trust and identity." (jabber-test-omemo-protocol-with-db (let* ((account "me@example.com") (peer "alice@example.com") (did 7) (peer-store (jabber-omemo-deserialize-store (jabber-omemo-setup-store))) (bundle (jabber-omemo-get-bundle peer-store)) (identity (plist-get bundle :identity-key))) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) account))) (jabber-omemo-store-save-trust account peer did identity 2) (jabber-omemo--establish-session 'fake-jc peer did bundle) (let ((trust (jabber-omemo-store-load-trust account peer did))) (should (= 2 (plist-get trust :trust))) (should (string= identity (plist-get trust :identity-key)))))))) (ert-deftest jabber-test-omemo-protocol-establish-rejects-changed-identity () "Re-establishing rejects a changed identity before saving a session." (jabber-test-omemo-protocol-with-db (let* ((account "me@example.com") (peer "alice@example.com") (did 7) (old-store (jabber-omemo-deserialize-store (jabber-omemo-setup-store))) (new-store (jabber-omemo-deserialize-store (jabber-omemo-setup-store))) (old-identity (plist-get (jabber-omemo-get-bundle old-store) :identity-key)) (new-bundle (jabber-omemo-get-bundle new-store)) stored-identity) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_jc) account))) (jabber-omemo-store-save-trust account peer did old-identity 2) (setq stored-identity (plist-get (jabber-omemo-store-load-trust account peer did) :identity-key)) (should-error (jabber-omemo--establish-session 'fake-jc peer did new-bundle) :type 'user-error) (should-not (jabber-omemo-store-load-session account peer did)) (let ((trust (jabber-omemo-store-load-trust account peer did))) (should (= 2 (plist-get trust :trust))) (should (string= stored-identity (plist-get trust :identity-key)))))))) (ert-deftest jabber-test-omemo-protocol-session-failure-completes-callback () "A malformed bundle completes session establishment with no result." (let ((calls 0) (fetched 0) result) (cl-letf (((symbol-function 'jabber-omemo--get-device-id) (lambda (_jc) 1)) ((symbol-function 'jabber-omemo--get-session) (lambda (&rest _) nil)) ((symbol-function 'jabber-omemo--fetch-bundle) (lambda (_jc _jid _did callback) (cl-incf fetched) (funcall callback '(:pre-keys nil))))) (jabber-omemo--ensure-sessions-for-ids 'fake-jc "alice@example.com" '(7 8) (lambda (sessions) (should (= 2 fetched)) (cl-incf calls) (setq result sessions))) (should (= 1 calls)) (should-not result)))) (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))))))) (ert-deftest jabber-test-omemo-protocol-malformed-fetch-completes () "Malformed base64 completes the real bundle response with failure." (let ((calls 0) result escaped) (cl-letf (((symbol-function 'jabber-omemo--request-peer) (lambda (_jc _jid _node success _failure _callback) (funcall success nil '(iq () (pubsub () (items () (item () (bundle () (signedPreKeyPublic ((signedPreKeyId . "1")) "%%%%") (signedPreKeySignature () "YQ==") (identityKey () "YQ==")))))) nil)))) (condition-case err (jabber-omemo--fetch-bundle 'fake-jc "peer@example.com" 7 (lambda (value) (cl-incf calls) (setq result value))) (error (setq escaped err))) (should-not escaped) (should (= calls 1)) (should-not result)))) (ert-deftest jabber-test-omemo-protocol-bundle-response-completion-matrix () "Malformed fields settle acquisition and publication without stranding state." (dolist (field '(signedPreKeyPublic signedPreKeySignature identityKey preKeyPublic)) (dolist (text '("%%%%" "" (nested nil "not text"))) (let* ((bundle (copy-tree '(bundle () (signedPreKeyPublic ((signedPreKeyId . "1")) "YQ==") (signedPreKeySignature () "YQ==") (identityKey () "YQ==") (prekeys () (preKeyPublic ((preKeyId . "1")) "YQ=="))))) (container (if (eq field 'preKeyPublic) (car (jabber-xml-get-children bundle 'prekeys)) bundle)) (element (car (jabber-xml-get-children container field))) (jabber-omemo--bundle-publishes-in-flight (make-hash-table :test #'equal)) (calls 0) (published 0) result) (setcar (cddr element) text) (cl-letf (((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.com")) ((symbol-function 'jabber-omemo--get-device-id) (lambda (_) 99)) ((symbol-function 'jabber-omemo--get-session) (lambda (&rest _) nil)) ((symbol-function 'jabber-omemo--get-store) #'ignore) ((symbol-function 'jabber-omemo-get-bundle) #'ignore) ((symbol-function 'jabber-omemo-refill-pre-keys) #'ignore) ((symbol-function 'jabber-omemo--persist-store) #'ignore) ((symbol-function 'jabber-omemo--publish-bundle) (lambda (_) (cl-incf published))) ((symbol-function 'jabber-omemo--request-peer) (lambda (_jc _jid _node success _failure _callback) (funcall success nil `(iq () (pubsub () (items () (item () ,bundle)))) nil)))) (jabber-omemo--ensure-sessions-for-ids 'fake-jc "peer@example.com" '(7 8) (lambda (value) (cl-incf calls) (setq result value))) (should (= calls 1)) (should-not result) (jabber-omemo--publish-bundle-if-needed 'fake-jc) (should (= published 1)) (should (= 0 (hash-table-count jabber-omemo--bundle-publishes-in-flight)))))))) (ert-deftest jabber-test-omemo-protocol-bundle-callback-errors-not-retried () "A valid, empty or malformed response must not retry a failing consumer." (dolist (bundle '(nil (bundle () (signedPreKeyPublic () "YQ==") (signedPreKeySignature () "YQ==") (identityKey () "YQ==")) (bundle () (signedPreKeyPublic () "%%%%") (signedPreKeySignature () "YQ==") (identityKey () "YQ==")))) (let ((calls 0) result) (cl-letf (((symbol-function 'jabber-omemo--request-peer) (lambda (_jc _jid _node success _failure _callback) (funcall success nil `(iq () (pubsub () (items () (item () ,bundle)))) nil)))) (should-error (jabber-omemo--fetch-bundle 'fake-jc "peer@example.com" 7 (lambda (value) (cl-incf calls) (setq result value) (error "Consumer failed")))) (should (= calls 1)) (should (eq (not (null result)) (equal (car (jabber-xml-node-children (car (jabber-xml-get-children bundle 'signedPreKeyPublic)))) "YQ=="))))))) (provide 'jabber-test-omemo-protocol) ;;; jabber-test-omemo-protocol.el ends here emacs-jabber-0.15.1/tests/jabber-test-omemo-store.el000066400000000000000000000452511527111033600222510ustar00rootroot00000000000000;;; 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) (require 'jabber-omemo-core) ;;; 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-native-blob-close-reopen () "A generated native store remains consumable after SQLite close/reopen." (jabber-test-omemo-store-with-db (let ((blob (jabber-omemo--setup-store))) (jabber-omemo-store-save "fixture@example.invalid" blob) (jabber-db-close) (jabber-db-ensure-open) (let ((reloaded (jabber-omemo-store-load "fixture@example.invalid"))) (should (equal blob reloaded)) (should (equal '(("ok")) (sqlite-select jabber-db--connection "PRAGMA integrity_check"))) (should (equal blob (jabber-omemo--serialize-store (jabber-omemo--deserialize-store reloaded)))))))) (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 13 10 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 (unibyte-string 5 13 10 42 200 255))) (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 (let ((before (truncate (float-time)))) (jabber-omemo-store-save-device "me@example.com" "alice@example.com" 42) (let ((ts (plist-get (car (jabber-omemo-store-load-devices "me@example.com" "alice@example.com")) :last-seen))) ;; Bracket the save instead of assuming it takes under N seconds. (should (<= before ts (truncate (float-time)))))))) ;;; 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 (unibyte-string 13 10 0 1 127 200 255))) (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-reset-rolls-back-atomically () "A failed reset preserves both the old session and skipped keys." (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 delete failure")))) (should-error (jabber-omemo-store-delete-session-state "me@example.com" "alice@example.com" 42))) (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-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.15.1/tests/jabber-test-omemo-trust.el000066400000000000000000000315201527111033600222700ustar00rootroot00000000000000;;; 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))))))) ;;; Group 6: session reset (ert-deftest jabber-test-omemo-trust-reset-session-rebuilds-device () "Reset command rebuilds the selected peer device session." (let (called callback messages) (cl-letf (((symbol-function 'jabber-omemo-trust--device-at-point) (lambda () 42)) ((symbol-function 'jabber-connection-active-p) (lambda (jc) (eq jc 'live-jc))) ((symbol-function 'jabber-find-active-connection) (lambda (_jc) 'live-jc)) ((symbol-function 'jabber-omemo--reset-session) (lambda (jc jid did cb) (setq called (list jc jid did) callback cb))) ((symbol-function 'message) (lambda (format-string &rest args) (push (apply #'format format-string args) messages)))) (let ((jabber-omemo-trust--jc 'stale-jc) (jabber-omemo-trust--peer "alice@example.com")) (jabber-omemo-reset-session) (should (equal '(live-jc "alice@example.com" 42) called)) (funcall callback 'fresh-session) (should (equal '("OMEMO: rebuilt session for alice@example.com device 42" "OMEMO: resetting session for alice@example.com device 42") messages)))))) (ert-deftest jabber-test-omemo-trust-reset-session-reports-failure () "Reset command reports a failed asynchronous rebuild." (let (callback messages) (cl-letf (((symbol-function 'jabber-omemo-trust--device-at-point) (lambda () 42)) ((symbol-function 'jabber-connection-active-p) (lambda (_jc) t)) ((symbol-function 'jabber-omemo--reset-session) (lambda (_jc _jid _did cb) (setq callback cb))) ((symbol-function 'message) (lambda (format-string &rest args) (push (apply #'format format-string args) messages)))) (let ((jabber-omemo-trust--jc 'fake-jc) (jabber-omemo-trust--peer "alice@example.com")) (jabber-omemo-reset-session) (funcall callback nil) (should (equal '("OMEMO: could not rebuild session for alice@example.com device 42" "OMEMO: resetting session for alice@example.com device 42") messages)))))) (ert-deftest jabber-test-omemo-trust-reset-session-requires-active-connection () "Reset refuses to delete state when no active connection exists." (let (called) (cl-letf (((symbol-function 'jabber-omemo-trust--device-at-point) (lambda () 42)) ((symbol-function 'jabber-connection-active-p) (lambda (_jc) nil)) ((symbol-function 'jabber-find-active-connection) (lambda (_jc) nil)) ((symbol-function 'jabber-omemo--reset-session) (lambda (&rest _) (setq called t)))) (let ((jabber-omemo-trust--jc 'stale-jc) (jabber-omemo-trust--peer "alice@example.com")) (should-error (jabber-omemo-reset-session) :type 'user-error) (should-not called))))) (ert-deftest jabber-test-omemo-trust-reset-session-key () "The trust mode binds r to session reset." (should (eq #'jabber-omemo-reset-session (keymap-lookup jabber-omemo-trust-mode-map "r")))) (ert-deftest jabber-test-omemo-trust-delete-invalidates-cache () "Deleting a peer device must retire its live session without rebuilding." (let ((jabber-omemo--sessions (make-hash-table :test 'equal)) (jabber-omemo-trust--account "me@example.com") (jabber-omemo-trust--peer "peer@example.com") (jabber-omemo-trust--jc 'fake-jc)) (puthash (jabber-omemo--session-key "me@example.com" "peer@example.com" 7) 'old-session jabber-omemo--sessions) (cl-letf (((symbol-function 'jabber-omemo-trust--device-at-point) (lambda () 7)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_) "me@example.com")) ((symbol-function 'y-or-n-p) (lambda (&rest _) t)) ((symbol-function 'tabulated-list-print) #'ignore) ((symbol-function 'jabber-omemo-store-delete-trust) #'ignore) ((symbol-function 'jabber-omemo-store-delete-session) #'ignore) ((symbol-function 'jabber-omemo-store-load-session) #'ignore)) (jabber-omemo-trust-delete) (should-not (jabber-omemo--get-session 'fake-jc "peer@example.com" 7))))) (ert-deftest jabber-test-omemo-trust-delete-durable-state-and-rollback () "Peer and own-device deletion are atomic across SQLite and the cache." (dolist (own '(nil t)) (dolist (fail-table '(nil "omemo_sessions" "omemo_skipped_keys" "omemo_trust")) (let* ((dir (make-temp-file "jabber-delete-test-" t)) (jabber-db-path (expand-file-name "test.sqlite" dir)) (jabber-db--connection nil) (jabber-omemo--sessions (make-hash-table :test 'equal)) (jabber-omemo-trust--account "me@example.com") (jabber-omemo-trust--peer (if own "me@example.com" "peer@example.com")) (jabber-omemo-trust--jc 'fake-jc) (key (jabber-omemo--session-key jabber-omemo-trust--account jabber-omemo-trust--peer 7)) removed rebuilt) (unwind-protect (progn (jabber-db-ensure-open) (jabber-omemo-store-save-session jabber-omemo-trust--account jabber-omemo-trust--peer 7 "session") (jabber-omemo-store-save-trust jabber-omemo-trust--account jabber-omemo-trust--peer 7 "identity" 2) (sqlite-execute jabber-db--connection "INSERT INTO omemo_skipped_keys (account, jid, device_id, dh_key, message_number, message_key, created_at) VALUES (?, ?, 7, 'dh', 1, 'key', 0)" (list jabber-omemo-trust--account jabber-omemo-trust--peer)) (puthash key 'old-session jabber-omemo--sessions) (puthash "unrelated" 'other-session jabber-omemo--sessions) (when fail-table (sqlite-execute jabber-db--connection (format "CREATE TEMP TRIGGER fail_delete BEFORE DELETE ON %s BEGIN SELECT RAISE(ABORT, 'injected failure'); END" fail-table))) (cl-letf (((symbol-function 'jabber-omemo-trust--device-at-point) (lambda () 7)) ((symbol-function 'jabber-omemo--get-device-id) (lambda (_) 99)) ((symbol-function 'jabber-connection-bare-jid) (lambda (_) jabber-omemo-trust--account)) ((symbol-function 'y-or-n-p) (lambda (&rest _) t)) ((symbol-function 'tabulated-list-print) #'ignore) ((symbol-function 'jabber-omemo--ensure-sessions) (lambda (&rest _) (setq rebuilt t))) ((symbol-function 'jabber-omemo--remove-device) (lambda (&rest _) (setq removed t)))) (if fail-table (should-error (jabber-omemo-trust-delete)) (jabber-omemo-trust-delete)) (should-not rebuilt) (should (eq (and own (not fail-table)) removed)) (should (eq (gethash key jabber-omemo--sessions) (and fail-table 'old-session))) (unless fail-table (should-not (jabber-omemo--get-session 'fake-jc jabber-omemo-trust--peer 7)))) (should (eq 'other-session (gethash "unrelated" jabber-omemo--sessions))) ;; Reopen the real database; TEMP failure triggers are gone. (jabber-db-close) (dolist (table '("omemo_sessions" "omemo_skipped_keys" "omemo_trust")) (should (= (caar (sqlite-select (jabber-db-ensure-open) (format "SELECT COUNT(*) FROM %s" table))) (if fail-table 1 0))))) (jabber-db-close) (delete-directory dir t)))))) (provide 'jabber-test-omemo-trust) ;;; jabber-test-omemo-trust.el ends here emacs-jabber-0.15.1/tests/jabber-test-openpgp-legacy.el000066400000000000000000000044671527111033600227210ustar00rootroot00000000000000;;; 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.15.1/tests/jabber-test-openpgp.el000066400000000000000000000540511527111033600214510ustar00rootroot00000000000000;;; 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 &optional success _failure) (setq ,sent-var stanza) (when success (funcall success))))) ,@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-buffer-connection 'fake-jc) (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)))) ;;; Receive admission with real GnuPG (defun jabber-test-openpgp--gpg (input &rest args) "Run isolated GnuPG with INPUT and ARGS, returning binary output." (with-temp-buffer (set-buffer-multibyte nil) (insert input) (let ((coding-system-for-read 'binary) (coding-system-for-write 'binary)) (unless (zerop (apply #'call-process-region (point-min) (point-max) "gpg" t (list t nil) nil "--homedir" epg-gpg-home-directory "--batch" "--yes" "--no-tty" args)) (error "Fixture GnuPG operation failed"))) (buffer-string))) (defun jabber-test-openpgp--with-keys (function) "Call FUNCTION with disposable sender, recipient and unrelated keys. All GnuPG and EasyPG operations use a private temporary home." (unless (and (executable-find "gpg") (executable-find "gpgconf")) (ert-skip "GnuPG with gpgconf is required")) (let* ((home (make-temp-file "jabber-gpg-" t)) (epg-gpg-home-directory home) (process-environment (copy-sequence process-environment)) (temporary-file-directory home)) (set-file-modes home #o700) (setenv "GNUPGHOME" home) (unwind-protect (progn ;; No configuration, network key retrieval or real user agent. (with-temp-file (expand-file-name "gpg.conf" home) (insert "no-auto-key-retrieve\nauto-key-locate clear\n")) (dolist (uid '("xmpp:alice@example.org" "xmpp:bob@example.org" "Alice ")) (jabber-test-openpgp--gpg "" "--pinentry-mode" "loopback" "--passphrase" "" "--quick-generate-key" uid "ed25519" "sign" "0")) (let* ((ctx (epg-make-context 'OpenPGP)) (alice (car (epg-list-keys ctx "=xmpp:alice@example.org"))) (bob (car (epg-list-keys ctx "=xmpp:bob@example.org"))) (other (car (epg-list-keys ctx "=Alice ")))) (jabber-test-openpgp--gpg "" "--pinentry-mode" "loopback" "--passphrase" "" "--quick-add-key" (jabber-openpgp--key-fingerprint bob) "cv25519" "encr" "0") ;; Sign with a subkey, not the primary fingerprint in the pin. (jabber-test-openpgp--gpg "" "--pinentry-mode" "loopback" "--passphrase" "" "--quick-add-key" (jabber-openpgp--key-fingerprint alice) "ed25519" "sign" "0") (funcall function alice bob other))) (call-process "gpgconf" nil nil nil "--homedir" home "--kill" "all") (delete-directory home t)))) (defun jabber-test-openpgp--cipher (xml recipient &optional signer corrupt) "Encrypt XML for RECIPIENT, optionally using SIGNER and CORRUPT signature." (let* ((bytes (encode-coding-string xml 'utf-8)) (signed (if signer (jabber-test-openpgp--gpg bytes "--compress-algo" "none" "--local-user" (jabber-openpgp--key-fingerprint signer) "--sign") bytes)) (packet (if corrupt ;; Alter only literal XML, leaving its signature intact. (replace-regexp-in-string "secret body" "forged body" signed t t) signed))) (apply #'jabber-test-openpgp--gpg packet (append (when signer '("--no-literal")) (list "--trust-model" "always" "--recipient" (jabber-openpgp--key-fingerprint recipient) "--encrypt"))))) (defun jabber-test-openpgp--envelope (&optional kind) "Return a fresh valid envelope of KIND, defaulting to signcrypt." (copy-tree `(,(or kind 'signcrypt) ((xmlns . ,jabber-openpgp-xmlns)) (to ((jid . "bob@example.org"))) (time ((stamp . "2026-09-26T10:00:00Z"))) (payload () (body ((xmlns . "jabber:client")) "secret body"))))) (defun jabber-test-openpgp--receive (cipher &optional reject from to) "Receive CIPHER from FROM to TO; expect refusal when REJECT is non-nil." (let* ((element `(openpgp ((xmlns . ,jabber-openpgp-xmlns)) ,(base64-encode-string cipher t))) (stanza (copy-tree `(message ((from . ,(or from "alice@example.org/phone")) (to . ,(or to "bob@example.org/laptop"))) (body () "fallback") ,element))) (before (copy-tree stanza))) (if reject (progn (should-error (jabber-openpgp--decrypt-stanza nil stanza element)) (should (equal stanza before)) ;; The real chat refusal boundary must not publish plaintext either. (jabber-chat--try-decrypt nil stanza element '(:decrypt jabber-openpgp--decrypt-stanza :error-label "OpenPGP")) (should (equal (caddr (car (jabber-xml-get-children stanza 'body))) "[OpenPGP: could not decrypt]"))) (jabber-openpgp--decrypt-stanza nil stanza element) (should (equal (caddr (car (jabber-xml-get-children stanza 'body))) "secret body"))))) (ert-deftest jabber-test-openpgp-real-signatures () "Require a valid sender signature and exact XMPP UID, including subkeys." (jabber-test-openpgp--with-keys (lambda (alice bob other) (let* ((jabber-openpgp-key-alist `(("alice@example.org" . ,(jabber-openpgp--key-fingerprint alice)))) (xml (jabber-sexp2xml (jabber-test-openpgp--envelope)))) (jabber-test-openpgp--receive (jabber-test-openpgp--cipher xml bob alice)) (jabber-test-openpgp--receive (jabber-test-openpgp--cipher xml bob) t) (jabber-test-openpgp--receive (jabber-test-openpgp--cipher xml bob alice t) t) (jabber-test-openpgp--receive (jabber-test-openpgp--cipher xml bob other) t) ;; A configured key is not an exemption from the XMPP UID requirement. (let ((jabber-openpgp-key-alist `(("alice@example.org" . ,(jabber-openpgp--key-fingerprint other))))) (jabber-test-openpgp--receive (jabber-test-openpgp--cipher xml bob other) t)) (let ((jabber-openpgp-key-alist nil)) (jabber-test-openpgp--receive (jabber-test-openpgp--cipher xml bob alice))) ;; Ephemeral key lookup cannot turn a sender mismatch into authentication. (jabber-test-openpgp--receive (jabber-test-openpgp--cipher xml bob alice) t "mallory@example.org") ;; A second key claiming the same UID cannot bypass the configured pin. (jabber-test-openpgp--gpg "" "--quick-add-uid" (jabber-openpgp--key-fingerprint other) "xmpp:alice@example.org") (jabber-test-openpgp--receive (jabber-test-openpgp--cipher xml bob other) t) (let ((jabber-openpgp-key-alist `(("alice@example.org" . ,(jabber-openpgp--key-fingerprint other))))) (jabber-test-openpgp--receive (jabber-test-openpgp--cipher xml bob other)) (jabber-test-openpgp--gpg "" "--quick-revoke-uid" (jabber-openpgp--key-fingerprint other) "xmpp:alice@example.org") (jabber-test-openpgp--receive (jabber-test-openpgp--cipher xml bob other) t)) (jabber-test-openpgp--gpg "" "--quick-add-uid" (jabber-openpgp--key-fingerprint other) "xmpp:άλικη@example.org") (let ((jabber-openpgp-key-alist `(("άλικη@example.org" . ,(jabber-openpgp--key-fingerprint other))))) (jabber-test-openpgp--receive (jabber-test-openpgp--cipher xml bob other) nil "άλικη@example.org/phone")))))) (ert-deftest jabber-test-openpgp-real-epg-evidence () "Prove EasyPG decrypts bad signatures and reports signing subkeys." (jabber-test-openpgp--with-keys (lambda (alice bob _other) (let ((xml (jabber-sexp2xml (jabber-test-openpgp--envelope)))) (dolist (kind '(good bad unsigned)) (let* ((cipher (jabber-test-openpgp--cipher xml bob (unless (eq kind 'unsigned) alice) (eq kind 'bad))) (context (epg-make-context 'OpenPGP)) (plain (epg-decrypt-string context cipher)) (signatures (epg-context-result-for context 'verify))) (should (string-match-p (if (eq kind 'bad) "forged body" "secret body") plain)) (should (epg-context-result-for context 'decryption-okay)) (if (eq kind 'unsigned) (should-not signatures) (should (= (length signatures) 1)) (should (eq (epg-signature-status (car signatures)) kind)) (when (eq kind 'good) (should-not (equal (epg-signature-fingerprint (car signatures)) (jabber-openpgp--key-fingerprint alice))))))) ;; No public signing key: decryption still succeeds, verification does not. (let ((cipher (jabber-test-openpgp--cipher xml bob alice)) (context (epg-make-context 'OpenPGP))) (jabber-test-openpgp--gpg "" "--delete-secret-and-public-key" (jabber-openpgp--key-fingerprint alice)) (should (string-match-p "secret body" (epg-decrypt-string context cipher))) (should-not (eq (epg-signature-status (car (epg-context-result-for context 'verify))) 'good)) (jabber-test-openpgp--receive cipher t)))))) (ert-deftest jabber-test-openpgp-real-envelope () "Reject malformed signed envelopes before publishing their plaintext." (jabber-test-openpgp--with-keys (lambda (alice bob _other) (let ((jabber-openpgp-key-alist `(("alice@example.org" . ,(jabber-openpgp--key-fingerprint alice))))) (dolist (change (list (lambda (xml) (setcdr (assq 'xmlns (cadr xml)) "wrong:ns")) (lambda (xml) (setcdr (assq 'jid (cadr (nth 2 xml))) "other@example.org")) (lambda (xml) (setcdr (assq 'jid (cadr (nth 2 xml))) "bob@example.org/elsewhere")) (lambda (xml) (setcdr (assq 'stamp (cadr (nth 3 xml))) "")) (lambda (xml) (setcdr (assq 'stamp (cadr (nth 3 xml))) "2026-02-31T10:00:00Z")) (lambda (xml) (setcdr (assq 'stamp (cadr (nth 3 xml))) "2026-09-26T99:00:00Z")) (lambda (xml) (setcar (nthcdr 3 xml) '(unrelated ()))) (lambda (xml) (nconc xml (list (copy-tree (nth 3 xml))))) (lambda (xml) (setcar (nthcdr 4 xml) '(unrelated ()))) (lambda (xml) (nconc xml (list (copy-tree (nth 4 xml))))) (lambda (xml) (setcar (nthcdr 2 xml) '(unrelated ()))) (lambda (xml) (setcar (cdr (nth 4 xml)) '((xmlns . "wrong:ns")))))) (let ((xml (jabber-test-openpgp--envelope))) (funcall change xml) (jabber-test-openpgp--receive (jabber-test-openpgp--cipher (jabber-sexp2xml xml) bob alice) t))) (jabber-test-openpgp--receive (jabber-test-openpgp--cipher (concat (jabber-sexp2xml (jabber-test-openpgp--envelope)) (jabber-sexp2xml (jabber-test-openpgp--envelope))) bob alice) t) ;; Namespace prefixes, fractional seconds and numeric zones are legal. (jabber-test-openpgp--receive (jabber-test-openpgp--cipher "secret body" bob alice)))))) (ert-deftest jabber-test-openpgp-real-crypt () "Preserve unsigned crypt, whose recipient list is optional." (jabber-test-openpgp--with-keys (lambda (alice bob _other) (let* ((xml (jabber-test-openpgp--envelope 'crypt)) (text (jabber-sexp2xml xml))) (jabber-test-openpgp--receive (jabber-test-openpgp--cipher text bob)) (jabber-test-openpgp--receive (jabber-test-openpgp--cipher text bob alice) t) (setcdr (cdr xml) (cdddr xml)) (jabber-test-openpgp--receive (jabber-test-openpgp--cipher (jabber-sexp2xml xml) bob)))))) (provide 'jabber-test-openpgp) ;;; jabber-test-openpgp.el ends here emacs-jabber-0.15.1/tests/jabber-test-presence.el000066400000000000000000000372221527111033600216060ustar00rootroot00000000000000;;; 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 :sm-recovered-queue '(stanza))) (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))) (should (null (plist-get result :sm-recovered-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))))) (ert-deftest jabber-test-sm-stall-reports-exact-virtual-transport () "A non-process stall reports the exact transport to the FSM." (let* ((connection (make-symbol "virtual-transport")) (state-data (list :connection connection :sm-outbound-queue '((1 . first)))) sent) (cl-letf (((symbol-function 'processp) (lambda (_) nil)) ((symbol-function 'fsm-send) (lambda (jc event) (setq sent (list jc event))))) (jabber-sm--recover-stall 'fake-jc state-data)) (should (equal sent (list 'fake-jc (list :connection-dead connection "Stream Management acknowledgement timeout")))))) ;;; 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 moves unacked stanzas into recovered wire order." (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-id "abc" :sm-outbound-count 3 :sm-outbound-queue (list (cons 1 msg-a) (cons 2 msg-b) (cons 3 msg-c)) :sm-recovered-queue nil :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 result :sm-last-acked) 1)) (should (= (plist-get result :sm-outbound-count) 1)) (should (null (plist-get result :sm-outbound-queue))) (should (eq (plist-get result :sm-resumed) t)) (should-not (plist-get result :sm-resuming)) (should (equal (plist-get result :sm-recovered-queue) (list msg-b 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-id "abc" :sm-outbound-count 2 :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 . "2") (previd . "abc")))) (result (jabber-sm--handle-resumed sd resumed))) (should (null (plist-get result :sm-recovered-queue))))) (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-id "s1" :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)) (to-resend (plist-get result :sm-recovered-queue))) ;; Counter must reset to server's h so resent stanzas start from 8 (should (= (plist-get result :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 result)) (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-resumed-prepends-new-recovery () "Newly unacked occurrences precede older unsent recovered work." (let* ((old-a (list 'message '((id . "same")))) (old-b (list 'message '((id . "same")))) (unsent (list 'presence '((id . "later")))) (pending (list (cons 0 '(message ((id . "pending")))))) (outbound (list (cons 4 old-a) (cons 5 old-b))) (sd (list :sm-enabled t :sm-id "s1" :sm-outbound-count 5 :sm-last-acked 3 :sm-outbound-queue outbound :sm-recovered-queue (list unsent) :sm-pending-queue pending :sm-resuming t)) (result (jabber-sm--handle-resumed sd '(resumed ((h . "3") (previd . "s1")))))) (should (equal (plist-get result :sm-recovered-queue) (list old-a old-b unsent))) (should (eq (nth 0 (plist-get result :sm-recovered-queue)) old-a)) (should (eq (nth 1 (plist-get result :sm-recovered-queue)) old-b)) (should (eq (plist-get result :sm-pending-queue) pending)) (should (eq (plist-get sd :sm-outbound-queue) outbound)) (should (= 5 (plist-get sd :sm-outbound-count))) (should (= 3 (plist-get sd :sm-last-acked))) (should-not (plist-get sd :sm-resumed)))) (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 (make-symbol "failed-resume")) (jabber-connections (list fsm)) (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) (put fsm :state :sm-resume) (put fsm :state-data state-data) (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-schedules-pending-drain () "A newly established session schedules rather than runs its drain inline." (let* ((msg '(message ((to . "a@x")) (body () "pending"))) (jc (make-symbol "new-session-drain")) (state-data (plist-put (jabber-sm--reset nil) :connection 'transport)) (enter (gethash :session-established (get 'jabber-connection :fsm-enter))) (jabber-connections (list jc)) scheduled) (setq state-data (plist-put state-data :sm-pending-queue (list (cons 0 msg)))) (jabber-test-sm--install-drain-state jc state-data) (cl-letf (((symbol-function 'jabber-lifecycle-dispatch-session-bootstrap) #'ignore) ((symbol-function 'jabber-sm--schedule-drain) (lambda (scheduled-jc scheduled-data) (setq scheduled (list scheduled-jc scheduled-data)))) ((symbol-function 'jabber-send-sexp--raw) (lambda (&rest _) (error "inline drain")))) (pcase-let ((`(,result nil) (funcall enter jc state-data))) (should (eq (car scheduled) jc)) (should (eq (cadr scheduled) result)) (should (= 1 (length (plist-get result :sm-pending-queue)))))))) (ert-deftest jabber-test-sm-ack-schedules-pending-drain () "An acknowledgement schedules its pending drain after handler return." (let* ((jc (make-symbol "ack-drain")) (state-data (list :connection 'transport :sm-enabled t :sm-outbound-count 1 :sm-last-acked 0 :sm-outbound-queue '((1 . sent)) :sm-pending-queue '((0 . pending)))) (handler (gethash :session-established (get 'jabber-connection :fsm-event))) scheduled) (cl-letf (((symbol-function 'jabber-sm--schedule-drain) (lambda (scheduled-jc scheduled-data) (setq scheduled (list scheduled-jc scheduled-data)))) ((symbol-function 'jabber-send-sexp--raw) (lambda (&rest _) (error "inline drain")))) (pcase-let ((`(:session-established ,result :keep) (funcall handler jc state-data `(:stanza (a ((xmlns . ,jabber-sm-xmlns) (h . "1")))) #'ignore))) (should (eq (car scheduled) jc)) (should (eq (cadr scheduled) result)) (should (= 1 (length (plist-get result :sm-pending-queue)))))))) (ert-deftest jabber-test-sm-resume-schedules-recovered-drain () "A resumed FSM enters the session before scheduling recovered work." (let* ((jc (make-symbol "resume-drain")) (msg '(message ((id . "unacked")))) (state-data (list :connection 'transport :sm-enabled t :sm-id "s1" :sm-outbound-count 1 :sm-last-acked 0 :sm-outbound-queue (list (cons 1 msg)) :sm-recovered-queue nil :sm-pending-queue nil :sm-resuming t)) (jabber-connections (list jc)) (jabber-post-resume-hooks nil) scheduled) (put jc :name 'jabber-connection) (put jc :state :sm-resume) (put jc :state-data state-data) (cl-letf (((symbol-function 'jabber-sm--start-r-timer) (lambda (_jc data) data)) ((symbol-function 'jabber-sm--schedule-drain) (lambda (scheduled-jc scheduled-data) (setq scheduled (list scheduled-jc scheduled-data)))) ((symbol-function 'jabber-send-sexp--raw) (lambda (&rest _) (error "inline replay")))) (fsm-send-sync jc `(:stanza (resumed ((xmlns . ,jabber-sm-xmlns) (h . "0") (previd . "s1"))))) (should (eq (get jc :state) :session-established)) (should (eq (car scheduled) jc)) (should (eq (cadr scheduled) (fsm-get-state-data jc))) (should (eq (car (plist-get (fsm-get-state-data jc) :sm-recovered-queue)) msg))))) (ert-deftest jabber-test-sm-resume-hook-sends-follow-recovered-work () "New countable sends from resume hooks cannot overtake recovered wire order." (dolist (cap '(nil 1 40)) (let* ((jabber-sm-max-in-flight cap) (jc (make-symbol "resume-order")) (old '(presence ((id . "old")))) (new '(message ((id . "new")))) (iq '(iq ((id . "new-iq") (type . "get")))) (control '(r ((xmlns . "urn:xmpp:sm:3")))) sent scheduled (state-data (list :connection 'transport :sm-enabled t :sm-id "s1" :sm-outbound-count 1 :sm-last-acked 0 :sm-outbound-queue (list (cons 1 old)) :sm-recovered-queue nil :sm-pending-queue nil :send-function (lambda (_transport xml) (push xml sent)) :sm-resuming t)) (jabber-connections (list jc)) (jabber-post-resume-hooks (list (lambda (fsm) (jabber-send-sexp fsm new) (jabber-send-sexp fsm iq) (jabber-send-sexp fsm control))))) (put jc :name 'jabber-connection) (put jc :state :sm-resume) (put jc :state-data state-data) (cl-letf (((symbol-function 'jabber-sm--start-r-timer) (lambda (_jc data) data)) ((symbol-function 'jabber-sm--schedule-drain) (lambda (_jc data) (setq scheduled data)))) (fsm-send-sync jc `(:stanza (resumed ((xmlns . ,jabber-sm-xmlns) (h . "0") (previd . "s1")))))) (should (eq (get jc :state) :session-established)) (should (equal sent (list (jabber-sexp2xml control)))) (should (equal (mapcar #'jabber-sm--pending-stanza (plist-get scheduled :sm-pending-queue)) (list new iq))) (jabber-sm--drain-pending jc scheduled) (should (equal (cadr (reverse sent)) (concat (jabber-sexp2xml old) (jabber-sm--make-request-xml)))) (if (eql cap 1) (should (= (length sent) 2)) (should (= (length sent) 4)))))) (ert-deftest jabber-test-sm-raw-send-revalidates-handoff-owner () "Logging and serialization cannot redirect a stale stanza to a successor." (dolist (boundary '(logging serialization)) (dolist (replacement '(state transport sender)) (let* ((jc (make-symbol "handoff-owner")) (old (make-symbol "old-transport")) (new (make-symbol "new-transport")) sent (sender (lambda (transport xml) (push (list transport xml) sent))) (sd (list :connection old :send-function sender)) (replace-owner (lambda () (pcase replacement ('state (put jc :state-data (copy-sequence sd))) ('transport (plist-put sd :connection new)) ('sender (plist-put sd :send-function #'ignore))))) (jabber-debug-log-xml t) (jabber-stanza-log-function (lambda (&rest _) (when (eq boundary 'logging) (funcall replace-owner)))) (serialize (symbol-function 'jabber-sexp2xml))) (put jc :state-data sd) (cl-letf (((symbol-function 'jabber-sexp2xml) (lambda (sexp) (when (eq boundary 'serialization) (funcall replace-owner)) (funcall serialize sexp)))) (should-error (jabber-send-sexp--raw jc '(message ((id . "old")))))) (should-not sent))))) (ert-deftest jabber-test-sm-drain-logger-cannot-write-or-recover-successor () "A logger replacing the transport leaves queued work and the successor alone." (dolist (replace-state '(nil t)) (let* ((jc (make-symbol "drain-logger")) (jabber-connections (list jc)) (old (make-symbol "old-transport")) (new (make-symbol "new-transport")) (stanza '(message ((id . "retained")))) writes recovery (sd (list :connection old :sm-enabled t :sm-outbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-recovered-queue (list stanza) :sm-pending-queue nil :send-function (lambda (&rest args) (push args writes)))) (jabber-debug-log-xml t) (jabber-stanza-log-function (lambda (&rest _) (let ((current (fsm-get-state-data jc))) (when replace-state (setq current (copy-sequence current)) (put jc :state-data current)) (plist-put current :connection new))))) (jabber-test-sm--install-drain-state jc sd) (cl-letf (((symbol-function 'fsm-send) (lambda (&rest args) (push args recovery)))) (jabber-sm--drain-pending jc sd)) (should-not writes) (should-not recovery) (should (eq (plist-get (fsm-get-state-data jc) :connection) new)) (should (equal (plist-get (fsm-get-state-data jc) :sm-recovered-queue) (list stanza))) (should (= (plist-get (fsm-get-state-data jc) :sm-outbound-count) 0))))) (ert-deftest jabber-test-sm-drain-handoff-failure-requests-recovery () "Every failed replay position retains its tail and requests transport recovery." (dolist (fail-at '(1 2 3)) (let* ((jc (make-symbol "replay-failure")) (jabber-connections (list jc)) (jabber-auto-reconnect t) (jabber-lost-connection-hooks nil) (jabber-lifecycle-connection-list-changed-functions nil) (jabber-lifecycle-session-reset-functions nil) (stanzas '((message ((id . "one"))) (message ((id . "two"))) (presence ((id . "three"))))) (attempts 0) recovery (sd (list :username "user" :server "example.org" :resource "emacs" :ever-session-established t :connection 'transport :sm-enabled t :sm-id "s1" :sm-resume-allowed t :sm-outbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-recovered-queue stanzas :sm-pending-queue nil :send-function (lambda (_transport _xml) (when (= (cl-incf attempts) fail-at) (error "Transport failed")))))) (jabber-test-sm--install-drain-state jc sd) (cl-letf (((symbol-function 'fsm-send) (lambda (fsm event &optional _callback) (setq recovery (list fsm event))))) (jabber-sm--drain-pending jc sd)) (setq sd (fsm-get-state-data jc)) (should (= (plist-get sd :sm-outbound-count) (1- fail-at))) (should (equal (plist-get sd :sm-recovered-queue) (nthcdr (1- fail-at) stanzas))) (should (eq (car recovery) jc)) (should (equal (seq-take (cadr recovery) 2) '(:connection-dead transport))) (unwind-protect (progn (apply #'fsm-send-sync recovery) (should-not (get jc :state)) (should (plist-get (fsm-get-state-data jc) :sm-resuming)) (should (timerp (get jc :timeout))) (should-not (plist-get (fsm-get-state-data jc) :disconnection-expected)) (should (equal (plist-get (fsm-get-state-data jc) :sm-recovered-queue) (nthcdr (1- fail-at) stanzas)))) (fsm-stop-timer jc))))) (ert-deftest jabber-test-sm-session-entry-reentry-preserves-terminal-state () "A resume hook disconnect cannot be overwritten or schedule a stale drain." (let* ((jc (make-symbol "session-enter-disconnect")) (jabber-auto-reconnect nil) (jabber-connections (list jc)) (jabber-lost-connection-hooks nil) (jabber-lifecycle-session-reset-functions nil) (jabber-lifecycle-connection-list-changed-functions nil) scheduled close-writes (state-data (list :username "user" :server "example.org" :resource "emacs" :ever-session-established t :connection 'transport :send-function (lambda (_transport string) (push string close-writes)) :sm-enabled t :sm-id "s1" :sm-resumed t :sm-outbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-recovered-queue nil :sm-pending-queue nil)) (jabber-post-resume-hooks (list (lambda (_fsm) (fsm-send-sync jc :do-disconnect))))) (put jc :name 'jabber-connection) (put jc :state :sm-resume) (put jc :state-data state-data) (cl-letf (((symbol-function 'jabber-sm--start-r-timer) (lambda (_jc data) data)) ((symbol-function 'jabber-sm--schedule-drain) (lambda (&rest args) (setq scheduled args)))) (fsm-update jc :session-established state-data nil)) (should (equal close-writes '(""))) (should-not scheduled) (should-not (get jc :state)) (should (plist-get (fsm-get-state-data jc) :terminalized)) (should-not (memq jc jabber-connections)))) (ert-deftest jabber-test-sm-session-entry-contains-hook-conditions () "Session hooks cannot abort later hooks or the scheduled drain." (dolist (branch '(resume bootstrap)) (dolist (condition '(error quit)) (let* ((jc (make-symbol "session-hook-condition")) (jabber-connections (list jc)) (later 0) (scheduled 0) escaped result (callbacks (list (lambda (_fsm) (signal condition nil)) (lambda (_fsm) (cl-incf later)))) (jabber-post-resume-hooks (and (eq branch 'resume) callbacks)) (jabber-lifecycle-session-bootstrap-functions (and (eq branch 'bootstrap) callbacks)) (state-data (list :connection 'transport :sm-enabled nil :sm-resumed (eq branch 'resume) :sm-pending-queue '((0 . pending))))) (jabber-test-sm--install-drain-state jc state-data) (cl-letf (((symbol-function 'jabber-sm--schedule-drain) (lambda (_jc _state-data) (cl-incf scheduled)))) (setq escaped (condition-case nil (progn (setq result (funcall (gethash :session-established (get 'jabber-connection :fsm-enter)) jc state-data)) nil) ((error quit) t)))) (should-not escaped) (should (= later 1)) (should (= scheduled 1)) (should (plist-get (car result) :ever-session-established)))))) ;;; 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 "10" (when enabled (jabber-sm--make-request-xml)))))) (should (= (plist-get (fsm-get-state-data jc) :sm-outbound-count) (if enabled 1 0)))))) (ert-deftest jabber-test-sm-enqueue-pending () "Enqueue appends to pending queue as (priority . sexp) pairs." (let* ((sd (list :sm-pending-queue nil)) (msg1 '(message ((to . "a@b")) (body () "1"))) (msg2 '(message ((to . "a@b")) (body () "2")))) (setq sd (jabber-sm--enqueue-pending sd msg1)) (setq sd (jabber-sm--enqueue-pending sd msg2)) (should (= (length (plist-get sd :sm-pending-queue)) 2)) (should (equal (cdar (plist-get sd :sm-pending-queue)) msg1)) (should (equal (cdadr (plist-get sd :sm-pending-queue)) msg2)) ;; Both are messages, priority 0 (should (= (caar (plist-get sd :sm-pending-queue)) 0)) (should (= (caadr (plist-get sd :sm-pending-queue)) 0)))) (defun jabber-test-sm--install-drain-state (jc state-data) "Install STATE-DATA as an active session owned by JC." (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state-data)) (ert-deftest jabber-test-sm-schedule-drain-is-top-level () "Drain scheduling captures exact lease arguments on a zero timer." (let ((jc (make-symbol "scheduled-drain")) (state-data (list :lease t)) call) (cl-letf (((symbol-function 'run-at-time) (lambda (seconds repeat function &rest arguments) (setq call (list seconds repeat function arguments)) 'timer))) (should (eq (jabber-sm--schedule-drain jc state-data) 'timer))) (should (equal (car call) 0)) (should-not (cadr call)) (should (eq (nth 2 call) #'jabber-sm--drain-pending)) (should (eq (car (nth 3 call)) jc)) (should (eq (cadr (nth 3 call)) state-data)))) (ert-deftest jabber-test-sm-drain-pending-partial () "Drain sends stanzas up to the cap, leaving the rest queued." (let* ((jabber-sm-max-in-flight 2) (msg1 '(message ((to . "a@b")) (body () "1"))) (msg2 '(message ((to . "a@b")) (body () "2"))) (msg3 '(message ((to . "a@b")) (body () "3"))) (sd (list :sm-enabled t :connection 'transport :sm-outbound-count 0 :sm-inbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-pending-queue (list (cons 0 msg1) (cons 0 msg2) (cons 0 msg3)))) (sent nil) (jc (make-symbol "drain-partial")) (jabber-connections (list jc))) (jabber-test-sm--install-drain-state jc sd) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc sexp) (push sexp sent)))) (jabber-sm--drain-pending jc sd)) (setq sd (fsm-get-state-data jc)) (should (= (length sent) 2)) (should (= (length (plist-get sd :sm-pending-queue)) 1)) (should (equal (cdar (plist-get sd :sm-pending-queue)) msg3)) (should (= (plist-get sd :sm-outbound-count) 2)))) (ert-deftest jabber-test-sm-drain-pending-counts-once () "Draining counts each transmitted stanza exactly once." (let* ((jabber-sm-max-in-flight 2) (existing '(message ((to . "old@b")))) (msg '(message ((to . "a@b")) (body () "1"))) (outbound (list (cons 10 existing))) (sd (list :sm-enabled t :connection 'transport :sm-outbound-count 10 :sm-last-acked 9 :sm-outbound-queue outbound :sm-pending-queue (list (cons 0 msg)))) (sent nil) (jc (make-symbol "drain-once")) (jabber-connections (list jc))) (jabber-test-sm--install-drain-state jc sd) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc sexp) (push sexp sent)))) (jabber-sm--drain-pending jc sd)) (setq sd (fsm-get-state-data jc)) (should (equal sent (list msg))) (should (= (plist-get sd :sm-outbound-count) 11)) (should (= (length (plist-get sd :sm-outbound-queue)) 2)) (should (= (caadr (plist-get sd :sm-outbound-queue)) 11)) (should (= (length outbound) 1)) (should (eq (cdar outbound) existing)) (should (null (plist-get sd :sm-pending-queue))))) (ert-deftest jabber-test-sm-drain-pending-empty () "Drain with empty queue is a no-op." (let* ((jabber-sm-max-in-flight 10) (sd (list :sm-enabled t :connection 'transport :sm-outbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-pending-queue nil)) (sent nil) (jc (make-symbol "drain-empty")) (jabber-connections (list jc))) (jabber-test-sm--install-drain-state jc sd) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc sexp) (push sexp sent)))) (jabber-sm--drain-pending jc sd)) (setq sd (fsm-get-state-data jc)) (should (null sent)) (should (null (plist-get sd :sm-pending-queue))))) (ert-deftest jabber-test-sm-reset-clears-pending-queue () "Reset clears the pending queue." (let* ((sd (list :sm-enabled t :sm-pending-queue '((0 . a) (1 . b) (2 . c)))) (result (jabber-sm--reset sd))) (should (null (plist-get result :sm-pending-queue))))) (ert-deftest jabber-test-sm-drain-runs-transport-success-callback () "A queued stanza commits only after queue drain writes it." (let* ((jabber-sm-max-in-flight nil) (successes 0) (failures 0) (msg '(message ((to . "a@b")) (body () "queued"))) (sd (list :sm-enabled t :connection 'transport :sm-outbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-pending-queue nil)) (jc (make-symbol "drain-success")) (jabber-connections (list jc))) (setq sd (jabber-sm--enqueue-pending sd msg (lambda () (cl-incf successes)) (lambda (_reason) (cl-incf failures)))) (jabber-test-sm--install-drain-state jc sd) (should (= 0 successes)) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (&rest _) nil))) (jabber-sm--drain-pending jc sd)) (setq sd (fsm-get-state-data jc)) (should (= 1 successes)) (should (= 0 failures)) (should (null (plist-get sd :sm-pending-queue))))) (ert-deftest jabber-test-sm-drain-write-failure-retains-work () "A failed queue-drain write retains work without settling callbacks." (let* ((jabber-sm-max-in-flight nil) (successes 0) (failures 0) (msg '(message ((to . "a@b")) (body () "queued"))) (sd (list :sm-enabled t :connection 'transport :sm-outbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-pending-queue nil)) (jc (make-symbol "drain-failure")) (jabber-connections (list jc))) (setq sd (jabber-sm--enqueue-pending sd msg (lambda () (cl-incf successes)) (lambda (_reason) (cl-incf failures)))) (jabber-test-sm--install-drain-state jc sd) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (&rest _) (error "transport failed")))) (jabber-sm--drain-pending jc sd)) (setq sd (fsm-get-state-data jc)) (should (= 0 successes)) (should (= 0 failures)) (should (= 0 (plist-get sd :sm-outbound-count))) (should (= 1 (length (plist-get sd :sm-pending-queue)))))) (ert-deftest jabber-test-sm-drain-write-condition-retries-losslessly () "An error or quit leaves both drain partitions available for retry." (dolist (condition '(error quit)) (let* ((jabber-sm-max-in-flight nil) (successes 0) (recovered (list 'presence `((id . ,(symbol-name condition))))) (pending-stanza (list 'message '((id . "pending")))) (pending-entry (list :priority 0 :stanza pending-stanza :success (lambda () (cl-incf successes)))) (sd (list :sm-enabled t :connection 'transport :sm-outbound-count 7 :sm-last-acked 7 :sm-outbound-queue nil :sm-recovered-queue (list recovered) :sm-pending-queue (list pending-entry))) (jc (make-symbol "drain-retry")) (jabber-connections (list jc)) (attempt 0) sent) (jabber-test-sm--install-drain-state jc sd) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc stanza) (cl-incf attempt) (if (= attempt 1) (signal condition nil) (push stanza sent)))) ((symbol-function 'message) #'ignore)) (should-not (condition-case nil (progn (jabber-sm--drain-pending jc sd) nil) (quit t))) (setq sd (fsm-get-state-data jc)) (should (= 7 (plist-get sd :sm-outbound-count))) (should-not (plist-get sd :sm-outbound-queue)) (should (eq (car (plist-get sd :sm-recovered-queue)) recovered)) (should (eq (car (plist-get sd :sm-pending-queue)) pending-entry)) (should (= 0 successes)) (jabber-sm--drain-pending jc sd)) (setq sd (fsm-get-state-data jc)) (should (equal (nreverse sent) (list recovered pending-stanza))) (should (= 1 successes)) (should (= 9 (plist-get sd :sm-outbound-count))) (should-not (plist-get sd :sm-recovered-queue)) (should-not (plist-get sd :sm-pending-queue))))) (ert-deftest jabber-test-sm-drain-recovered-before-ordinary-priority () "Recovered wire order precedes stable ordinary priority order." (let* ((jabber-sm-max-in-flight nil) (recovered-a (list 'presence '((id . "same")))) (recovered-b (list 'presence '((id . "same")))) (ordinary-presence '(presence ((id . "ordinary-presence")))) (ordinary-message-a (list 'message '((id . "ordinary-message")))) (ordinary-message-b (list 'message '((id . "ordinary-message")))) (sd (list :sm-enabled t :connection 'transport :sm-outbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-recovered-queue (list recovered-a recovered-b) :sm-pending-queue (list (cons 2 ordinary-presence) (cons 0 ordinary-message-a) (cons 0 ordinary-message-b)))) (jc (make-symbol "drain-order")) (jabber-connections (list jc)) sent) (jabber-test-sm--install-drain-state jc sd) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc stanza) (push stanza sent)))) (jabber-sm--drain-pending jc sd)) (setq sent (nreverse sent)) (should (equal sent (list recovered-a recovered-b ordinary-message-a ordinary-message-b ordinary-presence))) (should (eq (nth 0 sent) recovered-a)) (should (eq (nth 1 sent) recovered-b)) (should (eq (nth 2 sent) ordinary-message-a)) (should (eq (nth 3 sent) ordinary-message-b)))) (ert-deftest jabber-test-sm-drain-recovered-bypasses-ordinary-cap () "All recovered work replays before the in-flight cap blocks pending work." (let* ((jabber-sm-max-in-flight 1) (first '(message ((id . "recovered-1")))) (second '(message ((id . "recovered-2")))) (pending '(message ((id . "pending")))) (sd (list :connection 'transport :sm-enabled t :sm-outbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-recovered-queue (list first second) :sm-pending-queue (list (cons 0 pending)))) (jc (make-symbol "recovered-cap")) (jabber-connections (list jc)) sent) (jabber-test-sm--install-drain-state jc sd) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc stanza) (push stanza sent)))) (jabber-sm--drain-pending jc sd)) (setq sd (fsm-get-state-data jc)) (should (equal (nreverse sent) (list first second))) (should (= 2 (plist-get sd :sm-outbound-count))) (should-not (plist-get sd :sm-recovered-queue)) (should (equal (mapcar #'jabber-sm--pending-stanza (plist-get sd :sm-pending-queue)) (list pending))))) (ert-deftest jabber-test-sm-drain-publishes-before-disconnecting-callback () "A success callback sees its commit and cannot let the drain resurrect JC." (let* ((jabber-sm-max-in-flight nil) (jc (make-symbol "drain-disconnect")) (jabber-auto-reconnect nil) (jabber-connections (list jc)) (jabber-lost-connection-hooks nil) (jabber-lifecycle-session-reset-functions nil) (jabber-lifecycle-connection-list-changed-functions nil) (first '(message ((id . "first")))) (second '(message ((id . "second")))) (successes 0) (second-successes 0) (second-failures 0) observed sent close-writes (sd (list :username "user" :server "example.org" :resource "emacs" :ever-session-established t :sm-enabled t :sm-id "sm" :connection 'transport :send-function (lambda (_transport string) (push string close-writes)) :sm-outbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-recovered-queue nil :sm-pending-queue nil))) (setq sd (jabber-sm--enqueue-pending sd first (lambda () (let ((current (fsm-get-state-data jc))) (setq observed (list (plist-get current :sm-outbound-count) (length (plist-get current :sm-outbound-queue)) (length (plist-get current :sm-pending-queue))))) (cl-incf successes) (fsm-send-sync jc :do-disconnect)) nil)) (setq sd (jabber-sm--enqueue-pending sd second (lambda () (cl-incf second-successes)) (lambda (_reason) (cl-incf second-failures)))) (jabber-test-sm--install-drain-state jc sd) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc stanza) (push stanza sent)))) (jabber-sm--drain-pending jc sd)) (should (equal observed '(1 1 1))) (should (= 1 successes)) (should (= 0 second-successes)) (should (= 1 second-failures)) (should (equal sent (list first))) (should (equal close-writes '(""))) (should-not (get jc :state)) (should-not (memq jc jabber-connections)) (should (plist-get (fsm-get-state-data jc) :terminalized)))) (ert-deftest jabber-test-sm-drain-stale-lease-is-inert () "A stale state-data or registration lease cannot send or publish." (dolist (mode '(replaced unregistered)) (let* ((jabber-sm-max-in-flight nil) (jc (make-symbol "stale-drain")) (stanza '(message ((id . "stale")))) (expected (list :connection 'transport :sm-enabled t :sm-outbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-pending-queue (list (cons 0 stanza)))) (replacement (copy-sequence expected)) (jabber-connections (and (eq mode 'replaced) (list jc))) sent) (jabber-test-sm--install-drain-state jc replacement) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc sexp) (push sexp sent)))) (jabber-sm--drain-pending jc expected)) (should-not sent) (should (eq (fsm-get-state-data jc) replacement))))) (ert-deftest jabber-test-sm-drain-send-replacement-is-not-overwritten () "A replacement installed during raw send survives stale completion." (let* ((jabber-sm-max-in-flight nil) (jc (make-symbol "replace-during-send")) (stanza '(message ((id . "old")))) (successes 0) (expected (list :connection 'transport :sm-enabled t :sm-outbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-pending-queue (list (list :priority 0 :stanza stanza :success (lambda () (cl-incf successes)))))) (replacement (list :replacement t :connection 'new-transport)) (jabber-connections (list jc))) (jabber-test-sm--install-drain-state jc expected) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc _stanza) (put jc :state-data replacement)))) (jabber-sm--drain-pending jc expected)) (should (eq (fsm-get-state-data jc) replacement)) (should (= 0 successes)) (should (= 1 (length (plist-get expected :sm-pending-queue)))))) (ert-deftest jabber-test-sm-drain-head-replacement-is-not-committed () "A same-lease queue-head replacement survives stale send completion." (let* ((jabber-sm-max-in-flight nil) (jc (make-symbol "replace-drain-head")) (old-stanza '(message ((id . "old")))) (replacement-stanza '(message ((id . "replacement")))) (old-entry (cons 0 old-stanza)) (replacement-entry (cons 0 replacement-stanza)) (state-data (list :connection 'transport :sm-enabled t :sm-outbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-pending-queue (list old-entry))) (jabber-connections (list jc))) (jabber-test-sm--install-drain-state jc state-data) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc _stanza) (plist-put (fsm-get-state-data jc) :sm-pending-queue (list replacement-entry))))) (jabber-sm--drain-pending jc state-data)) (setq state-data (fsm-get-state-data jc)) (should (eq (car (plist-get state-data :sm-pending-queue)) replacement-entry)) (should (= 0 (plist-get state-data :sm-outbound-count))) (should-not (plist-get state-data :sm-outbound-queue)))) (ert-deftest jabber-test-sm-drain-removes-one-occurrence-after-send () "A send-time equal successor remains queued as a distinct occurrence." (let* ((jabber-sm-max-in-flight 1) (jc (make-symbol "append-during-send")) (stanza '(message ((id . "same")))) (old-entry (cons 0 stanza)) successor (sd (list :connection 'transport :sm-enabled t :sm-outbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-pending-queue (list old-entry))) (jabber-connections (list jc))) (jabber-test-sm--install-drain-state jc sd) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc _stanza) (jabber-sm--enqueue-pending (fsm-get-state-data jc) stanza) (setq successor (car (last (plist-get (fsm-get-state-data jc) :sm-pending-queue))))))) (jabber-sm--drain-pending jc sd)) (setq sd (fsm-get-state-data jc)) (should (= 1 (length (plist-get sd :sm-pending-queue)))) (should (eq (car (plist-get sd :sm-pending-queue)) successor)) (should-not (eq successor old-entry)))) (ert-deftest jabber-test-sm-discard-pending-isolates-failure-callbacks () "Discard runs every failure callback even when one callback errors." (let* ((called nil) (msg '(message ((to . "a@b")) (body () "queued"))) (sd (list :sm-pending-queue nil))) (setq sd (jabber-sm--enqueue-pending sd msg nil (lambda (_reason) (push 'first called) (error "restoration failed")))) (setq sd (jabber-sm--enqueue-pending sd msg nil (lambda (_reason) (push 'second called)))) (setq sd (jabber-sm--discard-pending sd "session reset")) (should (equal called '(second first))) (should (null (plist-get sd :sm-pending-queue))))) (ert-deftest jabber-test-lifecycle-reset-isolates-error-and-quit () "A failing reset hook cannot skip later reset effects." (dolist (condition '(error quit)) (let* ((calls nil) (jabber-lifecycle-session-reset-functions (list (lambda (_jc) (push 'first calls) (signal condition nil)) (lambda (_jc) (push 'second calls))))) (should-not (condition-case nil (progn (jabber-lifecycle-dispatch-session-reset 'fake-jc) nil) ((error quit) t))) (should (equal calls '(second first)))))) (ert-deftest jabber-test-lifecycle-reset-preserves-local-hook-semantics () "Reset dispatch honors local hooks that include global functions." (let ((calls nil) (saved (default-value 'jabber-lifecycle-session-reset-functions))) (unwind-protect (progn (setq-default jabber-lifecycle-session-reset-functions (list (lambda (_jc) (push 'global calls)))) (with-temp-buffer (setq-local jabber-lifecycle-session-reset-functions (list (lambda (_jc) (push 'local calls)) t)) (jabber-lifecycle-dispatch-session-reset 'fake-jc)) (should (equal calls '(global local)))) (setq-default jabber-lifecycle-session-reset-functions saved)))) (ert-deftest jabber-test-sm-drain-isolates-success-callback-quit () "A quitting success callback cannot skip later queued work." (let* ((jabber-sm-max-in-flight nil) (sent nil) (later 0) (first '(message ((to . "first@example.org")))) (second '(message ((to . "second@example.org")))) (sd (plist-put (jabber-sm--reset nil) :connection 'transport)) (jc (make-symbol "drain-callback-quit")) (jabber-connections (list jc))) (setq sd (jabber-sm--enqueue-pending sd first (lambda () (signal 'quit nil)) nil)) (setq sd (jabber-sm--enqueue-pending sd second (lambda () (cl-incf later)) nil)) (jabber-test-sm--install-drain-state jc sd) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc stanza) (push stanza sent)))) (should-not (condition-case nil (progn (jabber-sm--drain-pending jc sd) nil) (quit t)))) (setq sd (fsm-get-state-data jc)) (should (= later 1)) (should (equal (nreverse sent) (list first second))) (should-not (plist-get sd :sm-pending-queue)))) (ert-deftest jabber-test-sm-discard-isolates-failure-callback-quit () "A quitting failure callback cannot skip later settlements." (let* ((later 0) (msg '(message ((to . "a@example.org")))) (sd (jabber-sm--reset nil))) (setq sd (jabber-sm--enqueue-pending sd msg nil (lambda (_reason) (signal 'quit nil)))) (setq sd (jabber-sm--enqueue-pending sd msg nil (lambda (_reason) (cl-incf later)))) (should-not (condition-case nil (progn (setq sd (jabber-sm--discard-pending sd "terminal")) nil) (quit t))) (should (= later 1)) (should-not (plist-get sd :sm-pending-queue)))) (ert-deftest jabber-test-sm-discard-detaches-before-callbacks () "Discard removes live queue ownership before failure callbacks." (let* ((observed 'unset) (msg '(message ((to . "a@example.org")))) (sd (jabber-sm--reset nil))) (setq sd (jabber-sm--enqueue-pending sd msg nil (lambda (_reason) (setq observed (plist-get sd :sm-pending-queue))))) (setq sd (jabber-sm--discard-pending sd "terminal")) (should-not observed) (should-not (plist-get sd :sm-pending-queue)))) (ert-deftest jabber-test-lifecycle-list-change-isolates-error-and-quit () "A failing list-change hook cannot skip later notifications." (dolist (condition '(error quit)) (let* ((calls nil) (jabber-lifecycle-connection-list-changed-functions (list (lambda () (push 'first calls) (signal condition nil)) (lambda () (push 'second calls))))) (should-not (condition-case nil (progn (jabber-lifecycle-dispatch-connection-list-changed) nil) ((error quit) t))) (should (equal calls '(second first)))))) (ert-deftest jabber-test-sm-terminal-loss-detaches-before-callbacks () "Terminal loss retires the old connection before reset and failure effects." (let* ((jc (make-symbol "terminal-loss")) (replacement (make-symbol "replacement")) (transport (make-symbol "transport")) (jabber-auto-reconnect nil) (jabber-connections (list jc)) (jabber-lost-connection-hooks nil) (reset-observation nil) (failure-observation nil) (failures 0) (sd (list :username "user" :server "example.org" :resource "emacs" :connection transport :ever-session-established t :sm-enabled nil :sm-pending-queue nil))) (setq sd (jabber-sm--enqueue-pending sd '(message ((to . "peer@example.org"))) nil (lambda (_reason) (cl-incf failures) (setq failure-observation (list (memq jc jabber-connections) (plist-get (fsm-get-state-data jc) :connection) (plist-get (fsm-get-state-data jc) :sm-pending-queue)))))) (let ((jabber-lifecycle-session-reset-functions (list (lambda (_connection) (setq reset-observation (list (memq jc jabber-connections) (plist-get (fsm-get-state-data jc) :connection) (plist-get (fsm-get-state-data jc) :sm-pending-queue))) (push replacement jabber-connections))))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data sd) (fsm-send-sync jc (list :connection-dead transport "lost"))) (should (equal reset-observation '(nil nil nil))) (should (equal failure-observation '(nil nil nil))) (should (= failures 1)) (should-not (memq jc jabber-connections)) (should (memq replacement jabber-connections)) (should-not (plist-get (fsm-get-state-data jc) :connection)) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue)))) (ert-deftest jabber-test-sm-terminal-resumable-loss-without-retry-discards () "Resumable work is terminally settled when no retry owner exists." (let* ((jc (make-symbol "terminal-resumable")) (transport (make-symbol "transport")) (jabber-auto-reconnect nil) (jabber-connections (list jc)) (jabber-lost-connection-hooks nil) (jabber-lifecycle-session-reset-functions nil) (failures 0) (sd (list :username "user" :server "example.org" :resource "emacs" :connection transport :ever-session-established t :sm-enabled t :sm-id "session" :sm-pending-queue nil))) (setq sd (jabber-sm--enqueue-pending sd '(message ((to . "peer@example.org"))) nil (lambda (_reason) (cl-incf failures)))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data sd) (fsm-send-sync jc (list :connection-dead transport "lost")) (should (= failures 1)) (should-not (plist-get (fsm-get-state-data jc) :sm-enabled)) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (should-not (memq jc jabber-connections)) (should-not (get jc :timeout)))) (ert-deftest jabber-test-sm-cancel-retry-detaches-before-callbacks () "Cancelling a retry retires old ownership before arbitrary effects." (let* ((jc (make-symbol "cancel-retry")) (replacement (make-symbol "replacement")) (transport (make-symbol "stale-transport")) (timer (run-with-timer 3600 nil #'ignore)) (sm-timer (run-with-timer 3600 nil #'ignore)) (jabber-connections (list jc)) (jabber-lost-connection-hooks nil) (reset-observation nil) (failure-observation nil) (failures 0) (sd (list :username "user" :server "example.org" :resource "emacs" :connection transport :disconnection-expected nil :sm-enabled nil :sm-r-timer sm-timer :sm-pending-queue nil))) (unwind-protect (progn (setq sd (jabber-sm--enqueue-pending sd '(message ((to . "peer@example.org"))) nil (lambda (_reason) (cl-incf failures) (setq failure-observation (list (memq jc jabber-connections) (get jc :timeout) (plist-get (fsm-get-state-data jc) :sm-r-timer) (memq sm-timer timer-list) (plist-get (fsm-get-state-data jc) :connection) (plist-get (fsm-get-state-data jc) :sm-pending-queue)))))) (put jc :name 'jabber-connection) (put jc :state nil) (put jc :state-data sd) (put jc :timeout timer) (let ((jabber-lifecycle-session-reset-functions (list (lambda (_connection) (setq reset-observation (list (memq jc jabber-connections) (get jc :timeout) (plist-get (fsm-get-state-data jc) :sm-r-timer) (memq sm-timer timer-list) (plist-get (fsm-get-state-data jc) :connection) (plist-get (fsm-get-state-data jc) :sm-pending-queue))) (push replacement jabber-connections))))) (jabber-disconnect-one jc)) (should (equal reset-observation '(nil nil nil nil nil nil))) (should (equal failure-observation '(nil nil nil nil nil nil))) (should (= failures 1)) (should-not (memq jc jabber-connections)) (should (memq replacement jabber-connections)) (should-not (get jc :timeout)) (should-not (plist-get (fsm-get-state-data jc) :sm-r-timer)) (should-not (memq sm-timer timer-list)) (should-not (plist-get (fsm-get-state-data jc) :connection)) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue))) (when (timerp timer) (cancel-timer timer)) (when (timerp sm-timer) (cancel-timer sm-timer))))) (ert-deftest jabber-test-sm-terminal-lost-hooks-isolate-error-and-quit () "A failing lost-connection hook cannot skip later loss effects." (dolist (condition '(error quit)) (let* ((jc (make-symbol "terminal-lost-hook")) (transport (make-symbol "transport")) (jabber-auto-reconnect nil) (jabber-connections (list jc)) (jabber-lifecycle-session-reset-functions nil) (later-loss 0) (sd (list :username "user" :server "example.org" :resource "emacs" :connection transport :ever-session-established t :sm-enabled nil :sm-pending-queue nil)) (jabber-lost-connection-hooks (list (lambda (_connection) (signal condition nil)) (lambda (_connection) (cl-incf later-loss))))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data sd) (should-not (condition-case nil (progn (fsm-send-sync jc (list :connection-dead transport "lost")) nil) ((error quit) t))) (should (= later-loss 1)) (should-not (memq jc jabber-connections))))) (ert-deftest jabber-test-sm-terminal-transport-cleanup-cannot-abort () "Transport cleanup error or quit cannot interrupt terminal settlement." (dolist (case '((delete error) (delete quit) (buffer error) (buffer quit))) (pcase-let* ((`(,source ,condition) case) (jc (make-symbol "terminal-transport-cleanup")) (transport (make-symbol "transport")) (buffer (generate-new-buffer " *jabber-terminal-cleanup*")) (original-kill-buffer (symbol-function 'kill-buffer)) (jabber-auto-reconnect nil) (jabber-debug-keep-process-buffers nil) (jabber-connections (list jc)) (jabber-lost-connection-hooks nil) (resets 0) (failures 0) (buffer-cleanups 0) (jabber-lifecycle-session-reset-functions (list (lambda (_connection) (cl-incf resets)))) (sd (list :username "user" :server "example.org" :resource "emacs" :connection transport :ever-session-established t :sm-enabled nil :sm-pending-queue nil))) (setq sd (jabber-sm--enqueue-pending sd '(message ((to . "peer@example.org"))) nil (lambda (_reason) (cl-incf failures)))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data sd) (cl-letf (((symbol-function 'processp) (lambda (object) (eq object transport))) ((symbol-function 'process-buffer) (lambda (_process) buffer)) ((symbol-function 'delete-process) (lambda (_process) (when (eq source 'delete) (signal condition nil)))) ((symbol-function 'kill-buffer) (lambda (target) (if (eq target buffer) (progn (cl-incf buffer-cleanups) (when (eq source 'buffer) (signal condition nil))) (funcall original-kill-buffer target))))) (should-not (condition-case nil (progn (fsm-send-sync jc (list :connection-dead transport "lost")) nil) ((error quit) t)))) (should (= buffer-cleanups 1)) (should (= resets 1)) (should (= failures 1)) (should-not (memq jc jabber-connections)) (should-not (plist-get (fsm-get-state-data jc) :connection)) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (when (buffer-live-p buffer) (kill-buffer buffer))))) (ert-deftest jabber-test-sm-reentrant-cancel-prevents-orphan-retry () "Cancelling from retry callbacks cannot re-arm an orphan FSM." (dolist (source '(reset pending lost)) (let* ((jc (make-symbol "reentrant-cancel")) (replacement (make-symbol "replacement")) (transport (make-symbol "transport")) (jabber-auto-reconnect t) (jabber-reconnect-delay 300) (jabber-connections (list jc)) (cancelled nil) (resets 0) (failures 0) (losses 0) (list-changes 0) (cancel (lambda () (unless cancelled (setq cancelled t) (push replacement jabber-connections) (jabber-disconnect-one jc)))) (jabber-lifecycle-session-reset-functions (list (lambda (_connection) (cl-incf resets) (when (eq source 'reset) (funcall cancel))))) (jabber-lifecycle-connection-list-changed-functions (list (lambda () (cl-incf list-changes)))) (jabber-lost-connection-hooks (list (lambda (_connection) (cl-incf losses) (when (eq source 'lost) (funcall cancel))))) (sd (list :username "user" :server "example.org" :resource "emacs" :connection transport :ever-session-established t :disconnection-expected nil :sm-enabled (eq source 'lost) :sm-id (and (eq source 'lost) "session") :sm-pending-queue nil))) (setq sd (jabber-sm--enqueue-pending sd '(message ((to . "peer@example.org"))) nil (lambda (_reason) (cl-incf failures) (when (eq source 'pending) (funcall cancel))))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data sd) (unwind-protect (progn (fsm-send-sync jc (list :connection-dead transport "lost")) (should-not (get jc :state)) (should-not (get jc :timeout)) (should-not (memq jc jabber-connections)) (should (memq replacement jabber-connections)) (should (plist-get (fsm-get-state-data jc) :terminalized)) (should (plist-get (fsm-get-state-data jc) :disconnection-expected)) (should (= failures 1)) (should (= resets 1)) (should (= losses 1)) (should (= list-changes 1))) (when (timerp (get jc :timeout)) (cancel-timer (get jc :timeout))))))) (ert-deftest jabber-test-sm-terminal-reentry-is-once-only () "Terminal callbacks cannot repeat retirement effects." (dolist (source '(reset pending list lost)) (let* ((jc (make-symbol "terminal-reentry")) (replacement (make-symbol "replacement")) (transport (make-symbol "transport")) (jabber-auto-reconnect nil) (jabber-connections (list jc)) (triggered nil) (resets 0) (failures 0) (losses 0) (list-changes 0) (reenter (lambda () (unless triggered (setq triggered t) (push replacement jabber-connections) (jabber-disconnect-one jc)))) (jabber-lifecycle-session-reset-functions (list (lambda (_connection) (cl-incf resets) (when (eq source 'reset) (funcall reenter))))) (jabber-lifecycle-connection-list-changed-functions (list (lambda () (cl-incf list-changes) (when (eq source 'list) (funcall reenter))))) (jabber-lost-connection-hooks (list (lambda (_connection) (cl-incf losses) (when (eq source 'lost) (funcall reenter))))) (sd (list :username "user" :server "example.org" :resource "emacs" :connection transport :ever-session-established t :disconnection-expected nil :sm-enabled nil :sm-pending-queue nil))) (setq sd (jabber-sm--enqueue-pending sd '(message ((to . "peer@example.org"))) nil (lambda (_reason) (cl-incf failures) (when (eq source 'pending) (funcall reenter))))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data sd) (fsm-send-sync jc (list :connection-dead transport "lost")) (should-not (get jc :state)) (should-not (get jc :timeout)) (should-not (memq jc jabber-connections)) (should (memq replacement jabber-connections)) (should (plist-get (fsm-get-state-data jc) :terminalized)) (should (= resets 1)) (should (= failures 1)) (should (= losses 1)) (should (= list-changes 1))))) (defun jabber-test-sm--active-disconnect-observation (state condition) "Return active disconnect results for STATE when send signals CONDITION." (let* ((jc (make-symbol "active-disconnect")) (transport (make-symbol "transport")) (resets 0) (failures 0) (list-changes 0) (losses 0) (sends 0) sent expected-at-send escaped (jabber-connections (list jc)) (jabber-lost-connection-hooks (list (lambda (_connection) (cl-incf losses)))) (jabber-lifecycle-session-reset-functions (list (lambda (_connection) (cl-incf resets)))) (jabber-lifecycle-connection-list-changed-functions (list (lambda () (cl-incf list-changes)))) (input (list :username "user" :server "example.org" :resource "emacs" :connection transport :disconnection-expected nil :ever-session-established t :sm-enabled nil :sm-pending-queue nil :send-function (lambda (_connection string) (cl-incf sends) (setq sent string) (setq expected-at-send (plist-get (fsm-get-state-data jc) :disconnection-expected)) (put jc :state-data (plist-put (copy-sequence (fsm-get-state-data jc)) :close-send-observed t)) (when condition (signal condition nil))))) (state-data (jabber-sm--enqueue-pending input '(message ((to . "peer@example.org"))) nil (lambda (_reason) (cl-incf failures))))) (put jc :name 'jabber-connection) (put jc :state state) (put jc :state-data state-data) (condition-case err (jabber-disconnect-one jc) ((error quit) (setq escaped err))) (let ((current (fsm-get-state-data jc))) (prog1 (list :condition condition :transport transport :escaped (car-safe escaped) :sends sends :sent sent :expected-at-send expected-at-send :fsm-state (get jc :state) :terminalized (plist-get current :terminalized) :send-observed (plist-get current :close-send-observed) :expected (plist-get current :disconnection-expected) :connection (plist-get current :connection) :pending (plist-get current :sm-pending-queue) :registered (and (memq jc jabber-connections) t) :resets resets :failures failures :list-changes list-changes :losses losses :input-expected (plist-get input :disconnection-expected) :input-terminalized (plist-get input :terminalized) :input-connection (plist-get input :connection) :input-pending (plist-get input :sm-pending-queue)) (when (timerp (get jc :timeout)) (cancel-timer (get jc :timeout))))))) (ert-deftest jabber-test-sm-active-disconnect-is-fail-closed () "Every active state reaches terminal cleanup despite close failures." (let ((observations (cl-loop for state in '(:connected :starttls :register-account :legacy-auth :sasl-auth :bind :sm-enable :sm-resume :session-established) append (cl-loop for condition in '(nil error quit) collect (jabber-test-sm--active-disconnect-observation state condition))))) (should (cl-every (lambda (entry) (and (null (plist-get entry :escaped)) (= (plist-get entry :sends) 1) (equal (plist-get entry :sent) "") (plist-get entry :expected-at-send) (null (plist-get entry :fsm-state)) (plist-get entry :terminalized) (plist-get entry :send-observed) (plist-get entry :expected) (null (plist-get entry :connection)) (null (plist-get entry :pending)) (not (plist-get entry :registered)) (= (plist-get entry :resets) 1) (= (plist-get entry :failures) 1) (= (plist-get entry :list-changes) 1) (= (plist-get entry :losses) 0) (null (plist-get entry :input-expected)) (null (plist-get entry :input-terminalized)) (eq (plist-get entry :input-connection) (plist-get entry :transport)) (= (length (plist-get entry :input-pending)) 1))) observations)))) (ert-deftest jabber-test-sm-terminalization-does-not-mark-input-plist () "Terminal retirement does not mark or detach an external plist alias." (dolist (entry '(active-loss nil-disconnect)) (let* ((jc (make-symbol "terminal-state-copy")) (transport (make-symbol "transport")) (jabber-auto-reconnect nil) (jabber-connections (list jc)) (jabber-lifecycle-session-reset-functions nil) (jabber-lifecycle-connection-list-changed-functions nil) (jabber-lost-connection-hooks nil) (state-data (list :username "user" :server "example.org" :resource "emacs" :connection transport :ever-session-established t :disconnection-expected nil :sm-enabled nil :sm-pending-queue nil))) (put jc :name 'jabber-connection) (put jc :state (and (eq entry 'active-loss) :session-established)) (put jc :state-data state-data) (if (eq entry 'active-loss) (fsm-send-sync jc (list :connection-dead transport "lost")) (jabber-disconnect-one jc)) (should-not (plist-get state-data :terminalized)) (should-not (plist-get state-data :disconnection-expected)) (should (eq (plist-get state-data :connection) transport)) (should (plist-get (fsm-get-state-data jc) :terminalized))))) (defun jabber-test-sm--assert-unowned-resume-terminalized (source) "Assert resumable loss from unowned SOURCE is terminally settled." (let* ((jc (make-symbol "unowned-resume")) (replacement (make-symbol "replacement")) (transport (make-symbol "transport")) (jabber-auto-reconnect t) (jabber-reconnect-delay 300) (jabber-connections (if (eq source 'entry) (list replacement) (list jc))) (resets 0) (failures 0) (list-changes 0) (lost-observation nil) (jabber-lifecycle-session-reset-functions (list (lambda (_connection) (cl-incf resets)))) (jabber-lifecycle-connection-list-changed-functions (list (lambda () (cl-incf list-changes)))) (jabber-lost-connection-hooks (list (lambda (_connection) (when (eq source 'entry) (let ((current (fsm-get-state-data jc))) (setq lost-observation (list (plist-get current :terminalized) (plist-get current :sm-enabled) (plist-get current :sm-pending-queue) failures resets list-changes)))) (when (eq source 'lost-hook) (setq jabber-connections (cons replacement (delq jc jabber-connections))))))) (sd (list :username "user" :server "example.org" :resource "emacs" :connection transport :ever-session-established t :disconnection-expected nil :sm-enabled t :sm-id "session" :sm-pending-queue nil))) (setq sd (jabber-sm--enqueue-pending sd '(message ((to . "peer@example.org"))) nil (lambda (_reason) (cl-incf failures)))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data sd) (unwind-protect (progn (fsm-send-sync jc (list :connection-dead transport "lost")) (let ((current (fsm-get-state-data jc))) (should (plist-get current :terminalized)) (should-not (plist-get current :sm-enabled)) (should-not (plist-get current :sm-id)) (should-not (plist-get current :sm-resuming)) (should-not (plist-get current :sm-pending-queue))) (should (= resets 1)) (should (= failures 1)) (should (= list-changes 1)) (should-not (get jc :timeout)) (should-not (memq jc jabber-connections)) (should (memq replacement jabber-connections))) (when (eq source 'entry) (should (equal lost-observation '(t nil nil 1 1 1)))) (when (timerp (get jc :timeout)) (cancel-timer (get jc :timeout)))))) (ert-deftest jabber-test-sm-resumable-retry-requires-owner-at-entry () "Resumable state without an entry retry owner is terminally settled." (jabber-test-sm--assert-unowned-resume-terminalized 'entry)) (ert-deftest jabber-test-sm-resumable-retry-settles-lost-owner () "Resumable state whose retry owner is lost before return is settled." (jabber-test-sm--assert-unowned-resume-terminalized 'lost-hook)) (ert-deftest jabber-test-sm-nonresumable-lost-owner-does-not-reset-twice () "Late terminalization reuses an already completed session reset." (let* ((jc (make-symbol "lost-fresh-owner")) (replacement (make-symbol "replacement")) (transport (make-symbol "transport")) (jabber-auto-reconnect t) (jabber-reconnect-delay 300) (jabber-connections (list jc)) (resets 0) (failures 0) (list-changes 0) (jabber-lifecycle-session-reset-functions (list (lambda (_connection) (cl-incf resets)))) (jabber-lifecycle-connection-list-changed-functions (list (lambda () (cl-incf list-changes)))) (jabber-lost-connection-hooks (list (lambda (_connection) (setq jabber-connections (list replacement))))) (sd (list :username "user" :server "example.org" :resource "emacs" :connection transport :ever-session-established t :disconnection-expected nil :sm-enabled nil :sm-pending-queue nil))) (setq sd (jabber-sm--enqueue-pending sd '(message ((to . "peer@example.org"))) nil (lambda (_reason) (cl-incf failures)))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data sd) (fsm-send-sync jc (list :connection-dead transport "lost")) (should (= resets 1)) (should (= failures 1)) (should (= list-changes 1)) (should-not (get jc :timeout)) (should-not (memq jc jabber-connections)) (should (memq replacement jabber-connections)) (should (plist-get (fsm-get-state-data jc) :terminalized)))) (ert-deftest jabber-test-sm-transport-cleanup-cancel-is-once-only () "Cancellation from transport cleanup retires old ownership once." (let* ((jc (make-symbol "cleanup-cancel")) (replacement (make-symbol "replacement")) (buffer (generate-new-buffer " *jabber-cleanup-cancel*")) (transport (make-pipe-process :name "jabber-cleanup-cancel" :buffer buffer :noquery t)) (jabber-auto-reconnect t) (jabber-reconnect-delay 300) (jabber-debug-keep-process-buffers nil) (jabber-connections (list jc)) (triggered nil) (resets 0) (failures 0) (losses 0) (list-changes 0) (jabber-lifecycle-session-reset-functions (list (lambda (_connection) (cl-incf resets)))) (jabber-lifecycle-connection-list-changed-functions (list (lambda () (cl-incf list-changes)))) (jabber-lost-connection-hooks (list (lambda (_connection) (cl-incf losses)))) (state-data (list :username "user" :server "example.org" :resource "emacs" :connection transport :ever-session-established t :disconnection-expected nil :sm-enabled t :sm-id "session" :sm-pending-queue nil))) (setq state-data (jabber-sm--enqueue-pending state-data '(message ((to . "peer@example.org"))) nil (lambda (_reason) (cl-incf failures)))) (with-current-buffer buffer (add-hook 'kill-buffer-hook (lambda () (unless triggered (setq triggered t) (push replacement jabber-connections) (jabber-disconnect-one jc))) nil t)) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state-data) (unwind-protect (progn (fsm-send-sync jc (list :connection-dead transport "lost")) (let ((current (fsm-get-state-data jc))) (should (plist-get current :terminalized)) (should (plist-get current :disconnection-expected)) (should-not (plist-get current :sm-pending-queue)) (should-not (plist-get current :nil-entry-pending))) (should (= resets 1)) (should (= failures 1)) (should (= losses 1)) (should (= list-changes 1)) (should-not (memq jc jabber-connections)) (should (memq replacement jabber-connections)) (should-not (get jc :timeout)) (should-not (buffer-live-p buffer))) (when (process-live-p transport) (delete-process transport)) (when (buffer-live-p buffer) (kill-buffer buffer))))) (ert-deftest jabber-test-sm-transport-cleanup-timeout-waits-for-retry-lease () "Transport cleanup cannot reconnect before the retry lease is armed." (let* ((jc (make-symbol "cleanup-retry")) (buffer (generate-new-buffer " *jabber-cleanup-retry*")) (transport (make-pipe-process :name "jabber-cleanup-retry" :buffer buffer :noquery t)) (jabber-auto-reconnect t) (jabber-reconnect-delay 300) (jabber-debug-keep-process-buffers nil) (jabber-connections (list jc)) (triggered nil) (reconnects 0) (resets 0) (failures 0) (losses 0) (list-changes 0) (jabber-lifecycle-session-reset-functions (list (lambda (_connection) (cl-incf resets)))) (jabber-lifecycle-connection-list-changed-functions (list (lambda () (cl-incf list-changes)))) (jabber-lost-connection-hooks (list (lambda (_connection) (cl-incf losses)))) (state-data (list :username "user" :server "example.org" :resource "emacs" :connection transport :connection-type 'network :network-server "example.org" :port 5222 :ever-session-established t :disconnection-expected nil :sm-enabled nil :sm-pending-queue nil))) (setq state-data (jabber-sm--enqueue-pending state-data '(message ((to . "peer@example.org"))) nil (lambda (_reason) (cl-incf failures)))) (with-current-buffer buffer (add-hook 'kill-buffer-hook (lambda () (unless triggered (setq triggered t) (fsm-send-sync jc :timeout))) nil t)) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state-data) (unwind-protect (cl-letf (((symbol-function 'jabber-get-connect-function) (lambda (_type) (lambda (&rest _) (cl-incf reconnects))))) (fsm-send-sync jc (list :connection-dead transport "lost")) (should-not (get jc :state)) (should (= reconnects 0)) (should (= resets 1)) (should (= failures 1)) (should (= losses 1)) (should (= list-changes 0)) (should (memq jc jabber-connections)) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (should (timerp (get jc :timeout))) (fsm-send-sync jc :timeout) (should (eq (get jc :state) :connecting)) (should (= reconnects 1)) (should-not (get jc :timeout)) (should-not (buffer-live-p buffer))) (when (process-live-p transport) (delete-process transport)) (when (buffer-live-p buffer) (kill-buffer buffer))))) (ert-deftest jabber-test-sm-session-establishment-clears-reset-marker () "A genuine session permits one later logical-session reset." (let* ((jc (make-symbol "fresh-session")) (token (cons nil nil)) (held (list (make-symbol "held"))) (state-data (list :session-reset-done t :nil-entry-token token :nil-entry-pending held :connection 'transport :sm-resumed nil :sm-enabled nil :sm-pending-queue nil)) (jabber-connections (list jc)) (enter (gethash :session-established (get 'jabber-connection :fsm-enter)))) (jabber-test-sm--install-drain-state jc state-data) (cl-letf (((symbol-function 'jabber-lifecycle-dispatch-session-bootstrap) #'ignore) ((symbol-function 'jabber-sm--schedule-drain) #'ignore)) (setq state-data (car (funcall enter jc state-data)))) (should-not (plist-get state-data :session-reset-done)) (should-not (plist-get state-data :nil-entry-token)) (should-not (plist-get state-data :nil-entry-pending)) (should-not (plist-get (fsm-get-state-data jc) :session-reset-done)) (should-not (plist-get (fsm-get-state-data jc) :nil-entry-token)) (should-not (plist-get (fsm-get-state-data jc) :nil-entry-pending)))) (ert-deftest jabber-test-sm-terminal-cleanup-keeps-cancellation () "Terminal cleanup reentry preserves explicit cancellation authority." (dolist (mode '(no-retry lost-owner)) (let* ((jc (make-symbol "terminal-cleanup")) (replacement (make-symbol "replacement")) (buffer (generate-new-buffer " *jabber-terminal-cleanup*")) (process (make-pipe-process :name "jabber-terminal-cleanup" :buffer buffer :noquery t)) (jabber-auto-reconnect (not (eq mode 'no-retry))) (jabber-debug-keep-process-buffers nil) (jabber-connections (if (eq mode 'lost-owner) (list replacement) (list jc))) (triggered nil) (resets 0) (failures 0) (list-changes 0) (lost 0) reset-observations (jabber-lost-connection-hooks (list (lambda (_connection) (cl-incf lost)))) (jabber-lifecycle-session-reset-functions (list (lambda (_connection) (cl-incf resets) (push (plist-get (fsm-get-state-data jc) :disconnection-expected) reset-observations)))) (jabber-lifecycle-connection-list-changed-functions (list (lambda () (cl-incf list-changes)))) (input (list :username "user" :server "example.org" :resource "emacs" :connection process :disconnection-expected nil :ever-session-established t :sm-enabled nil :sm-pending-queue nil)) state-data) (setq state-data (jabber-sm--enqueue-pending input '(message ((to . "peer@example.org"))) nil (lambda (_reason) (cl-incf failures)))) (with-current-buffer buffer (add-hook 'kill-buffer-hook (lambda () (unless triggered (setq triggered t) (cl-pushnew replacement jabber-connections) (jabber-disconnect-one jc))) nil t)) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state-data) (unwind-protect (progn (fsm-send-sync jc (list :connection-dead process "lost")) (let ((current (fsm-get-state-data jc))) (should triggered) (should (equal reset-observations '(t))) (should (plist-get current :disconnection-expected)) (should (plist-get current :terminalized)) (should-not (get jc :state)) (should-not (memq jc jabber-connections)) (should (memq replacement jabber-connections)) (should (= resets 1)) (should (= failures 1)) (should (= list-changes 1)) (should (= lost 1)))) (when (timerp (get jc :timeout)) (cancel-timer (get jc :timeout))) (when (process-live-p process) (delete-process process)) (when (buffer-live-p buffer) (kill-buffer buffer)))))) (defun jabber-test-sm--terminal-timeout-case (source) "Assert terminal timeout reentry from SOURCE stays inert." (let* ((jc (make-symbol "terminal-timeout")) (replacement (make-symbol "replacement")) (buffer (and (eq source 'cleanup) (generate-new-buffer " *jabber-timeout-cleanup*"))) (process (and buffer (make-pipe-process :name "jabber-timeout-cleanup" :buffer buffer :noquery t))) (transport (or process (make-symbol "transport"))) (jabber-auto-reconnect nil) (jabber-debug-keep-process-buffers nil) (jabber-connections (list jc replacement)) (triggered 0) (reconnects 0) (resets 0) (failures 0) (list-changes 0) (lost 0) trigger (jabber-lifecycle-session-reset-functions (list (lambda (_connection) (cl-incf resets) (when (eq source 'reset) (funcall trigger))))) (jabber-lifecycle-connection-list-changed-functions (list (lambda () (cl-incf list-changes) (when (eq source 'list) (funcall trigger))))) (jabber-lost-connection-hooks (list (lambda (_connection) (cl-incf lost) (when (eq source 'lost) (funcall trigger))))) (state-data (list :username "user" :server "example.org" :resource "emacs" :connection transport :disconnection-expected nil :ever-session-established t :sm-enabled nil :sm-pending-queue nil))) (setq trigger (lambda () (cl-incf triggered) (fsm-send-sync jc :timeout))) (setq state-data (jabber-sm--enqueue-pending state-data '(message ((to . "peer@example.org"))) nil (lambda (_reason) (cl-incf failures) (when (eq source 'pending) (funcall trigger))))) (when buffer (with-current-buffer buffer (add-hook 'kill-buffer-hook (lambda () (funcall trigger)) nil t))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state-data) (unwind-protect (cl-letf (((symbol-function 'jabber-get-connect-function) (lambda (_connection-type) (lambda (&rest _) (cl-incf reconnects))))) (fsm-send-sync jc (list :connection-dead transport "lost")) (when (eq source 'delayed) (funcall trigger)) (let ((current (fsm-get-state-data jc))) (should (= triggered 1)) (should (= reconnects 0)) (should-not (get jc :state)) (should (plist-get current :terminalized)) (should-not (memq jc jabber-connections)) (should (memq replacement jabber-connections)) (should-not (get jc :timeout)))) (when (timerp (get jc :timeout)) (cancel-timer (get jc :timeout))) (when (and process (process-live-p process)) (delete-process process)) (when (and buffer (buffer-live-p buffer)) (kill-buffer buffer))))) (ert-deftest jabber-test-sm-terminal-timeout-is-inert () "Terminal reset, failure, list, lost, cleanup, and delayed timeouts are inert." (dolist (source '(reset pending list lost cleanup delayed)) (jabber-test-sm--terminal-timeout-case source))) (ert-deftest jabber-test-sm-timeout-requires-complete-retry-lease () "Only a registered, tokened, nonterminal nil-state retry may reconnect." (dolist (case '(unregistered terminal expected missing-token missing-timer live)) (let* ((jc (make-symbol "retry-lease")) (transport (make-symbol "transport")) (jabber-auto-reconnect t) (jabber-reconnect-delay 300) (jabber-connections (list jc)) (jabber-lifecycle-session-reset-functions nil) (jabber-lifecycle-connection-list-changed-functions nil) (jabber-lost-connection-hooks nil) (reconnects 0) (state-data (list :username "user" :server "example.org" :resource "emacs" :connection transport :connection-type 'network :network-server "example.org" :port 5222 :disconnection-expected nil :ever-session-established t :sm-enabled nil :sm-pending-queue nil))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state-data) (unwind-protect (cl-letf (((symbol-function 'jabber-get-connect-function) (lambda (_connection-type) (lambda (&rest _) (cl-incf reconnects))))) (fsm-send-sync jc (list :connection-dead transport "lost")) (pcase case ('unregistered (setq jabber-connections (delq jc jabber-connections))) ('terminal (plist-put (fsm-get-state-data jc) :terminalized t)) ('expected (plist-put (fsm-get-state-data jc) :disconnection-expected t)) ('missing-token (plist-put (fsm-get-state-data jc) :nil-entry-token nil))) (when (eq case 'missing-timer) (fsm-stop-timer jc)) (fsm-send-sync jc :timeout) (if (eq case 'live) (progn (should (eq (get jc :state) :connecting)) (should (= reconnects 1))) (should-not (get jc :state)) (should (= reconnects 0)))) (when (timerp (get jc :timeout)) (cancel-timer (get jc :timeout))))))) (ert-deftest jabber-test-sm-reset-reentry-keeps-successor-queue () "Reset and pending callbacks cannot erase same-plist successor work." (dolist (source '(reset pending)) (let* ((jc (make-symbol "reset-successor")) (replacement (make-symbol "replacement")) (transport (make-symbol "transport")) (jabber-auto-reconnect t) (jabber-connections (list jc replacement)) (resets 0) (old-failures 0) (successor-failures 0) (reconnects 0) (advanced nil) (same-object nil) successor-entries advance (jabber-lost-connection-hooks nil) (jabber-lifecycle-connection-list-changed-functions nil) (jabber-lifecycle-session-reset-functions (list (lambda (_connection) (cl-incf resets) (when (eq source 'reset) (funcall advance))))) (state-data (list :username "user" :server "example.org" :resource "emacs" :connection transport :disconnection-expected nil :ever-session-established t :sm-enabled nil :sm-pending-queue nil))) (setq advance (lambda () (unless advanced (setq advanced t) (fsm-send-sync jc :timeout) (let* ((current (fsm-get-state-data jc)) (first (jabber-sm--enqueue-pending current '(message ((id . "successor"))) nil (lambda (_reason) (cl-incf successor-failures)))) (second (jabber-sm--enqueue-pending first '(message ((id . "successor"))) nil (lambda (_reason) (cl-incf successor-failures))))) (setq same-object (and (eq current first) (eq first second))) (setq successor-entries (copy-sequence (plist-get second :sm-pending-queue))) (put jc :state-data second))))) (setq state-data (jabber-sm--enqueue-pending state-data '(message ((id . "old"))) nil (lambda (_reason) (cl-incf old-failures) (when (eq source 'pending) (funcall advance))))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state-data) (cl-letf (((symbol-function 'jabber-get-connect-function) (lambda (_connection-type) (lambda (&rest _) (cl-incf reconnects))))) (fsm-send-sync jc (list :connection-dead transport "lost")) (let ((current (fsm-get-state-data jc))) (should advanced) (should same-object) (should-not (get jc :state)) (should (memq jc jabber-connections)) (should (memq replacement jabber-connections)) (should (= reconnects 0)) (should (= resets 1)) (should (= old-failures 1)) (should (= successor-failures 0)) (let ((pending (plist-get current :sm-pending-queue))) (should (= (length pending) 2)) (should (eq (nth 0 pending) (nth 0 successor-entries))) (should (eq (nth 1 pending) (nth 1 successor-entries))) (should (equal (mapcar #'jabber-sm--pending-stanza pending) '((message ((id . "successor"))) (message ((id . "successor"))))))) (should (timerp (get jc :timeout))) (fsm-send-sync jc :timeout) (should (eq (get jc :state) :connecting)) (should (= reconnects 1))))))) (ert-deftest jabber-test-sm-expected-loss-does-not-retry () "An expected active loss is terminal despite automatic reconnect." (let* ((jc (make-symbol "expected-loss")) (transport (make-symbol "transport")) (jabber-auto-reconnect t) (jabber-connections (list jc)) (jabber-lifecycle-session-reset-functions nil) (jabber-lifecycle-connection-list-changed-functions nil) (jabber-lost-connection-hooks nil) (state-data (list :username "user" :server "example.org" :resource "emacs" :connection transport :disconnection-expected t :ever-session-established t :sm-enabled nil :sm-pending-queue nil))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state-data) (fsm-send-sync jc (list :connection-dead transport "closed")) (should (plist-get (fsm-get-state-data jc) :terminalized)) (should-not (memq jc jabber-connections)) (should-not (get jc :timeout)))) (ert-deftest jabber-test-sm-initial-failure-does-not-retry () "A never-established FSM is terminal despite automatic reconnect." (let* ((jc (make-symbol "initial-failure")) (jabber-auto-reconnect t) (jabber-connections (list jc)) (jabber-lifecycle-session-reset-functions nil) (jabber-lifecycle-connection-list-changed-functions nil) (jabber-lost-connection-hooks nil) (state-data (list :username "user" :server "example.org" :resource "emacs" :connection nil :disconnection-expected nil :ever-session-established nil :sm-enabled nil :sm-pending-queue nil))) (put jc :name 'jabber-connection) (put jc :state :connecting) (put jc :state-data state-data) (fsm-send-sync jc '(:connection-failed ("no route"))) (should (plist-get (fsm-get-state-data jc) :terminalized)) (should-not (memq jc jabber-connections)) (should-not (get jc :timeout)))) (ert-deftest jabber-test-sm-nested-nil-entry-preserves-new-retry-timer () "A stale outer nil entry cannot replace a nested retry timer." (let* ((jc (make-symbol "nested-nil-entry")) (transport (make-symbol "transport")) (jabber-auto-reconnect t) (jabber-reconnect-delay 300) (jabber-connections (list jc)) (jabber-lost-connection-hooks nil) (nested nil) (resets 0) (failures 0) (reconnects 0) old-token new-token nested-timer (jabber-lifecycle-session-reset-functions (list (lambda (_connection) (cl-incf resets) (unless nested (setq nested t) (setq old-token (plist-get (fsm-get-state-data jc) :nil-entry-token)) (fsm-start-timer jc 300) (fsm-send-sync jc :timeout) (fsm-send-sync jc '(:connection-failed ("nested"))) (setq new-token (plist-get (fsm-get-state-data jc) :nil-entry-token)) (setq nested-timer (get jc :timeout)))))) (state-data (list :username "user" :server "example.org" :resource "emacs" :connection transport :connection-type 'network :network-server "example.org" :port 5222 :disconnection-expected nil :ever-session-established t :sm-enabled nil :sm-pending-queue nil))) (setq state-data (jabber-sm--enqueue-pending state-data '(message ((id . "old"))) nil (lambda (_reason) (cl-incf failures)))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state-data) (unwind-protect (cl-letf (((symbol-function 'jabber-get-connect-function) (lambda (_connection-type) (lambda (&rest _) (cl-incf reconnects))))) (fsm-send-sync jc (list :connection-dead transport "lost")) (should nested) (should old-token) (should new-token) (should-not (eq old-token new-token)) (should (eq (get jc :state) nil)) (should (eq (get jc :timeout) nested-timer)) (should (timerp nested-timer)) (should (memq jc jabber-connections)) (should (= reconnects 1)) (should (= resets 1)) (should (= failures 1))) (when (timerp (get jc :timeout)) (cancel-timer (get jc :timeout)))))) (ert-deftest jabber-test-sm-cleanup-added-work-survives-session-reset () "Cleanup-created successor occurrences survive old-session settlement." (dolist (mode '(retry terminal)) (let* ((jc (make-symbol "cleanup-successor-work")) (buffer (generate-new-buffer " *jabber-cleanup-successor*")) (transport (make-pipe-process :name "jabber-cleanup-successor" :buffer buffer :noquery t)) (jabber-auto-reconnect (eq mode 'retry)) (jabber-reconnect-delay 300) (jabber-debug-keep-process-buffers nil) (jabber-connections (list jc)) (jabber-lifecycle-session-reset-functions nil) (jabber-lifecycle-connection-list-changed-functions nil) (jabber-lost-connection-hooks nil) (old-failures 0) (successor-failures 0) successor-entries (state-data (list :username "user" :server "example.org" :resource "emacs" :connection transport :ever-session-established t :disconnection-expected nil :sm-enabled nil :sm-pending-queue nil))) (setq state-data (jabber-sm--enqueue-pending state-data '(message ((id . "old"))) nil (lambda (_reason) (cl-incf old-failures)))) (with-current-buffer buffer (add-hook 'kill-buffer-hook (lambda () (let* ((current (fsm-get-state-data jc)) (first (jabber-sm--enqueue-pending current '(message ((id . "successor"))) nil (lambda (_reason) (cl-incf successor-failures)))) (second (jabber-sm--enqueue-pending first '(message ((id . "successor"))) nil (lambda (_reason) (cl-incf successor-failures))))) (setq successor-entries (copy-sequence (plist-get second :sm-pending-queue))) (put jc :state-data second))) nil t)) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state-data) (unwind-protect (progn (fsm-send-sync jc (list :connection-dead transport "lost")) (should (= old-failures 1)) (should (= successor-failures 0)) (let ((pending (plist-get (fsm-get-state-data jc) :sm-pending-queue))) (should (= (length pending) 2)) (should (eq (nth 0 pending) (nth 0 successor-entries))) (should (eq (nth 1 pending) (nth 1 successor-entries))) (should (equal (mapcar #'jabber-sm--pending-stanza pending) '((message ((id . "successor"))) (message ((id . "successor"))))))) (if (eq mode 'retry) (progn (should (memq jc jabber-connections)) (should (timerp (get jc :timeout)))) (should-not (memq jc jabber-connections)) (should-not (get jc :timeout)))) (when (timerp (get jc :timeout)) (cancel-timer (get jc :timeout))) (when (process-live-p transport) (delete-process transport)) (when (buffer-live-p buffer) (kill-buffer buffer)))))) (ert-deftest jabber-test-sm-resumable-cleanup-restores-old-before-successors () "A surviving resumable retry restores old work before cleanup additions." (let* ((jc (make-symbol "resumable-cleanup-order")) (buffer (generate-new-buffer " *jabber-resumable-cleanup-order*")) (transport (make-pipe-process :name "jabber-resumable-cleanup-order" :buffer buffer :noquery t)) (jabber-auto-reconnect t) (jabber-reconnect-delay 300) (jabber-debug-keep-process-buffers nil) (jabber-connections (list jc)) (jabber-lifecycle-session-reset-functions nil) (jabber-lifecycle-connection-list-changed-functions nil) (jabber-lost-connection-hooks nil) (old-failures 0) (successor-failures 0) old-queue successor-entries (state-data (list :username "user" :server "example.org" :resource "emacs" :connection transport :ever-session-established t :disconnection-expected nil :sm-enabled t :sm-id "session" :sm-pending-queue nil))) (setq state-data (jabber-sm--enqueue-pending state-data '(message ((id . "old"))) nil (lambda (_reason) (cl-incf old-failures)))) (setq old-queue (plist-get state-data :sm-pending-queue)) (with-current-buffer buffer (add-hook 'kill-buffer-hook (lambda () (let* ((current (fsm-get-state-data jc)) (first (jabber-sm--enqueue-pending current '(message ((id . "successor-1"))) nil (lambda (_reason) (cl-incf successor-failures)))) (second (jabber-sm--enqueue-pending first '(message ((id . "successor-2"))) nil (lambda (_reason) (cl-incf successor-failures))))) (setq successor-entries (copy-sequence (plist-get second :sm-pending-queue))) (put jc :state-data second))) nil t)) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state-data) (unwind-protect (progn (fsm-send-sync jc (list :connection-dead transport "lost")) (let ((pending (plist-get (fsm-get-state-data jc) :sm-pending-queue))) (should (= old-failures 0)) (should (= successor-failures 0)) (should (= (length old-queue) 1)) (should (= (length pending) 3)) (should (eq (nth 0 pending) (nth 0 old-queue))) (should (eq (nth 1 pending) (nth 0 successor-entries))) (should (eq (nth 2 pending) (nth 1 successor-entries))) (should (equal (mapcar #'jabber-sm--pending-stanza pending) '((message ((id . "old"))) (message ((id . "successor-1"))) (message ((id . "successor-2"))))))) (should (plist-get (fsm-get-state-data jc) :sm-resuming)) (should (memq jc jabber-connections)) (should (timerp (get jc :timeout))) (should-not (plist-get (fsm-get-state-data jc) :nil-entry-pending))) (when (timerp (get jc :timeout)) (cancel-timer (get jc :timeout))) (when (process-live-p transport) (delete-process transport)) (when (buffer-live-p buffer) (kill-buffer buffer))))) (ert-deftest jabber-test-sm-resumable-callback-timeout-promotes-held-work () "A callback-armed retry promotes held work before connecting." (let* ((jc (make-symbol "resumable-callback-timeout")) (buffer (generate-new-buffer " *jabber-resumable-timeout*")) (transport (make-pipe-process :name "jabber-resumable-timeout" :buffer buffer :noquery t)) (jabber-auto-reconnect t) (jabber-reconnect-delay 300) (jabber-debug-keep-process-buffers nil) (jabber-connections (list jc)) (jabber-lost-connection-hooks nil) (jabber-post-resume-hooks nil) (jabber-lifecycle-session-reset-functions nil) (jabber-lifecycle-connection-list-changed-functions nil) (old-failures 0) (successor-failures 0) (reconnects 0) old-queue old-entry successor-entries (state-data (list :username "user" :server "example.org" :resource "emacs" :connection transport :connection-type 'network :network-server "example.org" :port 5222 :disconnection-expected nil :ever-session-established t :sm-enabled t :sm-id "session" :sm-pending-queue nil))) (setq state-data (jabber-sm--enqueue-pending state-data '(message ((id . "old"))) nil (lambda (_reason) (cl-incf old-failures)))) (setq old-queue (plist-get state-data :sm-pending-queue)) (setq old-entry (car old-queue)) (with-current-buffer buffer (add-hook 'kill-buffer-hook (lambda () (let* ((current (fsm-get-state-data jc)) (first (jabber-sm--enqueue-pending current '(message ((id . "successor-1"))) nil (lambda (_reason) (cl-incf successor-failures)))) (second (jabber-sm--enqueue-pending first '(message ((id . "successor-2"))) nil (lambda (_reason) (cl-incf successor-failures))))) (setq successor-entries (copy-sequence (plist-get second :sm-pending-queue))) (put jc :state-data second) (fsm-start-timer jc 300) (fsm-send-sync jc :timeout))) nil t)) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state-data) (unwind-protect (cl-letf (((symbol-function 'jabber-get-connect-function) (lambda (_connection-type) (lambda (&rest _) (cl-incf reconnects))))) (fsm-send-sync jc (list :connection-dead transport "lost")) (let* ((current (fsm-get-state-data jc)) (pending (plist-get current :sm-pending-queue))) (should (eq (get jc :state) :connecting)) (should (= reconnects 1)) (should (= old-failures 0)) (should (= successor-failures 0)) (should (= (length old-queue) 1)) (should (= (length pending) 3)) (should (eq (nth 0 pending) old-entry)) (should (eq (nth 1 pending) (nth 0 successor-entries))) (should (eq (nth 2 pending) (nth 1 successor-entries))) (should-not (plist-get current :nil-entry-pending)) (setq current (copy-sequence current)) (setq current (plist-put current :sm-resumed t)) (fsm-update jc :session-established current nil)) (let ((pending (plist-get (fsm-get-state-data jc) :sm-pending-queue))) (should (= (length pending) 3)) (should (eq (nth 0 pending) old-entry)) (should (eq (nth 1 pending) (nth 0 successor-entries))) (should (eq (nth 2 pending) (nth 1 successor-entries))) (should-not (plist-get (fsm-get-state-data jc) :nil-entry-pending)))) (let ((timer (plist-get (fsm-get-state-data jc) :sm-r-timer))) (when (timerp timer) (cancel-timer timer))) (when (timerp (get jc :timeout)) (cancel-timer (get jc :timeout))) (when (process-live-p transport) (delete-process transport)) (when (buffer-live-p buffer) (kill-buffer buffer))))) (ert-deftest jabber-test-sm-late-owner-loss-preserves-cleanup-work () "Late retry-owner loss cannot consume cleanup-created successor work." (dolist (mode '(nonresumable resumable)) (let* ((jc (make-symbol "late-owner-cleanup")) (replacement (make-symbol "replacement")) (buffer (generate-new-buffer " *jabber-late-owner-cleanup*")) (transport (make-pipe-process :name "jabber-late-owner-cleanup" :buffer buffer :noquery t)) (jabber-auto-reconnect t) (jabber-reconnect-delay 300) (jabber-debug-keep-process-buffers nil) (jabber-connections (list jc)) (resets 0) (list-changes 0) (losses 0) (old-failures 0) (successor-failures 0) successor-entries (jabber-lifecycle-session-reset-functions (list (lambda (_connection) (cl-incf resets)))) (jabber-lifecycle-connection-list-changed-functions (list (lambda () (cl-incf list-changes)))) (jabber-lost-connection-hooks (list (lambda (_connection) (cl-incf losses) (setq jabber-connections (cons replacement (delq jc jabber-connections)))))) (state-data (list :username "user" :server "example.org" :resource "emacs" :connection transport :ever-session-established t :disconnection-expected nil :sm-enabled (eq mode 'resumable) :sm-id (and (eq mode 'resumable) "session") :sm-pending-queue nil))) (setq state-data (jabber-sm--enqueue-pending state-data '(message ((id . "old"))) nil (lambda (_reason) (cl-incf old-failures)))) (with-current-buffer buffer (add-hook 'kill-buffer-hook (lambda () (let* ((current (fsm-get-state-data jc)) (first (jabber-sm--enqueue-pending current '(message ((id . "successor"))) nil (lambda (_reason) (cl-incf successor-failures)))) (second (jabber-sm--enqueue-pending first '(message ((id . "successor"))) nil (lambda (_reason) (cl-incf successor-failures))))) (setq successor-entries (copy-sequence (plist-get second :sm-pending-queue))) (put jc :state-data second))) nil t)) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state-data) (unwind-protect (progn (fsm-send-sync jc (list :connection-dead transport "lost")) (let* ((current (fsm-get-state-data jc)) (pending (plist-get current :sm-pending-queue))) (should (= old-failures 1)) (should (= successor-failures 0)) (should (= (length pending) 2)) (should (eq (nth 0 pending) (nth 0 successor-entries))) (should (eq (nth 1 pending) (nth 1 successor-entries))) (should (equal (mapcar #'jabber-sm--pending-stanza pending) '((message ((id . "successor"))) (message ((id . "successor")))))) (should (= resets 1)) (should (= list-changes 1)) (should (= losses 1)) (should (plist-get current :terminalized)) (should-not (plist-get current :sm-enabled)) (should-not (plist-get current :sm-id))) (should-not (get jc :state)) (should-not (get jc :timeout)) (should-not (memq jc jabber-connections)) (should (memq replacement jabber-connections))) (when (timerp (get jc :timeout)) (cancel-timer (get jc :timeout))) (when (process-live-p transport) (delete-process transport)) (when (buffer-live-p buffer) (kill-buffer buffer)))))) (ert-deftest jabber-test-sm-late-list-cancellation-keeps-current-state () "Late terminal list reentry preserves explicit cancellation state." (let* ((jc (make-symbol "late-list-cancel")) (replacement (make-symbol "replacement")) (transport (make-symbol "transport")) (jabber-auto-reconnect t) (jabber-reconnect-delay 300) (jabber-connections (list jc)) (triggered nil) (resets 0) (failures 0) (list-changes 0) (losses 0) (jabber-lifecycle-session-reset-functions (list (lambda (_connection) (cl-incf resets)))) (jabber-lifecycle-connection-list-changed-functions (list (lambda () (cl-incf list-changes) (unless triggered (setq triggered t) (jabber-disconnect-one jc))))) (jabber-lost-connection-hooks (list (lambda (_connection) (cl-incf losses) (setq jabber-connections (cons replacement (delq jc jabber-connections)))))) (state-data (list :username "user" :server "example.org" :resource "emacs" :connection transport :ever-session-established t :disconnection-expected nil :sm-enabled t :sm-id "session" :sm-pending-queue nil))) (setq state-data (jabber-sm--enqueue-pending state-data '(message ((id . "old"))) nil (lambda (_reason) (cl-incf failures)))) (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state-data) (unwind-protect (progn (fsm-send-sync jc (list :connection-dead transport "lost")) (let ((current (fsm-get-state-data jc))) (should triggered) (should (plist-get current :terminalized)) (should (plist-get current :disconnection-expected)) (should-not (plist-get current :sm-pending-queue))) (should (= resets 1)) (should (= failures 1)) (should (= list-changes 1)) (should (= losses 1)) (should-not (get jc :state)) (should-not (get jc :timeout)) (should-not (memq jc jabber-connections)) (should (memq replacement jabber-connections))) (when (timerp (get jc :timeout)) (cancel-timer (get jc :timeout)))))) ;;; Priority queue (ert-deftest jabber-test-sm-stanza-priority-message () "Messages have priority 0." (should (= (jabber-sm--stanza-priority '(message ((to . "a@b")) (body () "hi"))) 0))) (ert-deftest jabber-test-sm-stanza-priority-iq () "IQs have priority 1." (should (= (jabber-sm--stanza-priority '(iq ((type . "get") (id . "1")))) 1))) (ert-deftest jabber-test-sm-stanza-priority-presence () "Presence has priority 2." (should (= (jabber-sm--stanza-priority '(presence ((to . "room@muc/nick")))) 2))) (ert-deftest jabber-test-sm-drain-pending-priority-order () "Drain sends messages before presence, preserving FIFO within class." (let* ((jabber-sm-max-in-flight nil) (pres1 '(presence ((to . "r1@muc/nick")))) (msg1 '(message ((to . "a@b")) (body () "1"))) (pres2 '(presence ((to . "r2@muc/nick")))) (iq1 '(iq ((type . "get") (id . "1")))) (msg2 '(message ((to . "c@d")) (body () "2"))) (pending (list (cons 2 pres1) (cons 0 msg1) (cons 2 pres2) (cons 1 iq1) (cons 0 msg2))) (sd (list :sm-enabled t :connection 'transport :sm-outbound-count 0 :sm-inbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-pending-queue pending)) (sent nil) (jc (make-symbol "drain-priority")) (jabber-connections (list jc))) (jabber-test-sm--install-drain-state jc sd) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc sexp) (push sexp sent)))) (jabber-sm--drain-pending jc sd)) (setq sd (fsm-get-state-data jc)) (setq sent (nreverse sent)) (should (= (length sent) 5)) (should (eq (car-safe (nth 0 sent)) 'message)) (should (eq (car-safe (nth 1 sent)) 'message)) (should (eq (car-safe (nth 2 sent)) 'iq)) (should (eq (car-safe (nth 3 sent)) 'presence)) (should (eq (car-safe (nth 4 sent)) 'presence)) (should (equal (nth 0 sent) msg1)) (should (equal (nth 1 sent) msg2)) (should (equal (nth 3 sent) pres1)) (should (equal (nth 4 sent) pres2)) (should (equal (mapcar #'jabber-sm--pending-stanza pending) (list pres1 msg1 pres2 iq1 msg2))))) (ert-deftest jabber-test-sm-drain-pending-priority-partial () "With a cap, messages drain first even if presence was enqueued first." (let* ((jabber-sm-max-in-flight 2) (pres1 '(presence ((to . "r1@muc/nick")))) (msg1 '(message ((to . "a@b")) (body () "urgent"))) (pres2 '(presence ((to . "r2@muc/nick")))) (sd (list :sm-enabled t :connection 'transport :sm-outbound-count 0 :sm-inbound-count 0 :sm-last-acked 0 :sm-outbound-queue nil :sm-pending-queue (list (cons 2 pres1) (cons 0 msg1) (cons 2 pres2)))) (sent nil) (jc (make-symbol "drain-priority-partial")) (jabber-connections (list jc))) (jabber-test-sm--install-drain-state jc sd) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc sexp) (push sexp sent)))) (jabber-sm--drain-pending jc sd)) (setq sd (fsm-get-state-data jc)) (setq sent (nreverse sent)) (should (= (length sent) 2)) (should (equal (nth 0 sent) msg1)) (should (equal (nth 1 sent) pres1)) (should (= (length (plist-get sd :sm-pending-queue)) 1)) (should (equal (cdar (plist-get sd :sm-pending-queue)) pres2)))) ;;; Transport logging (ert-deftest jabber-test-stanza-log-calls-configured-sink () "Forward enabled XML logs to the configured sink." (let ((jabber-debug-log-xml t) (jabber-stanza-log-function (lambda (jc direction data) (list jc direction data)))) (should (equal (jabber-log-xml 'jc "sending" '(message)) '(jc "sending" (message)))))) (ert-deftest jabber-test-stanza-log-skips-disabled-sink () "Do not call the stanza log sink when XML logging is disabled." (let* ((jabber-debug-log-xml nil) (called nil) (jabber-stanza-log-function (lambda (&rest _) (setq called t)))) (jabber-log-xml 'jc "sending" '(message)) (should-not called))) (ert-deftest jabber-test-sm-resume-id-roundtrip () "Opaque session identifiers survive enable parsing and resume encoding." (dolist (encoded '("a'b&c" "a"b<c>")) (let* ((enabled (with-temp-buffer (insert (format "" encoded)) (car (xml-parse-region (point-min) (point-max))))) (id (plist-get (jabber-sm--parse-enabled enabled) :id)) (resumed (with-temp-buffer (insert (jabber-sm--make-resume-xml 7 id)) (car (xml-parse-region (point-min) (point-max)))))) (should (equal (jabber-xml-get-attribute resumed 'previd) id)) (should (equal (jabber-xml-get-attribute resumed 'h) "7"))))) (ert-deftest jabber-test-sm-fresh-recovery-keeps-tail-and-room-barrier () "Fresh recovery keeps wire order, but blocked rooms permit direct work." (dolist (enabled '(nil t)) (let* ((jc (make-symbol "fresh")) (jabber-connections (list jc)) (jabber-sm-max-in-flight nil) (room '(message ((to . "room@example.org") (type . "groupchat")))) (iq '(iq ((id . "old-iq")))) (direct '(message ((to . "peer@example.org")))) (state (jabber-sm--reset nil)) sent) (setq state (plist-put state :sm-outbound-queue (list (cons 1 room)))) (setq state (plist-put state :sm-outbound-count 1)) (setq state (plist-put state :sm-recovered-queue (list iq))) (setq state (jabber-sm--enqueue-pending state direct)) (setq state (jabber-sm--handle-failed-resume state '(failed ()))) (should (equal (mapcar #'jabber-sm--pending-stanza (plist-get state :sm-pending-queue)) (list room iq direct))) (setq state (plist-put state :sm-enabled enabled)) (setq state (plist-put state :connection 'transport)) (jabber-test-sm--install-drain-state jc state) (cl-letf (((symbol-function 'jabber-send-sexp--raw) (lambda (_jc stanza) (push stanza sent)))) (jabber-sm--drain-pending jc state)) (should (equal (reverse sent) (list iq direct))) (should (equal (mapcar #'jabber-sm--pending-stanza (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (list room)))))) (ert-deftest jabber-test-sm-fresh-fallback-requires-exact-bind () "Missing or wrong namespace bind does not convert or reset retained work." (dolist (feature '(nil (bind ((xmlns . "wrong"))) (other ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind"))))) (dolist (source '(:bind :sm-resume)) (let* ((jc (make-symbol "no-bind")) (jabber-connections (list jc)) (state (jabber-sm--reset nil)) (features `(features () ,@(when feature (list feature)))) (resets 0) (jabber-lifecycle-session-reset-functions (list (lambda (_jc) (cl-incf resets))))) (setq state (plist-put state :sm-enabled t)) (setq state (plist-put state :sm-resuming t)) (setq state (plist-put state :sm-id "old")) (setq state (plist-put state :stream-features features)) (setq state (plist-put state :sm-outbound-queue '((1 message ())))) (put jc :name 'jabber-connection) (put jc :state source) (put jc :state-data state) (cl-letf (((symbol-function 'jabber--send-bind-request) (lambda (&rest _) (ert-fail "Unexpected bind")))) (let ((result (funcall (gethash source (get 'jabber-connection :fsm-event)) jc state (list :stanza (if (eq source :bind) features '(failed ((xmlns . "urn:xmpp:sm:3"))))) #'ignore))) (should-not (car result)) (should (plist-get (cadr result) :sm-id)) (should (plist-get (cadr result) :sm-outbound-queue)) (should (= resets 0)))))))) (ert-deftest jabber-test-sm-fresh-reset-reentry-keeps-current-owner () "Reset hooks may cancel, replace transport, or enqueue behind old work." (dolist (action '(cancel replace enqueue)) (let* ((jc (make-symbol "reset-owner")) (jabber-connections (list jc)) (jabber-lifecycle-connection-list-changed-functions nil) (old '(message ((to . "peer@example.org") (id . "old")))) (new '(message ((to . "peer@example.org") (id . "new")))) (state (jabber-sm--reset nil)) (failures 0) (binds 0) observations (jabber-lifecycle-session-reset-functions (list (lambda (connection) (push (plist-get (fsm-get-state-data connection) :sm-pending-queue) observations) (when (= (length observations) 1) (pcase action ('cancel (jabber-disconnect-one connection)) ('replace (put connection :state :connecting) (put connection :state-data (list :connection 'successor :sm-pending-queue (list (cons 0 new))))) ('enqueue (jabber-send-sexp connection new)))))))) (setq state (plist-put state :connection 'old-transport)) (setq state (plist-put state :stream-features `(features () (bind ((xmlns . ,jabber-bind-xmlns)))))) (setq state (jabber-sm--enqueue-pending state old nil (lambda (_reason) (cl-incf failures)))) (put jc :name 'jabber-connection) (put jc :state :sm-resume) (put jc :state-data state) (cl-letf (((symbol-function 'jabber--send-bind-request) (lambda (&rest _) (cl-incf binds))) ((symbol-function 'jabber-send-stream-header) #'ignore)) (fsm-send-sync jc '(:stanza (failed ((xmlns . "urn:xmpp:sm:3"))))) (should (car (last observations))) (pcase action ('cancel (should-not (memq jc jabber-connections)) (should-not (get jc :state)) (should (= failures 1)) (should (= binds 0))) ('replace (should (eq (get jc :state) :connecting)) (should (eq (plist-get (fsm-get-state-data jc) :connection) 'successor)) (should (= binds 0))) ('enqueue (should (eq (get jc :state) :bind)) (should (= binds 1)) (should (equal (mapcar #'jabber-sm--pending-stanza (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (list old new))))))))) (ert-deftest jabber-sm-test-ack-parser-keeps-pending-fifo () "An IQ callback between acknowledgement and drain cannot overtake messages." (let* ((jc (make-symbol "sm-parser")) (jabber-connections (list jc)) (jabber-sm-max-in-flight 1) (jabber-open-info-queries nil) (jabber-iq-chain '(jabber-process-iq)) (buffer (generate-new-buffer " *jabber-sm-parser*")) (proc (make-pipe-process :name "jabber-sm-parser" :buffer buffer :noquery t)) sent callbacks (state (jabber-sm--reset (list :connection proc :send-function (lambda (_proc wire) (push wire sent)))))) (unwind-protect (progn (put jc :name 'jabber-connection) (put jc :state :session-established) (put jc :state-data state) (plist-put state :sm-enabled t) (jabber-send-sexp jc '(message nil (body nil "first")) (lambda () (push 'first callbacks))) (jabber-send-sexp jc '(message nil (body nil "second")) (lambda () (push 'second callbacks))) (push (list "fifo-iq" (cons (lambda (conn _stanza _context) (jabber-send-sexp conn '(message nil (body nil "third")) (lambda () (push 'third callbacks)))) nil) nil nil) jabber-open-info-queries) (jabber-pre-filter proc "" jc) ;; Exercise the native FSM and its deferred zero-delay timers. (let ((deadline (+ (float-time) 30))) (while (and (< (length sent) 2) (< (float-time) deadline)) (accept-process-output nil 0.01))) (should (= (length sent) 2)) (should (string-match-p "second" (car sent))) (should (equal (reverse callbacks) '(first second))) (jabber-pre-filter proc "" jc) (let ((deadline (+ (float-time) 30))) (while (and (< (length sent) 3) (< (float-time) deadline)) (accept-process-output nil 0.01))) (should (= (length sent) 3)) (should (string-match-p "third" (car sent))) (should (equal (reverse callbacks) '(first second third))) (should (= (plist-get (fsm-get-state-data jc) :sm-outbound-count) 3)) (should-not (plist-get (fsm-get-state-data jc) :sm-pending-queue)) (jabber-pre-filter proc "" jc) (let ((deadline (+ (float-time) 30))) (while (and (plist-get (fsm-get-state-data jc) :sm-outbound-queue) (< (float-time) deadline)) (accept-process-output nil 0.01))) (should-not (plist-get (fsm-get-state-data jc) :sm-outbound-queue)) (should (equal (reverse callbacks) '(first second third)))) (put jc :state nil) (delete-process proc) (kill-buffer buffer)))) (ert-deftest jabber-sm-test-pending-barrier-respects-priority-and-room-gates () "Eligible pending work blocks peers, not higher priority or bootstrap IQ." (let ((state (jabber-sm--reset (list :connection 'transport)))) (plist-put state :sm-enabled t) (jabber-sm--enqueue-pending state '(presence nil)) (should-not (jabber-sm--should-queue-p state '(message nil))) (should (jabber-sm--should-queue-p state '(presence nil))) (should-not (jabber-sm--should-queue-p state '(iq nil))) (plist-put state :sm-pending-queue nil) (jabber-sm--enqueue-pending state '(message nil)) (should (jabber-sm--should-queue-p state '(message nil))) (should (jabber-sm--should-queue-p state '(presence nil))) (should-not (jabber-sm--should-queue-p state '(iq nil))) (plist-put state :sm-pending-queue (list (jabber-sm--pending-entry '(message ((to . "room@example.test") (type . "groupchat"))) nil nil '(:retained-room "room@example.test")))) (should-not (jabber-sm--should-queue-p state '(message ((to . "friend@example.test"))))))) (provide 'jabber-test-sm) ;;; jabber-test-sm.el ends here emacs-jabber-0.15.1/tests/jabber-test-srv.el000066400000000000000000000242521527111033600206130ustar00rootroot00000000000000;;; jabber-test-srv.el --- Tests for jabber-srv -*- lexical-binding: t; -*- ;;; Commentary: ;; SRV DNS lookups and XEP-0368 direct TLS. ;;; Code: (require 'ert) (require 'jabber-srv) (require 'jabber-conn) ;;; Test data helpers (defun jabber-test-srv--make-answer (priority weight port target) "Build an SRV answer alist." (list (list 'priority priority) (list 'weight weight) (list 'port port) (list 'target target))) ;;; Group by priority (ert-deftest jabber-test-srv-group-by-priority-single () "Single priority group." (let* ((a1 (jabber-test-srv--make-answer 10 50 5222 "a.example.com")) (a2 (jabber-test-srv--make-answer 10 50 5222 "b.example.com")) (groups (jabber-srv--group-by-priority (list a1 a2)))) (should (= (length groups) 1)) (should (= (caar groups) 10)) (should (= (length (cdar groups)) 2)))) (ert-deftest jabber-test-srv-group-by-priority-multiple () "Multiple priority groups sorted lowest first." (let* ((a1 (jabber-test-srv--make-answer 20 50 5222 "low.example.com")) (a2 (jabber-test-srv--make-answer 5 50 5222 "high.example.com")) (a3 (jabber-test-srv--make-answer 20 50 5223 "low2.example.com")) (groups (jabber-srv--group-by-priority (list a1 a2 a3)))) (should (= (length groups) 2)) (should (= (caar groups) 5)) (should (= (caadr groups) 20)) (should (= (length (cdadr groups)) 2)))) ;;; Sort answers (ert-deftest jabber-test-srv-sort-answers-preserves-all () "Sort preserves all elements." (let* ((a1 (jabber-test-srv--make-answer 10 50 5222 "a.example.com")) (a2 (jabber-test-srv--make-answer 20 50 5222 "b.example.com")) (a3 (jabber-test-srv--make-answer 10 50 5223 "c.example.com")) (sorted (jabber-srv--sort-answers (list a1 a2 a3)))) (should (= (length sorted) 3)) ;; Priority 10 entries come before priority 20 (let ((targets (mapcar (lambda (a) (cadr (assq 'target a))) sorted))) (should (member "a.example.com" targets)) (should (member "b.example.com" targets)) (should (member "c.example.com" targets)) ;; b.example.com (priority 20) must be last (should (string= (nth 2 targets) "b.example.com"))))) ;;; Fetch answers (ert-deftest jabber-test-srv-fetch-answers-nil () "No DNS results returns nil." (cl-letf (((symbol-function 'jabber-srv--dns-query) (lambda (_target) '((answers nil))))) (should (null (jabber-srv--fetch-answers "_xmpp-client._tcp.example.com"))))) (ert-deftest jabber-test-srv-fetch-answers-dot () "Single dot target returns :dot." (cl-letf (((symbol-function 'jabber-srv--dns-query) (lambda (_target) `((answers (((data ((priority 0) (weight 0) (port 0) (target ".")))))))))) (should (eq :dot (jabber-srv--fetch-answers "_xmpp-client._tcp.example.com"))))) (ert-deftest jabber-test-srv-fetch-answers-records () "Normal records returned as list." (cl-letf (((symbol-function 'jabber-srv--dns-query) (lambda (_target) `((answers (((data ((priority 10) (weight 50) (port 5222) (target "xmpp.example.com")))))))))) (let ((result (jabber-srv--fetch-answers "_xmpp-client._tcp.example.com"))) (should (listp result)) (should (= (length result) 1)) (should (string= (cadr (assq 'target (car result))) "xmpp.example.com"))))) ;;; Lookup mixed (defun jabber-test-srv--mock-fetch (xmpps-answers xmpp-answers) "Return a mock for `jabber-srv--fetch-answers'. XMPPS-ANSWERS is returned for _xmpps queries, XMPP-ANSWERS for _xmpp." (lambda (target) (cond ((string-match "^_xmpps-client" target) xmpps-answers) ((string-match "^_xmpp-client" target) xmpp-answers)))) (ert-deftest jabber-test-srv-lookup-mixed-both () "Both services return records, merged by priority, with fallback appended." (cl-letf (((symbol-function 'jabber-srv--fetch-answers) (jabber-test-srv--mock-fetch (list (jabber-test-srv--make-answer 5 50 443 "tls.example.com")) (list (jabber-test-srv--make-answer 10 50 5222 "plain.example.com"))))) (let ((result (jabber-srv-lookup-mixed "example.com"))) ;; 2 SRV records + 1 fallback (should (= (length result) 3)) ;; Priority 5 (direct TLS) comes first (should (string= (nth 0 (car result)) "tls.example.com")) (should (= (nth 1 (car result)) 443)) (should (nth 2 (car result))) ;; Priority 10 (STARTTLS) comes second (should (string= (nth 0 (cadr result)) "plain.example.com")) (should (= (nth 1 (cadr result)) 5222)) (should-not (nth 2 (cadr result))) ;; Fallback: example.com:5222 STARTTLS at the end (let ((last (car (last result)))) (should (string= (nth 0 last) "example.com")) (should (= (nth 1 last) 5222)) (should-not (nth 2 last)))))) (ert-deftest jabber-test-srv-lookup-mixed-only-xmpp () "Only _xmpp-client returns records, fallback appended." (cl-letf (((symbol-function 'jabber-srv--fetch-answers) (jabber-test-srv--mock-fetch nil (list (jabber-test-srv--make-answer 10 50 5222 "plain.example.com"))))) (let ((result (jabber-srv-lookup-mixed "example.com"))) (should (= (length result) 2)) (should (string= (nth 0 (car result)) "plain.example.com")) (should-not (nth 2 (car result))) ;; Fallback appended (should (equal (cadr result) '("example.com" 5222 nil)))))) (ert-deftest jabber-test-srv-lookup-mixed-only-xmpps () "Only _xmpps-client returns records, with STARTTLS fallback." (cl-letf (((symbol-function 'jabber-srv--fetch-answers) (jabber-test-srv--mock-fetch (list (jabber-test-srv--make-answer 5 50 443 "tls.example.com")) nil))) (let ((result (jabber-srv-lookup-mixed "example.com"))) (should (= (length result) 2)) (should (string= (nth 0 (car result)) "tls.example.com")) (should (nth 2 (car result))) ;; Fallback (should (equal (cadr result) '("example.com" 5222 nil)))))) (ert-deftest jabber-test-srv-lookup-mixed-xmpps-dot () "xmpps-client returns dot, only STARTTLS targets with fallback." (cl-letf (((symbol-function 'jabber-srv--fetch-answers) (jabber-test-srv--mock-fetch :dot (list (jabber-test-srv--make-answer 10 50 5222 "plain.example.com"))))) (let ((result (jabber-srv-lookup-mixed "example.com"))) (should (= (length result) 2)) (should-not (nth 2 (car result))) (should (equal (cadr result) '("example.com" 5222 nil)))))) (ert-deftest jabber-test-srv-lookup-mixed-neither () "Neither service returns records." (cl-letf (((symbol-function 'jabber-srv--fetch-answers) (jabber-test-srv--mock-fetch nil nil))) (should (null (jabber-srv-lookup-mixed "example.com"))))) (ert-deftest jabber-test-srv-lookup-mixed-xmpps-error () "DNS error for xmpps is caught, xmpp results still used with fallback." (cl-letf (((symbol-function 'jabber-srv--fetch-answers) (lambda (target) (cond ((string-match "^_xmpps-client" target) (error "DNS query failed")) ((string-match "^_xmpp-client" target) (list (jabber-test-srv--make-answer 10 50 5222 "plain.example.com"))))))) (let ((result (jabber-srv-lookup-mixed "example.com"))) (should (= (length result) 2)) (should (string= (nth 0 (car result)) "plain.example.com")) (should (equal (cadr result) '("example.com" 5222 nil)))))) ;;; Fallback dedup (ert-deftest jabber-test-srv-has-fallback-p () "Detect existing domain:5222 STARTTLS in target list." (should (jabber-srv--has-fallback-p '(("example.com" 5222 nil)) "example.com")) (should-not (jabber-srv--has-fallback-p '(("other.example.com" 5222 nil)) "example.com")) (should-not (jabber-srv--has-fallback-p '(("example.com" 443 t)) "example.com"))) (ert-deftest jabber-test-srv-lookup-mixed-no-dup-fallback () "No fallback appended when SRV already includes domain:5222 STARTTLS." (cl-letf (((symbol-function 'jabber-srv--fetch-answers) (jabber-test-srv--mock-fetch nil (list (jabber-test-srv--make-answer 10 50 5222 "example.com"))))) (let ((result (jabber-srv-lookup-mixed "example.com"))) ;; SRV already has example.com:5222, no dup fallback (should (= (length result) 1)) (should (equal (car result) '("example.com" 5222 nil)))))) ;;; jabber-srv-targets (ert-deftest jabber-test-srv-targets-user-override () "User-specified network-server returns single STARTTLS target." (let ((result (jabber-srv-targets "example.com" "custom.host" nil))) (should (= (length result) 1)) (should (equal (car result) '("custom.host" 5222 nil))))) (ert-deftest jabber-test-srv-targets-user-port () "User-specified port returns single STARTTLS target." (let ((result (jabber-srv-targets "example.com" nil 5223))) (should (= (length result) 1)) (should (equal (car result) '("example.com" 5223 nil))))) (ert-deftest jabber-test-srv-targets-proxy-bypasses-lookup () "Proxy targets use the configured host directly without SRV lookup." (cl-letf (((symbol-function 'jabber-srv-lookup-mixed) (lambda (&rest _) (ert-fail "Unexpected SRV lookup")))) (let ((proxy '(:type socks5 :host "127.0.0.1" :port 9050))) (should (equal (jabber-srv-targets "example.com" nil nil proxy) '(("example.com" 5222 nil)))) (should (equal (jabber-srv-targets "example.com" "xmpp.example.net" 443 proxy) '(("xmpp.example.net" 443 nil))))))) (ert-deftest jabber-test-srv-targets-fallback () "No SRV records falls back to server:5222." (cl-letf (((symbol-function 'jabber-srv-lookup-mixed) (lambda (_server) nil))) (let ((jabber-direct-tls-lookup t)) (let ((result (jabber-srv-targets "example.com" nil nil))) (should (= (length result) 1)) (should (equal (car result) '("example.com" 5222 nil))))))) (provide 'jabber-test-srv) ;;; jabber-test-srv.el ends here emacs-jabber-0.15.1/tests/jabber-test-styling.el000066400000000000000000000531121527111033600214670ustar00rootroot00000000000000;;; jabber-test-styling.el --- Tests for jabber-styling -*- lexical-binding: t; -*- ;;; Commentary: ;; XEP-0393 Message Styling. ;;; Code: (require 'ert) (require 'jabber-xml) (require 'jabber-disco) (require 'jabber-styling) ;;; Load contract (ert-deftest jabber-test-styling-loads-org-faces () "Loading styling makes its inherited Org faces available." (should (featurep 'org-faces)) (should (facep 'org-block)) (should (facep 'org-block-begin-line))) ;;; Group 1: jabber-styling--classify-block (ert-deftest jabber-test-styling-classify-plain () "Plain text lines classify as plain." (should (eq 'plain (jabber-styling--classify-block "Hello world")))) (ert-deftest jabber-test-styling-classify-quote () "Lines starting with > 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.15.1/tests/jabber-test-time.el000066400000000000000000000021071527111033600207320ustar00rootroot00000000000000;;; 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.15.1/tests/jabber-test-util.el000066400000000000000000000472041527111033600207600ustar00rootroot00000000000000;;; 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) (require 'jabber-core) (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 ((old-zone (getenv "TZ")) (process-environment (copy-sequence process-environment))) (unwind-protect (dolist (zone '("UTC0" "Etc/GMT-3")) (set-time-zone-rule zone) (let ((result (jabber-message-timestamp '(message nil (x ((xmlns . "jabber:x:delay") (stamp . "20240101T12:30:45"))))))) (should (time-equal-p result (encode-time '(45 30 12 1 1 2024 nil -1 0)))) (should (equal (jabber-encode-legacy-time result) "20240101T12:30:45")))) (set-time-zone-rule old-zone)))) (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 (lambda (jid) (jabber-jid-symbol jid jc)) 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"))) (ert-deftest jabber-test-util-jid-resource-does-not-change-bare-parts () "Ignore resource delimiters when extracting the account identity." (dolist (bare '("alice@example.test" "example.test")) (dolist (resource '("" "/desktop@host" "/desk/@host/other")) (let ((jid (concat bare resource))) (should (equal (jabber-jid-username jid) (and (string-prefix-p "alice@" bare) "alice"))) (should (equal (jabber-jid-server jid) "example.test")) (should (equal (jabber-jid-user jid) bare)) (should (equal (jabber-jid-resource jid) (unless (equal resource "") (substring resource 1)))))))) (ert-deftest jabber-test-util-bind-resource-at-sign () "Preserve all bound JID parts and the account key through the bind handler." (let* ((jc (make-symbol "bind")) (state (jabber-sm--reset (list :username "alice" :server "example.test" :resource "desktop@host" :stream-features '(features nil)))) (result (funcall (gethash :bind (get 'jabber-connection :fsm-event)) jc state '(:bind-success (iq ((type . "result")) (bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind")) (jid nil "alice@example.test/desktop@host")))) #'ignore)) (bound (cadr result))) (put jc :state-data bound) (should (equal (plist-get bound :username) "alice")) (should (equal (plist-get bound :server) "example.test")) (should (equal (plist-get bound :resource) "desktop@host")) (should (equal (jabber-connection-bare-jid jc) "alice@example.test")))) (ert-deftest jabber-test-util-parse-time-fractions-and-offsets () "Preserve fractional seconds and signed offsets in either time format." ;; These semantic assertions replace the representation-specific cases ;; from parse-date.el; the exact integer/cons/list layout is Emacs-owned. (dolist (current-time-list '(nil t)) (dolist (fraction '("" ".500" ".550")) (dolist (offset '(("" . 0) ("Z" . 0) ("+00:00" . 0) ("-00:00" . 0) ("+01:00" . 3600) ("-01:00" . -3600))) (let* ((stamp (concat "2024-02-25T23:32:40" fraction (car offset))) (expected (+ (- 1708903960 (cdr offset)) (if (equal fraction "") 0 (string-to-number fraction))))) (should (< (abs (- (float-time (jabber-parse-time stamp)) expected)) 0.000001))))))) (defvar jabber-test-util--chain-seen nil) (ert-deftest jabber-test-util-chain-accepts-list-functions () "A bare list-form function in a chain is called whole. Interpreted closures are such conses before Emacs 30." (let ((handler '(lambda (_jc xml) (setq jabber-test-util--chain-seen xml))) (jabber-message-chain nil) (jabber-test-util--chain-seen nil)) (jabber-chain-add 'jabber-message-chain #'ignore 5) (push handler jabber-message-chain) ;; A legacy bare entry is recognised as already present. (jabber-chain-add 'jabber-message-chain handler) (should (= 2 (length jabber-message-chain))) (jabber-process-input 'jc '(message ((id . "m")))) (should (equal jabber-test-util--chain-seen '(message ((id . "m"))))))) (provide 'jabber-test-util) ;;; jabber-test-util.el ends here emacs-jabber-0.15.1/tests/jabber-test-vcard-avatars.el000066400000000000000000000017571527111033600225440ustar00rootroot00000000000000;;; 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.15.1/tests/load-all.el000066400000000000000000000003541527111033600172630ustar00rootroot00000000000000;; 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.15.1/tests/nick-change-fail.el000066400000000000000000000060161527111033600206570ustar00rootroot00000000000000;; -*- 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.15.1/tests/omemo-c-test.c000066400000000000000000000066601527111033600177370ustar00rootroot00000000000000/* Local picomemo regressions. Synthetic stores only; never print material. * The CBC fault is linked only into this standalone test executable. */ #include #include #include #include #include #include "picomemo/omemo.h" static int fail_cbc; int __real_mbedtls_aes_crypt_cbc(mbedtls_aes_context *, int, size_t, unsigned char iv[16], const unsigned char *, unsigned char *); int __wrap_mbedtls_aes_crypt_cbc(mbedtls_aes_context *ctx, int mode, size_t n, unsigned char *iv, const unsigned char *src, unsigned char *dst) { if (fail_cbc) { /* A failed backend may already have written partial output. */ memset(dst, 0xa5, n); return MBEDTLS_ERR_AES_INVALID_INPUT_LENGTH; } return __real_mbedtls_aes_crypt_cbc(ctx, mode, n, iv, src, dst); } static void encrypt_failure(void) { struct omemoStore alice, bob; struct omemoSession sender = {0}, receiver = {0}, before; omemoSerializedKey spk, ik, pk; struct omemoKeyMessage msg, empty = {0}; uint8_t key[32] = {0}, out[32]; assert(!omemoSetupStore(&alice)); assert(!omemoSetupStore(&bob)); omemoSerializeKey(spk, bob.cursignedprekey.kp.pub); omemoSerializeKey(ik, bob.identity.pub); omemoSerializeKey(pk, bob.prekeys[0].kp.pub); assert(!omemoInitiateSession(&sender, &alice, bob.cursignedprekey.sig, spk, ik, pk, bob.cursignedprekey.id, bob.prekeys[0].id)); /* Check both the first message and a subsequent chain advance. */ for (int i = 0; i < 2; i++) { memcpy(&before, &sender, sizeof before); memset(&msg, 0xa5, sizeof msg); fail_cbc = 1; int rc = omemoEncryptKey(&sender, &msg, key, sizeof key); fail_cbc = 0; assert(rc == OMEMO_ECRYPTO); assert(!memcmp(&before, &sender, sizeof sender)); assert(!memcmp(&empty, &msg, sizeof msg)); assert(!omemoEncryptKey(&sender, &msg, key, sizeof key)); size_t n = sizeof out; assert(!omemoDecryptKey(&receiver, &bob, out, &n, msg.isprekey, msg.p, msg.n)); assert(n == sizeof key && !memcmp(out, key, n)); } } static void store_roundtrip(void) { struct omemoStore store, restored = {0}; assert(!omemoSetupStore(&store)); for (int i = 0; i < 28; i++) { memset(&store.prekeys[0], 0, sizeof store.prekeys[0]); assert(!omemoRefillPreKeys(&store)); } assert(store.pkcounter == 128); size_t n = omemoGetSerializedStoreSize(&store); uint8_t *blob = malloc(n), *copy = malloc(n); assert(blob && copy); omemoSerializeStore(blob, &store); assert(!omemoDeserializeStore(blob, n, &restored)); assert(omemoGetSerializedStoreSize(&restored) == n); omemoSerializeStore(copy, &restored); assert(!memcmp(blob, copy, n)); /* A repeated entry cannot extend past the enclosing input. */ assert(omemoDeserializeStore(blob, n - 1, &restored) == OMEMO_EPROTOBUF); /* The identity private key still has a fixed schema length of 32. */ assert(blob[2] == 0x12 && blob[3] == 32); blob[3] = 31; assert(omemoDeserializeStore(blob, n, &restored) == OMEMO_EPROTOBUF); free(copy); free(blob); } int main(int argc, char **argv) { assert(argc == 2); if (!strcmp(argv[1], "encrypt")) encrypt_failure(); else { assert(!strcmp(argv[1], "store")); store_roundtrip(); } puts("picomemo regression passed"); return 0; } emacs-jabber-0.15.1/tests/omemo-random-test.c000066400000000000000000000064551527111033600207770ustar00rootroot00000000000000/* Regression for the module's real RNG callback (not picomemo's weak fallback). * SPDX-License-Identifier: GPL-3.0-or-later * TEST_OPENBSD and TEST_ANDROID simulate APIs, not native OS builds. */ #include #include #include #include #include #include #include #include #include #include "picomemo/omemo.h" #if defined(__ANDROID__) || defined(TEST_ANDROID) #include #include #elif !defined(__OpenBSD__) #include #endif static int calls; static int failure; static size_t requested; static ssize_t test_getrandom(void *p, size_t n, unsigned int flags) { assert(flags == 0); calls++; requested = n; if (failure == 1) { errno = EIO; return -1; } memset(p, 0xa5, n); return failure == 2 ? (ssize_t)n - 1 : (ssize_t)n; } static void test_arc4random_buf(void *p, size_t n) { calls++; requested = n; memset(p, 0xa5, n); } /* Retain the incoming patch's API semantics as a mutation-test oracle. */ static int test_getentropy(void *p, size_t n) { if (n > 256) { errno = EIO; return -1; } test_arc4random_buf(p, n); return 0; } /* All host headers are loaded before selecting a simulated platform branch. */ #if defined(TEST_OPENBSD) && !defined(__OpenBSD__) #define __OpenBSD__ 1 #endif #if defined(TEST_ANDROID) && !defined(__ANDROID__) #define __ANDROID__ 1 #endif #if defined(__ANDROID__) /* Production Android expands getrandom to syscall; intercept that boundary. */ static long test_syscall(long number, ...) { assert(number == SYS_getrandom); va_list args; va_start(args, number); void *p = va_arg(args, void *); size_t n = va_arg(args, size_t); int flags = va_arg(args, int); va_end(args); return test_getrandom(p, n, flags); } #define syscall test_syscall #else #define getrandom test_getrandom #endif #define arc4random_buf test_arc4random_buf #define getentropy test_getentropy #ifndef OMEMO_CORE_SOURCE #define OMEMO_CORE_SOURCE "../src/jabber-omemo-core.c" #endif #include OMEMO_CORE_SOURCE int main(void) { unsigned char buf[602]; const size_t lengths[] = {0, 1, 32, 64, 257, 600}; for (size_t i = 0; i < sizeof(lengths) / sizeof(lengths[0]); i++) { size_t n = lengths[i]; memset(buf, 0x5a, sizeof(buf)); calls = 0; assert(omemoRandom(buf + 1, n) == 0); assert(calls == 1 && requested == n); assert(buf[0] == 0x5a && buf[n + 1] == 0x5a); for (size_t j = 1; j <= n; j++) assert(buf[j] == 0xa5); } #if defined(__OpenBSD__) /* A mistaken getrandom path must not pass the success checks above. */ failure = 1; assert(omemoRandom(buf, 32) == 0); puts("OpenBSD API simulation: full fills and zero-success passed"); #else for (failure = 1; failure <= 2; failure++) { assert(omemoRandom(buf, 32) != 0); uint8_t key[32], iv[12], plaintext[1] = {0}, ciphertext[1]; assert(omemoEncryptMessage(ciphertext, key, iv, plaintext, 1) != 0); } #if defined(__ANDROID__) puts("Android syscall API simulation: full fills, errors and short reads passed"); #else puts("getrandom API: full fills, errors and short-read propagation passed"); #endif #endif return 0; } emacs-jabber-0.15.1/tests/parse-next-stanza.el000066400000000000000000000010521527111033600211560ustar00rootroot00000000000000;; 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")))