diff options
Diffstat (limited to 'emacs/xmpp.el')
| -rw-r--r-- | emacs/xmpp.el | 438 |
1 files changed, 438 insertions, 0 deletions
diff --git a/emacs/xmpp.el b/emacs/xmpp.el new file mode 100644 index 0000000..40b43af --- /dev/null +++ b/emacs/xmpp.el @@ -0,0 +1,438 @@ +;;; 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. Might be nice to reuse some generic IM UI library, +;; something like lui.el. + +;; This is even less polished than the library. + +;;; Code: + +(require 'xml) +(require 'seq) + +(defvar xmpp-command "rexmpp_xml_interface" + "A command to run an XMPP client subprocess.") + +(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-request-queue nil + "A subprocess request queue.") +(make-variable-buffer-local 'xmpp-request-queue) + + +(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-child (xml elem) + (seq-find (lambda (x) (and (consp x) (eq (xml-node-name x) elem))) + 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)) + (process-send-eof cur-proc)))) + +(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)) + (message-openpgp (xmpp-xml-child message-contents 'openpgp))) + (if message-openpgp + ;; TODO: check validation results. + (xmpp-request `(openpgp-decrypt-message nil ,message-xml) + (lambda (response) + (let* ((payload (xmpp-xml-child response 'payload))) + (funcall func (car (xml-node-children payload))))) + proc) + (funcall func message-body)))) + +(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 (eq (xml-node-name xml) 'message) + (xmpp-with-message-body + proc xml + (lambda (message-body) + (let ((message-from (xml-get-attribute-or-nil xml 'from))) + (pcase (xml-get-attribute-or-nil xml 'type) + ("chat" + (when message-body + (with-current-buffer (xmpp-query message-from proc) + (xmpp-insert + (concat "< " (car (xml-node-children message-body)) "\n"))))) + ("groupchat" + (when message-body + (with-current-buffer (xmpp-muc-buffer message-from proc) + (xmpp-insert + (concat (xmpp-jid-resource message-from) ": " + (car (xml-node-children message-body)) "\n"))))))))))) + +(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 (eq (xml-node-name xml) 'message) + (xmpp-with-message-body + ;; The "from" attribute is needed for validation. + proc (xmpp-set-from proc xml) + (lambda (message-body) + (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 + "> " (car (xml-node-children message-body)) "\n"))))))) + ("groupchat" nil))))))) + +(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)) + (xml-elem (car xml))) + (pcase (xml-node-name xml-elem) + ('request + (pcase (car (xml-node-children xml-elem)) + (`(sasl ((property . ,prop))) + (xmpp-proc-write `((response nil ,(read-passwd + (concat "SASL " prop ": ")))) + proc)) + (`(xml-in nil ,xml-in) + (progn (xmpp-process-input proc xml-in) + (xmpp-proc-write '((response nil "0")) proc))) + (`(xml-out nil ,xml-out) + (progn (xmpp-process-output proc xml-out) + (xmpp-proc-write '((response nil "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 + (when (cdar (last xmpp-request-queue)) + (funcall (cdar (last xmpp-request-queue)) + (car (xml-node-children xml-elem)))) + (setq-local xmpp-request-queue + (reverse (cdr (reverse xmpp-request-queue)))) + ;; send the next request if we have any queued + (when xmpp-request-queue + (xmpp-proc-write `((request nil ,(caar (last xmpp-request-queue)))) + xmpp-proc))))))) + +(defun xmpp-request (req cb &optional proc) + (let ((cur-proc (or proc xmpp-proc))) + (with-current-buffer (process-buffer cur-proc) + (when (not xmpp-request-queue) + (xmpp-proc-write `((request nil ,req)) cur-proc)) + (push (cons req cb) xmpp-request-queue)))) + +(defun xmpp-stop (&optional proc) + (interactive) + (xmpp-request '(stop) nil proc)) + +(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 (xml-parse-region (point-min) (1- zero)))) + (xmpp-process proc xml) + (delete-region (point-min) zero) + (setq zero (search-forward "\0" nil t))))))))) + +(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-request-queue 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-insert (args) + (save-excursion + (goto-char xmpp-input-point) + (funcall 'insert args) + (setq-local xmpp-input-point (point))) + (goto-char (point-max))) + +(defun xmpp-insert-xml (xml) + (save-excursion + (goto-char xmpp-input-point) + (xml-print xml) + (setq-local xmpp-input-point (point))) + (goto-char (point-max))) + +(defun xmpp-send-input () + (interactive) + (let ((input (buffer-substring xmpp-input-point (point-max)))) + (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 (xml-parse-region xmpp-input-point (point-max)))))) + (delete-region xmpp-input-point (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." + (setq-local xmpp-input-point (point-min))) + +(define-derived-mode xmpp-query-mode xmpp-mode "XMPP-query" + "XMPP Query major mode." + (setq-local xmpp-input-point (point-min))) + +(define-derived-mode xmpp-muc-mode xmpp-mode "XMPP-MUC" + "XMPP Query major mode." + (setq-local xmpp-input-point (point-min))) + +(define-derived-mode xmpp-console-mode xmpp-mode "XMPP-text-console" + "XMPP Text Console major mode." + (setq-local xmpp-input-point (point-min))) + +(define-derived-mode xmpp-xml-mode xmpp-mode "XMPP-XML-console" + "XMPP XML Console major mode." + (setq-local xmpp-input-point (point-min))) + + +(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)) + (bare-jid (xmpp-jid-to-bare jid))) + (with-current-buffer (process-buffer process) + (if (assoc bare-jid xmpp-query-buffers) + (let ((query-buf (cdr (assoc bare-jid xmpp-query-buffers)))) + (display-buffer query-buf) + query-buf) + (let ((query-buf (generate-new-buffer (concat "*xmpp:" bare-jid "*")))) + (with-current-buffer query-buf + (xmpp-query-mode) + (setq-local xmpp-jid bare-jid) + (setq-local xmpp-proc process) + (setq-local kill-buffer-query-functions + (cons #'xmpp-query-buffer-on-close + kill-buffer-query-functions))) + (push (cons bare-jid query-buf) xmpp-query-buffers) + (display-buffer query-buf) + query-buf))))) + +(defun xmpp-muc-join (jid &optional nick proc) + (interactive "sConference JID: ") + (let* ((process (or proc xmpp-proc)) + (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"))))) + (let ((buf (xmpp-muc-buffer jid proc))) + (with-current-buffer buf + (setq-local xmpp-muc-my-nick my-nick)) + buf))) + +(defun xmpp-muc-leave (jid &optional proc) + (interactive "sConference JID: ") + (let ((process (or proc xmpp-proc)) + (full-jid (concat jid "/" xmpp-muc-my-nick))) + (xmpp-send `(presence ((xmlns . "jabber:client") + (id . ,(xmpp-gen-id)) + (to . ,full-jid) + (type . "unavailable")))))) + + +(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) + (if (assoc bare-jid xmpp-muc-buffers) + (let ((muc-buf (cdr (assoc bare-jid xmpp-muc-buffers)))) + (display-buffer muc-buf) + muc-buf) + (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) + (display-buffer muc-buf) + muc-buf))))) + +(provide 'xmpp) + +;;; xmpp.el ends here |