diff options
Diffstat (limited to 'emacs')
| -rw-r--r-- | emacs/README | 24 | ||||
| -rw-r--r-- | emacs/xml_interface.c | 402 | ||||
| -rw-r--r-- | emacs/xmpp.el | 701 |
3 files changed, 1127 insertions, 0 deletions
diff --git a/emacs/README b/emacs/README new file mode 100644 index 0000000..efa192c --- /dev/null +++ b/emacs/README @@ -0,0 +1,24 @@ +xmpp.el - an Emacs interface to rexmpp + +Since Emacs can't poll sockets and use rexmpp directly, this works by +introducing a program which basically serializes library calls and +callbacks into XML, and which xmpp.el runs as a subprocess. + +Once rexmpp_xml_interface is built, and possibly the path to it is +adjusted in the xmpp-command variable, one can load xmpp.el, set a +password in ~/.authinfo (or elsewhere auth-source will be able to read +it from, with "port xmpp"), perhaps enable tracking-mode, and run M-x +xmpp RET <JID> RET. + +The buffers it creates are an XML console, a text console (using +rexmpp's console module, type "help" to see the available commands), a +process buffer, a log buffer. The xmpp-query function (or just +incoming messages) will create query buffers for one-to-one chats, +xmpp-muc-join creates MUC ones. + +The used XML interface will probably be adjusted, and there's still a +lot to add or improve in xmpp.el, but it is fairly usable (i.e., +replaces bitlbee + rcirc for me) since September 2021. + +Possibly in the future it will work with other libraries as well, +and/or will be moved out of the rexmpp's repository. diff --git a/emacs/xml_interface.c b/emacs/xml_interface.c new file mode 100644 index 0000000..f98d5d1 --- /dev/null +++ b/emacs/xml_interface.c @@ -0,0 +1,402 @@ +/** + @file xml-interface.c + @brief An XML interface to communicate with Emacs. + @author defanor <defanor@uberspace.net> + @date 2021 + @copyright MIT license. + +A basic and ad hoc XML interface. The parent process (e.g., Emacs) is +supposed to respond to requests starting with the most recent one. + +This program's output is separated with NUL ('\0') characters, to +simplify parsing in Emacs, while the input is separated with newlines, +to simplify reading with rexmpp_xml_read_fd. + +*/ + +#include <string.h> +#include <stdio.h> +#include <errno.h> +#include <syslog.h> +#include <gnutls/gnutls.h> +#include <rexmpp.h> +#include <rexmpp_xml.h> +#include <rexmpp_openpgp.h> +#include <rexmpp_http_upload.h> + + +void print_xml (rexmpp_xml_t *node) { + char *s = rexmpp_xml_serialize(node, 0); + printf("%s%c\n", s, '\0'); + free(s); +} + +char *request (rexmpp_t *s, rexmpp_xml_t *payload) +{ + rexmpp_xml_t *req = rexmpp_xml_new_elem("request", NULL); + rexmpp_xml_add_id(req); + rexmpp_xml_add_child(req, payload); + print_xml(req); + char *id = strdup(rexmpp_xml_find_attr_val(req, "id")); + rexmpp_xml_free(req); + return id; +} + +void req_process (rexmpp_t *s, + rexmpp_xml_t *elem); + +rexmpp_xml_t *read_response (rexmpp_t *s, const char *id) { + rexmpp_xml_t *elem = rexmpp_xml_read_fd(STDIN_FILENO); + if (elem != NULL) { + if (rexmpp_xml_match(elem, NULL, "response")) { + const char *resp_id = rexmpp_xml_find_attr_val(elem, "id"); + if (resp_id != NULL) { + if (strcmp(resp_id, id) == 0) { + return elem; + } else { + /* Just fail for now, to avoid deadlocks. Though this + shouldn't happen. */ + rexmpp_xml_free(elem); + rexmpp_log(s, LOG_ERR, "Unexpected response ID received."); + return NULL; + } + } + } + req_process(s, elem); + rexmpp_xml_free(elem); + } + return read_response(s, id); +} + +rexmpp_xml_t *req_block (rexmpp_t *s, rexmpp_xml_t *req) { + char *id = request(s, req); + rexmpp_xml_t *resp = read_response(s, id); + free(id); + return resp; +} + +void respond_xml (rexmpp_t *s, + const char *id, + rexmpp_xml_t *payload) { + rexmpp_xml_t *response = rexmpp_xml_new_elem("response", NULL); + rexmpp_xml_add_attr(response, "id", id); + if (payload != NULL) { + rexmpp_xml_add_child(response, payload); + } + print_xml(response); + rexmpp_xml_free(response); +} + +void respond_text (rexmpp_t *s, + const char *id, + const char *buf) { + rexmpp_xml_t *response = rexmpp_xml_new_elem("response", NULL); + rexmpp_xml_add_attr(response, "id", id); + if (buf != NULL) { + rexmpp_xml_add_text(response, buf); + } + print_xml(response); + rexmpp_xml_free(response); +} + +void on_http_upload (rexmpp_t *s, void *cb_data, const char *url) { + char *id = cb_data; + respond_text(s, id, url); + free(id); +} + +void req_process (rexmpp_t *s, + rexmpp_xml_t *elem) +{ + const char *id = rexmpp_xml_find_attr_val(elem, "id"); + if (id == NULL) { + return; + } + rexmpp_err_t err; + char buf[64]; + rexmpp_xml_t *child = rexmpp_xml_first_elem_child(elem); + if (rexmpp_xml_match(child, NULL, "stop")) { + snprintf(buf, 64, "%d", rexmpp_stop(s)); + respond_text(s, id, buf); + } else if (rexmpp_xml_match(child, NULL, "console")) { + char *in = strdup(rexmpp_xml_text_child(child)); + rexmpp_console_feed(s, in, strlen(in)); + free(in); + respond_text(s, id, NULL); + } else if (rexmpp_xml_match(child, NULL, "send")) { + if (rexmpp_xml_first_elem_child(child)) { + rexmpp_xml_t *stanza = + rexmpp_xml_clone(rexmpp_xml_first_elem_child(child)); + snprintf(buf, 64, "%d", rexmpp_send(s, stanza)); + respond_text(s, id, buf); + } + } else if (rexmpp_xml_match(child, NULL, "openpgp-decrypt-message")) { + int valid; + rexmpp_xml_t *plaintext = + rexmpp_openpgp_decrypt_verify_message(s, rexmpp_xml_first_elem_child(child), + &valid); + /* todo: wrap into another element, with the 'valid' attribute */ + respond_xml(s, id, plaintext); + } else if (rexmpp_xml_match(child, NULL, "openpgp-payload")) { + enum rexmpp_ox_mode mode = REXMPP_OX_CRYPT; + const char *mode_str = rexmpp_xml_find_attr_val(child, "mode"); + if (strcmp(mode_str, "sign") == 0) { + mode = REXMPP_OX_SIGN; + } else if (strcmp(mode_str, "signcrypt") == 0) { + mode = REXMPP_OX_SIGNCRYPT; + } + + rexmpp_xml_t *payload_xml = + rexmpp_xml_first_elem_child(rexmpp_xml_find_child(child, NULL, "payload")); + + char *recipients[16]; + int recipients_num = 0; + rexmpp_xml_t *plchild; + for (plchild = rexmpp_xml_first_elem_child(child); + plchild != NULL && recipients_num < 15; + plchild = plchild->next) { + if (rexmpp_xml_match(plchild, NULL, "to")) { + recipients[recipients_num] = strdup(rexmpp_xml_text_child(plchild)); + recipients_num++; + } + } + recipients[recipients_num] = NULL; + char *payload_str = + rexmpp_openpgp_payload(s, rexmpp_xml_clone(payload_xml), + (const char **)recipients, NULL, mode); + for (recipients_num = 0; recipients[recipients_num] != NULL; recipients_num++) { + free(recipients[recipients_num]); + } + respond_text(s, id, payload_str); + free(payload_str); + } else if (rexmpp_xml_match(child, NULL, "get-name")) { + const char *jid = rexmpp_xml_text_child(child); + if (jid != NULL) { + char *name = rexmpp_get_name(s, jid); + if (name != NULL) { + respond_text(s, id, name); + free(name); + } + } + } else if (rexmpp_xml_match(child, NULL, "http-upload")) { + char *in = strdup(rexmpp_xml_text_child(child)); + rexmpp_http_upload_path(s, NULL, in, NULL, on_http_upload, strdup(id)); + free(in); + /* Responding from on_http_upload */ + } else if (rexmpp_xml_match(child, NULL, "muc-ping-set")) { + const char *occupant_jid = rexmpp_xml_find_attr_val(child, "occupant-jid"); + const char *delay = rexmpp_xml_find_attr_val(child, "delay"); + const char *password = rexmpp_xml_find_attr_val(child, "password"); + if (occupant_jid != NULL && delay != NULL) { + snprintf(buf, 64, "%d", + rexmpp_muc_ping_set(s, occupant_jid, password, atoi(delay))); + respond_text(s, id, buf); + } + } else if (rexmpp_xml_match(child, NULL, "muc-ping-remove")) { + const char *occupant_jid = rexmpp_xml_find_attr_val(child, "occupant-jid"); + if (occupant_jid != NULL) { + snprintf(buf, 64, "%d", rexmpp_muc_ping_remove(s, occupant_jid)); + respond_text(s, id, buf); + } + } + return; +} + +void my_logger (rexmpp_t *s, int priority, const char *fmt, va_list args) { + /* Or could just use stderr. */ + char *buf = malloc(4096); + vsnprintf(buf, 4096, fmt, args); + char *priority_str = "unknown"; + switch (priority) { + case LOG_EMERG: priority_str = "emerg"; break; + case LOG_ALERT: priority_str = "alert"; break; + case LOG_CRIT: priority_str = "crit"; break; + case LOG_ERR: priority_str = "err"; break; + case LOG_WARNING: priority_str = "warning"; break; + case LOG_NOTICE: priority_str = "notice"; break; + case LOG_INFO: priority_str = "info"; break; + case LOG_DEBUG: priority_str = "debug"; break; + } + rexmpp_xml_t *node = rexmpp_xml_new_elem("log", NULL); + rexmpp_xml_add_attr(node, "priority", priority_str); + rexmpp_xml_add_text(node, buf); + free(buf); + print_xml(node); + rexmpp_xml_free(node); +} + +int my_console_print_cb (rexmpp_t *s, const char *fmt, va_list args) { + char *buf = malloc(1024 * 20); + vsnprintf(buf, 1024 * 20, fmt, args); + rexmpp_xml_t *node = rexmpp_xml_new_elem("console", NULL); + rexmpp_xml_add_text(node, buf); + free(buf); + print_xml(node); + rexmpp_xml_free(node); + return 0; +} + +int my_sasl_property_cb (rexmpp_t *s, rexmpp_sasl_property prop) { + if (prop == REXMPP_SASL_PROP_AUTHID) { + rexmpp_sasl_property_set (s, REXMPP_SASL_PROP_AUTHID, s->initial_jid.local); + return 0; + } + char *prop_str = NULL; + switch (prop) { + case REXMPP_SASL_PROP_PASSWORD: prop_str = "password"; break; + case REXMPP_SASL_PROP_AUTHID: prop_str = "authid"; break; + default: return -1; + } + rexmpp_xml_t *req = rexmpp_xml_new_elem("sasl", NULL); + rexmpp_xml_add_attr(req, "property", prop_str); + rexmpp_xml_t *rep = req_block(s, req); + if (rep == NULL) { + return -1; + } + const char *val = rexmpp_xml_text_child(rep); + if (val == NULL) { + return -1; + } + rexmpp_sasl_property_set (s, prop, val); + rexmpp_xml_free(rep); + return GSASL_OK; +} + +int my_xml_in_cb (rexmpp_t *s, rexmpp_xml_t *node) { + rexmpp_xml_t *req = rexmpp_xml_new_elem("xml-in", NULL); + rexmpp_xml_add_child(req, rexmpp_xml_clone(node)); + rexmpp_xml_t *rep = req_block(s, req); + if (rep == NULL) { + return 0; + } + const char *val = rexmpp_xml_text_child(rep); + if (val == NULL) { + return 0; + } + int n = atoi(val); + rexmpp_xml_free(rep); + return n; +} + +int my_xml_out_cb (rexmpp_t *s, rexmpp_xml_t *node) { + rexmpp_xml_t *req = rexmpp_xml_new_elem("xml-out", NULL); + rexmpp_xml_add_child(req, rexmpp_xml_clone(node)); + rexmpp_xml_t *rep = req_block(s, req); + if (rep == NULL) { + return 0; + } + const char *val = rexmpp_xml_text_child(rep); + if (val == NULL) { + return 0; + } + int n = atoi(val); + rexmpp_xml_free(rep); + return n; +} + + +int main (int argc, char **argv) { + + /* The minimal initialisation: provide an allocated rexmpp_t + structure and an initial jid. */ + rexmpp_t s; + rexmpp_err_t err; + err = rexmpp_init(&s, argv[1], my_logger); + if (err != REXMPP_SUCCESS) { + return -1; + } + s.sasl_property_cb = my_sasl_property_cb; + s.xml_in_cb = my_xml_in_cb; + s.xml_out_cb = my_xml_out_cb; + s.console_print_cb = my_console_print_cb; + + /* Could set a client certificate for SASL EXTERNAL authentication + here. */ + /* gnutls_certificate_set_x509_key_file(s.gnutls_cred, */ + /* "cert.pem", */ + /* "key.pem", */ + /* GNUTLS_X509_FMT_PEM); */ + + /* Could also set various other things manually. */ + /* s.socks_host = "127.0.0.1"; */ + /* s.socks_port = 4321; */ + /* s.manual_host = "foo.custom"; */ + /* gnutls_certificate_set_x509_trust_file(s.gnutls_cred, */ + /* "foo.custom.crt", */ + /* GNUTLS_X509_FMT_PEM); */ + /* rexmpp_openpgp_set_home_dir(&s, "pgp"); */ + s.roster_cache_file = "roster.xml"; + + + /* Once the main structure is initialised and everything is + sufficiently configured, we are ready to run the main loop and + call rexmpp from it. */ + + fd_set read_fds, write_fds; + int nfds; + struct timespec tv; + struct timespec *mtv; + struct timeval tv_ms; + struct timeval *mtv_ms; + int n = 0; + + do { + /* Check if we have some user input. */ + if (n > 0 && FD_ISSET(STDIN_FILENO, &read_fds)) { + rexmpp_xml_t *elem = rexmpp_xml_read_fd(STDIN_FILENO); + if (elem != NULL) { + req_process(&s, elem); + rexmpp_xml_free(elem); + } + } + + /* Run a single rexmpp iteration. */ + err = rexmpp_run(&s, &read_fds, &write_fds); + + if (err == REXMPP_SUCCESS) { + break; + } + if (err != REXMPP_E_AGAIN) { + printf("error: %s\n", rexmpp_strerror(err)); + break; + } + /* Could inspect the state here. */ + /* printf("res %d / conn %d / tls %d / sasl %d / stream %d / carbons %d\n", */ + /* s.resolver_state, */ + /* s.tcp_state, */ + /* s.tls_state, */ + /* s.sasl_state, */ + /* s.stream_state, */ + /* s.carbons_state); */ + + /* Ask rexmpp which file descriptors it is interested in, and what + the timeouts should be. */ + FD_ZERO(&read_fds); + FD_ZERO(&write_fds); + nfds = rexmpp_fds(&s, &read_fds, &write_fds); + mtv = rexmpp_timeout(&s, NULL, &tv); + mtv_ms = NULL; + if (mtv != NULL) { + tv_ms.tv_sec = mtv->tv_sec; + tv_ms.tv_usec = mtv->tv_nsec / 1000; + mtv_ms = &tv_ms; + } + + /* Add other file descriptors we are interested in, particularly + stdin for user input. */ + FD_SET(STDIN_FILENO, &read_fds); + + /* Run select(2) with all those file descriptors and timeouts, + waiting for either user input or some rexmpp event to occur. */ + n = select(nfds, &read_fds, &write_fds, NULL, mtv_ms); + if (n == -1) { + printf("select error: %s\n", strerror(errno)); + break; + } + } while (1); + + /* Deinitialise the rexmpp structure in the end, freeing whatever it + allocated. */ + rexmpp_done(&s); + return 0; +} diff --git a/emacs/xmpp.el b/emacs/xmpp.el new file mode 100644 index 0000000..ebe6911 --- /dev/null +++ b/emacs/xmpp.el @@ -0,0 +1,701 @@ +;;; xmpp.el --- an XMPP client -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 defanor + +;; Author: defanor <defanor@uberspace.net> +;; Maintainer: defanor <defanor@uberspace.net> +;; Created: 2021-02-24 +;; Keywords: xmpp, rexmpp +;; Homepage: https://git.uberspace.net/rexmpp/ +;; Version: 0.0.0 + +;; This file is not part of GNU Emacs. + +;; 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; See rexmpp's xml_interface.c. Possibly it'll also work with other +;; libraries later. + +;; This is even less polished than the library. + +;;; Code: + +(require 'xml) +(require 'seq) +(require 'tracking) +(require 'auth-source) + +(defgroup xmpp nil + "An Emacs interface to rexmpp." + :prefix "xmpp-" + :group 'applications) + +(defface xmpp-timestamp + '((((type graphic) (class color) (background dark)) :foreground "SteelBlue") + (((type graphic) (class color) (background light)) :foreground "SteelBlue")) + "Timestamp face." + :group 'xmpp) + +(defface xmpp-my-nick + '((((type graphic) (class color) (background dark)) :foreground "LightSkyBlue") + (((type graphic) (class color) (background light)) :foreground "Blue") + (t :weight bold)) + "Own nick face." + :group 'xmpp) + +(defface xmpp-other-nick + '((((type graphic) (class color) (background dark)) :foreground "PaleGreen") + (((type graphic) (class color) (background light)) :foreground "DarkGreen") + (t :weight bold)) + "Others' nick face." + :group 'xmpp) + +(defface xmpp-presence + '((((type graphic) (class color) (background dark)) :foreground "wheat1") + (((type graphic) (class color) (background light)) :foreground "wheat4")) + "Presence notification face." + :group 'xmpp) + +(defface xmpp-action + '((((type graphic) (class color) (background dark)) :foreground "thistle1") + (((type graphic) (class color) (background light)) :foreground "thistle4")) + "Action (/me) face." + :group 'xmpp) + + +(defvar xmpp-command "rexmpp_xml_interface" + "A command to run an XMPP client subprocess.") + +(defvar xmpp-timestamp-format "%H:%M" + "Time string format to use in query buffers.") + +(defvar xmpp-proc nil + "XMPP process buffer. This should be defined for all the + XMPP-related buffers.") +(make-variable-buffer-local 'xmpp-proc) + +(defvar xmpp-jid nil + "User JID related to a current XMPP-related buffer.") +(make-variable-buffer-local 'xmpp-jid) + +(defvar xmpp-query-buffers nil + "An association list of query buffers corresponding to JIDs.") +(make-variable-buffer-local 'xmpp-query-buffers) + +(defvar xmpp-muc-buffers nil + "An association list of MUC buffers corresponding to conference + JIDs.") +(make-variable-buffer-local 'xmpp-muc-buffers) + +(defvar xmpp-log-buffer nil + "An XMPP log buffer.") +(make-variable-buffer-local 'xmpp-log-buffer) + +(defvar xmpp-console-buffer nil + "An XMPP text console buffer.") +(make-variable-buffer-local 'xmpp-console-buffer) + +(defvar xmpp-xml-buffer nil + "An XMPP XML console buffer.") +(make-variable-buffer-local 'xmpp-xml-buffer) + +(defvar xmpp-active-requests nil + "Active requests for a subprocess.") +(make-variable-buffer-local 'xmpp-active-requests) + +(defvar xmpp-truncate-buffer-at 100000 + "The buffer size at which to truncate an XMPP-related buffer by + approximately halving it.") + +(defun xmpp-timestamp-string (&optional time) + (let ((str (format-time-string xmpp-timestamp-format time))) + (add-face-text-property 0 (length str) 'xmpp-timestamp nil str) + str)) + +(defun xmpp-activity-notify () + (tracking-add-buffer (current-buffer))) + +(defun xmpp-jid-to-bare (jid) + (let* ((jid-list (reverse (string-to-list jid))) + (resource-pos (seq-position jid-list ?/))) + (if resource-pos + (concat (reverse (seq-drop jid-list (1+ resource-pos)))) + jid))) + +(defun xmpp-jid-localpart (jid) + (let* ((jid-list (string-to-list jid)) + (at-pos (seq-position jid-list ?@))) + (when at-pos + (concat (seq-take jid-list at-pos))))) + +(defun xmpp-jid-resource (jid) + (let* ((jid-list (reverse (string-to-list jid))) + (resource-pos (seq-position jid-list ?/))) + (if resource-pos + (concat (reverse (seq-take jid-list resource-pos))) + jid))) + + +(defun xmpp-gen-id () + (number-to-string (random))) + +(defun xmpp-xml-set-xmlns (node &optional parent-ns) + "Propagates xmlns to child elements. This is a temporary hack +to keep using xml.el without proper namespace parsing, so that +its printing--which doesn't handle namespaces--can be used too." + (if (listp node) + (let* ((xmlns (xml-get-attribute-or-nil node 'xmlns)) + (ns (or xmlns parent-ns)) + (attrs (xml-node-attributes node))) + (cons (xml-node-name node) + (cons (if xmlns + attrs + (if ns + (cons (cons 'xmlns ns) attrs) + attrs)) + (mapcar (lambda (x) (xmpp-xml-set-xmlns x ns)) (xml-node-children node))))) + node)) + +(defun xmpp-xml-parse-region (&optional beg end buffer) + (mapcar 'xmpp-xml-set-xmlns + (xml-parse-region beg end buffer))) + +(defun xmpp-xml-match (xml name ns) + (and (consp xml) + (eq (xml-node-name xml) name) + (equal (xml-get-attribute-or-nil xml 'xmlns) ns))) + +(defun xmpp-xml-child (xml name &optional ns) + (seq-find (lambda (x) (xmpp-xml-match x name ns)) xml)) + +(defun xmpp-proc-write (xml &optional proc) + (let ((cur-proc (or proc xmpp-proc))) + (with-temp-buffer + (xml-print xml) + (insert "\n") + (process-send-region cur-proc (point-min) (point-max))))) + +(defun xmpp-with-message-body (proc message-xml func) + (let* ((message-contents (xml-node-children message-xml)) + (message-body (xmpp-xml-child message-contents 'body "jabber:client")) + (message-openpgp (xmpp-xml-child message-contents 'openpgp "urn:xmpp:openpgp:0"))) + (if message-openpgp + ;; TODO: check validation results. + (xmpp-request `(openpgp-decrypt-message nil ,message-xml) + (lambda (response) + (let* ((payload (xmpp-xml-child response 'payload "urn:xmpp:openpgp:0"))) + (funcall func (car (xml-node-children payload))))) + proc) + (funcall func message-body)))) + +(defun xmpp-message-string (str) + (if (string-prefix-p "/me " str) + (let ((action (substring str 3))) + (add-face-text-property + 0 + (length action) + 'xmpp-action + nil + action) + action) + (concat ": " str))) + +(defun xmpp-process-input (proc xml) + (with-current-buffer (process-buffer proc) + (with-current-buffer xmpp-xml-buffer + (xmpp-insert (format "<!-- server, %s -->\n" (current-time-string))) + (xmpp-insert-xml (list xml)) + (xmpp-insert "\n")) + (when (xmpp-xml-match xml 'presence "jabber:client") + (let* ((presence-from (xml-get-attribute-or-nil xml 'from)) + (presence-type (or (xml-get-attribute-or-nil xml 'type) "available")) + (presence-show (car (xml-node-children (xmpp-xml-child xml 'show "jabber:client")))) + (presence-status (car (xml-node-children (xmpp-xml-child xml 'status "jabber:client")))) + (presence-string + (concat + presence-from " is " + presence-type + (when presence-show + (concat " (" presence-show ")")) + (when presence-status + (concat ": " presence-status)))) + (bare-jid (xmpp-jid-to-bare presence-from)) + (resourcepart (xmpp-jid-resource presence-from))) + (add-face-text-property + 0 + (length presence-string) + 'xmpp-presence + nil + presence-string) + (when (assoc bare-jid xmpp-query-buffers) + (with-current-buffer (cdr (assoc bare-jid xmpp-query-buffers)) + (xmpp-insert (concat + (xmpp-timestamp-string) ", " + presence-string "\n")))) + (when (assoc bare-jid xmpp-muc-buffers) + (with-current-buffer (cdr (assoc bare-jid xmpp-muc-buffers)) + (xmpp-insert + (concat (xmpp-timestamp-string) ", " + presence-string "\n"))))))) + (when (xmpp-xml-match xml 'message "jabber:client") + (let* ((carbons-sent (xmpp-xml-child xml 'sent "urn:xmpp:carbons:2")) + (carbons-received (xmpp-xml-child xml 'received "urn:xmpp:carbons:2")) + (carbons-forwarded (xmpp-xml-child (or carbons-sent carbons-received) + 'forwarded "urn:xmpp:forward:0")) + (carbons-message (xmpp-xml-child carbons-forwarded 'message "jabber:client")) + (message-xml (or carbons-message xml)) + (message-from (xml-get-attribute-or-nil message-xml 'from)) + (message-delay (xmpp-xml-child message-xml 'delay "urn:xmpp:delay")) + (message-time (if message-delay + (encode-time + (iso8601-parse + (xml-get-attribute-or-nil message-delay 'stamp))) + (current-time))) + (chat-with (cond (carbons-sent (xml-get-attribute-or-nil message-xml 'to)) + (t message-from)))) + (xmpp-with-message-body + proc message-xml + (lambda (message-body) + (when message-body + (let ((message-str + (xmpp-message-string (car (xml-node-children message-body))))) + (xmpp-with-name + message-from + (lambda (message-from-name) + (pcase (xml-get-attribute-or-nil xml 'type) + ("chat" + (with-current-buffer (xmpp-query chat-with proc) + (add-face-text-property + 0 + (length message-from-name) + (if (equal (with-current-buffer (process-buffer xmpp-proc) xmpp-jid) + (xmpp-jid-to-bare chat-with)) + 'xmpp-my-nick + 'xmpp-other-nick) + nil + message-from-name) + (xmpp-insert + (concat (xmpp-timestamp-string message-time) ", " + message-from-name + message-str "\n")) + (xmpp-activity-notify))) + ("groupchat" + (with-current-buffer (xmpp-muc-buffer chat-with proc) + (let ((from-nick (xmpp-jid-resource message-from))) + (add-face-text-property + 0 + (length from-nick) + (if (equal xmpp-muc-my-occupant-jid message-from) + 'xmpp-my-nick + 'xmpp-other-nick) + nil + from-nick) + (xmpp-insert + (concat (xmpp-timestamp-string message-time) ", " + from-nick + message-str "\n")) + (xmpp-activity-notify)))))))))))))) + +(defun xmpp-set-from (proc xml) + (let* ((name (xml-node-name xml)) + (attr (xml-node-attributes xml)) + (children (xml-node-children xml)) + (new-attr (if (assoc 'from attr) + attr + (cons (cons 'from + (with-current-buffer + (process-buffer proc) + xmpp-jid)) + attr)))) + (cons name (cons new-attr children)))) + +(defun xmpp-process-output (proc xml) + (with-current-buffer (process-buffer proc) + (with-current-buffer xmpp-xml-buffer + (xmpp-insert (format "<!-- client, %s -->\n" (current-time-string))) + (xmpp-insert-xml (list xml)) + (xmpp-insert "\n"))) + (when (xmpp-xml-match xml 'message "jabber:client") + (xmpp-with-message-body + ;; The "from" attribute is needed for validation. + proc (xmpp-set-from proc xml) + (lambda (message-body) + (xmpp-with-name + xmpp-jid + (lambda (my-name) + (add-face-text-property 0 (length my-name) 'xmpp-my-nick nil my-name) + (let ((message-to (xml-get-attribute-or-nil xml 'to))) + (pcase (xml-get-attribute-or-nil xml 'type) + ("chat" + (when message-body + (let ((buf (xmpp-query message-to proc))) + (when buf + (with-current-buffer buf + (xmpp-insert + (concat + (xmpp-timestamp-string) ", " + my-name + (xmpp-message-string + (car (xml-node-children message-body))) + "\n"))))))) + ("groupchat" nil)))))))) + (when (and (xmpp-xml-match xml 'presence "jabber:client") + (or (not (xml-get-attribute-or-nil xml 'type)) + (equal (xml-get-attribute-or-nil xml 'type) "available")) + (xmpp-xml-child xml 'x "http://jabber.org/protocol/muc")) + ;; Joining a MUC + (let* ((occupant-jid (xml-get-attribute xml 'to)) + (muc-jid (xmpp-jid-to-bare occupant-jid)) + (buf (xmpp-muc-buffer muc-jid proc))) + (with-current-buffer buf + (setq-local xmpp-muc-my-occupant-jid occupant-jid))))) + +(defun xmpp-process (proc xml) + (let* ((buf (process-buffer proc)) + (log-buf (with-current-buffer buf xmpp-log-buffer)) + (console-buf (with-current-buffer buf xmpp-console-buffer)) + (my-jid (with-current-buffer buf xmpp-jid)) + (xml-elem (car xml))) + (pcase (xml-node-name xml-elem) + ('request + (let ((rid (xml-get-attribute xml-elem 'id))) + (pcase (car (xml-node-children xml-elem)) + (`(sasl ((property . ,prop))) + (let ((resp + (if (equal prop "password") + (let ((secret + (plist-get + (car + (auth-source-search + :max 1 + :user my-jid + :port "xmpp" + :require '(:user :secret))) :secret))) + (if (functionp secret) + (funcall secret) + secret)) + (read-passwd + (concat "SASL " prop ": "))))) + (xmpp-proc-write `((response ((id . ,rid)) ,resp)) + proc))) + (`(xml-in nil ,xml-in) + (progn (xmpp-process-input proc xml-in) + (xmpp-proc-write `((response ((id . ,rid)) "0")) proc))) + (`(xml-out nil ,xml-out) + (progn (xmpp-process-output proc xml-out) + (xmpp-proc-write `((response ((id . ,rid)) "0")) proc)))))) + ('log + (with-current-buffer log-buf + (goto-char (point-max)) + (insert (format "%s [%s] %s\n" (current-time-string) + (xml-get-attribute xml-elem 'priority) + (car (xml-node-children xml-elem)))))) + ('console + (with-current-buffer console-buf + (xmpp-insert (car (xml-node-children xml-elem))))) + ('response + (with-current-buffer buf + (let* ((rid (xml-get-attribute xml-elem 'id)) + (cb (alist-get rid xmpp-active-requests nil nil 'string-equal))) + (setq xmpp-active-requests + (assoc-delete-all rid xmpp-active-requests)) + (when cb + (funcall cb (car (xml-node-children xml-elem)))))))))) + +(defun xmpp-request (req cb &optional proc) + (let ((cur-proc (or proc xmpp-proc)) + (req-id (xmpp-gen-id))) + (with-current-buffer (process-buffer cur-proc) + (xmpp-proc-write `((request ((id . ,req-id)) ,req)) cur-proc) + (push (cons req-id cb) xmpp-active-requests)))) + +(defun xmpp-with-name (jid cb &optional proc) + (let ((cur-proc (or proc xmpp-proc)) + (bare-jid (xmpp-jid-to-bare jid))) + (with-current-buffer (process-buffer cur-proc) + ;; Use resource for MUC private messages, determine a nick + ;; otherwise. + (if (assoc bare-jid xmpp-muc-buffers) + (funcall cb (xmpp-jid-resource jid)) + (xmpp-request `(get-name nil ,jid) cb proc))))) + +(defun xmpp-http-upload (path &optional proc) + (interactive "fFile path: ") + (xmpp-request + `(http-upload nil ,path) + (lambda (url) + (kill-new url) + (message "Uploaded the file to %s" url)) + proc)) + +(defun xmpp-stop (&optional proc) + (interactive) + (xmpp-request '(stop) nil proc)) + +(defun xmpp-kill-buffers (&optional proc) + (interactive) + (when (and xmpp-log-buffer + xmpp-console-buffer + xmpp-xml-buffer) + (mapcar (lambda (b) (kill-buffer (cdr b))) xmpp-query-buffers) + (mapcar (lambda (b) (kill-buffer (cdr b))) xmpp-muc-buffers) + (kill-buffer xmpp-log-buffer) + (kill-buffer xmpp-console-buffer) + (kill-buffer xmpp-xml-buffer) + (kill-buffer))) + +(defun xmpp-send (xml &optional proc) + (xmpp-request `(send nil ,xml) nil proc)) + +(defun xmpp-filter (proc str) + (when (buffer-live-p (process-buffer proc)) + (with-current-buffer (process-buffer proc) + (save-excursion + (goto-char (point-max)) + (insert str) + (goto-char (point-min)) + (let ((zero (search-forward "\0" nil t))) + (while zero + (let ((xml (xmpp-xml-parse-region (point-min) (1- zero)))) + (xmpp-process proc xml) + (delete-region (point-min) zero) + (setq zero (search-forward "\0" nil t))))))))) + +;;;###autoload +(defun xmpp (jid) + "Initiates a new XMPP session." + (interactive "sJID: ") + (let* ((bare-jid (xmpp-jid-to-bare jid)) + (proc-buf (generate-new-buffer + (concat "*xmpp:" bare-jid " process*")))) + (with-current-buffer proc-buf + (setq-local xmpp-jid bare-jid) + (setq-local xmpp-active-requests nil) + (setq-local xmpp-query-buffers '()) + (setq-local xmpp-muc-buffers '()) + (setq-local xmpp-log-buffer + (generate-new-buffer + (concat "*xmpp:" bare-jid " log*"))) + (setq-local xmpp-console-buffer + (generate-new-buffer + (concat "*xmpp:" bare-jid " text console*"))) + (setq-local xmpp-xml-buffer + (generate-new-buffer + (concat "*xmpp:" bare-jid " XML console*"))) + (with-current-buffer xmpp-console-buffer + (xmpp-console-mode)) + (with-current-buffer xmpp-xml-buffer + (xmpp-xml-mode)) + (setq-local xmpp-proc + (make-process :name "xmpp" + :command (list xmpp-command jid) + :buffer proc-buf + :filter 'xmpp-filter)) + (let ((new-proc xmpp-proc)) + (with-current-buffer xmpp-console-buffer + (setq-local xmpp-proc new-proc)) + (with-current-buffer xmpp-xml-buffer + (setq-local xmpp-proc new-proc)) + (with-current-buffer xmpp-log-buffer + (setq-local xmpp-proc new-proc)))))) + +(defun xmpp-restart (&optional proc) + "Restarts an XMPP process." + (interactive) + (let* ((cur-proc (or proc xmpp-proc)) + (proc-buf (process-buffer cur-proc))) + (when (and cur-proc (process-live-p cur-proc)) + (xmpp-stop cur-proc)) + (with-current-buffer proc-buf + (setq-local xmpp-active-requests nil) + (setq-local xmpp-proc + (make-process :name "xmpp" + :command (list xmpp-command xmpp-jid) + :buffer proc-buf + :filter 'xmpp-filter)) + (let ((new-proc xmpp-proc)) + (mapcar (lambda (b) + (with-current-buffer b (setq-local xmpp-proc new-proc))) + (append (list xmpp-console-buffer xmpp-xml-buffer xmpp-log-buffer) + (mapcar 'cdr xmpp-query-buffers) + (mapcar 'cdr xmpp-muc-buffers))))))) + +(defun xmpp-insert (args) + (save-excursion + (when (and xmpp-truncate-buffer-at + (> xmpp-prompt-start-marker xmpp-truncate-buffer-at)) + (goto-char (/ xmpp-truncate-buffer-at 2)) + (search-forward "\n") + (delete-region (point-min) (point))) + (goto-char xmpp-prompt-start-marker) + (funcall 'insert args) + (set-marker xmpp-prompt-start-marker (point)) + (set-marker xmpp-prompt-end-marker (+ 2 (point))))) + +(defun xmpp-insert-xml (xml) + (save-excursion + (goto-char xmpp-prompt-start-marker) + (xml-print xml) + (setq-local xmpp-prompt-start-marker (point-marker)) + (goto-char (+ 2 xmpp-prompt-start-marker)) + (setq-local xmpp-prompt-end-marker (point-marker)))) + +(defun xmpp-send-input () + (interactive) + (let ((input (buffer-substring xmpp-prompt-end-marker (point-max)))) + (unless (string-empty-p input) + (pcase major-mode + ('xmpp-query-mode (xmpp-send `(message ((xmlns . "jabber:client") + (id . ,(xmpp-gen-id)) + (to . ,xmpp-jid) + (type . "chat")) + (body nil ,input)))) + ('xmpp-muc-mode (xmpp-send `(message ((xmlns . "jabber:client") + (id . ,(xmpp-gen-id)) + (to . ,xmpp-jid) + (type . "groupchat")) + (body nil ,input)))) + ('xmpp-console-mode (xmpp-request `(console nil ,input) nil xmpp-proc)) + ('xmpp-xml-mode + (mapcar 'xmpp-send (xmpp-xml-parse-region xmpp-prompt-end-marker (point-max)))))) + (delete-region xmpp-prompt-end-marker (point-max)))) + + +(defvar xmpp-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'xmpp-send-input) + map) + "Keymap for `xmpp-mode'.") + +(define-derived-mode xmpp-mode nil "XMPP" + "XMPP major mode." + (insert "> ") + (add-text-properties (point-min) (point-max) + '(field t read-only t rear-nonsticky t)) + (setq-local xmpp-prompt-start-marker (point-min-marker)) + (setq-local xmpp-prompt-end-marker (point-max-marker))) + +(define-derived-mode xmpp-query-mode xmpp-mode "XMPP-query" + "XMPP Query major mode.") + +(define-derived-mode xmpp-muc-mode xmpp-mode "XMPP-MUC" + "XMPP Query major mode.") + +(define-derived-mode xmpp-console-mode xmpp-mode "XMPP-text-console" + "XMPP Text Console major mode.") + +(define-derived-mode xmpp-xml-mode xmpp-mode "XMPP-XML-console" + "XMPP XML Console major mode.") + + +(defun xmpp-query-buffer-on-close () + (let ((query-jid xmpp-jid)) + (when (buffer-live-p (process-buffer xmpp-proc)) + (with-current-buffer (process-buffer xmpp-proc) + (setq xmpp-query-buffers + (seq-remove (lambda (x) (equal (car x) query-jid)) + xmpp-query-buffers))))) + t) + +(defun xmpp-muc-buffer-on-close () + (let ((muc-jid xmpp-jid)) + (when (buffer-live-p (process-buffer xmpp-proc)) + (with-current-buffer (process-buffer xmpp-proc) + (setq xmpp-muc-buffers + (seq-remove (lambda (x) (equal (car x) muc-jid)) + xmpp-muc-buffers))))) + t) + +(defun xmpp-query (jid &optional proc) + (interactive "sQuery JID: ") + (let ((process (or proc xmpp-proc))) + (with-current-buffer (process-buffer process) + ;; Use full JID for MUC private messages, but a bare JID for + ;; regular chats. + (let* ((bare-jid (xmpp-jid-to-bare jid)) + (target-jid (if (assoc bare-jid xmpp-muc-buffers) + jid + bare-jid)) + (buf (if (assoc target-jid xmpp-query-buffers) + (cdr (assoc target-jid xmpp-query-buffers)) + (let ((query-buf (generate-new-buffer + (concat "*xmpp:" target-jid "*")))) + (with-current-buffer query-buf + (xmpp-query-mode) + (setq-local xmpp-jid target-jid) + (setq-local xmpp-proc process) + (setq-local kill-buffer-query-functions + (cons #'xmpp-query-buffer-on-close + kill-buffer-query-functions))) + (push (cons target-jid query-buf) xmpp-query-buffers) + query-buf)))) + (when (interactive-p) + (display-buffer buf)) + buf)))) + +(defun xmpp-muc-join (jid &optional nick proc) + (interactive "sConference JID: ") + (with-current-buffer (process-buffer (or proc xmpp-proc)) + (let* ((bare-jid (xmpp-jid-to-bare jid)) + (my-nick (or nick (xmpp-jid-localpart xmpp-jid))) + (full-jid (concat bare-jid "/" my-nick))) + (xmpp-send `(presence ((xmlns . "jabber:client") + (id . ,(xmpp-gen-id)) + (to . ,full-jid)) + (x ((xmlns . "http://jabber.org/protocol/muc"))))) + (xmpp-request + `(muc-ping-set ((occupant-jid . ,full-jid) + (delay . "600")) + nil) + nil + proc)))) + +(defun xmpp-muc-leave (jid &optional proc) + (interactive "sConference JID: ") + (with-current-buffer (process-buffer (or proc xmpp-proc)) + (with-current-buffer (cdr (assoc jid xmpp-muc-buffers)) + (xmpp-send `(presence ((xmlns . "jabber:client") + (id . ,(xmpp-gen-id)) + (to . ,xmpp-muc-my-occupant-jid) + (type . "unavailable")))) + (xmpp-request + `(muc-ping-remove ((occupant-jid . ,xmpp-muc-my-occupant-jid)) + nil) + nil)))) + +(defun xmpp-muc-buffer (jid &optional proc) + (let* ((process (or proc xmpp-proc)) + (bare-jid (xmpp-jid-to-bare jid))) + (with-current-buffer (process-buffer process) + (let ((buf (if (assoc bare-jid xmpp-muc-buffers) + (cdr (assoc bare-jid xmpp-muc-buffers)) + (let ((muc-buf (generate-new-buffer (concat "*xmpp:" bare-jid "*")))) + (with-current-buffer muc-buf + (xmpp-muc-mode) + (setq-local xmpp-jid bare-jid) + (setq-local xmpp-proc process) + (setq-local kill-buffer-query-functions + (cons #'xmpp-muc-buffer-on-close + kill-buffer-query-functions))) + (push (cons bare-jid muc-buf) xmpp-muc-buffers) + muc-buf)))) + (when (interactive-p) + (display-buffer buf)) + buf)))) + +(provide 'xmpp) + +;;; xmpp.el ends here |