Add nnatom.el

Direct copy from https://git.sr.ht/~dsemy/nnatom, with updated copyright header.
2026-02-16 09:14:18 +00:00 · 2023-06-17 18:47:59 -07:00 · 2023-06-17 18:47:59 -07:00 · 5c0cf97079
commit 5c0cf97079
parent 1b0348d959
1 changed files with 540 additions and 0 deletions
--- a/lisp/gnus/nnatom.el
+++ b/lisp/gnus/nnatom.el
@ -0,0 +1,540 @@
+;;; nnatom.el --- Atom backend for Gnus -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023  Free Software Foundation, Inc.
+
+;; Author: Daniel Semyonov <daniel@dsemy.com>
+
+;; This file is not part of GNU Emacs.
+
+;; nnatom 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.
+
+;; nnatom 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 nnatom.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Gnus backend for Atom feeds.
+
+;;; Code:
+
+(eval-when-compile
+  (require 'cl-lib)
+  (require 'gv)
+  (require 'subr-x))
+
+(require 'gnus)
+(require 'nnheader)
+(require 'nnoo)
+(require 'gnus-group)
+(require 'mm-url)
+
+(defgroup nnatom nil
+  "Atom backend for Gnus."
+  :group 'gnus)
+
+(nnoo-declare nnatom)
+
+(defvoo nnatom-backend 'nnatom
+  "Symbol which identifies this backend.")
+
+(defvoo nnatom-status-string nil
+  "Last status message reported by this backend.")
+
+(defsubst nnatom--backend-prefix (backend)
+  (concat (symbol-name backend) ":"))
+
+;;;; Atom feed parser:
+
+(defsubst nnatom--node-attributes (node subnode)
+  (cadr (assq subnode node)))
+
+(defsubst nnatom--node-subnodes (node subnode)
+  (let ((sub (cddr (assq subnode node))))
+    (or (and (atom (car sub)) (car sub)) sub)))
+
+(defun nnatom--parse-feed (feed)
+  "Return a list structure representing FEED, or nil."
+  (if (string-match-p "^https?://" feed)
+      (nnheader-report
+       nnatom-backend
+       "Address shouldn't start with \"http://\" or \"https://\"")
+    (with-temp-buffer
+      (condition-case e
+          (if (file-readable-p feed)
+              (insert-file-contents feed)
+            (mm-url-insert-file-contents (concat "https://" feed)))
+        (file-error (nnheader-report nnatom-backend (cdr e)))
+        (:success (cddr (libxml-parse-xml-region (point-min) (point-max))))))))
+
+(defun nnatom--read-article (data _)
+  "Return the next article and the remaining DATA in a cons cell, or nil."
+  (and data
+       `(,(let (article)
+            (while (not (eq (car (setq article (car data))) 'entry))
+              (setq data (cdr data)))
+            (setq data (cdr data))
+            article)
+         . ,data)))
+
+(defun nnatom--read-title (feed)
+  "Return the title of FEED, or nil."
+  (nnatom--node-subnodes feed 'title))
+
+(defun nnatom--read-article-or-feed-author (article-or-feed)
+  "Return the author of ARTICLE-OR-FEED, or nil."
+  (let* ((author (nnatom--node-subnodes article-or-feed 'author))
+         (name (nnatom--node-subnodes author 'name))
+         (email (nnatom--node-subnodes author 'email)))
+    (or (and name email (format "%s <%s>" name email))
+        name email)))
+
+(defun nnatom--read-id (article)
+  "Return the ID of ARTICLE.
+If the ARTICLE doesn't contain an ID but it does contain a subject,
+return the subject.  Otherwise, return nil."
+  (or (nnatom--node-subnodes article 'id)
+      (nnatom--read-subject article)))
+
+(defun nnatom--read-subject (article)
+  "Return the subject of ARTICLE, or nil."
+  (nnatom--node-subnodes article 'title))
+
+(defun nnatom--read-publish (article)
+  "Return the date and time ARTICLE was published, or nil."
+  (when-let ((pub (nnatom--node-subnodes article 'published)))
+    (and (stringp pub) (date-to-time pub))))
+
+(defun nnatom--read-update (article)
+  "Return the date and time of the last update to ARTICLE, or nil."
+  (when-let ((update (nnatom--node-subnodes article 'updated)))
+    (and (stringp update) (date-to-time update))))
+
+(defun nnatom--read-link (article)
+  "Return the link to ARTICLE, or nil."
+  (alist-get 'href (or (nnatom--node-attributes article 'link)
+                       (nnatom--node-subnodes article 'link))))
+
+(defun nnatom--read-summary-or-content-type (article summary-or-content)
+  "Return the type of SUMMARY-OR-CONTENT of ARTICLE, or \"plain\"."
+  (or (cdr (assq 'type
+                 (nnatom--node-attributes article summary-or-content)))
+      "plain"))
+
+(defun nnatom--read-summary-or-content (article summary-or-content)
+  "Return SUMMARY-OR-CONTENT of ARTICLE, or nil."
+  (nnatom--node-subnodes article summary-or-content))
+
+;;;; Feed I/O:
+
+(defvoo nnatom-read-feed-function #'nnatom--parse-feed
+  "Function returning a Lisp object representing a feed (or part of it).
+It should accept a single argument, the address of a feed.")
+
+(defvoo nnatom-read-article-function #'nnatom--read-article
+  "Function returning a cons cell of an article and remaining data from a feed.
+It should accept a two arguments, a Lisp object representing a feed,
+and a flag indicating whether the last article was stale (not new or updated).
+If there are no remaining articles, it should return nil.")
+
+(defvoo nnatom-read-title-function #'nnatom--read-title
+  "Function returning the title of a feed (a string).
+It should accept a single argument, a Lisp object representing a feed.")
+
+(defvoo nnatom-read-feed-author-function #'nnatom--read-article-or-feed-author
+  "Function returning the author of a feed (a string).
+It should accept a single argument, a Lisp object representing a feed.")
+
+(defvoo nnatom-read-id-function #'nnatom--read-id
+  "Function returning the ID of an article.
+It should accept a single argument, a Lisp object representing an article.")
+
+(defvoo nnatom-read-subject-function #'nnatom--read-subject
+  "Function returning the subject of an article (a string).
+It should accept a single argument, a Lisp object representing an article.")
+
+(defvoo nnatom-read-publish-date-function #'nnatom--read-publish
+  "Function returning the publish date of an article (a time value).
+It should accept a single argument, a Lisp object representing an article.")
+
+(defvoo nnatom-read-update-date-function #'nnatom--read-update
+  "Function returning the update date of an article (a time value).
+It should accept a single argument, a Lisp object representing an article.")
+
+(defvoo nnatom-read-author-function #'nnatom--read-article-or-feed-author
+  "Function returning the author of an article (a string).
+It should accept a single argument, a Lisp object representing an article.")
+
+(defvoo nnatom-read-link-function #'nnatom--read-link
+  "Function returning the link contained in an article (a string).
+It should accept a single argument, a Lisp object representing an article.")
+
+(defvoo nnatom-read-summary-type-function
+    (lambda (article)
+      (nnatom--read-summary-or-content-type article 'summary))
+  "Function returning the type of the summary of an article (a string).
+This is appended to \"text/\" to form the MIME type of the summary.
+It should accept a single argument, a Lisp object representing an article.")
+
+(defvoo nnatom-read-content-type-function
+    (lambda (article)
+      (nnatom--read-summary-or-content-type article 'content))
+  "Function returning the type of the content of an article (a string).
+This is appended to \"text/\" to form the MIME type of the content.
+It should accept a single argument, a Lisp object representing an article.")
+
+(defvoo nnatom-read-summary-function
+    (lambda (article)
+      (nnatom--read-summary-or-content article 'summary))
+  "Function returning the summary of an article (a string).
+It should accept a single argument, a Lisp object representing an article.")
+
+(defvoo nnatom-read-content-function
+    (lambda (article)
+      (nnatom--read-summary-or-content article 'content))
+  "Function returning the content of an article (a string).
+It should accept a single argument, a Lisp object representing an article.")
+
+(defvoo nnatom-groups (make-hash-table :test 'equal)
+  "Hash table mapping known group names to their data.
+
+Each value in this table should be a vector of the form
+[GROUP IDS ARTICLES MAX MIN], where:
+- GROUP is the name of the group.
+- IDS is a hash table mapping article IDs to their numbers.
+- ARTICLES is a hash table mapping article numbers to articles and
+  their attributes (see `nnatom-group-articles').
+- MAX is the maximum article number.
+- MIN is the minimum article number.")
+
+(defun nnatom-group-file (group)
+  "Return the file containing feed data for GROUP."
+  (expand-file-name (format "%s/%s.eld"
+                            (string-trim (symbol-name nnatom-backend)
+                                         "nn")
+                            (gnus-newsgroup-savable-name group))
+                    gnus-directory))
+
+(defun nnatom--read-feed (feed &optional group)
+  "Read FEED into a new or existing GROUP."
+  (let ((prefix (nnatom--backend-prefix nnatom-backend)))
+    (when (string-suffix-p "-ephemeral" feed)
+      (setq feed (or (cadr (assq (nnoo-symbol nnatom-backend 'address)
+                                 (cddr (gnus-server-to-method
+                                        (concat prefix feed)))))
+                     feed)))
+    (when-let ((data (funcall nnatom-read-feed-function feed))
+               (group (or (and group (string-trim group prefix))
+                          (cadr (assq (nnoo-symbol nnatom-backend 'name)
+                                      (gnus-server-to-method
+                                       (concat prefix feed))))
+                          (funcall nnatom-read-title-function data))))
+      (let* ((info (gnus-get-info (concat prefix group)))
+             (g (or (gethash group nnatom-groups)
+                    (nnatom-read-group group)
+                    `[ ,group ,(make-hash-table :test 'equal)
+                       ,(make-hash-table :test 'eql) nil 1]))
+             (ids (aref g 1))
+             (articles (aref g 2))
+             (max (aref g 3))
+             (max (if max max
+                    (setq max 0) ; Find max article number
+                    (dolist      ; remembered by Gnus.
+                        ( r (cons (gnus-info-read info)
+                                  (gnus-info-marks info))
+                          max)
+                      (mapc (lambda (x)
+                              (let ((x (if (consp x)
+                                           (if (< (car x) (cdr x))
+                                               (cdr x) (car x))
+                                         x)))
+                                (when (< max x) (setq max x))))
+                            (if (symbolp (car r)) (cdr r) r)))))
+             (feed-author (funcall nnatom-read-feed-author-function data))
+             article stale)
+        (while (setq article (funcall nnatom-read-article-function data stale)
+                     data (cdr article)
+                     article (car article))
+          (when-let ((id (funcall nnatom-read-id-function article))
+                     (id (format "<%s@%s.%s>" id group nnatom-backend)))
+            (let* ((num (gethash id ids))
+                   (update (funcall nnatom-read-update-date-function article))
+                   (prev-update (aref (gethash num articles
+                                               '[nil nil nil nil nil])
+                                      4)))
+              (if (or (null num) ; New article ID.
+                      (and (null prev-update) update)
+                      (and prev-update update
+                           (time-less-p prev-update update)))
+                  (let* ((num (or num (aset g 3 (cl-incf max))))
+                         (publish (funcall nnatom-read-publish-date-function
+                                           article)))
+                    (setf
+                     (gethash id (aref g 1)) num
+                     (gethash num (aref g 2))
+                     `[ ,id
+                        ,(or (funcall nnatom-read-author-function article)
+                             feed-author group)
+                        ,(or (funcall nnatom-read-subject-function article)
+                             "no subject")
+                        ,(or publish update '(0 0)) ; published
+                        ,(or update publish '(0 0)) ; updated
+                        ,(funcall nnatom-read-link-function article)
+                        (,(funcall nnatom-read-summary-function article)
+                         . ,(funcall nnatom-read-summary-type-function article))
+                        (,(funcall nnatom-read-content-function article)
+                         . ,(funcall
+                             nnatom-read-content-type-function
+                             article))]
+                     stale nil))
+                (setq stale t)))))
+        (puthash group g nnatom-groups)))))
+
+(defun nnatom-read-group (group)
+  "Read GROUP's information from `nnatom-directory'."
+  (if-let ((f (nnatom-group-file group))
+           ((file-readable-p f)))
+      (with-temp-buffer
+        (insert-file-contents f)
+        (goto-char (point-min))
+        (puthash group (read (current-buffer)) nnatom-groups))
+    (nnheader-report nnatom-backend "Can't read %s")))
+
+(defun nnatom-write-group (group)
+  "Write GROUP's information to `nnatom-directory'."
+  (if-let ((f (nnatom-group-file group))
+           ((file-writable-p f)))
+      (if-let ((g (gethash group nnatom-groups))
+               ((vectorp g)))
+          (with-temp-file f
+            (insert ";;;; -*- mode: lisp-data -*- DO NOT EDIT\n"
+                    (prin1-to-string g))
+            t)
+        t)
+    (nnheader-report nnatom-backend "Can't write %s" f)))
+
+;;;; Gnus backend functions:
+
+(defvoo nnatom-group nil
+  "Name of the current group.")
+
+(defvoo nnatom-group-article-ids (make-hash-table :test 'equal)
+  "Hash table mapping article IDs to their article number.")
+
+(defvoo nnatom-group-articles (make-hash-table :test 'eql)
+  "Hash table mapping article numbers to articles and their attributes.
+
+Each value in this table should be a vector of the form
+[ID FROM SUBJECT DATE UPDATED LINK SUMMARY CONTENT], where:
+- ID is the ID of the article.
+- FROM is the author of the article or group.
+- SUBJECT is the subject of the article.
+- DATE is the date the article was published, or last updated (time value).
+- UPDATE is the date the article was last updated, or published (time value).
+- LINK is the URL to the full (remote) version of the article.
+- SUMMARY and CONTENT are cons cells where the car is the raw
+  summary/content of the article and the cdr is the \"type\" of
+  the summary/content (appended to \"text/\" to form the MIME type).")
+
+(defvoo nnatom-group-article-max-num 0
+  "Maximum article number for the current group.")
+
+(defvoo nnatom-group-article-min-num 1
+  "Minimum article number for the current group.")
+
+(defvar nnatom-date-format "%F %X"
+  "Format of displayed dates.")
+
+(nnoo-define-basics nnatom)
+
+(defun nnatom-retrieve-article (article group)
+  (if-let ((a (gethash article (aref group 2))))
+      (insert (format "221 %s Article retrieved.
+From: %s\nSubject: %s\nDate: %s\nMessage-ID: %s\n.\n"
+                      article
+                      (aref a 1)
+                      (aref a 2)
+                      (format-time-string nnatom-date-format (aref a 3))
+                      (aref a 0)))
+    (insert "404 Article not found.\n.\n")))
+
+(deffoo nnatom-retrieve-headers (articles &optional group _server _fetch-old)
+  (if-let ((g (or (gethash group nnatom-groups)
+                  (nnatom-read-group group)
+                  `[ nil ,nnatom-group-article-ids
+                     ,nnatom-group-articles nil nil])))
+      (with-current-buffer nntp-server-buffer
+        (erase-buffer)
+        (or (and (stringp (car articles))
+                 (mapc (lambda (a)
+                         (nnatom-retrieve-article
+                          (gethash a (aref g 1)) g))
+                       articles))
+            (and (numberp (car articles))
+                 (range-map (lambda (a) (nnatom-retrieve-article a g))
+                            articles)))
+        'headers)
+    (nnheader-report nnatom-backend "Group %s not found" (or group ""))))
+
+(deffoo nnatom-request-close ()
+  (setq nnatom-groups (make-hash-table :test 'equal)
+        nnatom-status-string nil)
+  t)
+
+(defun nnatom--print-content (content type link)
+  "Return CONTENT with LINK appended and formatted according to TYPE."
+  (when (and content type)
+    (let ((html (or (string= type "html") (string= type "xhtml"))))
+      (concat (when html "<html><head></head><body>") content "\n\n"
+              (and (stringp link)
+                   (if html (format "<p><a href=\"%s\">[Link]</a></p>" link)
+                     link))
+              (when html "</body></html>")))))
+
+(deffoo nnatom-request-article (article &optional group _server to-buffer)
+  (if-let ((g (or (gethash group nnatom-groups)
+                  (and nnatom-group
+                       `[ nil ,nnatom-group-article-ids
+                          ,nnatom-group-articles
+                          ,nnatom-group-article-max-num
+                          ,nnatom-group-article-min-num])))
+           (num (or (and (stringp article)
+                         (gethash article (aref g 1)))
+                    (and (numberp article) article)))
+           ((and (<= num (aref g 3))
+                 (>= num (aref g 4))))
+           (a (gethash num (aref g 2))))
+      (with-current-buffer (or to-buffer nntp-server-buffer)
+        (erase-buffer)
+        (let* ((boundary (format "-_%s_-" nnatom-backend))
+               (link (aref a 5))
+               (summary (aref a 6))
+               (summary-type (cdr summary))
+               (summary
+                (nnatom--print-content (car summary) summary-type link))
+               (content (aref a 7))
+               (content-type (cdr content))
+               (content
+                (nnatom--print-content (car content) content-type link)))
+          (insert (format
+                   "Subject: %s\nFrom: %s\nDate: %s\nMessage-ID: %s\n"
+                   (aref a 2) (aref a 1)
+                   (format-time-string
+                    nnatom-date-format (or (aref a 3) '(0 0)))
+                   (aref a 0))
+                  "MIME-Version: 1.0\nContent-Type: "
+                  (concat (cond ((and summary content)
+                                 (format "multipart/alternative; boundary=%s
+--%s\nContent-Type: text/%s\n\n%s\n--%s\nContent-Type: text/%s\n\n%s\n--%s--\n"
+                                         boundary boundary summary-type
+                                         summary boundary content-type
+                                         content boundary))
+                                (summary (format "text/%s\n\n%s\n"
+                                                 summary-type summary))
+                                (content (format "text/%s\n\n%s\n"
+                                                 content-type content))
+                                (link (format "text/plain\n\n%s\n" link))
+                                (t "text/plain\n\n")))))
+        `(,group . ,num))
+    (nnheader-report nnatom-backend "No such article")))
+
+(deffoo nnatom-request-group (group &optional server fast _info)
+  (with-current-buffer nntp-server-buffer
+    (erase-buffer)
+    (if-let ((s (or server (nnoo-current-server nnatom-backend)))
+             (g (or (if fast
+                        (or (gethash group nnatom-groups)
+                            (nnatom-read-group group))
+                      (nnatom--read-feed s group))
+                    `[ ,group ,(make-hash-table :test 'equal)
+                       ,(make-hash-table :test 'eql) 0 1])))
+        (progn
+          (setq nnatom-group group
+                nnatom-group-article-ids (aref g 1)
+                nnatom-group-articles (aref g 2)
+                nnatom-group-article-max-num (aref g 3)
+                nnatom-group-article-min-num (aref g 4))
+          (insert (format "211 %s %s %s \"%s\""
+                          (hash-table-count nnatom-group-article-ids)
+                          nnatom-group-article-min-num
+                          nnatom-group-article-max-num group))
+          t)
+      (insert "404 group not found")
+      (nnheader-report nnatom-backend "Group %s not found" group))))
+
+(deffoo nnatom-close-group (group &optional _server)
+  (if (nnatom-write-group group)
+      (setq nnatom-group nil
+            nnatom-group-article-ids (make-hash-table :test 'equal)
+            nnatom-group-articles (make-hash-table :test 'eql)
+            nnatom-group-article-max-num 0
+            nnatom-group-article-min-num 1)
+    (nnheader-report nnatom-backend "Couldn't write group %s" group)))
+
+(deffoo nnatom-request-list (&optional server)
+  (with-current-buffer nntp-server-buffer
+    (erase-buffer)
+    (when-let ((g (nnatom--read-feed
+                   (or server (nnoo-current-server nnatom-backend)))))
+      (insert (format "\"%s\" %s %s y\n"
+                      (aref g 0) (aref g 3) (aref g 4)))
+      t)))
+
+(deffoo nnatom-request-post (&optional _server)
+  (nnheader-report nnatom-backend "%s is a read only backend" nnatom-backend))
+
+;;;; Optional back end functions:
+
+(deffoo nnatom-retrieve-groups (_groups &optional server)
+  (nnatom-request-list (or server (nnoo-current-server nnatom-backend)))
+  'active)
+
+(deffoo nnatom-request-type (_group &optional _article)
+  'unknown)
+
+(deffoo nnatom-request-delete-group (group _force &optional _server)
+  (delete-file (nnatom-group-file group))
+  (remhash group nnatom-groups)
+  (when (string= group nnatom-group)
+    (setq nnatom-group nil
+          nnatom-group-article-ids (make-hash-table :test 'equal)
+          nnatom-group-articles (make-hash-table :test 'eql)
+          nnatom-group-article-max-num 0
+          nnatom-group-article-min-num 1))
+  t)
+
+(gnus-declare-backend (symbol-name nnatom-backend) 'address)
+
+;;;; Utilities:
+
+(defmacro nnatom-define-basic-backend-interface (backend)
+  "Define a basic set of functions and variables for BACKEND."
+  (let ((bp (symbol-name backend)))
+    `(progn
+       (defvoo ,(intern (concat bp "-backend")) ',backend nil nnatom-backend)
+       (defvoo ,(intern (concat bp "-status-string"))
+           nil nil nnatom-status-string)
+       (defvoo ,(intern (concat bp "-group")) nil nil nnatom-group)
+       (defvoo ,(intern (concat bp "-groups"))
+           (make-hash-table :test 'equal) nil nnatom-groups)
+       (defvoo ,(intern (concat bp "-group-article-ids"))
+           (make-hash-table :test 'equal) nil nnatom-group-article-ids)
+       (defvoo ,(intern (concat bp "-group-articles"))
+           (make-hash-table :test 'eql) nil nnatom-group-articles)
+       (defvoo ,(intern (concat bp "-group-article-max-num")) 0 nil
+               nnatom-group-article-max-num)
+       (defvoo ,(intern (concat bp "-group-article-mix-num")) 1 nil
+               nnatom-group-article-min-num)
+       (nnoo-define-basics ,backend)
+       (nnoo-import ,backend (nnatom)))))
+
+(provide 'nnatom)
+
+;;; nnatom.el ends here