[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#64202: [PATCH] Gnus: Add back end for Atom feeds (nnatom)
|
From: |
Daniel Semyonov |
|
Subject: |
bug#64202: [PATCH] Gnus: Add back end for Atom feeds (nnatom) |
|
Date: |
Wed, 21 Jun 2023 17:26:25 +0300 |
|
User-agent: |
Gnus/5.13 (Gnus v5.13) |
>>>>> Eli Zaretskii writes:
>> Date: Wed, 21 Jun 2023 10:08:51 +0300 From: Daniel Semyonov via
>> "Bug reports for GNU Emacs, the Swiss army knife of text editors"
>> <bug-gnu-emacs@gnu.org>
>>
>> This patch adds a back end for Atom feeds to Gnus, and documents
>> it.
> Thanks for working on this.
> I don't use Gnus, so my comments will be mostly to the
> documentation parts. I expect others (CC'ed) to review the code
> more thoroughly.
Thanks, amended patch attached.
>> +Some web sites provide an Atom Syndication Format feed. Atom is
>> a web +feed format similar in function to RDF Site Summary
>> (@xref{RSS}).
> ^^^^^^^^^^
> This should be @pxref, not @xref.
Fixed.
>> +Note, however, that the server address shouldn't be prefixed
>> with +@code{http://} or @code{https://}.
> These should use @file, not @code, unless most or all of the rest
> of the Gnus manual uses @code for URLs.
I changed it to @url, as the close by RSS node uses it for URL.
Hopefully that's okay.
>> +The @code{nnatom} back end saves a server data file in the
>> +@code{atom} sub-directory of @code{gnus-directory} for each
>> feed.
> These should definitely be @file, not @code, as these are file
> names.
Fixed ('atom' and 'gnus-directory', not 'nnatom' as I think that should
stay @code).
>> +@defmac nnatom-define-basic-backend-interface backend +Define
>> server variables expected by @code{nnatom} and import its back
>> +end functions for BACKEND. This macro (or code similar to it)
>> should
> ^^^^^^^ This should be @var{backend}.
Fixed.
I also attached another back end I made between my last email and now,
for JSON feeds. This is just a POC I made to see how easy it is to
create a "full" derivative back end.
>From 6085ee8139cc3d815a5028babb4daf438df9d06b Mon Sep 17 00:00:00 2001
From: Daniel Semyonov <daniel@dsemy.com>
Date: Wed, 21 Jun 2023 10:05:04 +0300
Subject: [PATCH] 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 | 42 +++
etc/NEWS | 7 +
lisp/gnus/gnus.el | 1 +
lisp/gnus/nnatom.el | 705 ++++++++++++++++++++++++++++++++++++++++++++
4 files changed, 755 insertions(+)
create mode 100644 lisp/gnus/nnatom.el
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 8d25e868c8a..95eba21c4dd 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,46 @@ 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 (@xref{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
+@code{http://} or @code{https://}.
+
+The @code{nnatom} back end saves a server data file in the
+@code{atom} sub-directory of @code{gnus-directory} for each feed.
+
+The @code{nnatom} back end generates an article part for both the
+summary and content of each article in the feed.
+
+@code{nnatom} has been designed to be very modular, and theoretically
+supports many features which aren't available in the Atom Syndication
+Format, in an effort to reduce the work required to build back ends
+for other web feed formats.
+
+Every parsing step is handled by a function stored in a server
+variable; these are all called @code{nnatom-read-*-function}, and
+their requirements are detailed in their docstrings.
+
+The function responsible for printing the content of each article part
+is stored in a server variable (@code{nnatom-print-content-function}).
+The default function only handles (X)HTML and plain text content.
+
+@defmac nnatom-define-basic-backend-interface backend
+Define server variables expected by @code{nnatom} and import its back
+end functions for BACKEND. This macro (or code similar to it) should
+be used by any inheriting back end.
+@end defmac
+
+
@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..3da4644de20
--- /dev/null
+++ b/lisp/gnus/nnatom.el
@@ -0,0 +1,705 @@
+;;; 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.")
+
+(defsubst nnatom--backend-prefix (backend)
+ (concat (symbol-name 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 5 0))) ; [ALTERNATE RELATED SELF ENCLOSURE VIA]
+ (mapcan
+ (lambda (link)
+ (when-let
+ (((and (consp link) (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))))))))))
+ `(,(vector (cdr (assq 'href attrs))
+ (concat label ":") (concat "[" label "]")))))
+ article)))
+
+(defsubst nnatom--read-part (part type links)
+ `(,part
+ ("Content-Type" . ,(concat "text/" (or type "plain")))
+ ,(and (or (string= type "html") (string= type "xhtml"))
+ 'html)
+ ,(and links 'links)))
+
+(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 (dom-attr summary 'type))
+ (summary (dom-text summary))
+ (summary (unless (string-blank-p summary) summary))
+ (content (dom-child-by-tag article 'content))
+ (ctype (dom-attr content 'type))
+ (content (dom-text content))
+ (content (unless (string-blank-p content) content))
+ (st (string= stype ctype))
+ parts)
+ (cond ((and summary content)
+ (and st (push (nnatom--read-part summary stype nil) parts))
+ (push (nnatom--read-part content ctype t) parts)
+ (or st (push (nnatom--read-part summary stype nil) parts))
+ parts)
+ ((setq parts (or summary content))
+ `(,(nnatom--read-part parts (if content ctype stype) t)))
+ (t '((nil ("Content-Type" . "text/html") 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-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 a vector of the form
+[LINK LABEL HTML-LABEL], where:
+- LINK is the link.
+- LABEL is a label used for LINK (printed \"LABEL: LINK\").
+- HTML-LABEL is a label used for LINK, but only if the type of the
+ part in which LINK is printed is \"html\" or \"xhtml\" (printed \"[LABEL]\").
+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 string) 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.
+- `html', if present, will format the part as HTML.
+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 (nnatom--backend-prefix
+ 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))
+ (prefix (nnatom--backend-prefix nnatom-backend))
+ (s (or (gethash feed nnatom-servers)
+ (nnatom--read-server feed) t))
+ (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 prefix 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)]
+ 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], 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.")
+
+(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--group-data (group &optional server)
+ (let ((s (gethash server nnatom-servers)) c)
+ (or (and (hash-table-p s) (gethash group s))
+ (and (setq c (nnoo-current-server nnatom-backend))
+ (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 (nnoo-current-server nnatom-backend)))
+ (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 (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 (or backend 'nnatom) 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 ((html (memq 'html attributes))
+ (links (and (memq 'links attributes) links)))
+ (when (or content links)
+ (concat
+ (and html "<html><head></head><body>")
+ (and content (format "%s\n\n" content))
+ (and links html "<p>")
+ (and links
+ (if html
+ (mapconcat
+ (lambda (link)
+ (format "<a href=\"%s\">%s</a>" (aref link 0) (aref link
2)))
+ links " ")
+ (mapconcat
+ (lambda (link)
+ (format "%s %s\n" (aref link 1) (aref link 0)))
+ links "\n")))
+ (and links html "</p>")
+ (and html "</body></html>")))))
+
+(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 (nnoo-current-server nnatom-backend)))
+ (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* ((boundary (format "-_%s_-" nnatom-backend))
+ (links (aref a 5))
+ (parts (aref a 6))
+ (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))
+ "MIME-Version: 1.0\n"
+ (if multi
+ (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)
+ (let ((headers (cdr part)))
+ (format "--%s\n%s\n" boundary
+ (nnatom--print-part
+ (car part) headers 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 (nnoo-current-server nnatom-backend)))
+ (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 (nnoo-current-server nnatom-backend)))
+ (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 (nnoo-current-server nnatom-backend))))
+ ((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 (nnoo-current-server nnatom-backend)))
+ 'active)
+
+(deffoo nnatom-request-type (_group &optional _article)
+ 'unknown)
+
+(deffoo nnatom-request-group-description (group &optional server)
+ (when-let ((server (or server (nnoo-current-server nnatom-backend)))
+ (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 (nnoo-current-server nnatom-backend)))
+ (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 (nnoo-current-server nnatom-backend)))
+ (s (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-names)
+ (make-hash-table :test 'equal) nil nnatom-group-names)
+ (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
nnjsonfeed.el
Description: nnjsonfeed