From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Daniel Semyonov via "Bug reports for GNU Emacs, the Swiss army knife of text editors" Newsgroups: gmane.emacs.bugs Subject: bug#64202: [PATCH] Gnus: Add back end for Atom feeds (nnatom) Date: Sat, 15 Jul 2023 03:59:49 +0300 Message-ID: <878rbikn0a.fsf@dsemy.com> References: <87v8fhmgvw.fsf@dsemy.com> <87y1k76eip.fsf@dsemy.com> <87fs6epd6d.fsf@dsemy.com> <87bkh2p96o.fsf@dsemy.com> <83ilb4qb44.fsf@gnu.org> <87r0prkgsz.fsf@dsemy.com> <873525udhn.fsf@ericabrahamsen.net> <87pm59984x.fsf@dsemy.com> <87a5wdskw8.fsf@ericabrahamsen.net> <87edlm5yc9.fsf@dsemy.com> <874jmie0qj.fsf@ericabrahamsen.net> <87bkgq2nx3.fsf@dsemy.com> <87o7kqch2t.fsf@ericabrahamsen.net> Reply-To: Daniel Semyonov Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="34321"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Cc: 64202@debbugs.gnu.org To: Eric Abrahamsen Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Sat Jul 15 03:03:32 2023 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1qKTh5-0008h9-4H for geb-bug-gnu-emacs@m.gmane-mx.org; Sat, 15 Jul 2023 03:03:31 +0200 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1qKTge-0007SW-CI; Fri, 14 Jul 2023 21:03:04 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1qKTgc-0007Qc-EO for bug-gnu-emacs@gnu.org; Fri, 14 Jul 2023 21:03:02 -0400 Original-Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1qKTgc-0001gE-6K for bug-gnu-emacs@gnu.org; Fri, 14 Jul 2023 21:03:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1qKTgc-00042n-1m for bug-gnu-emacs@gnu.org; Fri, 14 Jul 2023 21:03:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Daniel Semyonov Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 15 Jul 2023 01:03:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 64202 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 64202-submit@debbugs.gnu.org id=B64202.168938296415498 (code B ref 64202); Sat, 15 Jul 2023 01:03:02 +0000 Original-Received: (at 64202) by debbugs.gnu.org; 15 Jul 2023 01:02:44 +0000 Original-Received: from localhost ([127.0.0.1]:43682 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1qKTgI-00041q-Ee for submit@debbugs.gnu.org; Fri, 14 Jul 2023 21:02:44 -0400 Original-Received: from dsemy.com ([46.23.89.208]:19663) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1qKTgE-00041Q-JO for 64202@debbugs.gnu.org; Fri, 14 Jul 2023 21:02:40 -0400 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; s=dkim; bh=vQ0apsl+izxvE 6b6WNPPIoq+SbVd/l27m2VIuFnuh9Y=; h=date:references:in-reply-to: subject:cc:to:from; d=dsemy.com; b=IM7O/E9CA1/umY9vRd6QGx6/417LUJhm5RV ylYN5qCRsIRB7CeWXy1meA4HLFobH+PUhbjwjlxGG3miZaXUZU+DBBuQd++8a3t6rX/Rjr NeABxnULuSSZR1WP6v1GYlhBdiu0AuBvK4Ncm+RcUaObOoXYxjKNEc0ZbZg5uVQxDsAFDx dNwVaeuguWlkGuH4CLVOC9l9qX4AHqlU/yYnzf5IzvuzCiZTafNnQI7CN41JOvplWw9nBf Nigrl3i8HYTvEWdqqskZ8+oC7M7DjPHHXlMOVmykU6u0r/O788T8Ex/qXdpFKSSfauIKvo jEEGnspVN6hHGEoulEnxi7VcdWw== Original-Received: from coldharbour.home.arpa ( [147.235.213.12]) by dsemy.com (OpenSMTPD) with ESMTPSA id 2d9abc6e (TLSv1.3:TLS_AES_256_GCM_SHA384:256:NO); Sat, 15 Jul 2023 03:02:31 +0200 (CEST) Original-Received: from localhost (coldharbour.home.arpa [local]) by coldharbour.home.arpa (OpenSMTPD) with ESMTPA id f4fa08bd; Sat, 15 Jul 2023 00:59:49 +0000 (UTC) In-Reply-To: <87o7kqch2t.fsf@ericabrahamsen.net> (Eric Abrahamsen's message of "Wed, 05 Jul 2023 12:07:54 -0700") X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.emacs.bugs:265135 Archived-At: --=-=-= Content-Type: text/plain >>>>> Eric Abrahamsen writes: > Where do you see that Gnus knows which backends require an > address? That would be very handy. Forgot to answer this -- 'gnus-valid-select-methods' holds this information (and a bunch of other info too). > But my reading of this function is that we don't even known that > the backend is loaded until the end of the group creation > process. You could probably mildly abuse the 'request-create-group > server function to further prompt the user for the URL. > It is a bit annoying that the ADDRESS argument is in there, but > not prompted for. It looks like that's been the case for at least > two decades, though. I'll add this to the pile of stuff I wanna change in Gnus once I'm satisfied with this backend (quite a large pile at this point :). In any case, I still didn't have much time to work on the backend unfortunately, but I attached a patch which incorporates the fixes from my last message + changes based on comments from Stefan. Things left to do: 1. Ensure support for none-libxml builds (I should probably figure out how ERT works to make this a non-issue going forward). 2. Factor out nnfeed.el and base nnatom on top of it (shouldn't be hard). 3. Add support for RSS (and steal cool stuff from nnrss). 4. Support Atom feeds linked in HTML documents. Regards, Daniel --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-Gnus-Add-back-end-for-Atom-feeds-nnatom.patch Content-Description: patch >From 0ddc9702d2205dc8323a9f172e7378c02946b157 Mon Sep 17 00:00:00 2001 From: Daniel Semyonov 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 | 58 ++++ etc/NEWS | 7 + lisp/gnus/gnus.el | 1 + lisp/gnus/nnatom.el | 796 ++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 862 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 d7f5fdc4cbb..16fc419834c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -386,6 +386,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..6ea47c317c0 --- /dev/null +++ b/lisp/gnus/nnatom.el @@ -0,0 +1,796 @@ +;;; nnatom.el --- Atom backend for Gnus -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. +;; Author: Daniel Semyonov + +;; 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 . + +;;; Commentary: + +;; Gnus backend for HTTP or local feeds following the +;; Atom Syndication Format . +;; Other types of feeds may be supported by providing custom parsing +;; functions. + +;;; Code: + +(eval-when-compile + (require 'cl-lib) + (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-name-absolute-p feed) + (insert-file-contents feed) + (mm-url-insert-file-contents (concat "https://" feed))) + (file-error (nnheader-report nnatom-backend (cdr e))) + (:success (when-let ((data (if (libxml-available-p) + (libxml-parse-xml-region + (point-min) (point-max)) + (car (xml-parse-region + (point-min) (point-max))))) + (auth (list 'authors))) + (when (eq (car data) 'top) + (setq data (assq 'feed data))) + (dom-add-child-before data auth) + (catch :stop ; Collect feed authors, stop at first entry. + (dolist (child (cdddr data)) + (let ((tag (car-safe child))) + (if (eq tag 'entry) + (throw :stop data) + (and (or (eq tag 'author) + (eq tag 'contributor)) + (dom-add-child-before auth child))))) + data))))))) + +(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 (cddr data))) + (while (and data (not (eq (car-safe (car data)) 'entry))) (pop data)) + (when-let ((article (car data)) + (auths (list 'authors)) (links (list 'links))) + (dom-add-child-before article links) + (dom-add-child-before article auths) + (dolist (child (cddddr article) `(,article . ,(cdr data))) + (pcase (car-safe child) ; Authors and links can appear + ((or 'author 'contributor) ; anywhere in the entry so we + (dom-add-child-before auths child) ; collect them all here to + (dom-add-child-before links child)) ; avoid looping over the + ((or 'link ; entry multiple times later. + (and 'content (guard (assq 'src (dom-attributes child))))) + (dom-add-child-before links child)))))) + +(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-authors (article-or-group) + "Return the authors of ARTICLE-OR-GROUP, or nil." + (when-let + ((a (string-trim-right + (mapconcat (lambda (author) + (let* ((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))) + (concat + (or (and name email (format "%s <%s>" name email)) + name email) + ", "))) + (dom-children + (dom-child-by-tag article-or-group 'authors))) + ", ")) + ((not (string-blank-p a)))) + a)) + +(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 ((alt 0) (rel 0) (sel 0) (enc 0) (via 0) (aut 0)) + (mapcan + (lambda (link) + (when-let ((l (car-safe link))) + (or + (when-let (((eq l 'content)) + (src (dom-attr link 'src)) + (label (concat "Link" + (and (< 1 (cl-incf alt)) + (format " %s" alt))))) + `(((("text/plain") . ,(format "%s: %s\n" label src)) + (("text/html") . ,(format "[%s] " + src label))))) + (when-let (((or (eq l 'author) (eq l 'contributor))) + (name (dom-text (dom-child-by-tag link 'name))) + (name (if (string-blank-p name) + (concat "Author" + (and (< 1 (cl-incf aut)) + (format " %s" aut))) + 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 "[%s] " + uri name))))) + (when-let (((eq l 'link)) + (attrs (dom-attributes link)) + (label (or (cdr (assq 'title attrs)) + (pcase (cdr (assq 'rel attrs)) + ("related" + (concat "Related" + (and (< 1 (cl-incf rel)) + (format " %s" rel)))) + ("self" + (concat "More" + (and (< 1 (cl-incf sel)) + (format " %s" sel)))) + ("enclosure" + (concat "Enclosure" + (and (< 1 (cl-incf enc)) + (format " %s" enc)))) + ("via" + (concat "Source" + (and (< 1 (cl-incf via)) + (format " %s" via)))) + (_ (if-let + ((lang (cdr (assq 'hreflang link)))) + (format "Link (%s)" lang) + (concat + "Link" + (and (< 1 (cl-incf alt)) + (format " %s" alt)))))))) + (link (cdr (assq 'href attrs)))) + `(((("text/plain") . ,(format "%s: %s\n" label link)) + (("text/html") . ,(format "[%s] " + link label)))))))) + (dom-children (dom-child-by-tag article 'links))))) + +(defun 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-authors + "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-authors + "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 s (current-buffer)) "\n") + t) + t) + (nnheader-report nnatom-backend "Can't write %s" f))) + +(defun 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))) + (cg (prog1 (car cg) (setq data (cdr 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)) + (article (prog1 (car article) (setq cg (cdr 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) + +(defun 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.") + +(defun nnatom--print-part (content headers mime links) + (concat + (mapconcat (lambda (header) + (when-let ((m (car-safe 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 --=-=-=--