Add utilities to describe mailing list messages

1 files changed, 49 insertions, 1 deletions

diff --git a/.emacs b/.emacs
index c1ad7a5..dfdce5b 100644
--- 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.