dotfiles

commit 8a4e6534c432c8711a88c3da9159ec0145bc4e1a
parent 899e968ac9d2e5154ee7b8952398337b4b8009c7
Author: Kévin Le Gouguec <kevin.legouguec@gmail.com>
Date:   Thu, 14 Jan 2021 22:11:02 +0100

Add utilities to describe mailing list messages

Diffstat:
M
.emacs
 | 
50
+++++++++++++++++++++++++++++++++++++++++++++++++-

1 file changed, 49 insertions(+), 1 deletion(-)
diff --git a/.emacs b/.emacs
@@ -388,10 +388,58 @@
       (my/unfroggify)
     (my/froggify)))
 
-(defun my/message-id ()
+;; Utilities for mailing lists.
+(defun my/kill-message-id ()
   (interactive)
   (my/kill (mail-header-message-id (gnus-summary-article-header))))
 
+(defun my/describe-message (id url)
+  (my/kill (format "%s\n%s\n"
+                   (if (string-prefix-p "<" id)
+                       id
+                     (format "<%s>" id))
+                   url)))
+
+(defun my/describe-message-id (list id)
+  "Format references from the Message-ID of a gnu.org list."
+  (interactive
+   (list
+    (read-string "List: ")            ; TODO: default to current list.
+    (let ((default-id
+            (mail-header-message-id (gnus-summary-article-header))))
+      (read-string (format-prompt "Message-ID" default-id)
+                   nil nil default-id))))
+  (with-current-buffer
+      (url-retrieve-synchronously
+       (concat
+        ;; For some reason, literal "+" chars cause the search to fail.
+        ;; Escape them.
+        "https://lists.gnu.org/archive/cgi-bin/namazu.cgi"
+        "?query=%2Bmessage-id:"
+        (replace-regexp-in-string "\\+" "%2B" id)
+        "&submit=Search!"
+        "&idxname=" list))
+    (search-forward-regexp
+     (rx "<a href=\""
+         (group "/archive/html/" (literal list) "/"
+                (+ (any "0-9-")) "/msg" (+ (any "0-9")) ".html")
+         "\">"))
+    (let ((url (concat "https://lists.gnu.org" (match-string 1))))
+      (my/describe-message id url))))
+
+(defun my/describe-message-url (url)
+  "Format references from an article archived on MHonArc."
+  (interactive
+   (list
+    (let ((default (or (thing-at-point 'url)
+                       (and (derived-mode-p 'eww-mode)
+                            (shr-url-at-point nil)))))
+      (read-string (format-prompt "URL" default) nil nil default))))
+  (with-current-buffer (url-retrieve-synchronously url)
+    (search-forward-regexp "^<!--X-Message-Id: \\(.+\\) -->$")
+    (let ((id (xml-substitute-numeric-entities (match-string 1))))
+      (my/describe-message id url))))
+
 ;; Font stuff 🤷🤦.  Emacs comes with sensible defaults (e.g. the
 ;; default fontset includes Symbola for various subgroups of the
 ;; "symbol" script), but no color font by default.