diff --git a/mu4e/mu4e-actions.el b/mu4e/mu4e-actions.el index c10b2ed8..967aaae5 100644 --- a/mu4e/mu4e-actions.el +++ b/mu4e/mu4e-actions.el @@ -28,6 +28,7 @@ ;;; Code: (require 'ido) +(require 'browse-url) (require 'mu4e-helpers) (require 'mu4e-message) @@ -247,6 +248,22 @@ the message." nil nil nil msgid (and (eq major-mode 'mu4e-view-mode) (not (eq mu4e-split-view 'single-window)))))))) + +(defun mu4e-actions-browse-list-archive (msg) + "Browse the archive for a mailing list message MSG. +See `mu4e-list-archives-resolve'." + (interactive (list (mu4e-message-at-point))) + (when-let ((url (mu4e-list-archives-resolve msg))) + (browse-url url))) + +(defun mu4e-actions-kill-list-archive (msg) + "Kill the archive url for a mailing list message MSG. +See `mu4e-list-archives-resolve'." + (interactive (list (mu4e-message-at-point))) + (let ((url (mu4e-list-archives-resolve msg))) + (if (stringp url) (kill-new url) + (user-error "Cannot get url for this message")))) + ;;; _ (provide 'mu4e-actions) ;;; mu4e-actions.el ends here diff --git a/mu4e/mu4e-list-archives.el b/mu4e/mu4e-list-archives.el new file mode 100644 index 00000000..80a291e9 --- /dev/null +++ b/mu4e/mu4e-list-archives.el @@ -0,0 +1,206 @@ +;;; mu4e-list-archives.el --- Locate online mailing list archives -*- lexical-binding: t; -*- + +;; Copyright (C) 2023 Ruijie Yu + +;; Author: Ruijie Yu + +;; This file is not part of GNU Emacs. + +;; mu4e 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. + +;; mu4e 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 mu4e. If not, see . + +;;; Commentary: + +;; In this file, we attempt to locate an online archive for a mailing list +;; message. + +;;; Code: +(eval-when-compile (require 'subr-x)) ; for `thread-last' +(require 'cl-lib) +(require 'mu4e-lists) + +(defgroup mu4e-list-archives nil + "Configuration group for retrieving online mailing list archives." + :group 'mu4e-lists) + +(defcustom mla-user-actions nil + "An alist with cells (MAILING-LIST-ID . ARCHIVE-ACTION). +This variable is consulted before `mla-actions' when +determining the archive URL of a given mailing list. + +ARCHIVE-ACTION can take one of the following three forms: + +- nil: this mailing list has no online archive. This is useful +to override a default setting in `mla-actions'. + +- a string: it should contain a single `format' \"%s\" parameter, + where the message ID is substituted. + +- a function: the function should take one argument: the message + object as returned by `mu4e-message-at-point', and return + either nil to indicate no archive, or a string that will be + treated as the archive URL for the current message." + :type '(alist :key-type (string :tag "Mailing List ID") + :value-type + (choice (const :tag "No online archive" nil) + (string :tag "URL format with one \"%s\" parameter") + (function :tag "Function returning URL or nil")))) + +(defun mla--get-recipients (msg) + "Helper function to retrieve a list of recipients from MSG." + (delete-dups + (delq nil (mapcar (lambda (c) (plist-get c :email)) + (apply #'append + (mapcar (apply-partially #'plist-get msg) + '(:to :cc :bcc))))))) + +(defun mla-resolve-debbug (base-url &optional debbug-mail-domain) + "Return an ARCHIVE-ACTION function for debbug, based on BASE-URL. +This function sequentially checks that one of the following +conditions is true, and returns the url based on the found bug +number if possible, returning nil if all have failed. + +1. That the subject contains \"bug#xxxxx\" (case-insensitive). + +2. When DEBBUG-MAIL-DOMAIN is non-nil, that one of the recipients + has address . + +See `mu4e-list-archives-actions' for details on ARCHIVE-ACTION." + (lambda (msg) + "Returned by `mu4e-list-archives-resolve-debbug', which see." + (and-let* + ((match-subject (rx bow "bug#" (group-n 1 (+ digit)))) + (match-recipient (if debbug-mail-domain + (rx (group-n 1 (+ digit)) + ?@ (literal debbug-mail-domain)) + (rx unmatchable))) + (bug (cond + ((let ((case-fold-search nil)) ; (1) + (save-match-data + (and-let* ((subject (plist-get msg :subject)) + ((string-match match-subject subject))) + (match-string 1 subject))))) + (debbug-mail-domain ; (2) + (save-match-data + (seq-drop-while + (lambda (recipient) + (and-let* (((string-match match-recipient recipient))) + (match-string 1 recipient))) + (mla--get-recipients msg))))))) + (format "%s?bug=%s" base-url bug)))) + +(defun mla--resolve-namazu (search-url-fmt url-base msg) + "Resolve the actual archive page from the namazu search result. +Return the actual url or nil if not found. + +SEARCH-URL-FMT is a url format satisfying the second definition +of ARCHIVE-ACTION. + +MSG is a plist returned by `mu4e-message-at-point'. + +URL-BASE is the base url string." + (defvar url-asynchronous) + (let ((url-asynchronous nil)) + (and-let* (((libxml-available-p)) + (msgid (plist-get msg :message-id)) + (search-url (format search-url-fmt (url-hexify-string msgid))) + (buf (url-retrieve search-url #'ignore))) + (with-current-buffer buf + (while (process-live-p (get-buffer-process buf)) + (sit-for 0.1 t)) + (save-excursion + (save-match-data + (goto-char 1) + (and-let* (((re-search-forward (rx bol eol) nil t)) + (url (thread-last + ;; emacs#63291 + (libxml-parse-html-region (point) (point-max)) + (alist-get 'body) ; get body + (alist-get 'dl) ; get first dl + (alist-get 'dt) ; get first dt + (alist-get 'strong) ; get first strong + (alist-get 'a) ; get first aref + (car) ; peel the nested list + (alist-get 'href))) ; might be relative url + (url (url-generic-parse-url url)) + (url-base (url-generic-parse-url url-base))) + (prog2 (url-default-expander url url-base) + (url-recreate-url url))))))))) + +(defcustom mla-resolve-namazu-search t + "Whether to resolve namazu search page. +On mailman+namazu system, currently there is no direct way to get +the actual url for a given message id. The only way is to +perform a \"search\" on namazu. + +Enabling this option makes it to look into the structure of the +search page, and to locate the only match. Requires enabling +libxml support at compile time." + :type 'boolean + :safe #'booleanp) + +(defun mla-resolve-mailman-namazu (url-base internal-list-id) + "Return an ARCHIVE-ACTION for mailman namazu. +URL-BASE is the base url such that \"URL-BASE/namazu.cgi\" is the search page. + +INTERNAL-LIST-ID is the internal name for the list id, which is +usually the first part of the list id." + (let ((search-url-fmt + (format "%s/namazu.cgi?%s" + url-base + (string-join + (list "submit=Search%%21" + (format "idxname=%s" internal-list-id) + (format "query=%s:%%s" "%%2bmessage-id")) + "&")))) + (lambda (msg) + (cond + ((and (libxml-available-p) + mla-resolve-namazu-search + ;; This may fail. Fallback if failed. + (mla--resolve-namazu search-url-fmt url-base msg))) + ;; fallback + ((format search-url-fmt (plist-get msg :message-id))))))) + +(defconst mla-actions + `(("bug-gnu-emacs.gnu.org" . ,(mla-resolve-debbug + "https://debbugs.gnu.org/cgi/bugreport.cgi")) + ("emacs-orgmode.gnu.org" . "https://list.orgmode.org/%s") + ("help-gnu-emacs.gnu.org" + . ,(mla-resolve-mailman-namazu + "https://lists.gnu.org/archive/cgi-bin" "help-gnu-emacs"))) + "An alist with cells (MAILING-LIST-ID . ARCHIVE-ACTION). +See `mu4e-list-archives-user-actions' for further details.") + +(defun mla-resolve (msg) + "Return the archive url for a mailing list message MSG, or nil. +Based on `mu4e-lists-user-archive-urls' and +`mu4e-lists-archive-urls', in this order." + (and-let* (msg + (list-id (plist-get msg :list)) + (msg-id (plist-get msg :message-id)) + (archive-action + (let ((get (lambda (actions) + (alist-get list-id actions nil nil #'string=)))) + (or (funcall get mu4e-list-archives-user-actions) + (funcall get mu4e-list-archives-actions))))) + (pcase archive-action + ((pred stringp) (format archive-action msg-id)) + ((pred functionp) (funcall archive-action msg))))) + +(provide 'mu4e-list-archives) +;;; mu4e-list-archives.el ends here. + +;; Local Variables: +;; read-symbol-shorthands: (("mla" . "mu4e-list-archives")) +;; End: diff --git a/mu4e/mu4e-lists.el b/mu4e/mu4e-lists.el index 30d96670..861e073a 100644 --- a/mu4e/mu4e-lists.el +++ b/mu4e/mu4e-lists.el @@ -84,6 +84,9 @@ ("zsh-users.zsh.org" . "ZshUsr")) "AList of cells (MAILING-LIST-ID . SHORTNAME).") +(defgroup mu4e-lists nil "Configuration for mailing lists." + :group 'mu4e) + (defcustom mu4e-user-mailing-lists nil "An alist with cells (MAILING-LIST-ID . SHORTNAME). These are used in addition to the built-in list `mu4e-mailing-lists'."