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: Wed, 21 Jun 2023 17:26:25 +0300 Message-ID: <87legcuc1a.fsf@dsemy.com> References: <87v8fhmgvw.fsf@dsemy.com> <83y1kd3r4s.fsf@gnu.org> 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="20855"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Cc: Andrew Cohen , Eric Abrahamsen , Lars Ingebrigtsen , Stefan Monnier , 64202@debbugs.gnu.org To: Eli Zaretskii Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Wed Jun 21 16:29:25 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 1qBypp-0005FA-5F for geb-bug-gnu-emacs@m.gmane-mx.org; Wed, 21 Jun 2023 16:29:25 +0200 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1qBypU-0000ad-D6; Wed, 21 Jun 2023 10:29: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 1qBypT-0000Sw-FW for bug-gnu-emacs@gnu.org; Wed, 21 Jun 2023 10:29:03 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1qBypT-0002S4-6W for bug-gnu-emacs@gnu.org; Wed, 21 Jun 2023 10:29:03 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1qBypS-0005hA-ER for bug-gnu-emacs@gnu.org; Wed, 21 Jun 2023 10:29: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: Wed, 21 Jun 2023 14:29: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.168735771221853 (code B ref 64202); Wed, 21 Jun 2023 14:29:02 +0000 Original-Received: (at 64202) by debbugs.gnu.org; 21 Jun 2023 14:28:32 +0000 Original-Received: from localhost ([127.0.0.1]:33880 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1qByow-0005gL-4y for submit@debbugs.gnu.org; Wed, 21 Jun 2023 10:28:32 -0400 Original-Received: from dsemy.com ([46.23.89.208]:9603) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1qByot-0005g6-C8 for 64202@debbugs.gnu.org; Wed, 21 Jun 2023 10:28:29 -0400 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; s=dkim; bh=32kyhCKUij70e CowyrEwTMYqCpx0neE6qMvJcHQNA20=; h=date:references:in-reply-to: subject:cc:to:from; d=dsemy.com; b=RXmBfhzDFhkgAB58LzP5GHhg1X006t3rNBP DMr2lVPR9EW1Yma4HrmG4UKOKECaGZX/6FZFAGnO5zHijEqtet84KCNaGYoemhZvc8pXYT kTHbSFZk1ACWvIVyNR8iqXjXYT9v4T7k9a8JkNG1Z/33/clmUnK5cZWUI+g1GnGAW6PWa6 PwQbLQz8z1NjdoT/4xTr1ZC14U3LsjZveyauDZIUmlgPihN3gRxmYLFFmwqwLM5A73xVfw LckPnO6xQKvSTyzoWzDdxNaxOKEvxcKIlz/2wOMLYHWh7aNb69X0edMFGHfVmI5nvH21jq s6GHqLV7SGXmvWA6EuM8yWZqMDQ== Original-Received: from coldharbour.home.arpa (bzq-109-64-87-185.red.bezeqint.net [109.64.87.185]) by dsemy.com (OpenSMTPD) with ESMTPSA id 49150d03 (TLSv1.3:TLS_AES_256_GCM_SHA384:256:NO); Wed, 21 Jun 2023 16:28:20 +0200 (CEST) Original-Received: from localhost (coldharbour.home.arpa [local]) by coldharbour.home.arpa (OpenSMTPD) with ESMTPA id 090771e2; Wed, 21 Jun 2023 14:26:25 +0000 (UTC) In-Reply-To: <83y1kd3r4s.fsf@gnu.org> (Eli Zaretskii's message of "Wed, 21 Jun 2023 16:02:27 +0300") 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:263826 Archived-At: --=-=-= Content-Type: text/plain >>>>> 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" >> >> >> 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. --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0001-Gnus-Add-back-end-for-Atom-feeds-nnatom.patch Content-Description: patch >From 6085ee8139cc3d815a5028babb4daf438df9d06b 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 | 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 + +;; 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 , 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 "") + (and content (format "%s\n\n" content)) + (and links html "

") + (and links + (if html + (mapconcat + (lambda (link) + (format "%s" (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 "

") + (and 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 --=-=-= Content-Type: application/emacs-lisp Content-Disposition: attachment; filename=nnjsonfeed.el Content-Transfer-Encoding: quoted-printable Content-Description: nnjsonfeed ;;; nnjsonfeed.el --- JSON Feed backend for Gnus -*- lexical-binding: t -*- ;; Copyright (C) 2023 Free Software Foundation, Inc. ;; Author: Daniel Semyonov ;; This file is part of GNU Emacs. ;; nnjsonfeed 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. ;; nnjsonfeed 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 nnjsonfeed. If not, see . ;;; Commentary: ;; Gnus backend for JSON feeds. ;;; Code: (require 'nnatom) (nnoo-declare nnjsonfeed nnatom) (nnatom-define-basic-backend-interface nnjsonfeed) ;;;; JSON feed parser: (defun nnjsonfeed--read-feed (feed _) (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 nnjsonfeed-backend (cdr e))) (:success (or (when-let ((j (json-parse-buffer))) `(,j . 0)) (nnheader-report nnjsonfeed-backend "Invalid feed: %s" feed)))))) (defun nnjsonfeed--read-item (feed _) (when-let ((f (car feed)) (i (cdr feed)) (items (gethash "items" f)) (item t)) (unless (length=3D items i) (setcdr feed (1+ i)) (setq item (aref items i)) (aset items i nil) `(,item . ,feed)))) (defun nnjsonfeed--read-title (feed-or-item) (setq feed-or-item (if (listp feed-or-item) (car feed-or-item) feed-or-item)) (gethash "title" feed-or-item)) (defun nnjsonfeed--read-description (feed) (gethash "description" (car feed))) (defsubst nnjsonfeed--read-author-name (author) (when (stringp (setq author (gethash "name" author))) (concat author ", "))) (defun nnjsonfeed--read-authors (feed-or-item) (setq feed-or-item (if (listp feed-or-item) (car feed-or-item) feed-or-item)) (string-trim-right (if-let ((authors (gethash "authors" feed-or-item))) (mapconcat #'nnjsonfeed--read-author-name authors) (if-let ((author (gethash "author" feed-or-item))) (nnjsonfeed--read-author-name author) "")) ", ")) (defun nnjsonfeed--read-id (item) (gethash "id" item)) (defun nnjsonfeed--read-date (item mod) (when-let ((d (gethash (if mod "date_modified" "date_published") item))) (date-to-time d))) (defun nnjsonfeed--read-links (item) (let ((atts 0) links) (when-let ((l (gethash "url" item))) (push (vector l "Link:" "[Link]") links)) (when-let ((l (gethash "external_url" item))) (push (vector l "Related:" "[Related]") links)) (append links (mapcar (lambda (a) (let* ((l (gethash "url" a)) (type (gethash "mime_type" a)) (size (gethash "size_in_bytes" a)) (dur (gethash "duration_in_seconds" a)) (title (concat (or (gethash "title" a) (format "Attachment%s" (if (< 1 (cl-incf atts)) (format " %d" atts) ""))) (if dur " [" " ") (and dur (format-seconds "%y year, %d days, %.2h:%z%.2m:%.2s= ]" dur)) " (" type (and size ", ") (and size (file-size-human-readable size)) ")= "))) (vector l (concat title ":") (concat "[" title "]")))) (gethash "attachments" item))))) (defun nnjsonfeed--read-parts (item) (let ((summary (gethash "summary" item)) (contentt (gethash "content_text" item)) (contenth (gethash "content_html" item)) parts) (if (not (or summary contentt contenth)) '((nil ("Content-Type" . "text/html") html links)) (setq parts nil) (and contenth (push (nnatom--read-part contenth "html" t) parts)) (and summary (push (nnatom--read-part summary "plain" (not (or contenth contentt))) parts)) (and contentt (push (nnatom--read-part summary "plain" (not contenth)) parts)) parts))) (defvoo nnjsonfeed-read-feed-function #'nnjsonfeed--read-feed nil nnatom-read-feed-function) (defvoo nnjsonfeed-read-item-function #'nnjsonfeed--read-item nil nnatom-read-article-function) (defvoo nnjsonfeed-read-title-function #'nnjsonfeed--read-title nil nnatom-read-title-function nnatom-read-subject-function) (defvoo nnjsonfeed-read-description-function #'nnjsonfeed--read-description nil nnatom-read-description-function) (defvoo nnjsonfeed-read-authors-function #'nnjsonfeed--read-authors nil nnatom-read-group-author-function nnatom-read-author-function) (defvoo nnjsonfeed-read-id-function #'nnjsonfeed--read-id nil nnatom-read-id-function) (defvoo nnjsonfeed-read-publish-date-function (lambda (item) (nnjsonfeed--read-date item nil)) nil nnatom-read-publish-date-function) (defvoo nnjsonfeed-read-modified-date-function (lambda (item) (nnjsonfeed--read-date item t)) nil nnatom-read-update-date-function) (defvoo nnjsonfeed-read-links-function #'nnjsonfeed--read-links nil nnatom-read-links-function) (defvoo nnjsonfeed-read-parts-function #'nnjsonfeed--read-parts nil nnatom-read-parts-function) (gnus-declare-backend (symbol-name nnjsonfeed-backend) 'address) (provide 'nnjsonfeed) ;;; nnjsonfeed.el ends here --=-=-=--