summaryrefslogtreecommitdiffhomepage
path: root/lib/net
diff options
context:
space:
mode:
Diffstat (limited to 'lib/net')
-rw-r--r--lib/net/jao-eww-session.el192
-rw-r--r--lib/net/jao-frm.el222
-rw-r--r--lib/net/jao-notmuch-gnus.el106
-rw-r--r--lib/net/jao-notmuch.el383
-rw-r--r--lib/net/jao-r2e.el231
-rw-r--r--lib/net/jao-url.el45
-rw-r--r--lib/net/randomsig.el93
-rw-r--r--lib/net/signel.org546
8 files changed, 613 insertions, 1205 deletions
diff --git a/lib/net/jao-eww-session.el b/lib/net/jao-eww-session.el
index 9a34656..76da717 100644
--- a/lib/net/jao-eww-session.el
+++ b/lib/net/jao-eww-session.el
@@ -1,6 +1,6 @@
;;; jao-eww-session.el --- Persistent eww sessions -*- lexical-binding: t; -*-
-;; Copyright (C) 2003, 2004, 2006, 2007, 2008, 2009, 2012, 2021, 2022 Jose A Ortega Ruiz
+;; Copyright (C) 2003-2004, 2006-2009, 2012, 2021-2022, 2025-2026 Jose A Ortega Ruiz
;; Author: Jose A Ortega Ruiz <jao@gnu.org>
;; Version: 0.4
@@ -21,212 +21,86 @@
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
-;;; Commentary:
-
-;; jao-eww-session provides persistent eww browsing sessions. When
-;; quitting eww (or, if you request it, at any other time while using
-;; it) you can save the current eww session (that is, the set of open
-;; tabs and the URLs they're visiting). Upon restarting emacs, you'll
-;; have the possibity of recovering the saved session (that is, of
-;; re-opening the saved tabs and URLs). You also have at your disposal
-;; a command to recover the saved session at any other time, via the
-;; commands:
-;;
-;; jao-eww-session-load -- load the last stored session
-;; jao-eww-session-save -- save the current session
-;;
-;; A customization group, jao-eww-session, is available. There you can
-;; customize the following variables:
-
;;; Code:
;;; Dependencies:
(require 'eww)
(require 'url)
-
-;;; Custom variables:
-
-(defgroup jao-eww-session nil
- "eww - session saving in eww."
- :group 'eww
- :prefix "jao-eww-session-")
-
-(defcustom jao-eww-session-save-always nil
- "If on, always save eww session without asking."
- :type 'boolean)
-
-(defcustom jao-eww-session-load-always t
- "If on, always load eww session without asking."
- :type 'boolean)
-
-(defcustom jao-eww-session-show-titles t
- "If on, show URL titles in the load prompt."
- :type 'boolean)
-
-(defcustom jao-eww-session-duplicate-tabs 'never
- "How to treat session URL already being visited.
-
-When loading a session with `jao-eww-session-load', if one of the URLs in
-the session is already displayed in a eww tab, jao-eww-session can:
-- `never' create a new tab (just reload it), or
-- `always' duplicate the URL in a new tab, or
-- `ask' the user what to do."
- :type '(choice (const :value never)
- (const :value always)
- (const :value ask)))
-
-(defcustom jao-eww-session-file "~/.emacs.d/eww-session.eld"
- "File to save the eww session data."
- :type 'file)
+(require 'multisession)
;;; Internals:
;;;; auxiliary functions
-(defvar jao-eww-current-session '(jao-eww-session 0 nil))
+(define-multisession-variable jao-eww-session '(0))
-(defun jao-eww-session--list-buffers (&optional skip)
+(defun jao-eww-session--current (&optional s)
+ (when s (setf (multisession-value jao-eww-session) s))
+ (multisession-value jao-eww-session))
+
+(defun jao-eww-session-eww-buffers (&optional skip)
(seq-filter (lambda (b)
(when (not (eq b skip))
(with-current-buffer b (derived-mode-p 'eww-mode))))
(buffer-list)))
-(defun jao-eww-session-invisible-buffers ()
- (seq-filter (lambda (b) (null (get-buffer-window b)))
- (jao-eww-session--list-buffers (current-buffer))))
-
(defun jao-eww--current-url ()
- (when-let (url (eww-current-url)) (url-encode-url url)))
+ (when-let* ((url (eww-current-url))) (url-encode-url url)))
(defun jao-eww-session--current-urls (&optional skip-current)
(let ((urls)
(cb (current-buffer))
(pos 0)
(count 0))
- (dolist (b (jao-eww-session--list-buffers (when skip-current cb))
+ (dolist (b (jao-eww-session-eww-buffers (when skip-current cb))
(list pos (reverse urls)))
(set-buffer b)
- (when-let (url (jao-eww--current-url))
+ (when-let* ((url (jao-eww--current-url)))
(when (eq b cb) (setq pos count))
(setq count (1+ count))
(push (cons url (jao-eww-buffer-title)) urls)))))
(defun jao-eww-session-urls (&optional s)
- (let ((s (or s jao-eww-current-session)))
- (mapcar 'car (nth 2 s))))
+ (mapcar 'car (cadr (or s (jao-eww-session--current)))))
(defun jao-eww-session-offset (&optional s)
- (let ((s (or s jao-eww-current-session)))
- (nth 1 s)))
+ (car (or s (jao-eww-session--current))))
(defun jao-eww-session-titles (&optional s)
- (let ((s (or s jao-eww-current-session)))
- (mapcar 'cdr (nth 2 s))))
+ (let ((s (or s (jao-eww-session--current))))
+ (mapcar 'cdr (cadr s))))
-(defun jao-eww-session--update-current (&optional skip-current)
- (save-current-buffer
- (setq jao-eww-current-session
- (cons 'jao-eww-session (jao-eww-session--current-urls skip-current)))))
+(defun jao-eww-session--update ()
+ (jao-eww-session--current (jao-eww-session--current-urls)))
(defun jao-eww-session--find-dups (urls)
(seq-filter
(lambda (b)
- (with-current-buffer b
- (when-let (url (jao-eww--current-url))
- (when (member url urls)
- (when (y-or-n-p "Already open session, abort? ")
- (switch-to-buffer b)
- (user-error "Aborted"))
- (or (and (eq jao-eww-session-duplicate-tabs 'never))
- (not (y-or-n-p (format "'%s' (%s) is already open. Duplicate? "
- (jao-eww-buffer-title) url))))))))
- (jao-eww-session--list-buffers)))
-
-(defun jao-eww-session-load-aux ()
- (let ((new-session (jao-eww-session-from-file
- (expand-file-name jao-eww-session-file))))
- (when (and new-session
- (or jao-eww-session-load-always
- (y-or-n-p
- (if jao-eww-session-show-titles
- (format "Load last eww session %S? "
- (jao-eww-session-titles new-session))
- "Load last eww session? "))))
- (setq jao-eww-current-session new-session))))
-
-(defun jao-eww-session-from-file (fname)
- (let ((fname (jao-eww-session--check--backup fname)))
- (when (file-readable-p fname)
- (with-temp-buffer
- (insert-file-contents fname)
- (goto-char (point-min))
- (let ((sexp (read (current-buffer))))
- (and (equal 'jao-eww-session (car sexp)) sexp))))))
-
-(defun jao-eww-session-not-empty () (> (length (jao-eww-session-urls)) 0))
-
-(defun jao-eww-session--to--file (filename &optional skip)
- (require 'pp)
- (when (jao-eww-session-not-empty)
- (let ((inhibit-message t)
- (session (jao-eww-session--update-current skip)))
- (with-temp-buffer
- (insert ";;;; File generated by jao-eww-session. DO NOT EDIT!\n")
- (pp session (current-buffer))
- (insert "\n" ";;;; End of "
- (file-name-nondirectory jao-eww-session-file) "\n")
- (write-region (point-min) (point-max) (expand-file-name filename))))))
-
-(defun jao-eww-session--backup-name (fname)
- (concat (expand-file-name fname) ".bak"))
-
-(defun jao-eww-session--check--backup (fname)
- (let ((bfname (jao-eww-session--backup-name fname)))
- (if (and (file-newer-than-file-p bfname fname)
- (y-or-n-p "A newer autosaved session exists. Use it? "))
- bfname
- fname)))
-
-(defun jao-eww-session--save-backup (&optional skip)
- (let ((f (jao-eww-session--backup-name jao-eww-session-file)))
- (jao-eww-session--to--file f skip)))
-
-(defun jao-eww-session--save-backup-1 ()
- (when (derived-mode-p 'eww-mode) (jao-eww-session--save-backup t)))
+ (with-current-buffer b (member (jao-eww--current-url) urls)))
+ (jao-eww-session-eww-buffers)))
;;;; save session on checkpoints
-(add-hook 'kill-emacs-query-functions #'jao-eww-session-save)
-(add-hook 'kill-buffer-hook #'jao-eww-session--save-backup-1)
-(add-hook 'eww-after-render-hook #'jao-eww-session--save-backup)
-(advice-add 'eww-back-url :after #'jao-eww-session--save-backup)
-(advice-add 'eww-forward-url :after #'jao-eww-session--save-backup)
+(add-hook 'eww-after-render-hook #'jao-eww-session--update)
+(advice-add 'eww-back-url :after #'jao-eww-session--update)
+(advice-add 'eww-forward-url :after #'jao-eww-session--update)
-;;;###autoload
(defun jao-eww-buffer-title () (plist-get eww-data :title))
-;;;###autoload
-(defun jao-eww-session-save ()
- "Save the current eww session."
- (interactive)
- (when (and (jao-eww-session-not-empty)
- (or jao-eww-session-save-always (y-or-n-p "Save eww session? ")))
- (jao-eww-session--to--file jao-eww-session-file))
- t)
-
-;;;###autoload
(defun jao-eww-session-load ()
"Load last stored session into eww."
(interactive)
- (when-let ((s (jao-eww-session-load-aux)))
- (let* ((urls (jao-eww-session-urls s))
- (offset (jao-eww-session-offset s))
- (buffers (unless (equal jao-eww-session-duplicate-tabs 'always)
- (jao-eww-session--find-dups urls))))
- (dolist (url urls) (eww url 4))
- (seq-each #'kill-buffer buffers)
- (unless (zerop offset)
- (switch-to-buffer (nth offset (jao-eww-session--list-buffers)))))))
+ (let* ((urls (jao-eww-session-urls))
+ (offset (jao-eww-session-offset))
+ (dups (jao-eww-session--find-dups urls)))
+ (dolist (url urls) (eww url 4))
+ (seq-each #'kill-buffer dups)
+ (unless (zerop offset)
+ (switch-to-buffer (nth offset (jao-eww-session-eww-buffers))))))
+
+(defun jao-eww-session-invisible-buffers ()
+ (seq-filter (lambda (b) (null (get-buffer-window b)))
+ (jao-eww-session-eww-buffers (current-buffer))))
(provide 'jao-eww-session)
;;; jao-eww-session.el ends here
diff --git a/lib/net/jao-frm.el b/lib/net/jao-frm.el
deleted file mode 100644
index 2658687..0000000
--- a/lib/net/jao-frm.el
+++ /dev/null
@@ -1,222 +0,0 @@
-;;; jao-frm.el --- use frm to show mailbox
-
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2019, 2020
-
-;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
-;; Keywords: mail
-
-;; 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 3, 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:
-
-;; Little hack to see the contents of your mailbox using GNU mailutils'
-;; `frm' program.
-;;
-;; Just put (require 'jao-frm) in your .emacs, and M-x jao-frm will pop up a
-;; new window with your mailbox contents (from and subject) as
-;; printed by frm. In this buffer, use `n' and `p' to move, `q' to close
-;; the window. `g' will call Gnus.
-;;
-
-;;; Code:
-
-;;;; Customisation:
-
-(defgroup jao-frm nil
- "Frm-base mailbox checker"
- :group 'mail
- :prefix "jao-frm-")
-
-(defcustom jao-frm-exec-path "frm"
- "frm executable path"
- :group 'jao-frm
- :type 'file)
-
-(defcustom jao-frm-mail-command 'gnus
- "Emacs function to invoke when `g' is pressed on an frm buffer."
- :group 'jao-frm
- :type 'symbol)
-
-(defcustom jao-frm-mailboxes nil
- "List of mailboxes to check, or directory containing them."
- :group 'jao-frm
- :type '(choice directory (repeat file)))
-
-(defface jao-frm-mailno-face '((t (:foreground "dark slate grey")))
- "Face for the mail number."
- :group 'jao-frm)
-
-(defface jao-frm-from-face '((t (:foreground "slate grey")))
- "Face for From: header."
- :group 'jao-frm)
-
-(defface jao-frm-subject-face '((t (:foreground "slate blue")))
- "Face for Subject: header."
- :group 'jao-frm)
-
-(defface jao-frm-mailbox-face '((t (:bold t :weight bold)))
- "Face for mailbox name."
- :group 'jao-frm)
-
-;;;; Mode:
-
-(defvar jao-frm-mode-map
- (let ((map (make-keymap)))
- (suppress-keymap map)
- (define-key map [?q] 'jao-frm-delete-window)
- (define-key map [?n] 'next-line)
- (define-key map [?p] 'previous-line)
- (define-key map [?r] 'jao-frm)
- (define-key map [?g] (lambda ()
- (interactive)
- (funcall jao-frm-mail-command)))
- (define-key map [(control k)] 'jao-frm-delete-message)
- map))
-
-(setq jao-frm-font-lock-keywords
- '(("^[^ :]+:" . 'jao-frm-mailbox-face)
- ("^\\([ 0-9]+\\):\t+\\([^\t]+\\)\t+\\([^\n]+$\\)"
- (1 'jao-frm-mailno-face)
- (2 'jao-frm-from-face)
- (3 'jao-frm-subject-face))))
-
-(defvar jao-frm-mode-syntax-table
- (let ((st (make-syntax-table)))
- st))
-
-(defun jao-frm-mode ()
- "Major mode for displaying frm output."
- (interactive)
- (kill-all-local-variables)
- (buffer-disable-undo)
- (use-local-map jao-frm-mode-map)
- (set (make-local-variable 'font-lock-defaults)
- '(jao-frm-font-lock-keywords))
- (set (make-local-variable 'truncate-lines) t)
- (set (make-local-variable 'kill-whole-line) t)
- (set (make-local-variable 'next-line-add-newlines) nil)
- (setq major-mode 'jao-frm-mode)
- (setq mode-name "frm")
- (read-only-mode 1)
- (goto-char 1))
-
-;;;; Mode commands:
-(defvar jao-frm-last-config nil)
-
-(defun jao-frm-delete-window ()
- "Delete frm window and restore last win config"
- (interactive)
- (if (and (consp jao-frm-last-config)
- (window-configuration-p (car jao-frm-last-config)))
- (progn
- (set-window-configuration (car jao-frm-last-config))
- (goto-char (cadr jao-frm-last-config))
- (setq jao-frm-last-config nil))
- (bury-buffer)))
-
-(defun jao-frm-delete-message ()
- "Delete message at point"
- (interactive)
- (when (eq (current-buffer) (get-buffer "*frm*"))
- (beginning-of-line)
- (when (search-forward-regexp "^ +\\([0-9]+\\):" nil t)
- (let ((mn (string-to-number (match-string 1))))
- (when (y-or-n-p (format "Delete message number %d? " mn))
- (read-only-mode -1)
- (shell-command (format "echo 'd %d'|mail" mn) t)
- (jao-frm)
- (when (= (point-max) (point-min))
- (jao-frm-delete-window)
- (message "Mailbox is empty")))))))
-
-;;;; Activate frm:
-(defun jao-frm-mbox-mails (mbox)
- (let ((no (ignore-errors
- (substring
- (shell-command-to-string (format "frm -s n %s|wc -l" mbox))
- 0 -1))))
- (if (stringp no) (string-to-number no) 0)))
-
-(defun jao-frm-mail-number ()
- (let ((no 0))
- (dolist (b (jao-frm-mboxes) no) (setq no (+ no (jao-frm-mbox-mails b))))))
-
-(defun jao-frm-default-count-formatter (m n)
- (format "%s: %s" (file-name-sans-extension (file-name-nondirectory m)) n))
-
-(defun jao-frm-mail-counts (fmt)
- (let ((fmt (or fmt 'jao-frm-default-count-formatter)))
- (remove nil
- (mapcar (lambda (m)
- (let ((n (jao-frm-mbox-mails m)))
- (unless (zerop n) (funcall fmt m n))))
- (jao-frm-mboxes)))))
-
-(defun jao-frm-display-mailbox (mbox)
- (when (not (zerop (jao-frm-mbox-mails mbox)))
- (insert (or (file-name-nondirectory mbox) mbox) ":\n\n")
- (apply 'call-process
- `(,jao-frm-exec-path nil ,(current-buffer) nil
- "-s" "n" "-n" "-t" ,@(and mbox (list mbox))))
- (newline 2)))
-
-(defun jao-frm-mboxes ()
- (cond ((null jao-frm-mailboxes) (list (getenv "MAIL")))
- ((listp jao-frm-mailboxes) jao-frm-mailboxes)
- ((stringp jao-frm-mailboxes)
- (if (file-directory-p jao-frm-mailboxes)
- (directory-files jao-frm-mailboxes t "^[^.]")
- (list jao-frm-mailboxes)))
- (t (error "Error in mbox specification. Check `jao-frm-mailboxes'"))))
-
-;;;###autoload
-(defun jao-frm ()
- "Run frm."
- (interactive)
- (let ((fbuff (get-buffer-create "*frm*"))
- (inhibit-read-only t))
- (if (not (eq fbuff (current-buffer)))
- (setq jao-frm-last-config
- (list (current-window-configuration) (point-marker))))
- (with-current-buffer fbuff
- (delete-region (point-min) (point-max))
- (mapc 'jao-frm-display-mailbox (jao-frm-mboxes))
- (unless (eq major-mode 'jao-frm-mode)
- (jao-frm-mode))
- (goto-char (point-min))
- (if (= (point-min) (point-max))
- (message "Mailbox is empty.")
- (pop-to-buffer fbuff))
- (when (and (boundp 'display-time-mode) display-time-mode)
- (display-time-update)))))
-
-;;;###autoload
-(defun jao-frm-show-mail-numbers (&optional fmt)
- (interactive)
- (let ((counts (jao-frm-mail-counts fmt)))
- (message (if counts (mapconcat 'identity counts ", ") "No mail"))))
-
-;;;###autoload
-(defun jao-frm-mail-string ()
- (let ((counts (jao-frm-mail-counts
- (lambda (m n)
- (let ((m (substring (file-name-nondirectory m) 0 1)))
- (format "%s%s" (capitalize m) n))))))
- (mapconcat 'identity counts " ")))
-
-(provide 'jao-frm)
-
-;;; jao-frm.el ends here
diff --git a/lib/net/jao-notmuch-gnus.el b/lib/net/jao-notmuch-gnus.el
index e18c5a1..9b408c2 100644
--- a/lib/net/jao-notmuch-gnus.el
+++ b/lib/net/jao-notmuch-gnus.el
@@ -1,6 +1,6 @@
;;; jao-notmuch-gnus.el --- notmuch-gnus interoperability -*- lexical-binding: t; -*-
-;; Copyright (C) 2022 jao
+;; Copyright (C) 2022, 2024, 2025, 2026 jao
;; Author: jao <mail@jao.io>
;; Keywords: mail
@@ -28,7 +28,6 @@
(require 'ol-gnus)
(require 'notmuch-show)
-
;;; Tagging in notmuch from Gnus buffers
(defun jao-notmuch-gnus--notmuch-id (id)
@@ -53,7 +52,7 @@
"Interactively add or remove tags to the current message."
(interactive)
(let* ((id (or id (jao-notmuch-gnus-message-id)))
- (current (unless tags (jao-notmuch-gnus-message-tags id)))
+ (current (or tags (jao-notmuch-gnus-message-tags id)))
(prompt (format "Change tags %s" (string-join current "/")))
(tags (or tags (notmuch-read-tag-changes current prompt))))
(notmuch-tag (concat "id:" id) tags)
@@ -63,9 +62,14 @@
(defun jao-notmuch-gnus-show-tags ()
"Display in the echo area the tags of the current message."
(interactive)
- (when-let (id (jao-notmuch-gnus-message-id))
+ (when-let* ((id (jao-notmuch-gnus-message-id)))
(message "%s" (string-join (jao-notmuch-gnus-message-tags id) " "))))
+(jao-transient-major-mode+ gnus-summary
+ ["Tags"
+ ("s" "show message tags" jao-notmuch-gnus-show-tags)
+ ("t" "tag message" jao-notmuch-gnus-tag-message)])
+
(defun jao-notmuch-gnus-toggle-tags (tags &optional id current)
"Toggle the given TAGS list for the current Gnus message."
(let* ((id (or id (jao-notmuch-gnus-message-id)))
@@ -77,9 +81,9 @@
(message "New tags: %s" (jao-notmuch-gnus-message-tags id))))
(defun jao-notmuch-gnus-tag-mark ()
- "Remove the new tag for an article when it's marked as seen by Gnus."
- (when-let (id (jao-notmuch-gnus-message-id t))
- (jao-notmuch-gnus-tag-message id '("-new") t)))
+ "Remove the new and unread tags for an article when it's marked as seen by Gnus."
+ (when-let* ((id (jao-notmuch-gnus-message-id t)))
+ (jao-notmuch-gnus-tag-message id '("-new" "-unread") t)))
(add-hook 'gnus-mark-article-hook #'jao-notmuch-gnus-tag-mark)
@@ -100,16 +104,50 @@
(add-hook 'gnus-summary-article-move-hook #'jao-notmuch-gnus-tag-on-move)
(add-hook 'gnus-summary-article-expire-hook #'jao-notmuch-gnus-tag-on-move))
-
-;;;; Displaying search results in Gnus
+;;; Gnus search using notmuch
+
+(require 'gnus-search)
+
+(add-to-list 'gnus-search-expandable-keys "list")
+
+(defclass gnus-search-jao-notmuch (gnus-search-notmuch) ())
+
+(cl-defmethod gnus-search-indexed-search-command
+ ((engine gnus-search-jao-notmuch) (qstring string) query &optional groups)
+ (let* ((limit (alist-get 'limit query))
+ (thread (alist-get 'thread query))
+ (qs (cond (thread
+ (format "thread:\"{%s}\""
+ (thread-last (string-replace "\"" "\"\"" qstring)
+ (string-replace "<" "")
+ (string-replace ">" ""))))
+ (groups
+ (let ((gs (mapconcat 'gnus-group-short-name groups "|")))
+ (format "(%s) and folder:/%s/" qstring gs)))
+ (t qstring))))
+ (with-slots (switches config-file) engine
+ `(,(format "--config=%s" config-file) "search" "--output=files"
+ ,@(unless thread '("--duplicate=1"))
+ ,@(when limit (list (format "--limit=%d" limit)))
+ ,@switches
+ ,qs))))
+
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-jao-notmuch)
+ (expr (head list)))
+ (message "List query: %s" expr)
+ (format "List:%s" (gnus-search-transform-expression engine (cdr expr))))
+
+
+;;; Displaying search results in Gnus
(defvar jao-notmuch-gnus-server "nnml"
"Name of the target Gnus server, e.g. nnml+mail.")
-(defvar jao-notmuch-gnus-mail-directory (expand-file-name "~/.emacs.d/gnus/Mail")
+(defvar jao-notmuch-gnus-mail-directory (expand-file-name "~/var/mail/gnus")
"Directory where Gnus stores its mail.")
-(defvar jao-notmuch-gnus-leafnode-directory (expand-file-name "~/var/news")
+(defvar jao-notmuch-gnus-leafnode-directory (expand-file-name "~/var/mail/news")
"Directory where leafnode stores its messages as seen by notmuch.")
(defun jao-notmuch-gnus-file-to-group (file &optional maildir newsdir)
@@ -162,10 +200,16 @@ Example:
(msg-id (when msg-id (replace-regexp-in-string "^id:" "" msg-id))))
(if (and group msg-id)
(org-gnus-follow-link group msg-id)
- (message "Couldn't get relevant infos for switching to Gnus."))))
+ (message "Couldn't get relevant info for switching to Gnus."))))
+
+(defun jao-notmuch-gnus-engine (prefix config)
+ (let ((prefix (file-name-as-directory (expand-file-name prefix "~")))
+ (config (expand-file-name config gnus-home-directory)))
+ `(gnus-search-engine gnus-search-notmuch
+ (remove-prefix ,prefix)
+ (config-file ,config))))
-
-;;;; Org links
+;;; Org links
(defun jao-notmuch-gnus--fname (id)
(let ((cmd (format "notmuch search --output=files id:%s" id)))
(car (split-string (shell-command-to-string cmd)))))
@@ -176,12 +220,12 @@ Example:
(org-gnus-follow-link group id)))
(defun jao-notmuch-gnus-org-store ()
- (when-let (d (or (when (derived-mode-p 'notmuch-show-mode 'notmuch-tree-mode)
- (cons (notmuch-show-get-message-id)
- (notmuch-show-get-subject)))
- (when (derived-mode-p 'gnus-summary-mode 'gnus-article-mode)
- (cons (jao-notmuch-gnus-message-id)
- (gnus-summary-article-subject)))))
+ (when-let* ((d (or (when (derived-mode-p 'notmuch-show-mode 'notmuch-tree-mode)
+ (cons (notmuch-show-get-message-id)
+ (notmuch-show-get-subject)))
+ (when (derived-mode-p 'gnus-summary-mode 'gnus-article-mode)
+ (cons (jao-notmuch-gnus-message-id)
+ (gnus-summary-article-subject))))))
(org-link-store-props :type "mail"
:link (concat "mail:" (car d))
:description (concat "Mail: " (cdr d)))))
@@ -193,21 +237,19 @@ Example:
(org-link-set-parameters "gnus" :store #'ignore)
(org-link-set-parameters "notmuch" :store #'ignore)
-
-;;;; consult-notmuch
+;;; tags and flags
-(with-eval-after-load "consult-notmuch"
- (defun jao-notmuch-gnus--open-candidate (candidate)
- "Open a notmuch-search completion candidate email in Gnus."
- (message "candidate: %S" candidate)
- (jao-notmuch-gnus-goto-message (consult-notmuch--thread-id candidate)))
+(defun jao-notmuch-gnus-flag-current (&rest _)
+ (jao-notmuch-gnus-tag-message nil '("+flagged") t))
- (defun jao-gnus-consult-notmuch ()
- "Run a consult-notmuch query that opens candidates in Gnus."
- (interactive)
- (jao-notmuch-gnus--open-candidate (consult-notmuch--search)))
+(defun jao-notmuch-gnus-unflag-current (&rest _)
+ (jao-notmuch-gnus-tag-message nil '("-flagged") t))
- (consult-customize jao-gnus-consult-notmuch :preview-key 'any))
+(advice-add 'gnus-summary-tick-article-forward
+ :before #'jao-notmuch-gnus-flag-current)
+(advice-add 'gnus-summary-mark-as-read-forward
+ :before #'jao-notmuch-gnus-unflag-current)
+;;; .
(provide 'jao-notmuch-gnus)
;;; jao-notmuch-gnus.el ends here
diff --git a/lib/net/jao-notmuch.el b/lib/net/jao-notmuch.el
index bd48e8f..61233e6 100644
--- a/lib/net/jao-notmuch.el
+++ b/lib/net/jao-notmuch.el
@@ -1,6 +1,6 @@
-;;; jao-notmuch.el --- Extensions for notmuch -*- lexical-binding: t; -*-
+;; jao-notmuch.el --- Extensions for notmuch -*- lexical-binding: t; -*-
-;; Copyright (C) 2021, 2022 jao
+;; Copyright (C) 2021, 2022, 2023, 2024, 2025, 2026 jao
;; Author: jao <mail@jao.io>
;; Keywords: mail
@@ -18,11 +18,9 @@
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
-;;; Commentary:
+;; Extensions to vanilla notmuch, mostly for tree view
-;; Extensions to vanilla notmuch, mostly for tree view
-
-;;; Code:
+;;; require:
(require 'outline)
(require 'mm-decode)
@@ -32,11 +30,11 @@
(require 'notmuch-tree)
(require 'notmuch-show)
-
-;;;; Targetting the displayed message from the tree view
+
+;;; targetting the displayed message from the tree view
(defvar-local jao-notmuch--tree-buffer nil)
-(declare eww--url-at-point "eww")
+(declare-function eww--url-at-point "eww")
(defun jao-notmuch-goto-message-buffer (&optional and-click no-record)
(interactive "P")
@@ -54,12 +52,6 @@
(notmuch-tree-close-message-window)
(notmuch-tree-show-message nil)))
-(defun jao-notmuch-click-message-buffer ()
- (interactive)
- (let ((b (current-buffer)))
- (unless (eq 'url (jao-notmuch-goto-message-buffer t t))
- (pop-to-buffer b))))
-
(defun jao-notmuch-tree--find-tree-buffer ()
(or jao-notmuch--tree-buffer
(let ((mb (current-buffer)))
@@ -77,7 +69,7 @@
(user-error "No tree view for this buffer")))
(defun jao-notmuch-tree--looking-at-message ()
- (when-let (id (plist-get (notmuch-tree-get-message-properties) :id))
+ (when-let* ((id (plist-get (notmuch-tree-get-message-properties) :id)))
(equal (concat "*notmuch-id:" id "*")
(buffer-name (window-buffer notmuch-tree-message-window)))))
@@ -87,7 +79,7 @@
(if (not (jao-notmuch-tree--looking-at-message))
(jao-notmuch-tree-show-or-scroll t)
(if (notmuch-tree-scroll-message-window)
- (jao-notmuch-tree-next nil)
+ (notmuch-tree-outline-next)
(when (not (window-live-p notmuch-tree-message-window))
(notmuch-tree-show-message nil)))))
@@ -113,7 +105,7 @@
(goto-char (point-min))
(let ((pos (point)))
(while (setq pos (next-single-property-change pos 'w3m-href-anchor))
- (when-let ((url (get-text-property pos 'w3m-href-anchor)))
+ (when-let* ((url (get-text-property pos 'w3m-href-anchor)))
(when (stringp url) (cl-pushnew url res :test #'string=))))
(seq-uniq res #'string=))))
@@ -125,13 +117,13 @@
(defun jao-notmuch-browse-urls (&optional external)
(interactive "P")
- (if-let ((urls (jao-notmuch-message-urls)))
+ (if-let* ((urls (jao-notmuch-message-urls)))
(funcall (if external browse-url-secondary-browser-function #'browse-url)
(completing-read "Browse URL: " urls))
(message "No URLs in this message")))
-
-;;;; Navigating URLs
+
+;;; navigating URLs
(require 'ffap)
@@ -139,26 +131,26 @@
(interactive)
(when (get-text-property (point) 'w3m-href-anchor)
(goto-char (next-single-property-change (point) 'w3m-href-anchor)))
- (if-let (pos (next-single-property-change (point) 'w3m-href-anchor))
+ (if-let* ((pos (next-single-property-change (point) 'w3m-href-anchor)))
(goto-char pos)
(or (forward-button 1 nil t t)
(ffap-next-guess))))
(defun jao-notmuch-show-previous-button ()
(interactive)
- (if-let (pos (previous-single-property-change (point) 'w3m-href-anchor))
+ (if-let* ((pos (previous-single-property-change (point) 'w3m-href-anchor)))
(goto-char (previous-single-property-change pos 'w3m-href-anchor))
(or (backward-button 1 nil t t)
(ffap-next-guess t))))
(defun jao-notmuch-show-ret ()
(interactive)
- (when-let (url (or (get-text-property (point) 'w3m-href-anchor)
- (thing-at-point-url-at-point)))
+ (when-let* ((url (or (get-text-property (point) 'w3m-href-anchor)
+ (thing-at-point-url-at-point))))
(browse-url url)))
-
-;;;; Toggling mime parts and images
+
+;;; toggling mime parts and images
(defun jao-notmuch--toggle-mime ()
(save-excursion
@@ -175,7 +167,7 @@
(jao-notmuch-goto-tree-buffer t)))
(defun jao-notmuch--view-html ()
- "Open the text/html part of the current message using `notmuch-show-view-part'."
+ "Open the text/html part of current message using `notmuch-show-view-part'."
(interactive)
(save-excursion
(goto-char
@@ -207,40 +199,46 @@
(defun jao-notmuch-toggle-images ()
(interactive)
- (cond ((eq mm-text-html-renderer 'w3m)
- (when (fboundp 'jao-notmuch--w3m-toggle-images)
- (jao-notmuch--w3m-toggle-images)))
+ (cond ((memq mm-text-html-renderer '(w3m jao-w3m-html-renderer))
+ (when (fboundp 'jao-notmuch--w3m-toggle-images)
+ (jao-notmuch--w3m-toggle-images)))
(window-system (jao-notmuch--shr-toggle-images))
- (t (with-current-buffer notmuch-tree-message-buffer
- (jao-notmuch--view-html)))))
+ (notmuch-tree-message-buffer
+ (if nil ;;(fboundp 'jao-open-in-x-frame)
+ (let ((w (get-buffer-window notmuch-tree-message-buffer)))
+ (jao-open-in-x-frame (window-width w) (window-height w))
+ (jao-notmuch--shr-toggle-images)
+ (delete-window))
+ (with-current-buffer notmuch-tree-message-buffer
+ (jao-notmuch--view-html))))))
-
-;;;; Keeping track of unread messages in current tree view
+;;; header and mode lines with thread message counts
(defun jao-notmuch--looking-at-new-p (&optional p)
- (when-let (ts (if p (plist-get p :tags) (notmuch-show-get-tags)))
+ (when-let* ((ts (if p (plist-get p :tags) (notmuch-show-get-tags))))
(or (member "unread" ts) (member "new" ts))))
(defsubst jao-notmuch-tree--first-p (&optional msg)
(plist-get (or msg (notmuch-tree-get-message-properties)) :first))
-(defun jao-notmuch--message-counts (&optional thread)
- (let ((cnt) (total 0) (match 0) (msg))
- (save-excursion
- (if thread
- (while (and (not (jao-notmuch-tree--first-p))
- (zerop (forward-line -1))))
- (goto-char (point-min)))
- (while (and (setq msg (notmuch-tree-get-message-properties))
- (or (not cnt)
- (not thread)
- (not (jao-notmuch-tree--first-p msg))))
- (unless cnt (setq cnt 0))
- (setq total (1+ total))
- (when (plist-get msg :match) (setq match (1+ match)))
- (when (jao-notmuch--looking-at-new-p msg) (setq cnt (1+ cnt)))
- (forward-line 1)))
- (when cnt (list total match cnt))))
+(defun jao-notmuch--message-counts (tree-buffer &optional thread)
+ (with-current-buffer tree-buffer
+ (let ((cnt) (total 0) (match 0) (msg))
+ (save-excursion
+ (if thread
+ (while (and (not (jao-notmuch-tree--first-p))
+ (zerop (forward-line -1))))
+ (goto-char (point-min)))
+ (while (and (setq msg (notmuch-tree-get-message-properties))
+ (or (not cnt)
+ (not thread)
+ (not (jao-notmuch-tree--first-p msg))))
+ (unless cnt (setq cnt 0))
+ (setq total (1+ total))
+ (when (plist-get msg :match) (setq match (1+ match)))
+ (when (jao-notmuch--looking-at-new-p msg) (setq cnt (1+ cnt)))
+ (forward-line 1)))
+ (when cnt (list total match cnt)))))
(defvar jao-notmuch-header-line-format "%Q [%N / %M / %T] %n / %m / %t")
@@ -249,186 +247,159 @@
`((?Q . ,query) (?T . ,total) (?N . ,new) (?M . ,match)
(?t . ,ttotal) (?n . ,tnew) (?m . ,tmatch))))
-(defun jao-notmuch--update-header-line (mb)
- (let* ((n (or (jao-notmuch--message-counts) '(0 0 0)))
- (nc (append n (or (jao-notmuch--message-counts t) '(0 0 0))))
- (q (buffer-name)))
- (with-current-buffer mb
+(defun jao-notmuch--format-header-line (tree-buffer buffer subject)
+ (let* ((n (jao-notmuch--message-counts tree-buffer))
+ (nc (jao-notmuch--message-counts tree-buffer t)))
+ (with-current-buffer buffer
(when (derived-mode-p 'notmuch-show-mode)
- (let* ((s (thread-last (notmuch-show-get-subject)
- (notmuch-show-strip-re)
- (notmuch-sanitize)))
+ (let* ((nc (append (or n '(0 0 0)) (or nc '(0 0 0))))
+ (q (if (string= tree-buffer subject) "" tree-buffer))
(c (apply 'jao-notmuch--format-counts q nc))
- (n (- (window-width) 3 (string-width s) (string-width c)))
- (s (if (< n 0) (substring s 0 (- n 4)) s))
- (n (if (< n 0) 5 (1+ n))))
- (setq-local header-line-format
- (concat " " s (make-string n ? ) c)))))))
-
-(defun jao-notmuch-tree--find-update-header-line (&rest _args)
- (when-let ((mb (if (derived-mode-p 'notmuch-show-mode)
- (current-buffer)
- (window-buffer notmuch-tree-message-window))))
- (seq-find (lambda (b)
- (with-current-buffer b
- (and (derived-mode-p 'notmuch-tree-mode)
- (or (null notmuch-tree-message-buffer)
- (eq notmuch-tree-message-buffer mb))
- (jao-notmuch--update-header-line mb))))
- (buffer-list))))
-
-(add-hook 'notmuch-after-tag-hook #'jao-notmuch-tree--find-update-header-line)
-(add-hook 'notmuch-show-hook #'jao-notmuch-tree--find-update-header-line)
-
-
-;;;; Outline mode for tree view
-
-(defun jao-notmuch-tree--msg-prefix (msg)
- (insert (propertize (if (plist-get msg :first) "> " " ") 'display " ")))
-
-(defun jao-notmuch-tree--mode-setup ()
- (setq-local outline-regexp "^> \\|^En")
- (outline-minor-mode t))
-
-(defun jao-notmuch-tree-hide-others (&optional and-show)
- (interactive)
- (outline-hide-body)
- (outline-show-entry)
- (when and-show (notmuch-tree-show-message nil)))
-
-(defun jao-notmuch-tree--next (prev thread no-exit &optional ignore-new)
- (let ((line-move-ignore-invisible nil))
- (cond ((and (not ignore-new) (jao-notmuch--looking-at-new-p)))
- (thread
- (notmuch-tree-next-thread prev)
- (unless (or (not (notmuch-tree-get-message-properties))
- (jao-notmuch--looking-at-new-p))
- (notmuch-tree-matching-message prev (not no-exit))))
- (t (notmuch-tree-matching-message prev (not no-exit)))))
- (when (notmuch-tree-get-message-id)
- (jao-notmuch-tree-hide-others t))
- (when prev (forward-char 2)))
-
-(defvar jao-notmuch-tree--prefix-map
- (let ((m (make-keymap "Thread operations")))
- (define-key m (kbd "TAB") #'outline-cycle)
- (define-key m (kbd "t") #'outline-toggle-children)
- (define-key m (kbd "s") #'outline-show-entry)
- (define-key m (kbd "S") #'outline-show-all)
- (define-key m (kbd "h") #'outline-hide-entry)
- (define-key m (kbd "H") #'outline-hide-body)
- (define-key m (kbd "o") #'jao-notmuch-tree-hide-others)
- (define-key m (kbd "n") #'outline-hide-other)
- m))
-
-(defun jao-notmuch-tree-outline-setup (&optional prefix)
- (define-key notmuch-tree-mode-map (kbd (or prefix "T"))
- jao-notmuch-tree--prefix-map)
- (define-key notmuch-tree-mode-map (kbd "TAB") #'outline-cycle)
- (define-key notmuch-tree-mode-map (kbd "M-TAB") #'outline-cycle-buffer)
- (add-hook 'notmuch-tree-mode-hook #'jao-notmuch-tree--mode-setup)
- (advice-add 'notmuch-tree-insert-msg :before #'jao-notmuch-tree--msg-prefix))
-
-(defun jao-notmuch-tree-next (thread &optional no-exit)
- "Next message or thread in forest, taking care of thread visibility."
- (interactive "P")
- (jao-notmuch-tree--next nil thread no-exit))
-
-(defun jao-notmuch-tree-next-thread (&optional exit)
- "Next thread in forest, taking care of thread visibility."
- (interactive "P")
- (jao-notmuch-tree--next nil t exit))
-
-(defun jao-notmuch-tree-previous (thread)
- "Previous message or thread in forest, taking care of thread visibility."
- (interactive "P")
- (jao-notmuch-tree--next t thread t))
-
-(defun jao-notmuch-tree-previous-thread (&optional exit)
- "Previous thread in forest, taking care of thread visibility."
- (interactive "P")
- (jao-notmuch-tree--next t t exit))
-
-
-;;;; Updating the tree window after insertion
-
-(defun jao-notmuch--tree-sentinel (proc &rest _)
- (when (eq (process-status proc) 'exit)
- (jao-notmuch-tree-hide-others)))
-
-(defun jao-notmuch-tree-setup (&optional prefix)
- "Set up display of trees, with PREFIX key for outline commands."
- (jao-notmuch-tree-outline-setup prefix)
- (advice-add 'notmuch-tree-process-sentinel :after #'jao-notmuch--tree-sentinel))
-
-
-;;;; Tagging
+ (n (- (window-width) 2 (string-width subject) (string-width c)))
+ (subject (if (< n 0) (substring subject 0 n) subject))
+ (n (if (< n 0) 2 (+ n 2))))
+ (concat (when window-system " ") subject (make-string n ? ) c))))))
+
+(defun jao-notmuch-message-header-line (subject)
+ (if-let* ((cb (buffer-name (current-buffer)))
+ (tb (seq-find (lambda (b)
+ (with-current-buffer b
+ (and (derived-mode-p 'notmuch-tree-mode) b)))
+ (buffer-list))))
+ `((:eval
+ (jao-notmuch--format-header-line ,(buffer-name tb) ,cb ,subject)))
+ (concat " " subject)))
+
+(defun jao-notmuch--format-lighter ()
+ (when (derived-mode-p 'notmuch-tree-mode)
+ (let* ((n (jao-notmuch--message-counts (current-buffer)))
+ (nc (jao-notmuch--message-counts (current-buffer) t))
+ (nc (append (or n '(0 0 0)) (or nc '(0 0 0)))))
+ (apply 'jao-notmuch--format-counts "" nc))))
+
+(define-minor-mode jao-notmuch-thread-info-mode ""
+ :lighter (:eval (format " %s" (jao-notmuch--format-lighter))))
+
+
+;;; tagging
(defsubst jao-notmuch--has-tag (tag)
(member tag (notmuch-tree-get-tags)))
-(defun jao-notmuch-tag-jump-and-next (reverse)
- (interactive "P")
- (notmuch-tag-jump reverse)
- (jao-notmuch-tree-next nil t))
-
-(defun jao-notmuch-tree--tag (tags reverse whole-thread)
+(defun jao-notmuch-tree--tag (tags reverse)
(let ((c (notmuch-tag-change-list tags reverse)))
- (if whole-thread (notmuch-tree-tag-thread c) (notmuch-tree-tag c))))
-
-(defun jao-notmuch-tree--tag-and-next (tags reverse whole-thread)
- (jao-notmuch-tree--tag tags reverse whole-thread)
- (jao-notmuch-tree-next whole-thread t))
+ (notmuch-tree-tag c)))
+
+(defun jao-notmuch-tree-tag-thread (tags reverse full)
+ (when full (notmuch-tree-thread-top))
+ (let ((c (notmuch-tag-change-list tags reverse))
+ (level (or (notmuch-tree-get-prop :level) 0))
+ (go t))
+ (while go
+ (notmuch-tree-tag c)
+ (forward-line)
+ (setq go (> (or (notmuch-tree-get-prop :level) 0) level)))
+ (when notmuch-tree-outline-mode
+ (ignore-errors (outline-show-branches))
+ (notmuch-tree-outline-next))))
+
+(defun jao-notmuch-tree--tag-and-next (tags reverse)
+ (jao-notmuch-tree--tag tags reverse)
+ (notmuch-tree-outline-next t))
(defun jao-notmuch-tree-toggle-delete ()
(interactive)
(let ((undo (jao-notmuch--has-tag "deleted")))
- (jao-notmuch-tree--tag-and-next '("+deleted" "-new" "-unread") undo nil)))
+ (jao-notmuch-tree--tag-and-next '("+deleted" "-new" "-unread") undo)))
-(defun jao-notmuch-tree-toggle-delete-thread ()
- (interactive)
+(defun jao-notmuch-tree-toggle-delete-thread (full)
+ (interactive "P")
(let ((undo (jao-notmuch--has-tag "deleted")))
- (jao-notmuch-tree--tag-and-next '("+deleted" "-new" "-unread") undo t)))
+ (jao-notmuch-tree-tag-thread '("+deleted" "-new" "-unread") undo full)))
-(defun jao-notmuch-tree-read-thread (unread)
+(defun jao-notmuch-tree-mark-all-read ()
+ (interactive)
+ (when-let* ((q notmuch-tree-basic-query))
+ (when (yes-or-no-p "Mark all messages as read? ")
+ (notmuch-tag q '("-new" "-unread")))))
+
+(defun jao-notmuch-tree-read-thread (full)
(interactive "P")
- (jao-notmuch-tree--tag-and-next '("-unread" "-new") unread t))
+ (jao-notmuch-tree-tag-thread '("-unread" "-new") nil full))
(defun jao-notmuch-tree-toggle-flag ()
(interactive)
(let ((tags (if (jao-notmuch--has-tag "flagged")
'("-flagged")
'("-unread" "-new" "-deleted" "+flagged"))))
- (jao-notmuch-tree--tag-and-next tags nil nil)))
+ (jao-notmuch-tree--tag-and-next tags nil)))
(defun jao-notmuch-tree-toggle-spam ()
(interactive)
(let ((tags (if (jao-notmuch--has-tag "spam")
'("-spam")
'("-unread" "-new" "+spam"))))
- (jao-notmuch-tree--tag-and-next tags nil nil)))
+ (jao-notmuch-tree--tag-and-next tags nil)))
(defun jao-notmuch-tree-reset-tags ()
(interactive)
(let ((tags (plist-get (notmuch-tree-get-message-properties) :orig-tags)))
- (jao-notmuch-tree--tag tags nil nil)
- (jao-notmuch-tree--next nil nil t t)))
+ (jao-notmuch-tree--tag tags nil)))
-
-;;;; Results formatters
+(defvar jao-notmuch--shared-tags
+ '("new" "unread" "flagged" "signed" "sent" "attachment" "forwarded" "inbox"
+ "encrypted" "gmane" "gnus" "feeds" "rss" "mce" "trove" "prog" "emacs"))
-(defun jao-notmuch-format-tags (fmt msg)
- (let ((ts (thread-last (notmuch-tree-format-field "tags" "%s" msg)
- (split-string)
- (seq-sort-by #'length #'<))))
- (format-spec fmt `((?s . ,(mapconcat #'identity ts " "))))))
+(defun jao-notmuch-subtags (tag &rest excl)
+ (let* ((cmd (concat "notmuch search --output=tags tag:" tag))
+ (ts (split-string (shell-command-to-string cmd))))
+ (seq-difference ts (append jao-notmuch--shared-tags (cons tag excl)))))
+
+;;; fcc
+(defvar jao-notmuch-tags-not-inherited
+ '("attachment" "sent" "new" "trove" "flagged" "drivel" "replied"))
-(defun jao-notmuch-tree-and-subject (fmt msg)
+(defvar jao-notmuch-sent-dir "sent")
+
+(defun jao-notmuch-mua--inherited-fcc ()
+ (let* ((tags (seq-difference (notmuch-show-get-tags)
+ jao-notmuch-tags-not-inherited))
+ (tagstr (mapconcat (lambda (s) (concat "+" s)) tags " "))
+ (fcc (concat jao-notmuch-sent-dir " " tagstr " -new +sent"))
+ (fcc-dirs (assoc-delete-all ".*" (copy-alist notmuch-fcc-dirs))))
+ (append fcc-dirs `((".*" . ,fcc)))))
+
+(defun jao-notmuch-mua-new-reply (fun &rest args)
+ (let ((notmuch-fcc-dirs (jao-notmuch-mua--inherited-fcc)))
+ (apply fun args)))
+
+(advice-add 'notmuch-mua-new-reply :around #'jao-notmuch-mua-new-reply)
+
+;;; results formatters
+
+(defun jao-notmuch-cmp-tags (a b)
+ (or (> (length a) (length b)) (string-lessp a b)))
+
+(defun jao-notmuch-format-tags (fmt msg)
+ (if (> (window-width) 85)
+ (let ((ts (thread-last (notmuch-tree-format-field "tags" "%s" msg)
+ (split-string)
+ ;; (seq-sort-by #'length #'<)
+ (seq-sort #'jao-notmuch-cmp-tags))))
+ (format-spec fmt `((?s . ,(mapconcat #'identity ts " ")))))
+ ""))
+
+(defun jao-notmuch-format-authors (threshold msg)
+ (let ((fmt (if (< (window-width) threshold) "%-15s" "%-35s")))
+ (notmuch-tree-format-field "authors" fmt msg)))
+
+(defun jao-notmuch-format-tree-and-subject (_fmt msg)
(let ((tr (notmuch-tree-format-field "tree" " %s" msg))
- (sb (notmuch-tree-format-field "subject" " %s" msg)))
+ (sb (notmuch-tree-format-field "subject" " %s" msg))
+ (fmt (format "%%>-%ds" (- (window-width) 45))))
(format-spec fmt `((?s . ,(concat tr sb))))))
-(defun jao-notmuch-msg-ticks (mails-rx msg)
+(defun jao-notmuch-format-msg-ticks (mails-rx msg)
(let ((headers (plist-get msg :headers)))
(cond ((string-match-p mails-rx (or (plist-get headers :To) ""))
(propertize " »" 'face 'notmuch-tree-match-tree-face))
@@ -437,4 +408,24 @@
(t " "))))
(provide 'jao-notmuch)
+;;; org links
+(defun jao-notmuch-id-file-name (id)
+ (let ((cmd (format "notmuch search --output=files id:%s" id)))
+ (car (split-string (shell-command-to-string cmd)))))
+
+(defun jao-notmuch-org-store ()
+ (when-let* ((d (and (derived-mode-p '(notmuch-show-mode notmuch-tree-mode))
+ (cons (notmuch-show-get-message-id)
+ (notmuch-show-get-subject)))))
+ (org-link-store-props :type "mail"
+ :link (concat "mail:" (car d))
+ :description (concat "Mail: " (cdr d)))))
+
+(defun jao-notmuch-org-links ()
+ (org-link-set-parameters "mail"
+ :follow #'notmuch-show
+ :store #'jao-notmuch-org-store)
+ (org-link-set-parameters "gnus" :store #'ignore)
+ (org-link-set-parameters "notmuch" :store #'ignore))
+
;;; jao-notmuch.el ends here
diff --git a/lib/net/jao-r2e.el b/lib/net/jao-r2e.el
new file mode 100644
index 0000000..f28b66b
--- /dev/null
+++ b/lib/net/jao-r2e.el
@@ -0,0 +1,231 @@
+;;; jao-r2e.el --- List of rss2email subscriptions -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2025, 2026 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <mail@jao.io>
+;; Keywords: news
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+(require 'multisession)
+(require 'jao-url)
+
+(autoload 'View-quit "view")
+(autoload 'eww-view-source "eww")
+(autoload 'jao-notmuch-subtags "jao-notmuch")
+
+(defvar jao-r2e-command "r2e")
+(defvar jao-r2e-confirm-toggle nil)
+
+(defconst jao-r2e--buffer "*r2e*")
+(defun jao-r2e--buffer ()
+ (with-current-buffer (get-buffer-create jao-r2e--buffer)
+ (unless (derived-mode-p 'jao-r2e-mode)
+ (jao-r2e-mode))
+ (current-buffer)))
+
+(defvar jao-r2e-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map)
+ (define-key map [?q] 'bury-buffer)
+ (define-key map [?n] 'next-line)
+ (define-key map [?p] 'previous-line)
+ (define-key map [?N] 'jao-r2e-next)
+ (define-key map [?P] 'jao-r2e-prev)
+ (define-key map [?g] 'jao-r2e-list)
+ (define-key map [?s] 'jao-r2e-subscribe)
+ (define-key map [?t] 'jao-r2e-toggle)
+ (define-key map [?D] 'jao-r2e-delete)
+ (define-key map [?u] 'jao-r2e-recover)
+ (define-key map [?y] 'jao-r2e-kill-url)
+ (define-key map [?x] 'jao-r2e-list-subscribed)
+ map))
+
+;;;###autoload
+(defun jao-r2e-mode ()
+ "A very simple mode to show the output of r2e commands."
+ (interactive)
+ (kill-all-local-variables)
+ (buffer-disable-undo)
+ (use-local-map jao-r2e-mode-map)
+ ;; (setq-local font-lock-defaults '(jao-r2e-font-lock-keywords))
+ (setq-local truncate-lines t)
+ (setq-local next-line-add-newlines nil)
+ (setq major-mode 'jao-r2e-mode)
+ (setq mode-name "r2e")
+ (read-only-mode 1))
+
+(defun jao-r2e--do (things &optional buffer)
+ "Execute a r2e command THINGS in the given BUFFER."
+ (let ((b (or buffer (pop-to-buffer (jao-r2e--buffer)))))
+ (let ((inhibit-read-only t)
+ (cmd (format "%s %s" jao-r2e-command things)))
+ (unless buffer
+ (with-current-buffer b (delete-region (point-min) (point-max))))
+ (with-temp-message (format "Running: %s ...." cmd)
+ (shell-command cmd b))
+ (unless buffer (read-only-mode 1)))))
+
+(defconst jao-r2e--feed-rx
+ "^\\([0-9]+\\): \\[\\( \\|\\*\\)\\] \\([^ ]+\\) (\\(.+\\) -> \\(.+\\))")
+
+(defun jao-r2e--feed-at-point ()
+ (beginning-of-line)
+ (when-let* ((m (looking-at jao-r2e--feed-rx)))
+ (list (match-string 1)
+ (match-string 3)
+ (string= "*" (match-string 2))
+ (match-string 4)
+ (match-string 5))))
+
+(defun jao-r2e ()
+ (interactive)
+ (pop-to-buffer (jao-r2e--buffer))
+ (when (looking-at-p "^$")
+ (jao-r2e-list)))
+
+(defun jao-r2e-list ()
+ (interactive)
+ (jao-r2e--do "list"))
+
+(defun jao-r2e-list-subscribed (arg)
+ "Show only subscribed (unsubscribed with arg) feeds."
+ (interactive "P")
+ (jao-r2e-list)
+ (let ((inhibit-read-only t))
+ (flush-lines (if arg ".*\\[\\*\\].*" ".*\\[ \\].*"))))
+
+(defun jao-r2e--srx (opp)
+ (when-let* ((f (jao-r2e--feed-at-point)))
+ (let ((a (if opp (not (caddr f)) (caddr f))))
+ (format "^[0-9]+: \\[%s\\] " (if a "\\*" " ")))))
+
+(defun jao-r2e-next (opp)
+ "Next feed with the same (or opposite) status."
+ (interactive "P")
+ (when-let* ((rx (jao-r2e--srx opp)))
+ (forward-line)
+ (when (re-search-forward rx nil t)
+ (beginning-of-line))))
+
+(defun jao-r2e-prev (opp)
+ "Previous feed with the same (or opposite) status."
+ (interactive "P")
+ (when-let* ((rx (jao-r2e--srx opp)))
+ (when (re-search-backward rx nil t)
+ (beginning-of-line))))
+
+(defun jao-r2e-kill-url ()
+ "Copy as kill the URL of the feed at point."
+ (interactive)
+ (let ((url (cadddr (jao-r2e--feed-at-point))))
+ (if (not url)
+ (error "No feed at point")
+ (kill-new url)
+ (message "%s" url))))
+
+(defun jao-r2e-toggle ()
+ (interactive)
+ (let ((f (jao-r2e--feed-at-point)))
+ (unless f (error "No feed at point"))
+ (let ((p (point))
+ (no (car f))
+ (name (cadr f))
+ (act (if (caddr f) "pause" "unpause")))
+ (when (or (not jao-r2e-confirm-toggle)
+ (yes-or-no-p (format "%s '%s'? " act name)))
+ (with-temp-buffer
+ (jao-r2e--do (format "%s %s" act no) (current-buffer)))
+ (jao-r2e-list)
+ (goto-char p)))))
+
+(define-multisession-variable jao-r2e-deleted-feeds '()
+ "List of rss2email feeds deleted at some point.")
+
+(defun jao-r2e--deleted () (multisession-value jao-r2e-deleted-feeds))
+
+(defun jao-r2e-delete ()
+ "Delete feed at point. Use `jao-r2e-recover' to undelete."
+ (interactive)
+ (let ((f (jao-r2e--feed-at-point)))
+ (unless f (error "No feed at point"))
+ (let ((p (point))
+ (no (car f))
+ (entry (cdr f)))
+ (when (yes-or-no-p (format "Delete feed '%s'" (car entry)))
+ (setf (multisession-value jao-r2e-deleted-feeds)
+ (cons entry (remove entry (jao-r2e--deleted))))
+ (with-temp-buffer
+ (jao-r2e--do (format "delete %s" no) (current-buffer)))
+ (jao-r2e-list)
+ (goto-char p)))))
+
+(defun jao-r2e-recover ()
+ (interactive)
+ (when (seq-empty-p (jao-r2e--deleted))
+ (error "No feeds recoverable at this point."))
+ (let* ((entries (jao-r2e--deleted))
+ (feed (completing-read "Recover feed: " entries)))
+ (when-let* ((ps (assoc feed entries))
+ (url (caddr ps))
+ (mail (car (last ps)))
+ (cat (when (string-match "feeds\\.\\(.+\\)@localhost" mail)
+ (match-string 1 mail))))
+ (jao-r2e-subscribe (list url feed) cat t)
+ (setf (multisession-value jao-r2e-deleted-feeds) (remove ps entries)))))
+
+(defun jao-r2e--find-url ()
+ (save-excursion
+ (when (derived-mode-p 'w3m-mode 'eww-mode)
+ (if (fboundp 'w3m-view-source) (w3m-view-source) (eww-view-source)))
+ (goto-char (point-min))
+ (when (re-search-forward
+ "type=\"application/\\(?:atom\\|rss\\)\\+xml\" +" nil t)
+ (let ((url (save-excursion
+ (when (re-search-forward
+ "href=\"\\([^\n\"]+\\)\"" nil t)
+ (match-string-no-properties 1))))
+ (title (when (re-search-forward
+ "\\(?:title=\"\\([^\n\"]+\\)\" +\\)" nil t)
+ (match-string-no-properties 1))))
+ (when (string-match-p ".*\\*eww-source\\b.*" (buffer-name))
+ (View-quit))
+ (when url (cons url (or title "")))))))
+
+(defun jao-r2e-subscribe (url &optional cat relist)
+ "Subscribe to a given RSS URL. If URL not given, look for it."
+ (interactive (list (or (jao-url-around-point)
+ (jao-r2e--find-url)
+ (read-string "Feed URL: "))))
+ (let* ((url+title (ensure-list url))
+ (url (car url+title))
+ (title (cdr url+title)))
+ (unless url (error "No feeds found"))
+ (let ((url (if (string-match "^feed:" url) (substring url 5) url)))
+ (when (y-or-n-p (format "Subscribe to <%s>? " url))
+ (let* ((name (read-string "Feed name: " title))
+ (cats (cons "prog" (jao-notmuch-subtags "feeds")))
+ (cat (completing-read "Category: " cats nil t cat))
+ (sfmt (format "%%s add %s '%s' mail+feeds_%s@jao.io" name url cat)))
+ (with-temp-message "Subscribing..."
+ (shell-command-to-string (format sfmt "r2e"))
+ (when (not (string= jao-r2e-command "r2e"))
+ (shell-command-to-string (format sfmt jao-r2e-command))))
+ (when (y-or-n-p "Retrieve feeds now? ")
+ (with-temp-message "Retrieving feed..."
+ (shell-command (format "%s run %s" jao-r2e-command name))))
+ (when relist (jao-r2e-list)))))))
+
+(provide 'jao-r2e)
+;;; jao-r2e.el ends here
diff --git a/lib/net/jao-url.el b/lib/net/jao-url.el
new file mode 100644
index 0000000..ac66cef
--- /dev/null
+++ b/lib/net/jao-url.el
@@ -0,0 +1,45 @@
+;;; jao-url.el --- URL handling -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2025 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <mail@jao.io>
+;; Keywords: hypermedia
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+(require 'shr)
+(require 'ffap)
+(require 'thingatpt)
+
+(defun jao-url-around-point (&optional current-url)
+ (or (and (fboundp 'w3m-anchor) (w3m-anchor))
+ (shr-url-at-point nil)
+ (ffap-url-at-point)
+ (thing-at-point 'url)
+ (when current-url
+ (or (and (fboundp 'w3m-anchor) (w3m-anchor))
+ (and (derived-mode-p 'eww-mode) (plist-get eww-data :url))))))
+
+
+(defun jao-url-email-url ()
+ (save-excursion
+ (goto-char (point-min))
+ (when (or (search-forward-regexp "^Via: h" nil t)
+ (search-forward-regexp "^URL:[\n ]h" nil t)
+ (and (search-forward-regexp "^Link$" nil t)
+ (not (beginning-of-line))))
+ (jao-url-around-point))))
+
+(provide 'jao-url)
+;;; jao-url.el ends here
diff --git a/lib/net/randomsig.el b/lib/net/randomsig.el
index cb37694..e3c735b 100644
--- a/lib/net/randomsig.el
+++ b/lib/net/randomsig.el
@@ -1,6 +1,6 @@
-;;; randomsig.el --- insert a randomly selected signature
+;;; randomsig.el --- insert a randomly selected signature -*- lexical-binding: t; -*-
-;; Copyright (C) 2001, 2002, 2013, 2020, 2021 Hans-Jürgen Ficker
+;; Copyright (C) 2001, 2002, 2013, 2020, 2021, 2024, 2026 Hans-Jürgen Ficker
;; Emacs Lisp Archive Entry
;; Author: Hans-Juergen Ficker <hj@backmes.de>
@@ -277,8 +277,11 @@ You probably want to have a newline at the end of it."
(defun randomsig-prompt (&optional prompt)
;; Prompt for a signature file.
(let ((files (randomsig-files-to-list randomsig-files)))
- (completing-read (if prompt prompt "signature: ")
- (mapcar 'list files) nil t nil randomsig-history (car files))))
+ (if (cdr files)
+ (completing-read (if prompt prompt "signature: ")
+ (mapcar 'list files) nil t nil
+ randomsig-history (car files))
+ (car files))))
(defun randomsig-read-signatures-to-buffer (buffer-name &optional files)
;; read the signatures into the signature buffer
@@ -305,7 +308,7 @@ You probably want to have a newline at the end of it."
;; get a list with file names of signature files
(let ((sigfiles (randomsig-files-to-list files)))
;; Insert all files into the newly created buffer
- (mapcar
+ (mapc
(lambda (fname)
(let ((pos (point-max)))
@@ -345,10 +348,10 @@ You probably want to have a newline at the end of it."
(defun randomsig-goto-signature ()
-;; This function is stolen fom message-goto signature.
-;; Go to beginnig of the signature, and return t.
-;; If there is no signature in current buffer, go to end of buffer,
-;; and return nil.
+ ;; This function is stolen fom message-goto signature.
+ ;; Go to beginnig of the signature, and return t.
+ ;; If there is no signature in current buffer, go to end of buffer,
+ ;; and return nil.
(goto-char (point-min))
(if (re-search-forward "^-- $" nil t)
(progn
@@ -380,30 +383,25 @@ Else a signature out of `randomsig-files' will be choosen."
(randomsig-read-signatures-to-buffer randomsig-buffer-name files)
(goto-char (point-min))
- (let '(count 0) 'selected
-
- ;; Count number of signatures
- (while (search-forward-regexp randomsig-delimiter-pattern nil t)
- (setq count (1+ count)))
-
- ;; Select random signature out out these
- (setq selected (1+ (random count)))
- (goto-char (point-min))
- (if (search-forward-regexp randomsig-delimiter-pattern nil t selected)
- (forward-char))
-
- ;; Cut signature and return it
- (let '(here (point)) 'signature-string
-
- (if (not (search-forward-regexp randomsig-delimiter-pattern
- nil t))
- (goto-char (point-max))
- (beginning-of-line))
- (setq signature-string
- (concat randomsig-static-string
- (buffer-substring here (point))))
- (kill-buffer randomsig-buffer-name)
- signature-string))))
+ (let ((count 0) (selected nil))
+ ;; Count number of signatures
+ (while (search-forward-regexp randomsig-delimiter-pattern nil t)
+ (setq count (1+ count)))
+ ;; Select random signature out out these
+ (setq selected (1+ (random count)))
+ (goto-char (point-min))
+ (if (search-forward-regexp randomsig-delimiter-pattern nil t selected)
+ (forward-char))
+ ;; Cut signature and return it
+ (let ((here (point))
+ (signature-string nil))
+ (if (not (search-forward-regexp randomsig-delimiter-pattern nil t))
+ (goto-char (point-max))
+ (beginning-of-line))
+ (setq signature-string
+ (concat randomsig-static-string (buffer-substring here (point))))
+ (kill-buffer randomsig-buffer-name)
+ signature-string))))
(defun randomsig-replace-sig (arg)
@@ -412,34 +410,31 @@ When called with prefix, read the filename of the signature-file
that should be used"
(interactive "P")
(save-excursion
-
(randomsig-replace-signature
(randomsig-signature
(if arg
(randomsig-prompt "read from signature-lib: ")
randomsig-files)))))
-
-
(defun randomsig-message-read-sig (arg)
"Get the signature of current message and copy it to a file.
If mark is active, get the marked region instead.
When called with prefix, let the user edit the signature before saving"
(interactive "P")
(save-excursion
- (let '(signature-string
+ (let ((signature-string
(if (randomsig-mark-active-p)
(buffer-substring (point) (mark))
(progn
(if (randomsig-goto-signature)
- (let `(here (point))
+ (let ((here (point)))
(goto-char (point-max))
(while (char-equal (char-before) 10)
(backward-char))
(buffer-substring here (point)))
- nil))))
+ nil)))))
(when signature-string
(if arg
(progn
@@ -448,7 +443,6 @@ When called with prefix, let the user edit the signature before saving"
(randomsig-edit signature-string))
(randomsig-write-signature signature-string))))))
-
(defun randomsig-write-signature (signature-string)
(set-buffer (find-file-noselect
(expand-file-name
@@ -462,14 +456,13 @@ When called with prefix, let the user edit the signature before saving"
(save-buffer))
-(defun gnus/randomsig-summary-read-sig (arg)
- "Get the signature of current message and copy it to a file"
- (interactive "P")
- (progn ;save-excursion
- ;; FIXME: Doesn't return to summary buffer (save-excursion should do this)
- (gnus-summary-select-article-buffer)
- (randomsig-message-read-sig arg)))
-
+;; (defun gnus/randomsig-summary-read-sig (arg)
+;; "Get the signature of current message and copy it to a file"
+;; (interactive "P")
+;; (progn ;save-excursion
+;; ;; FIXME: Doesn't return to summary buffer (save-excursion should do this)
+;; (gnus-summary-select-article-buffer)
+;; (randomsig-message-read-sig arg)))
(defun randomsig-search-sigfiles (&optional file)
"Scan `randomsig-dir' and its subdirectories for regular files.
@@ -486,7 +479,7 @@ If FILE is given, only FILE and its subdirectory will be searched."
;; unwanted...
nil
- (let '(path (expand-file-name file randomsig-dir))
+ (let ((path (expand-file-name file randomsig-dir)))
(if (file-directory-p path)
(mapcan (lambda (f)
(randomsig-search-sigfiles (if (string= file "")
@@ -568,7 +561,7 @@ You most likely do not want to call `randomsig-edit-mode' directly.
\\{randomsig-edit-mode-map}"
(define-key randomsig-edit-mode-map
- (kbd "C-c C-c") 'randomsig-edit-done))
+ (kbd "C-c C-c") 'randomsig-edit-done))
;;; Commands for randomsig-select-mode
diff --git a/lib/net/signel.org b/lib/net/signel.org
deleted file mode 100644
index 722069c..0000000
--- a/lib/net/signel.org
+++ /dev/null
@@ -1,546 +0,0 @@
-#+title: signel, a barebones signal chat on top of signal-cli
-#+date: <2020-02-23 05:03>
-#+filetags: emacs norss
-#+PROPERTY: header-args :tangle yes :comments yes :results silent
-
-Unlike most chat systems in common use, [[https://signal.org][Signal]] lacks a decent emacs
-client. All i could find was [[https://github.com/mrkrd/signal-msg][signal-msg]], which is able only to send
-messages and has a readme that explicitly warns that its is /not/ a chat
-application. Skimming over signal-msg's code i learnt about
-[[https://github.com/AsamK/signal-cli][signal-cli]], a java-based daemon that knows how to send and receive
-signal messages, and how to link to a nearby phone, or register new
-users. And playing with it i saw that it can output its activities
-formatted as JSON, and that offers (when run in daemon mode) a DBUS
-service that can be used to send messages.
-
-Now, emacs knows how to run a process and capture its output handling
-it to a filter function, and comes equipped with a JSON parser and
-a set of built-in functions to talk to DBUS buses.
-
-So how about writing a simple Signal chat app for emacs? Let's call it
-/signel/, and write it as [[https://gitlab.com/jaor/elibs/-/blob/master/net/signel.org][a blog post in literate org-mode]].
-
-* Starting a process
-
-We are going to need a variable for our identity (telephone number),
-and a list of contact names (until i discover how to get them directly
-from signal-cli):
-
-#+begin_src emacs-lisp
-(require 'cl-lib)
-
-(defvar signel-cli-user "+44744xxxxxx")
-(defvar signel-contact-names '(("+447xxxxxxxx" . "john")
- ("+346xxxxxxxx" . "anna")))
-#+end_src
-
-and a simple function to get a contact name given its telephone
-number:
-
-#+begin_src emacs-lisp
-(defun signel--contact-name (src)
- (or (alist-get src signel-contact-names nil nil #'string-equal) src))
-#+end_src
-
-We are also going to need the path for our signal-cli executable
-
-#+begin_src emacs-lisp
-(defvar signel-cli-exec "signal-cli")
-#+end_src
-
-Starting the signal-cli process is easy: ~make-process~ provides all the
-necessary bits. What we need is essentially calling
-
-#+begin_src shell
-signal-cli -u +44744xxxxxx daemon --json
-#+end_src
-
-associating to the process a buffer selected by the function
-~signel--proc-buffer~ . While we are at it, we'll write also little
-helpers for users of our API.
-
-#+begin_src emacs-lisp
-(defun signel--proc-buffer ()
- (get-buffer-create "*signal-cli*"))
-
-(defun signel-signal-cli-buffer ()
- (get-buffer "*signal-cli*"))
-
-(defun signel-signal-cli-process ()
- (when-let ((proc (get-buffer-process (signel-signal-cli-buffer))))
- (and (process-live-p proc) proc)))
-#+end_src
-
-#+begin_src emacs-lisp
-(defun signel-start ()
- "Start the underlying signal-cli process if needed."
- (interactive)
- (if (signel-signal-cli-process)
- (message "signal-cli is already running!")
- (let ((b (signel--proc-buffer)))
- (make-process :name "signal-cli"
- :buffer b
- :command `(,signel-cli-exec
- "-u"
- ,signel-cli-user
- "daemon" "--json")
- :filter #'signel--filter)
- (message "Listening to signals!"))))
-#+end_src
-
-* Parsing JSON
-
-We've told emacs to handle any ouput of the process to the function
-~signel--filter~, which we're going to write next. This function will
-receive the process object and its latest output as a string
-representing a JSON object. Here's an example of the kind of outputs
-that signal-cli emits:
-
-#+begin_src json :tangle no
-{
- "envelope": {
- "source": "+4473xxxxxxxx",
- "sourceDevice": 1,
- "relay": null,
- "timestamp": 1582396178696,
- "isReceipt": false,
- "dataMessage": {
- "timestamp": 1582396178696,
- "message": "Hello there!",
- "expiresInSeconds": 0,
- "attachments": [],
- "groupInfo": null
- },
- "syncMessage": null,
- "callMessage": null,
- "receiptMessage": null
- }
-}
-#+end_src
-
-Everything seems to be always inside ~envelope~, which contains objects
-for the possible messages received. In the example above, we're
-receiving a message from a /source/ contact. We can also receive
-receipt messages, telling us whether our last message has been
-received or read; e.g.:
-
-#+begin_src json :tangle no
-{
- "envelope": {
- "source": "+4473xxxxxxxx",
- "sourceDevice": 1,
- "relay": null,
- "timestamp": 1582397117584,
- "isReceipt": false,
- "dataMessage": null,
- "syncMessage": null,
- "callMessage": null,
- "receiptMessage": {
- "when": 1582397117584,
- "isDelivery": true,
- "isRead": false,
- "timestamps": [
- 1582397111524
- ]
- }
- }
-}
-#+end_src
-
-A bit confusingly, that delivery notification has a ~receiptMessage~,
-but its ~isReceipt~ flag is set to ~false~. At other times, we get
-~isReceipt~ but no ~receiptMessage~:
-
-#+begin_src json :tangle no
-{
- "envelope": {
- "source": "+346xxxxxxxx",
- "sourceDevice": 1,
- "relay": null,
- "timestamp": 1582476539281,
- "isReceipt": true,
- "dataMessage": null,
- "syncMessage": null,
- "callMessage": null,
- "receiptMessage": null
- }
-}
-#+end_src
-
-It is very easy to parse JSON in emacs and extract signal-cli's
-envelopes (and it's become faster in emacs 27, but the interface is a
-bit different):
-
-#+begin_src emacs-lisp
-(defun signel--parse-json (str)
- (if (> emacs-major-version 26)
- (json-parse-string str
- :null-object nil
- :false-object nil
- :object-type 'alist
- :array-type 'list)
- (json-read-from-string str)))
-
-(defun signel--msg-contents (str)
- (alist-get 'envelope (ignore-errors (signel--parse-json str))))
-#+end_src
-
-Here i am being old-school and opting to receive JSON dicitionaries as
-alists (rather than hash maps, the default), and arrays as lists
-rather than vectors just because lisps are lisps for a reason. I'm
-also going to do some mild [[https://lispcast.com/nil-punning/][nil punning]],
-hence the choice for null and false representations.
-
-Once the contents of the envelope is extracted, it's trivial (and
-boring) to get into its components:
-
-#+begin_src emacs-lisp
-(defun signel--msg-source (msg) (alist-get 'source msg))
-
-(defun signel--msg-data (msg)
- (alist-get 'message (alist-get 'dataMessage msg)))
-
-(defun signel--msg-timestamp (msg)
- (if-let (msecs (alist-get 'timestamp msg))
- (format-time-string "%H:%M" (/ msecs 1000))
- ""))
-
-;; emacs 26 compat
-(defun signel--not-false (x)
- (and (not (eq :json-false x)) x))
-
-(defun signel--msg-receipt (msg)
- (alist-get 'receiptMessage msg))
-
-(defun signel--msg-is-receipt (msg)
- (signel--not-false (alist-get 'isReceipt msg)))
-
-(defun signel--msg-receipt-timestamp (msg)
- (when-let (msecs (alist-get 'when (signel--msg-receipt msg)))
- (format-time-string "%H:%M" (/ msecs 1000))))
-
-(defun signel--msg-is-delivery (msg)
- (when-let ((receipt (signel--msg-receipt msg)))
- (signel--not-false (alist-get 'isDelivery msg))))
-
-(defun signel--msg-is-read (msg)
- (when-let ((receipt (signel--msg-receipt msg)))
- (signel--not-false (alist-get 'isRead msg))))
-#+end_src
-
-* A process output filter
-
-We're almost ready to write our filter. It will:
-
-- For debugging purposes, insert the raw JSON string in the process
- buffer.
-- Parse the received JSON string and extract its envelope contents.
-- Check wether it has a source and either message data or a receipt
- timestamp.
-- Dispatch to a helper function that will insert the data or
- notification in a chat buffer.
-
-Or, in elisp:
-
-#+begin_src emacs-lisp
-(defvar signel--line-buffer "")
-
-(defun signel--filter (proc str)
- (signel--ordinary-insertion-filter proc str)
- (let ((str (concat signel--line-buffer str)))
- (if-let ((msg (signel--msg-contents str)))
- (let ((source (signel--msg-source msg))
- (stamp (signel--msg-timestamp msg))
- (data (signel--msg-data msg))
- (rec-stamp (signel--msg-receipt-timestamp msg)))
- (setq signel--line-buffer "")
- (when source
- (signel--update-chat-buffer source data stamp rec-stamp msg)))
- (setq signel--line-buffer
- (if (string-match-p ".*\n$" str) "" str)))))
-#+end_src
-
-We've had to take care of the case when the filter receives input that
-is not a complete JSON expression: in the case of signal-cli, that
-only happens when we haven't seen yet an end of line.
-
-The function to insert the raw contents in the process buffer is
-surprisingly hard to get right, but the emacs manual spells out a
-reasonable implementation, which i just copied:
-
-#+begin_src emacs-lisp
-(defun signel--ordinary-insertion-filter (proc string)
- (when (and proc (buffer-live-p (process-buffer proc)))
- (with-current-buffer (process-buffer proc)
- (let ((moving (= (point) (process-mark proc))))
- (save-excursion
- ;; Insert the text, advancing the process marker.
- (goto-char (process-mark proc))
- (insert string)
- (set-marker (process-mark proc) (point)))
- (if moving (goto-char (process-mark proc)))))))
-#+end_src
-
-* It's not an emacs app if it doesn't have a new mode
-
-With that out of the way, we just have to insert our data in an
-appropriate buffer. We are going to associate a separate buffer to
-each /source/, using for that its name:
-
-#+begin_src emacs-lisp
-(defvar-local signel-user nil)
-
-(defun signel--contact-buffer (source)
- (let* ((name (format "*%s" (signel--contact-name source)))
- (buffer (get-buffer name)))
- (unless buffer
- (setq buffer (get-buffer-create name))
- (with-current-buffer buffer
- (signel-chat-mode)
- (setq-local signel-user source)
- (insert signel-prompt)))
- buffer))
-#+end_src
-
-where, as is often the case in emacs, we are going to have a dedicated
-major mode for chat buffers, called ~signel-chat-mode~. For now, let's
-keep it really simple (for the record, this is essentially a copy of
-what ERC does for its erc-mode):
-
-#+begin_src emacs-lisp
-(defvar signel-prompt ": ")
-
-(define-derived-mode signel-chat-mode fundamental-mode "Signal"
- "Major mode for Signal chats."
- (when (boundp 'next-line-add-newlines)
- (set (make-local-variable 'next-line-add-newlines) nil))
- (setq line-move-ignore-invisible t)
- (set (make-local-variable 'paragraph-separate)
- (concat "\C-l\\|\\(^" (regexp-quote signel-prompt) "\\)"))
- (set (make-local-variable 'paragraph-start)
- (concat "\\(" (regexp-quote signel-prompt) "\\)"))
- (setq-local completion-ignore-case t))
-#+end_src
-
-Note how, in ~signel--contact-buffer~, we're storing the user identity
-associated with the buffer (its /source/) in a buffer-local variable
-named ~signel-user~ that is set /after/ enabling ~signel-chat-mode~: order
-here matters because the major mode activation cleans up the values of
-any local variables previously set (i always forget that!).
-
-* And a customization group
-
-We're going to need a couple of new faces for the different parts of
-inserted messages, so we'll take the chance to be tidy and introduce a
-customization group:
-
-#+begin_src emacs-lisp
-(defgroup signel nil "Signel")
-
-(defface signel-contact '((t :weight bold))
- "Face for contact names."
- :group 'signel)
-
-(defface signel-timestamp '((t :foreground "grey70"))
- "Face for timestamp names."
- :group 'signel)
-
-(defface signel-notice '((t :inherit signel-timestamp))
- "Face for delivery notices."
- :group 'signel)
-
-(defface signel-prompt '((t :weight bold))
- "Face for the input prompt marker."
- :group 'signel)
-
-(defface signel-user '((t :foreground "orangered"))
- "Face for sent messages."
- :group 'signel)
-
-(defface signel-notification '((t :foreground "burlywood"))
- "Face for notifications shown by tracking, when available."
- :group 'signel)
-
-#+end_src
-
-
-* Displaying incoming messages
-
-We have now almost all the ingredients to write
-~signel--update-chat-buffer~, the function that inserts the received
-message data into the chat buffer. Let's define a few little
-functions to format those parts:
-
-#+begin_src emacs-lisp
-(defun signel--contact (name)
- (propertize name 'face 'signel-contact))
-
-(defun signel--timestamp (&rest p)
- (propertize (apply #'concat p) 'face 'signel-timestamp))
-
-(defun signel--notice (notice)
- (propertize notice 'face 'signel-notice))
-
-(defun signel--insert-prompt ()
- (let ((inhibit-read-only t)
- (p (point)))
- (insert signel-prompt)
- (set-text-properties p (- (point) 1)
- '(face signel-prompt
- read-only t front-sticky t rear-sticky t))))
-
-(defun signel--delete-prompt ()
- (when (looking-at-p (regexp-quote signel-prompt))
- (let ((inhibit-read-only t))
- (delete-char (length signel-prompt)))))
-
-(defun signel--delete-last-prompt ()
- (goto-char (point-max))
- (when (re-search-backward (concat "^" (regexp-quote signel-prompt)))
- (signel--delete-prompt)))
-
-#+end_src
-
-With that, we're finally ready to insert messages in our signel chat
-buffers:
-
-#+begin_src emacs-lisp
-(defcustom signel-report-deliveries nil
- "Whether to show message delivery notices."
- :group 'signel
- :type 'boolean)
-
-(defcustom signel-report-read t
- "Whether to show message read notices."
- :group 'signel
- :type 'boolean)
-
-(defun signel--prompt-and-notify ()
- (signel--insert-prompt)
- (when (fboundp 'tracking-add-buffer)
- (tracking-add-buffer (current-buffer) '(signel-notification))))
-
-(defun signel--needs-insert-p (data stamp rec-stamp msg)
- (or data
- (and (or rec-stamp stamp)
- (not (string= source signel-cli-user))
- (or signel-report-deliveries
- (and signel-report-read (signel--msg-is-read msg))))))
-
-(defun signel--update-chat-buffer (source data stamp rec-stamp msg)
- (when (signel--needs-insert-p data stamp rec-stamp msg)
- (when-let ((b (signel--contact-buffer source)))
- (with-current-buffer b
- (signel--delete-last-prompt)
- (if data
- (let ((p (point)))
- (insert (signel--timestamp "[" stamp "] ")
- (signel--contact (signel--contact-name source))
- signel-prompt
- data
- "\n")
- (fill-region p (point)))
- (let ((is-read (signel--msg-is-read msg)))
- (insert (signel--timestamp "*" (or rec-stamp stamp) "* ")
- (signel--notice (if is-read "(read)" "(delivered)"))
- "\n")))
- (signel--prompt-and-notify)
- (end-of-line)))))
-#+end_src
-
-There are some rough edges in the above implementation that must be
-polished should signel ever be released in the wild. For one, proper
-handling of timestamps and their formats. And of course notifications
-should be much more customizable (here i'm using [[https://github.com/jorgenschaefer/circe/blob/master/tracking.el][Circe's tracking.el]]
-if available).
-
-* Sending messages: the DBUS interface
-
-With that, we're going to receive and display messages and simple
-receipts, and i'm sure that we will feel the urge to answer some of
-them. As mentioned above, signal-cli let's us send messages via its
-[[https://github.com/AsamK/signal-cli/wiki/DBus-service][DBUS interface]].
-In a nutshell, if you want to send ~MESSAGETEXT~ to a
-~RECIPIENT~ you'd invoke something like:
-
-#+begin_src shell :tangle no
-dbus-send --session --type=method_call \
- --dest="org.asamk.Signal" \
- /org/asamk/Signal \
- org.asamk.Signal.sendMessage \
- string:MESSAGETEXT array:string: string:RECIPIENT
-#+end_src
-
-That is, call the method ~sendMessage~ of the corresponding service
-interface with three arguments (the second one empty). Using emacs'
-dbus libray one can write the above as:
-
-#+begin_src emacs-lisp
-(defun signel--send-message (user msg)
- (dbus-call-method :session "org.asamk.Signal" "/org/asamk/Signal"
- "org.asamk.Signal" "sendMessage"
- :string msg
- '(:array)
- :string user))
-#+end_src
-
-The only complicated bit is being careful with the specification of
-the types of the method arguments: if one gets them wrong, DBUS will
-simply complain and say that the method is not defined, which was
-confusing me at first (but of course makes sense because DBUS allows
-overloading method names, so the full method spec must include its
-signature).
-
-We want to read whatever our user writes after the last prompt and
-send it via the little helper above. Here's our interactive command
-for that:
-
-#+begin_src emacs-lisp
-(defun signel-send ()
- "Read text inserted in the current buffer after the last prompt and send it.
-
-The recipient of the message is looked up in a local variable set
-when the buffer was created."
- (interactive)
- (goto-char (point-max))
- (beginning-of-line)
- (let* ((p (point))
- (plen (length signel-prompt))
- (msg (buffer-substring (+ p plen) (point-max))))
- (signel--delete-prompt)
- (signel--send-message signel-user msg)
- (insert (signel--timestamp (format-time-string "(%H:%M) ")))
- (fill-region p (point-max))
- (goto-char (point-max))
- (set-text-properties p (point) '(face signel-user))
- (insert "\n")
- (signel--insert-prompt)))
-#+end_src
-
-and we can bind it to the return key in signal chat buffers:
-
-#+begin_src emacs-lisp
-(define-key signel-chat-mode-map "\C-m" #'signel-send)
-#+end_src
-
-And we are going sometimes to want to talk to contacts that don't have
-yet said anything and have, therefore, no associated chat buffer:
-
-#+begin_src emacs-lisp
-(defun signel-query (contact)
- "Start a conversation with a signal contact."
- (interactive (list (completing-read "Signal to: "
- (mapcar #'cdr-safe signel-contact-names))))
- (let ((phone (alist-get contact
- (cl-pairlis (mapcar #'cdr signel-contact-names)
- (mapcar #'car signel-contact-names))
- nil nil #'string-equal)))
- (when (not phone)
- (error "Unknown contact %s" contact))
- (pop-to-buffer (signel--contact-buffer phone))))
-#+end_src
-
-There are of course lots of rough edges and missing functionality in
-this incipient signel, but it's already usable and a nice
-demonstration of how easy it is to get the ball rolling in this lisp
-machine of ours!
generated by cgit v1.2.3 (git 2.46.0) at 2026-09-17 11:27:14 +0000