From 5c0cf970799d4d20473b6d232c1061ac0366cd85 Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Sat, 17 Jun 2023 18:47:59 -0700 Subject: [PATCH] Add nnatom.el Direct copy from https://git.sr.ht/~dsemy/nnatom, with updated copyright header. --- lisp/gnus/nnatom.el | 540 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 540 insertions(+) create mode 100644 lisp/gnus/nnatom.el diff --git a/lisp/gnus/nnatom.el b/lisp/gnus/nnatom.el new file mode 100644 index 00000000000..83ef1c3f28d --- /dev/null +++ b/lisp/gnus/nnatom.el @@ -0,0 +1,540 @@ +;;; nnatom.el --- Atom backend for Gnus -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Daniel Semyonov + +;; This file is not part of GNU Emacs. + +;; nnatom is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; nnatom is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with nnatom. If not, see . + +;;; Commentary: + +;; Gnus backend for Atom feeds. + +;;; Code: + +(eval-when-compile + (require 'cl-lib) + (require 'gv) + (require 'subr-x)) + +(require 'gnus) +(require 'nnheader) +(require 'nnoo) +(require 'gnus-group) +(require 'mm-url) + +(defgroup nnatom nil + "Atom backend for Gnus." + :group 'gnus) + +(nnoo-declare nnatom) + +(defvoo nnatom-backend 'nnatom + "Symbol which identifies this backend.") + +(defvoo nnatom-status-string nil + "Last status message reported by this backend.") + +(defsubst nnatom--backend-prefix (backend) + (concat (symbol-name backend) ":")) + +;;;; Atom feed parser: + +(defsubst nnatom--node-attributes (node subnode) + (cadr (assq subnode node))) + +(defsubst nnatom--node-subnodes (node subnode) + (let ((sub (cddr (assq subnode node)))) + (or (and (atom (car sub)) (car sub)) sub))) + +(defun nnatom--parse-feed (feed) + "Return a list structure representing FEED, or nil." + (if (string-match-p "^https?://" feed) + (nnheader-report + nnatom-backend + "Address shouldn't start with \"http://\" or \"https://\"") + (with-temp-buffer + (condition-case e + (if (file-readable-p feed) + (insert-file-contents feed) + (mm-url-insert-file-contents (concat "https://" feed))) + (file-error (nnheader-report nnatom-backend (cdr e))) + (:success (cddr (libxml-parse-xml-region (point-min) (point-max)))))))) + +(defun nnatom--read-article (data _) + "Return the next article and the remaining DATA in a cons cell, or nil." + (and data + `(,(let (article) + (while (not (eq (car (setq article (car data))) 'entry)) + (setq data (cdr data))) + (setq data (cdr data)) + article) + . ,data))) + +(defun nnatom--read-title (feed) + "Return the title of FEED, or nil." + (nnatom--node-subnodes feed 'title)) + +(defun nnatom--read-article-or-feed-author (article-or-feed) + "Return the author of ARTICLE-OR-FEED, or nil." + (let* ((author (nnatom--node-subnodes article-or-feed 'author)) + (name (nnatom--node-subnodes author 'name)) + (email (nnatom--node-subnodes author 'email))) + (or (and name email (format "%s <%s>" name email)) + name email))) + +(defun nnatom--read-id (article) + "Return the ID of ARTICLE. +If the ARTICLE doesn't contain an ID but it does contain a subject, +return the subject. Otherwise, return nil." + (or (nnatom--node-subnodes article 'id) + (nnatom--read-subject article))) + +(defun nnatom--read-subject (article) + "Return the subject of ARTICLE, or nil." + (nnatom--node-subnodes article 'title)) + +(defun nnatom--read-publish (article) + "Return the date and time ARTICLE was published, or nil." + (when-let ((pub (nnatom--node-subnodes article 'published))) + (and (stringp pub) (date-to-time pub)))) + +(defun nnatom--read-update (article) + "Return the date and time of the last update to ARTICLE, or nil." + (when-let ((update (nnatom--node-subnodes article 'updated))) + (and (stringp update) (date-to-time update)))) + +(defun nnatom--read-link (article) + "Return the link to ARTICLE, or nil." + (alist-get 'href (or (nnatom--node-attributes article 'link) + (nnatom--node-subnodes article 'link)))) + +(defun nnatom--read-summary-or-content-type (article summary-or-content) + "Return the type of SUMMARY-OR-CONTENT of ARTICLE, or \"plain\"." + (or (cdr (assq 'type + (nnatom--node-attributes article summary-or-content))) + "plain")) + +(defun nnatom--read-summary-or-content (article summary-or-content) + "Return SUMMARY-OR-CONTENT of ARTICLE, or nil." + (nnatom--node-subnodes article summary-or-content)) + +;;;; Feed I/O: + +(defvoo nnatom-read-feed-function #'nnatom--parse-feed + "Function returning a Lisp object representing a feed (or part of it). +It should accept a single argument, the address of a feed.") + +(defvoo nnatom-read-article-function #'nnatom--read-article + "Function returning a cons cell of an article and remaining data from a feed. +It should accept a two arguments, a Lisp object representing a feed, +and a flag indicating whether the last article was stale (not new or updated). +If there are no remaining articles, it should return nil.") + +(defvoo nnatom-read-title-function #'nnatom--read-title + "Function returning the title of a feed (a string). +It should accept a single argument, a Lisp object representing a feed.") + +(defvoo nnatom-read-feed-author-function #'nnatom--read-article-or-feed-author + "Function returning the author of a feed (a string). +It should accept a single argument, a Lisp object representing a feed.") + +(defvoo nnatom-read-id-function #'nnatom--read-id + "Function returning the ID of an article. +It should accept a single argument, a Lisp object representing an article.") + +(defvoo nnatom-read-subject-function #'nnatom--read-subject + "Function returning the subject of an article (a string). +It should accept a single argument, a Lisp object representing an article.") + +(defvoo nnatom-read-publish-date-function #'nnatom--read-publish + "Function returning the publish date of an article (a time value). +It should accept a single argument, a Lisp object representing an article.") + +(defvoo nnatom-read-update-date-function #'nnatom--read-update + "Function returning the update date of an article (a time value). +It should accept a single argument, a Lisp object representing an article.") + +(defvoo nnatom-read-author-function #'nnatom--read-article-or-feed-author + "Function returning the author of an article (a string). +It should accept a single argument, a Lisp object representing an article.") + +(defvoo nnatom-read-link-function #'nnatom--read-link + "Function returning the link contained in an article (a string). +It should accept a single argument, a Lisp object representing an article.") + +(defvoo nnatom-read-summary-type-function + (lambda (article) + (nnatom--read-summary-or-content-type article 'summary)) + "Function returning the type of the summary of an article (a string). +This is appended to \"text/\" to form the MIME type of the summary. +It should accept a single argument, a Lisp object representing an article.") + +(defvoo nnatom-read-content-type-function + (lambda (article) + (nnatom--read-summary-or-content-type article 'content)) + "Function returning the type of the content of an article (a string). +This is appended to \"text/\" to form the MIME type of the content. +It should accept a single argument, a Lisp object representing an article.") + +(defvoo nnatom-read-summary-function + (lambda (article) + (nnatom--read-summary-or-content article 'summary)) + "Function returning the summary of an article (a string). +It should accept a single argument, a Lisp object representing an article.") + +(defvoo nnatom-read-content-function + (lambda (article) + (nnatom--read-summary-or-content article 'content)) + "Function returning the content of an article (a string). +It should accept a single argument, a Lisp object representing an article.") + +(defvoo nnatom-groups (make-hash-table :test 'equal) + "Hash table mapping known group names to their data. + +Each value in this table should be a vector of the form +[GROUP IDS ARTICLES MAX MIN], where: +- GROUP is the name of the group. +- IDS is a hash table mapping article IDs to their numbers. +- ARTICLES is a hash table mapping article numbers to articles and + their attributes (see `nnatom-group-articles'). +- MAX is the maximum article number. +- MIN is the minimum article number.") + +(defun nnatom-group-file (group) + "Return the file containing feed data for GROUP." + (expand-file-name (format "%s/%s.eld" + (string-trim (symbol-name nnatom-backend) + "nn") + (gnus-newsgroup-savable-name group)) + gnus-directory)) + +(defun nnatom--read-feed (feed &optional group) + "Read FEED into a new or existing GROUP." + (let ((prefix (nnatom--backend-prefix nnatom-backend))) + (when (string-suffix-p "-ephemeral" feed) + (setq feed (or (cadr (assq (nnoo-symbol nnatom-backend 'address) + (cddr (gnus-server-to-method + (concat prefix feed))))) + feed))) + (when-let ((data (funcall nnatom-read-feed-function feed)) + (group (or (and group (string-trim group prefix)) + (cadr (assq (nnoo-symbol nnatom-backend 'name) + (gnus-server-to-method + (concat prefix feed)))) + (funcall nnatom-read-title-function data)))) + (let* ((info (gnus-get-info (concat prefix group))) + (g (or (gethash group nnatom-groups) + (nnatom-read-group group) + `[ ,group ,(make-hash-table :test 'equal) + ,(make-hash-table :test 'eql) nil 1])) + (ids (aref g 1)) + (articles (aref g 2)) + (max (aref g 3)) + (max (if max max + (setq max 0) ; Find max article number + (dolist ; remembered by Gnus. + ( r (cons (gnus-info-read info) + (gnus-info-marks info)) + max) + (mapc (lambda (x) + (let ((x (if (consp x) + (if (< (car x) (cdr x)) + (cdr x) (car x)) + x))) + (when (< max x) (setq max x)))) + (if (symbolp (car r)) (cdr r) r))))) + (feed-author (funcall nnatom-read-feed-author-function data)) + article stale) + (while (setq article (funcall nnatom-read-article-function data stale) + data (cdr article) + article (car article)) + (when-let ((id (funcall nnatom-read-id-function article)) + (id (format "<%s@%s.%s>" id group nnatom-backend))) + (let* ((num (gethash id ids)) + (update (funcall nnatom-read-update-date-function article)) + (prev-update (aref (gethash num articles + '[nil nil nil nil nil]) + 4))) + (if (or (null num) ; New article ID. + (and (null prev-update) update) + (and prev-update update + (time-less-p prev-update update))) + (let* ((num (or num (aset g 3 (cl-incf max)))) + (publish (funcall nnatom-read-publish-date-function + article))) + (setf + (gethash id (aref g 1)) num + (gethash num (aref g 2)) + `[ ,id + ,(or (funcall nnatom-read-author-function article) + feed-author group) + ,(or (funcall nnatom-read-subject-function article) + "no subject") + ,(or publish update '(0 0)) ; published + ,(or update publish '(0 0)) ; updated + ,(funcall nnatom-read-link-function article) + (,(funcall nnatom-read-summary-function article) + . ,(funcall nnatom-read-summary-type-function article)) + (,(funcall nnatom-read-content-function article) + . ,(funcall + nnatom-read-content-type-function + article))] + stale nil)) + (setq stale t))))) + (puthash group g nnatom-groups))))) + +(defun nnatom-read-group (group) + "Read GROUP's information from `nnatom-directory'." + (if-let ((f (nnatom-group-file group)) + ((file-readable-p f))) + (with-temp-buffer + (insert-file-contents f) + (goto-char (point-min)) + (puthash group (read (current-buffer)) nnatom-groups)) + (nnheader-report nnatom-backend "Can't read %s"))) + +(defun nnatom-write-group (group) + "Write GROUP's information to `nnatom-directory'." + (if-let ((f (nnatom-group-file group)) + ((file-writable-p f))) + (if-let ((g (gethash group nnatom-groups)) + ((vectorp g))) + (with-temp-file f + (insert ";;;; -*- mode: lisp-data -*- DO NOT EDIT\n" + (prin1-to-string g)) + t) + t) + (nnheader-report nnatom-backend "Can't write %s" f))) + +;;;; Gnus backend functions: + +(defvoo nnatom-group nil + "Name of the current group.") + +(defvoo nnatom-group-article-ids (make-hash-table :test 'equal) + "Hash table mapping article IDs to their article number.") + +(defvoo nnatom-group-articles (make-hash-table :test 'eql) + "Hash table mapping article numbers to articles and their attributes. + +Each value in this table should be a vector of the form +[ID FROM SUBJECT DATE UPDATED LINK SUMMARY CONTENT], where: +- ID is the ID of the article. +- FROM is the author of the article or group. +- SUBJECT is the subject of the article. +- DATE is the date the article was published, or last updated (time value). +- UPDATE is the date the article was last updated, or published (time value). +- LINK is the URL to the full (remote) version of the article. +- SUMMARY and CONTENT are cons cells where the car is the raw + summary/content of the article and the cdr is the \"type\" of + the summary/content (appended to \"text/\" to form the MIME type).") + +(defvoo nnatom-group-article-max-num 0 + "Maximum article number for the current group.") + +(defvoo nnatom-group-article-min-num 1 + "Minimum article number for the current group.") + +(defvar nnatom-date-format "%F %X" + "Format of displayed dates.") + +(nnoo-define-basics nnatom) + +(defun nnatom-retrieve-article (article group) + (if-let ((a (gethash article (aref group 2)))) + (insert (format "221 %s Article retrieved. +From: %s\nSubject: %s\nDate: %s\nMessage-ID: %s\n.\n" + article + (aref a 1) + (aref a 2) + (format-time-string nnatom-date-format (aref a 3)) + (aref a 0))) + (insert "404 Article not found.\n.\n"))) + +(deffoo nnatom-retrieve-headers (articles &optional group _server _fetch-old) + (if-let ((g (or (gethash group nnatom-groups) + (nnatom-read-group group) + `[ nil ,nnatom-group-article-ids + ,nnatom-group-articles nil nil]))) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (or (and (stringp (car articles)) + (mapc (lambda (a) + (nnatom-retrieve-article + (gethash a (aref g 1)) g)) + articles)) + (and (numberp (car articles)) + (range-map (lambda (a) (nnatom-retrieve-article a g)) + articles))) + 'headers) + (nnheader-report nnatom-backend "Group %s not found" (or group "")))) + +(deffoo nnatom-request-close () + (setq nnatom-groups (make-hash-table :test 'equal) + nnatom-status-string nil) + t) + +(defun nnatom--print-content (content type link) + "Return CONTENT with LINK appended and formatted according to TYPE." + (when (and content type) + (let ((html (or (string= type "html") (string= type "xhtml")))) + (concat (when html "") content "\n\n" + (and (stringp link) + (if html (format "

[Link]

" link) + link)) + (when html ""))))) + +(deffoo nnatom-request-article (article &optional group _server to-buffer) + (if-let ((g (or (gethash group nnatom-groups) + (and nnatom-group + `[ nil ,nnatom-group-article-ids + ,nnatom-group-articles + ,nnatom-group-article-max-num + ,nnatom-group-article-min-num]))) + (num (or (and (stringp article) + (gethash article (aref g 1))) + (and (numberp article) article))) + ((and (<= num (aref g 3)) + (>= num (aref g 4)))) + (a (gethash num (aref g 2)))) + (with-current-buffer (or to-buffer nntp-server-buffer) + (erase-buffer) + (let* ((boundary (format "-_%s_-" nnatom-backend)) + (link (aref a 5)) + (summary (aref a 6)) + (summary-type (cdr summary)) + (summary + (nnatom--print-content (car summary) summary-type link)) + (content (aref a 7)) + (content-type (cdr content)) + (content + (nnatom--print-content (car content) content-type link))) + (insert (format + "Subject: %s\nFrom: %s\nDate: %s\nMessage-ID: %s\n" + (aref a 2) (aref a 1) + (format-time-string + nnatom-date-format (or (aref a 3) '(0 0))) + (aref a 0)) + "MIME-Version: 1.0\nContent-Type: " + (concat (cond ((and summary content) + (format "multipart/alternative; boundary=%s +--%s\nContent-Type: text/%s\n\n%s\n--%s\nContent-Type: text/%s\n\n%s\n--%s--\n" + boundary boundary summary-type + summary boundary content-type + content boundary)) + (summary (format "text/%s\n\n%s\n" + summary-type summary)) + (content (format "text/%s\n\n%s\n" + content-type content)) + (link (format "text/plain\n\n%s\n" link)) + (t "text/plain\n\n"))))) + `(,group . ,num)) + (nnheader-report nnatom-backend "No such article"))) + +(deffoo nnatom-request-group (group &optional server fast _info) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (if-let ((s (or server (nnoo-current-server nnatom-backend))) + (g (or (if fast + (or (gethash group nnatom-groups) + (nnatom-read-group group)) + (nnatom--read-feed s group)) + `[ ,group ,(make-hash-table :test 'equal) + ,(make-hash-table :test 'eql) 0 1]))) + (progn + (setq nnatom-group group + nnatom-group-article-ids (aref g 1) + nnatom-group-articles (aref g 2) + nnatom-group-article-max-num (aref g 3) + nnatom-group-article-min-num (aref g 4)) + (insert (format "211 %s %s %s \"%s\"" + (hash-table-count nnatom-group-article-ids) + nnatom-group-article-min-num + nnatom-group-article-max-num group)) + t) + (insert "404 group not found") + (nnheader-report nnatom-backend "Group %s not found" group)))) + +(deffoo nnatom-close-group (group &optional _server) + (if (nnatom-write-group group) + (setq nnatom-group nil + nnatom-group-article-ids (make-hash-table :test 'equal) + nnatom-group-articles (make-hash-table :test 'eql) + nnatom-group-article-max-num 0 + nnatom-group-article-min-num 1) + (nnheader-report nnatom-backend "Couldn't write group %s" group))) + +(deffoo nnatom-request-list (&optional server) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (when-let ((g (nnatom--read-feed + (or server (nnoo-current-server nnatom-backend))))) + (insert (format "\"%s\" %s %s y\n" + (aref g 0) (aref g 3) (aref g 4))) + t))) + +(deffoo nnatom-request-post (&optional _server) + (nnheader-report nnatom-backend "%s is a read only backend" nnatom-backend)) + +;;;; Optional back end functions: + +(deffoo nnatom-retrieve-groups (_groups &optional server) + (nnatom-request-list (or server (nnoo-current-server nnatom-backend))) + 'active) + +(deffoo nnatom-request-type (_group &optional _article) + 'unknown) + +(deffoo nnatom-request-delete-group (group _force &optional _server) + (delete-file (nnatom-group-file group)) + (remhash group nnatom-groups) + (when (string= group nnatom-group) + (setq nnatom-group nil + nnatom-group-article-ids (make-hash-table :test 'equal) + nnatom-group-articles (make-hash-table :test 'eql) + nnatom-group-article-max-num 0 + nnatom-group-article-min-num 1)) + t) + +(gnus-declare-backend (symbol-name nnatom-backend) 'address) + +;;;; Utilities: + +(defmacro nnatom-define-basic-backend-interface (backend) + "Define a basic set of functions and variables for BACKEND." + (let ((bp (symbol-name backend))) + `(progn + (defvoo ,(intern (concat bp "-backend")) ',backend nil nnatom-backend) + (defvoo ,(intern (concat bp "-status-string")) + nil nil nnatom-status-string) + (defvoo ,(intern (concat bp "-group")) nil nil nnatom-group) + (defvoo ,(intern (concat bp "-groups")) + (make-hash-table :test 'equal) nil nnatom-groups) + (defvoo ,(intern (concat bp "-group-article-ids")) + (make-hash-table :test 'equal) nil nnatom-group-article-ids) + (defvoo ,(intern (concat bp "-group-articles")) + (make-hash-table :test 'eql) nil nnatom-group-articles) + (defvoo ,(intern (concat bp "-group-article-max-num")) 0 nil + nnatom-group-article-max-num) + (defvoo ,(intern (concat bp "-group-article-mix-num")) 1 nil + nnatom-group-article-min-num) + (nnoo-define-basics ,backend) + (nnoo-import ,backend (nnatom))))) + +(provide 'nnatom) + +;;; nnatom.el ends here -- 2.39.2