bug#64202: [PATCH] Gnus: Add back end for Atom feeds (nnatom)

[Daniel Semyonov via "Bug reports for GNU Emacs, the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 1189 bytes --]

>>>>> Daniel Semyonov writes:

    > This patch adds a back end for Atom feeds to Gnus, and
    > documents it.

Attached is an updated version of the patch with the following changes:
- Remove "backend+" prefix from server addresses returned by
  'nnoo-current-server'.
- Don't handle HTML in any special way when printing content.
- Fix group renaming when the last server of a backend inheriting from
  nnatom was of a different backend than the groups'.
- Fix newly parsed feed information being overwritten by old on-disk
  information (not sure how I missed this one before).
- Support all content types supported by Atom (I think).  Previously I
  stated Atom only supports plain text and (X)HTML.  This is wrong -
  Atom supports arbitrary MIME types too, and thankfully the encoding of
  binary data is defined to be base64, which is natively supported by Gnus.
- Change format of stored links - now an alist mapping MIME types (or
  lists of them) to a string to print is used.
- Support printing custom article-wide MIME headers.
- Probably some more minor stuff I don't remember.

Also attached is an updated version of the nnyt backend I use for
testing inheritance.

Daniel


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: nnatom --]
[-- Type: text/x-patch, Size: 39875 bytes --]

From 615d00a9294595574bab4f59df081c39f75724c2 Mon Sep 17 00:00:00 2001
From: Daniel Semyonov <daniel@dsemy.com>
Date: Wed, 21 Jun 2023 10:05:04 +0300
Subject: [PATCH 1/2] Gnus: Add back end for Atom feeds (nnatom)

* lisp/gnus/gnus.el (gnus-valid-select-methods): Add entry for nnatom.
* lisp/gnus/nnatom.el: New file.
* doc/misc/gnus.texi:
* etc/NEWS: Document nnatom
---
 doc/misc/gnus.texi  |  58 ++++
 etc/NEWS            |   7 +
 lisp/gnus/gnus.el   |   1 +
 lisp/gnus/nnatom.el | 762 ++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 828 insertions(+)
 create mode 100644 lisp/gnus/nnatom.el

diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 8d25e868c8a..9184a4035df 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -715,6 +715,7 @@ Top
 
 * Web Searches::                Creating groups from articles that match a string.
 * RSS::                         Reading RDF site summary.
+* Atom::                        Reading Atom Syndication Format feeds.
 
 Other Sources
 
@@ -17250,6 +17251,7 @@ Browsing the Web
 @menu
 * Web Searches::                Creating groups from articles that match a string.
 * RSS::                         Reading RDF site summary.
+* Atom::                        Reading Atom Syndication Format feeds.
 @end menu
 
 The main caveat with all these web sources is that they probably won't
@@ -17494,6 +17496,62 @@ RSS
 @end lisp
 
 
+@node Atom
+@subsection Atom
+@cindex nnatom
+@cindex Atom
+
+Some web sites provide an Atom Syndication Format feed.  Atom is a web
+feed format similar in function to RDF Site Summary (@pxref{RSS}).
+
+The @code{nnatom} back end allows you to add HTTP or local Atom feeds
+as Gnus servers (with a single group), as you would with any other
+method, by supplying the location of the feed as the server address.
+Note, however, that the server address shouldn't be prefixed with
+@url{http://} or @url{https://}.
+
+Features of @code{nnatom} include:
+
+@itemize @bullet
+
+@item
+Server data is saved per-server in the @file{atom} sub-directory of
+@file{gnus-directory}.
+
+@item
+An article part is generated for both the summary and the content for
+each entry in the feed.  Content of all MIME types should be displayed
+correctly through Gnus (as long as the feed specifies a MIME type),
+even base64 encoded files (like images for example), which are
+supported by Atom.
+
+@item
+Article modification and publish dates are tracked, and articles are
+updated if changed.
+
+@item
+Designed with modularity in mind, the back end theoretically supports
+features which aren't available in Atom (and thus aren't actually
+implemented in practice).  For example, the back end operates under
+the assumption that ``servers'' (Atom feeds) can have multiple groups,
+when in reality the parsing functions will only ever return servers
+with a single group.  In addition, all parsing steps and some of the
+printing is done in functions stored in server variables, to allow
+very easily defining new back ends for different kinds of feeds by
+inheriting from @code{nnatom}; these are called
+@code{nnatom-read-*-function} and
+@code{nnatom-print-content-function}, and their requirements are
+detailed in their docstrings.  A macro is provided to ease creation of
+new inheriting backends.
+
+@defmac nnatom-define-basic-backend-interface backend
+Define server variables expected by @code{nnatom} and import its back
+end functions for @var{backend}.  This macro (or code similar to it) should
+be used by any inheriting back end.
+@end defmac
+
+@end itemize
+
 @node Other Sources
 @section Other Sources
 
diff --git a/etc/NEWS b/etc/NEWS
index 77ca749ccc3..46e6aeb34dc 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -324,6 +324,13 @@ distracting and easily confused with actual code, or a significant
 early aid that relieves you from moving the buffer or reaching for the
 mouse to consult an error message.
 
+** Gnus
+
++++
+*** New back end 'nnatom'.
+This allow users to add Atom Syndication Format feeds to Gnus as
+servers.
+
 ** Python Mode
 
 ---
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index fc8518512ee..d35d709c448 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -1343,6 +1343,7 @@ gnus-valid-select-methods
     ("nnimap" post-mail address prompt-address physical-address respool
      server-marks cloud)
     ("nnmaildir" mail respool address server-marks)
+    ("nnatom" address)
     ("nnnil" none))
   "An alist of valid select methods.
 The first element of each list lists should be a string with the name
diff --git a/lisp/gnus/nnatom.el b/lisp/gnus/nnatom.el
new file mode 100644
index 00000000000..74ca2a8a5da
--- /dev/null
+++ b/lisp/gnus/nnatom.el
@@ -0,0 +1,762 @@
+;;; 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 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 HTTP or local feeds following the
+;; Atom Syndication Format <https://www.ietf.org/rfc/rfc4287>, or any
+;; other type of feed with customized parsing functions.
+
+;;; Code:
+
+(eval-when-compile
+  (require 'cl-lib)
+  (require 'gv)
+  (require 'subr-x))
+
+(require 'gnus)
+(require 'nnheader)
+(require 'nnoo)
+(require 'gnus-group)
+(require 'mm-url)
+(require 'dom)
+
+(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.")
+
+;;;; Atom feed parser:
+
+(defun nnatom--read-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 (if (libxml-available-p)
+                      (libxml-parse-xml-region (point-min) (point-max))
+                    (require 'xml)
+                    (car (xml-parse-region (point-min) (point-max)))))))))
+
+(defun nnatom--read-group (data)
+  "Return the next group and the remaining DATA in a cons cell, or nil."
+  `(,data))
+
+(defun nnatom--read-article (data  _)
+  "Return the next article and the remaining DATA in a cons cell, or nil."
+  (when (eq (car data) 'feed)
+    (setq data (dom-by-tag data 'entry)))
+  (and data `(,(car data) . , (setq data (cdr data)))))
+
+(defun nnatom--read-title (group)
+  "Return the title of GROUP, or nil."
+  (dom-text (dom-child-by-tag group 'title)))
+
+(defun nnatom--read-description (group)
+  "Return the description of GROUP, or nil."
+  (dom-text (dom-child-by-tag group 'subtitle)))
+
+(defun nnatom--read-article-or-group-author (article-or-group)
+  "Return the author of ARTICLE-OR-GROUP, or nil."
+  (let* ((author (dom-child-by-tag article-or-group 'author))
+         (name (dom-text (dom-child-by-tag author 'name)))
+         (name (unless (string-blank-p name) name))
+         (email (dom-text (dom-child-by-tag author 'email)))
+         (email (unless (string-blank-p email) email)))
+    (or (and name email (format "%s <%s>" name email))
+        name email)))
+
+(defun nnatom--read-subject (article)
+  "Return the subject of ARTICLE, or nil."
+  (dom-text (dom-child-by-tag article 'title)))
+
+(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 (dom-text (dom-child-by-tag article 'id))
+      (nnatom--read-subject article)))
+
+(defun nnatom--read-publish (article)
+  "Return the date and time ARTICLE was published, or nil."
+  (when-let (d (dom-child-by-tag article 'published))
+    (date-to-time (dom-text d))))
+
+(defun nnatom--read-update (article)
+  "Return the date and time of the last update to ARTICLE, or nil."
+  (when-let (d (dom-child-by-tag article 'updated))
+    (date-to-time (dom-text d))))
+
+(defun nnatom--read-links (article)
+  "Return all links contained in ARTICLE, or nil."
+  (let ((rel (make-vector 6 0))) ; [ALTERNATE RELATED SELF ENCLOSURE VIA AUTHOR]
+    (mapcan
+     (lambda (link)
+       (when (consp link)
+         (or
+          (when-let (((eq (car link) 'content))
+                     (src (dom-attr link 'src))
+                     (label (concat "Link"
+                                    (and (< 1 (cl-incf (aref rel 0)))
+                                         (format " %s" (aref rel 0))))))
+            `(((("text/plain") . ,(format "%s: %s\n" label src))
+               (("text/html") . ,(format "<a href=\"%s\">[%s]</a> "
+                                         src label)))))
+          (when-let (((eq (car link) 'author))
+                     (name (dom-text (dom-child-by-tag link 'name)))
+                     (name (if (string-blank-p name)
+                               (concat "Author"
+                                       (and (< 1 (cl-incf (aref rel 5)))
+                                            (format " %s" (aref rel 5))))
+                             name))
+                     (uri (dom-text (dom-child-by-tag link 'uri)))
+                     ((not (string-blank-p uri))))
+            `(((("text/plain") . ,(format "%s: %s\n" name uri))
+               (("text/html") . ,(format "<a href=\"%s\">[%s]</a> "
+                                         uri name)))))
+          (when-let (((eq (car link) 'link))
+                     (attrs (dom-attributes link))
+                     (label (or (cdr (assq 'title attrs))
+                                (pcase (cdr (assq 'rel attrs))
+                                  ("related"
+                                   (concat "Related"
+                                           (and (< 1 (cl-incf (aref rel 1)))
+                                                (format " %s" (aref rel 1)))))
+                                  ("self"
+                                   (concat "More"
+                                           (and (< 1 (cl-incf (aref rel 2)))
+                                                (format " %s" (aref rel 2)))))
+                                  ("enclosure"
+                                   (concat "Enclosure"
+                                           (and (< 1 (cl-incf (aref rel 3)))
+                                                (format " %s" (aref rel 3)))))
+                                  ("via"
+                                   (concat "Source"
+                                           (and (< 1 (cl-incf (aref rel 4)))
+                                                (format " %s" (aref rel 4)))))
+                                  (_ (if-let
+                                         ((lang (cdr (assq 'hreflang link))))
+                                         (format "Link (%s)" lang)
+                                       (concat
+                                        "Link"
+                                        (and (< 1 (cl-incf (aref rel 0)))
+                                             (format " %s" (aref rel 0)))))))))
+                     (link (cdr (assq 'href attrs))))
+            `(((("text/plain") . ,(format "%s: %s\n" label link))
+               (("text/html") . ,(format "<a href=\"%s\">[%s]</a> "
+                                         link label))))))))
+     article)))
+
+(defsubst nnatom--read-part (part type)
+  (let* ((atypes '("html" "plain"))
+         (mtypes '(("xhtml" . "text/html") ("text" . "text/plain")))
+         (xsuff (concat "[+/]xml\\(-\\(dtd\\|external-parsed-entity\\)\\)?\\'"
+                        "\\|^text"))
+         (part (if (string= type "xhtml")
+                   (with-temp-buffer
+                     (dom-print (dom-child-by-tag part 'div) nil t)
+                     (buffer-substring-no-properties
+                      (point-min) (point-max)))
+                 (dom-text part)))
+         (type (if (member type atypes) (concat "text/" type) type))
+         (type (or (cdr (assoc type mtypes)) type)))
+    (unless (string-blank-p part)
+      `(,part (Content-Type . ,(or type (setq type "text/plain")))
+              ,(and (not (string-match-p xsuff type))
+                    '(Content-Transfer-Encoding . "base64"))))))
+
+(defun nnatom--read-parts (article)
+  "Return all parts contained in ARTICLE, or an empty HTML part with links."
+  (let* ((summary (dom-child-by-tag article 'summary))
+         (stype (cdr (assq 'type (dom-attributes summary))))
+         (summary (nnatom--read-part summary stype))
+         (content (dom-child-by-tag article 'content))
+         (ctype (cdr (assq 'type (dom-attributes content))))
+         (content (nnatom--read-part content ctype))
+         (st (string= stype ctype))
+         parts)
+    (cond ((and summary content)
+           (and st (push summary parts))
+           (push (append content '(links)) parts)
+           (or st (push summary parts))
+           parts)
+          ((setq parts (or summary content))
+           `(,(append (or summary content) '(links))))
+          (t '((nil (Content-Type . "text/html") links))))))
+
+;;;; Feed I/O:
+
+(defvoo nnatom-read-feed-function #'nnatom--read-feed
+  "Function returning a Lisp object representing a feed (or part of it).
+It should accept two arguments, the address of a feed and the name of
+a group (or nil).
+If a group name is supplied, it should return a representation of only
+the group (as if it was extracted from the feed with
+`nnatom-read-group-function').")
+
+(defvoo nnatom-read-group-function #'nnatom--read-group
+  "Function returning a cons cell of a group and remaining data from a feed.")
+
+(defvoo nnatom-read-article-function #'nnatom--read-article
+  "Function returning a cons cell of an article and remaining data from a group.
+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).")
+
+(defvoo nnatom-read-title-function #'nnatom--read-title
+  "Function returning the title of a group (a string).
+It should accept a single argument, a Lisp object representing a group.")
+
+(defvoo nnatom-read-description-function #'nnatom--read-description
+  "Function returning the description of a group (a string).
+It should accept a single argument, a Lisp object representing a group.")
+
+(defvoo nnatom-read-group-author-function #'nnatom--read-article-or-group-author
+  "Function returning the author of a group (a string).
+It should accept a single argument, a Lisp object representing a group.")
+
+(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-group-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-headers-function #'ignore
+  "Function returning an alist of article-wide MIME headers.
+Each element of this alist maps a MIME header (a symbol,
+i.e. `Content-Type') to its value.  As a special case, `:boundary'
+maps to a string which will serve as the boundary between article
+parts.  This must be supplied if a custom boundary is used in a
+multipart content type header.  The default boundary is \"-_nnatom_-\",
+and is automatically modified to match the name of the back end.
+It should accept a single argument, a Lisp object representing an article.")
+
+(defvoo nnatom-read-links-function #'nnatom--read-links
+  "Function returning all links contained in an article.
+For the default `nnatom-print-content-function', it should return a
+list of links, where each link is an alist mapping MIME content types
+to links formatted for display in a part of that type.  Each content
+type may also be a list of content types.
+Otherwise, it could return any Lisp object.
+It should accept a single argument, a Lisp object representing an article.")
+
+(defvoo nnatom-read-parts-function #'nnatom--read-parts
+  "Function returning an alist associating parts of an article to their headers.
+For the default `nnatom-print-content-function', each part should be a
+string.  Otherwise, it can be any Lisp object.  The \"headers\" of
+each part should be a list where each element is either a cons of a
+MIME header (a symbol, i.e. `Content-Type') and its value (a string),
+or any other Lisp object.  MIME headers will be printed, the rest will
+be passed on to `nnatom-print-content-function', which recognizes the
+following extra data by default:
+- `links', if present, will cause links to be printed in the part.
+It should accept a single argument, a Lisp object representing an article.")
+
+(defvoo nnatom-servers (make-hash-table :test 'equal)
+  "Hash table mapping known servers to their groups.
+
+Each value in this table should itself be a hash table mapping known
+group names to their data, which should be a vector of the form
+[GROUP IDS ARTICLES MAX MIN DESCRIPTION], where:
+- GROUP is the \"real\" group name (the name known to the server).
+- 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.
+- DESCRIPTION is the group description.")
+
+(defvoo nnatom-group-names (make-hash-table :test 'equal)
+  "Hash table mapping real group names to their custom name.")
+
+(defun nnatom--server-file (server)
+  "Return the file containing data for SERVER."
+  (expand-file-name (format "%s/%s.eld"
+                            (string-trim (symbol-name nnatom-backend)
+                                         "nn")
+                            (gnus-newsgroup-savable-name server))
+                    gnus-directory))
+
+(defun nnatom--read-server (server)
+  "Read SERVER's information from `nnatom-directory'."
+  (if-let ((f (nnatom--server-file server))
+           ((file-readable-p f)))
+      (with-temp-buffer
+        (insert-file-contents f)
+        (goto-char (point-min))
+        (puthash server (read (current-buffer)) nnatom-servers))
+    (nnheader-report nnatom-backend "Can't read %s" server)))
+
+(defun nnatom--write-server (server)
+  "Write SERVER's information to `nnatom-directory'."
+  (if-let ((f (nnatom--server-file server))
+           ((file-writable-p f)))
+      (if-let ((s (gethash server nnatom-servers))
+               ((hash-table-p s)))
+          (with-temp-file f
+            (insert ";;;; -*- mode: lisp-data -*- DO NOT EDIT\n"
+                    (prin1-to-string s))
+            t)
+        t)
+    (nnheader-report nnatom-backend "Can't write %s" f)))
+
+(defsubst nnatom--server-address (server)
+  (if (string-suffix-p "-ephemeral" server)
+      (setq server (or (cadr (assq (nnoo-symbol nnatom-backend 'address)
+                                   (cddr (gnus-server-to-method
+                                          (concat
+                                           (symbol-name nnatom-backend) ":"
+                                           server)))))
+                       server))
+    server))
+
+(defun nnatom--parse-feed (feed &optional group)
+  "Parse FEED into a new or existing server.
+Optionally, only parse GROUP."
+  (let* ((feed (nnatom--server-address feed))
+         (s (or (gethash feed nnatom-servers) (nnatom--read-server feed)))
+         (g (or (and (hash-table-p s) (gethash group s)) `[,group]))
+         (name group) ; (Maybe) fake name
+         (group (or (aref g 0) name)) ; Real name
+         data)
+    (when (setq data (funcall nnatom-read-feed-function feed group)
+                s (or (gethash feed nnatom-servers)
+                      (make-hash-table :test 'equal)))
+      (while-let ((cg (or (and name `(,data))
+                          (funcall nnatom-read-group-function data)))
+                  ((progn (setq data (cdr cg)) t))
+                  (cg (car cg)))
+        (let* ((name (funcall nnatom-read-title-function cg)) ; Real name
+               (group (gethash name nnatom-group-names name)) ; (Maybe) fake name
+               (info (gnus-get-info
+                      (concat (symbol-name nnatom-backend) "+" feed ":" group)))
+               (g (or (gethash group s)
+                      `[ ,name ,(make-hash-table :test 'equal)
+                         ,(make-hash-table :test 'eql) nil 1 ""]))
+               (desc (funcall nnatom-read-description-function cg))
+               (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)))))
+               (group-author (funcall nnatom-read-group-author-function cg))
+               stale)
+          (and desc (aset g 5 desc))
+          (while-let ((article (funcall nnatom-read-article-function cg stale))
+                      ((progn (setq cg (cdr article)) t))
+                      (article (car article)))
+            (when-let ((id (funcall nnatom-read-id-function article))
+                       (id (format "<%s@%s.%s>" id name 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)
+                               group-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-links-function article)
+                          ,(funcall nnatom-read-parts-function article)
+                          ,(funcall nnatom-read-headers-function article)]
+                       stale nil))
+                  (setq stale t)))))
+          (puthash group g s)))
+      (puthash feed s nnatom-servers))))
+
+;;;; 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 LINKS PARTS HEADERS], 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).
+- LINKS is a collection of links (any Lisp object).
+- PARTS is an alist associating the content of each part of the
+  article to its headers.
+- HEADERS is an alist associating article-wide MIME headers to their value.")
+
+(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)
+
+(defsubst nnatom--current-server-no-prefix ()
+  (string-remove-prefix (concat (symbol-name nnatom-backend) "+")
+                        (nnoo-current-server nnatom-backend)))
+
+(defun nnatom--group-data (group &optional server)
+  (let ((s (gethash server nnatom-servers)) c)
+    (or (and (hash-table-p s) (gethash group s))
+        (and (setq c (nnatom--current-server-no-prefix))
+             (setq s (gethash c nnatom-servers))
+             (hash-table-p s) (gethash group s))
+        (catch :stop (maphash (lambda (n s)
+                                (or (string= n server)
+                                    (string= n c)
+                                    (when-let (((hash-table-p s))
+                                               (g (gethash group s)))
+                                      (throw :stop g))))
+                              nnatom-servers)))))
+
+(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 ((server (or server (nnatom--current-server-no-prefix)))
+           (g (or (nnatom--group-data group server)
+                  `[ nil ,nnatom-group-article-ids ,nnatom-group-articles
+                     nil 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 2)) 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-open-server (server &optional defs backend)
+  (let ((backend (or backend 'nnatom))
+        (a (nnatom--server-address server))
+        s)
+    (nnoo-change-server backend server defs)
+    (when (setq s (or (gethash server nnatom-servers)
+                      (nnatom--read-server a)))
+      (maphash (lambda (group g)
+                 (setq g (aref g 0))
+                 (unless (string= group g)
+                   (puthash group g nnatom-group-names)))
+               s))
+    (or s (file-writable-p (nnatom--server-file a))
+        (and (nnoo-close-server nnatom-backend server)
+             (nnheader-report
+              nnatom-backend "Server file %s not readable or writable"
+              server)))))
+
+(deffoo nnatom-request-close ()
+  (maphash (lambda (server _)
+             (nnatom--write-server
+              (nnatom--server-address server)))
+           nnatom-servers)
+  (setq nnatom-servers (make-hash-table :test 'equal)
+        nnatom-status-string nil)
+  t)
+
+(defun nnatom--print-content (content attributes links)
+  "Return CONTENT formatted according to ATTRIBUTES, possibly with LINKS added."
+  (let ((links (and (memq 'links attributes) links)))
+    (when (or content links)
+      (concat
+       (and content (format "%s\n\n" content))
+       (mapconcat (lambda (link)
+                    (cdr (assoc (cdr (assq 'Content-Type attributes)) link
+                                (lambda (types type)
+                                  (if (stringp types) (string= types type)
+                                    (member type types))))))
+                  links)))))
+
+(defvoo nnatom-print-content-function #'nnatom--print-content
+  "Function returning a single piece of content (a string).
+It should accept three arguments, a part and its attributes (as returned
+by `nnatom-read-parts-function'), and links.")
+
+(defsubst nnatom--print-part (content headers mime links)
+  (concat
+   (mapconcat (lambda (header)
+                (when-let (((consp header))
+                           (m (car header))
+                           ((member m mime)))
+                  (format "%s: %s\n" m (cdr header))))
+              headers)
+   "\n"
+   (funcall nnatom-print-content-function content headers links)))
+
+(deffoo nnatom-request-article (article &optional group server to-buffer)
+  (if-let ((server (or server (nnatom--current-server-no-prefix)))
+           (g (or (nnatom--group-data group server)
+                  (and (setq group nnatom-group)
+                       `[ nil ,nnatom-group-article-ids
+                          ,nnatom-group-articles
+                          ,nnatom-group-article-max-num
+                          ,nnatom-group-article-min-num nil])))
+           (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* ((links (aref a 5))
+               (parts (aref a 6))
+               (headers (aref a 7))
+               (boundary (or (cdr (assq :boundary headers))
+                             (format "-_%s_-" nnatom-backend)))
+               (multi (length> parts 1))
+               (mime '( Content-Type Content-Disposition
+                        Content-Transfer-Encoding)))
+          (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))
+                  (if (assq 'MIME-Version headers) "" "MIME-Version: 1.0\n")
+                  (mapconcat (lambda (header)
+                               (unless (keywordp (car header))
+                                 (format "%s: %s\n" (car header) (cdr header))))
+                             headers)
+                  (if multi
+                      (if (assq 'Content-Type headers) ""
+                        (format
+                         "Content-Type: multipart/alternative; boundary=%s\n"
+                         boundary))
+                    (prog1 (nnatom--print-part
+                            (caar parts) (cdar parts) mime links)
+                      (setq parts nil)))
+                  (mapconcat (lambda (part)
+                               (format "--%s\n%s\n" boundary
+                                       (nnatom--print-part
+                                        (car part) (cdr part) mime links)))
+                             parts)
+                  (if multi (format "--%s--" boundary) "\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 ((server (or server (nnatom--current-server-no-prefix)))
+             (g (or (if fast (nnatom--group-data group server)
+                      (setq server (nnatom--parse-feed server group))
+                      (and (hash-table-p server) (gethash group server)))
+                    `[ ,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)
+  (and (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))
+  (setq server (or server (nnatom--current-server-no-prefix)))
+  (nnatom--write-server server))
+
+(deffoo nnatom-request-list (&optional server)
+  (with-current-buffer nntp-server-buffer
+    (erase-buffer)
+    (when-let ((p (point))
+               (s (nnatom--parse-feed
+                   (or server (nnatom--current-server-no-prefix))))
+               ((hash-table-p s)))
+      (maphash (lambda (group g)
+                 (insert (format "\"%s\" %s %s y\n"
+                                 group (aref g 3) (aref g 4))))
+               s)
+      (not (= (point) p)))))
+
+(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 (nnatom--current-server-no-prefix)))
+  'active)
+
+(deffoo nnatom-request-type (_group &optional _article)
+  'unknown)
+
+(deffoo nnatom-request-group-description (group &optional server)
+  (when-let ((server (or server (nnatom--current-server-no-prefix)))
+             (g (nnatom--group-data group server)))
+    (with-current-buffer nntp-server-buffer
+      (erase-buffer)
+      (insert group "	" (aref g 5) "\n"))))
+
+(deffoo nnatom-request-list-newsgroups (&optional server)
+  (when-let ((server (or server (nnatom--current-server-no-prefix)))
+             (s (gethash server nnatom-servers))
+             ((hash-table-p s)))
+    (with-current-buffer nntp-server-buffer
+      (erase-buffer)
+      (maphash (lambda (group g)
+                 (insert group "	" (aref g 5) "\n"))
+               s))))
+
+(deffoo nnatom-request-rename-group (group new-name &optional server)
+  (when-let ((server (or server (nnatom--current-server-no-prefix)))
+             (s (or (gethash server nnatom-servers)
+                    (and ; Open the server to add it to `nnatom-servers'
+                     (save-match-data
+                       (nnatom-open-server
+                        server
+                        (cdr ; Get defs and backend.
+                         (assoc server (cdr (assq 'nnatom nnoo-state-alist))
+                                (lambda (car key)
+                                  (and (stringp car)
+                                       (string-match
+                                        (concat
+                                         "\\(\\(nn[[:alpha:]]+\\)\\+\\)?"
+                                         "\\(" (regexp-quote key) "\\)")
+                                        car)
+                                       (setq server car)))))
+                        (prog1 (if (stringp (match-string 1 server))
+                                   (intern (match-string 2 server))
+                                 'nnatom)
+                          (setq server (match-string 3 server))))
+                       (gethash server nnatom-servers)))))
+             (g (or (nnatom--group-data group server)
+                    `[ ,group ,(make-hash-table :test 'equal)
+                       ,(make-hash-table :test 'eql) nil 1 ""])))
+    (puthash new-name g s)
+    (puthash group new-name nnatom-group-names)
+    (remhash group s)
+    (and (string= group nnatom-group)
+         (setq nnatom-group new-name))
+    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."
+  `(progn
+     (defvoo ,(nnoo-symbol backend 'backend) ',backend nil nnatom-backend)
+     (defvoo ,(nnoo-symbol backend 'status-string)
+         nil nil nnatom-status-string)
+     (defvoo ,(nnoo-symbol backend 'group) nil nil nnatom-group)
+     (defvoo ,(nnoo-symbol backend 'servers)
+         (make-hash-table :test 'equal) nil nnatom-servers)
+     (defvoo ,(nnoo-symbol backend 'group-article-ids)
+         (make-hash-table :test 'equal) nil nnatom-group-article-ids)
+     (defvoo ,(nnoo-symbol backend 'group-articles)
+         (make-hash-table :test 'eql) nil nnatom-group-articles)
+     (defvoo ,(nnoo-symbol backend 'group-article-max-num) 0 nil
+             nnatom-group-article-max-num)
+     (defvoo ,(nnoo-symbol backend 'group-article-mix-num) 1 nil
+             nnatom-group-article-min-num)
+     ,@(mapcar (lambda (fun)
+                 `(deffoo ,(nnoo-symbol backend fun) (&optional server)
+	            (,(nnoo-symbol 'nnoo fun) ',backend server)))
+	       '(server-opened status-message))
+     (deffoo ,(nnoo-symbol backend 'open-server) (server &optional defs)
+       (nnatom-open-server server defs ',backend))
+     (nnoo-import ,backend (nnatom))))
+
+(provide 'nnatom)
+
+;;; nnatom.el ends here
-- 
2.41.0


[-- Attachment #3: nnyt --]
[-- Type: application/emacs-lisp, Size: 2443 bytes --]