1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
|
;;; nnatom.el --- Atom backend for Gnus -*- lexical-binding: t -*-
;; Copyright (C) 2023, 2025 Free Software Foundation, Inc.
;; Author: Daniel Semyonov <daniel@dsemy.com>
;; This file is part of GNU Emacs.
;; nnatom is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; nnatom is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with nnatom. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Gnus backend for HTTP or local feeds following the
;; Atom Syndication Format <https://www.ietf.org/rfc/rfc4287>.
;;; Code:
(eval-when-compile
(require 'cl-lib)
(require 'subr-x))
(require 'nnfeed)
(require 'mm-url)
(require 'dom)
(defgroup nnatom nil
"Atom backend for Gnus."
:group 'nnfeed)
(nnoo-declare nnatom nnfeed)
(nnfeed-define-basic-backend-interface nnatom)
;;;; Atom feed parser:
(declare-function libxml-parse-xml-region "xml.c")
(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)))))
(authors (list 'authors)))
(when (eq (car data) 'top)
(setq data (assq 'feed data)))
(dom-add-child-before data authors)
(let ((all (dom-children data)))
(while-let ((rest (cdr all))
(child (car-safe rest))
(type (car-safe child))
((not (eq type 'entry))))
(and (or (eq type 'author)
(eq type 'contributor))
(dom-add-child-before authors child))
(setq all rest))
;; Order of entries is reversed as most Atom feeds
;; list only the "most recent" entries, in reverse
;; chronological order.
(setcdr all (nreverse (cdr all))))
data))))))
(defvoo nnatom-read-feed-function #'nnatom--read-feed
nil nnfeed-read-feed-function)
(defun nnatom--read-group (data)
"Return the next group and the remaining DATA in a cons cell, or nil."
`(,data))
(defvoo nnatom-read-group-function #'nnatom--read-group
nil nnfeed-read-group-function)
(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-children data)))
;; Discard any children between/after entries.
(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))))))
(defvoo nnatom-read-article-function #'nnatom--read-article
nil nnfeed-read-article-function)
(defun nnatom--dom-line (node)
"Return NODE's text as a single, whitespace-trimmed line."
(string-trim (replace-regexp-in-string "[\r\n]+" " " (dom-text node) t)))
(defun nnatom--read-title (group)
"Return the title of GROUP, or nil."
(nnatom--dom-line (dom-child-by-tag group 'title)))
(defvoo nnatom-read-title-function #'nnatom--read-title
nil nnfeed-read-title-function)
(defun nnatom--read-description (group)
"Return the description of GROUP, or nil."
(nnatom--dom-line (dom-child-by-tag group 'subtitle)))
(defvoo nnatom-read-description-function #'nnatom--read-description
nil nnfeed-read-description-function)
(defun nnatom--read-article-or-group-authors (article-or-group)
"Return the authors of ARTICLE-OR-GROUP, or nil."
(when-let
((a (mapconcat
(lambda (author)
(let* ((name (nnatom--dom-line (dom-child-by-tag author 'name)))
(name (unless (string-blank-p name) name))
(email (nnatom--dom-line (dom-child-by-tag author 'email)))
(email (unless (string-blank-p email) email)))
(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))
(defvoo nnatom-read-author-function #'nnatom--read-article-or-group-authors
nil nnfeed-read-author-function)
(defvoo nnatom-read-group-author-function
#'nnatom--read-article-or-group-authors
nil nnfeed-read-group-author-function)
(defun nnatom--read-subject (article)
"Return the subject of ARTICLE, or nil."
(nnatom--dom-line (dom-child-by-tag article 'title)))
(defvoo nnatom-read-subject-function #'nnatom--read-subject
nil nnfeed-read-subject-function)
(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--dom-line (dom-child-by-tag article 'id))
(nnatom--read-subject article)))
(defvoo nnatom-read-id-function #'nnatom--read-id
nil nnfeed-read-id-function)
(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 (nnatom--dom-line d))))
(defvoo nnatom-read-publish-date-function #'nnatom--read-publish
nil nnfeed-read-publish-date-function)
(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 (nnatom--dom-line d))))
(defvoo nnatom-read-update-date-function #'nnatom--read-update
nil nnfeed-read-update-date-function)
(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 "<a href=\"%s\">[%s]</a> "
src label)))))
(when-let (((or (eq l 'author) (eq l 'contributor)))
(name (nnatom--dom-line (dom-child-by-tag link 'name)))
(name (if (string-blank-p name)
(concat "Author"
(and (< 1 (cl-incf aut))
(format " %s" aut)))
name))
(uri (nnatom--dom-line (dom-child-by-tag link 'uri)))
((not (string-blank-p uri))))
`(((("text/plain") . ,(format "%s: %s\n" name uri))
(("text/html") . ,(format "<a href=\"%s\">[%s]</a> "
uri name)))))
(when-let (((eq 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 "<a href=\"%s\">[%s]</a> "
link label))))))))
(dom-children (dom-child-by-tag article 'links)))))
(defvoo nnatom-read-links-function #'nnatom--read-links
nil nnfeed-read-links-function)
(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)))
((setq content (or summary content))
(push (append content '(links)) parts))
(t (push '((nil (Content-Type . "text/html") links)) parts)))
parts))
(defvoo nnatom-read-parts-function #'nnatom--read-parts
nil nnfeed-read-parts-function)
(gnus-declare-backend (symbol-name nnatom-backend) 'none 'address)
(provide 'nnatom)
;;; nnatom.el ends here
|
