1 ;;; atom.el --- Create an Atom feed -*- lexical-binding: t -*-
3 ;; Copyright (C) 2011 Frédéric Perrin
5 ;; Author: Frédéric Perrin <frederic.perrin@resel.fr>
6 ;; Keywords: www, hypermedia, atom, rss
8 ;; This program is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation, either version 3 of the License, or
11 ;; (at your option) any later version.
13 ;; This program is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
23 ;; This is a library for creating an Atom feed from a Lisp program.
24 ;; The normal usage is to create a feed with `atom-create', giving it
25 ;; a title and a Web address. Once the feed has been created, entries
26 ;; may be added to the feed, by specifying (at the minimum) a title, a
27 ;; permanent link and the content of the entry. Text-only, HTML and
28 ;; XHTML entries are supported.
30 ;; It is possible to produce both Atom and RSS feeds.
32 ;; A typical usage would look like this:
34 ;; (let ((my-atom-feed (atom-create "My feed" "http://example.org")))
35 ;; ; A simple, text-only entry
36 ;; (atom-add-text-entry
39 ;; "http://example.org/hello"
40 ;; "Hello the world!")
42 ;; (atom-add-xhtml-entry
45 ;; "http://example.org/html-example"
46 ;; "<p>One can also use <acronym>XHTML</acronym> in the entries.</p>")
48 ;; (atom-print my-atom-feed)
49 ;; ;; If you prefer RSS feeds:
50 ;; (atom-print-as-rss my-atom-feed))
52 ;; Full documentation is available at <http://tar-jx.bz/code/atom.html>.
53 ;; See atom-tests.el for usage examples.
60 (defun atom-create (title link &optional props)
61 "Create a new atom structure.
63 TITLE is the title for the feed, a short, text-only, human
66 LINK is the URL of a page responible for the content of this
69 PROPS is an optional plist with the following properties:
71 - :subtitle is a subtitle for the feed; it can be a bit longer than
72 TITLE, maybe a paragraph long.
74 - :self is the canonical URL to this feed. If missing, the resulting
75 feed is non-conforming.
77 - :id is a unique identifier for this feed. If not given, it
80 - :author is the author of the feed. See `atom-massage-author' for
81 the possible ways to specify it. In particular, nil uses
82 variable `user-full-name' and `user-mail-address'.
84 - :updated is the date the feed was last updated. If not given,
85 `(current-time)' is used."
86 (let ((atom-feed (list (list 'title nil title))))
87 (atom-modify-entry atom-feed 'link `(((href . ,link))))
88 (atom-modify-entry atom-feed 'author (atom-massage-author (plist-get props :author)))
89 (if (plist-member props :subtitle)
90 (atom-modify-entry atom-feed 'subtitle (plist-get props :subtitle)))
91 (if (plist-member props :self)
92 (atom-modify-entry atom-feed 'link
93 `(((href . ,(plist-get props :self)) (rel . "self")
94 (type . "application/atom+xml")))))
95 (atom-modify-entry atom-feed 'updated (atom-format-time (plist-get props :updated)))
96 (atom-modify-entry atom-feed 'id (or (plist-get props :id) (plist-get props :self) link))
99 (defun atom-push-entry (atom entry)
100 "Add the entry ENTRY to the feed ATOM."
101 (nconc atom (list `(entry nil ,@entry))))
103 (defun atom-modify-entry (entry name val)
104 "Set the NAME element of ENTRY to VAL."
105 (let ((elem (if (stringp val)
108 (nconc entry (list elem))))
110 (defun atom-add-entry (atom title link content &optional props)
111 "Add an entry to the atom flux ATOM.
113 Return the newly adde dentry.
115 TITLE is a short, text-only, human readable string.
117 LINK is a permanent link for this entry. For a given entry, LINK
118 may change between successive generations of the atom feed.
120 CONTENT is the content of the entry; use `atom-add-html-entry'
121 or `atom-add-xhtml-entry' when CONTENT is not text-only.
123 PROPS is an optional plist with the following properties:
125 - :summary, if is not given, the entry will not contain any summary.
127 - :updated defaults to `(current-time)'.
129 - :published, if given, is the earliest availability of the
130 entry. It is optional, and shouldn't change even if the entry
131 content (etc.) updated after the initial publication.
133 - :id is a unique ID for the entry; defaulting to LINK. RFC4287
134 has specific requirements about valid IRI that may be used,
135 which this library does not try to enforce."
136 (let ((entry (list (list 'title nil title))))
137 (atom-modify-entry entry 'link (list (list (cons 'href link))))
138 (atom-modify-entry entry 'id (or (plist-get props :id) link))
139 (atom-modify-entry entry 'updated (atom-format-time (plist-get props :updated)))
140 (if (plist-member props :published)
141 (atom-modify-entry entry 'published (atom-format-time (plist-get props :published))))
142 (if (plist-member props :summary)
143 (atom-modify-entry entry 'summary (plist-get props :summary)))
144 (atom-modify-entry entry 'content content)
145 (atom-push-entry atom entry)
148 (defalias 'atom-add-text-entry 'atom-add-entry
149 "Add an entry to ATOM, with a textual content. See
150 `atom-add-entry' for details.")
152 (defun atom-add-html-entry (atom title link content &optional props)
153 "Add an entry to ATOM, with some HTML content.
155 TITLE, LINK, PROPS as in `atom-add-entry'. CONTENT should be a string
156 enconding a valid HTML fragment. See `atom-add-entry' for
158 (if (plist-member props :summary)
159 (plist-put props :summary (atom-massage-html (plist-get props :summary))))
160 (atom-add-entry atom title link (atom-massage-html content) props))
162 (defun atom-add-xhtml-entry (atom title link content &optional props)
163 "Add an entry to ATOM, with some XHTML content.
165 TITLE, LINK, PROPS as in `atom-add-entry'. CONTENT may be given
166 either as a string, or as an XML tree, of a valid XHTML fragment.
167 See `atom-add-entry' for additional details."
168 (if (plist-member props :summary)
169 (plist-put props :summary (atom-massage-xhtml (plist-get props :summary))))
170 (atom-add-entry atom title link (atom-massage-xhtml content) props))
172 (defvar atom-xml-declaration "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
174 (defun atom-print (atom)
175 "Print the Atom feed ATOM in the current buffer."
176 (insert atom-xml-declaration)
177 (insert "<feed xmlns=\"http://www.w3.org/2005/Atom\">\n")
179 (insert "\n</feed>"))
181 (defun atom-write-file (atom filename)
182 "Writes the feed ATOM to FILENAME."
185 (write-file filename)))
188 (defun atom-to-rss (atom &optional rss-self)
189 "Translate Atom feed ATOM into an RSS one, returning the translation.
191 If RSS-SELF is given, it is used as self link of the RSS feed.
193 Some information may be lost or approximated."
194 (let ((rss (list (assoc 'title atom))))
196 (atom-modify-entry rss 'atom:link
197 `(((href . ,rss-self) (rel . "self")
198 (type . "application/atom+xml")))))
199 (atom-to-rss-translator atom rss '((subtitle . description)
202 (atom-to-rss-modify-time rss)
203 (atom-to-rss-modify-link rss)
204 (dolist (entry (xml-get-children atom 'entry))
205 (push (atom-to-rss-item entry) rss))
208 (defun atom-to-rss-item (entry)
209 "Translates the Atom entry ENTRY into an RSS item."
210 (let ((item (list (assoc 'title entry))))
211 (atom-to-rss-translator
212 (xml-node-children entry) item
213 '((id . guid) (content . description) (updated . pubDate) (link . link)))
214 (atom-to-rss-modify-time item)
215 (atom-to-rss-modify-link item)
216 (let ((guid (assoc 'guid item))
217 (descr (assoc 'description item)))
219 (setcar (cdr guid) (list (cons 'isPermaLink "false"))))
221 (equal (xml-get-attribute descr 'type) "xhtml"))
222 (setcar (cddr descr) (xml-node-as-text descr)))
223 (setcar (cdr descr) nil))
226 (defun atom-to-rss-translator (source target translations)
227 (dolist (translation translations)
228 (let* ((from (car translation))
229 (to (cdr translation))
230 (data (copy-tree (cdr (assoc from source)))))
232 (atom-modify-entry target to data)))))
234 (defun atom-to-rss-modify-link (entry)
235 (let* ((link (assoc 'link entry))
236 (link-addr (xml-get-attribute-or-nil link 'href)))
238 (setcar (cdr link) nil)
239 (setcdr (cdr link) (cons link-addr nil)))))
241 (defun atom-print-as-rss (atom &optional rss-self)
242 "Convert Atom feed ATOM to RSS in the current buffer.
244 If RSS-SELF is given, it is used as self link of the RSS feed."
245 (let ((rss (atom-to-rss atom rss-self)))
246 (insert atom-xml-declaration)
247 ;; xmlns:atom included in order to allow the atom:link rel=self element
248 (insert "<rss version=\"2.0\" xmlns:atom=\"http://www.w3.org/2005/Atom\">\n")
249 (insert " <channel>\n")
251 (insert "\n </channel>\n")
254 (defun atom-to-rss-time (time)
255 "Translate TIME from the format used by Atom into the format used by RSS.
258 (let ((system-time-locale "C"))
259 (format-time-string "%a, %d %b %Y %T %z" (atom-parse-time time))))
261 (defun atom-to-rss-modify-time (entry)
262 "Modify ENTRY, changing the format of the `pubDate' in it."
263 (let ((pubDate (assoc 'pubDate entry)))
264 (setcar (cddr pubDate)
265 (atom-to-rss-time (car (xml-node-children pubDate))))))
267 (defun atom-to-rss-write-file (atom filename &optional rss-self)
268 "Save ATOM as a RSS feed into FILENAME.
270 If RSS-SELF is given, it is used as self link of the RSS feed."
272 (atom-print-as-rss atom rss-self)
273 (write-file filename)))
276 (defvar atom-time-format-string "%Y-%m-%dT%T%z"
277 "The format for string representation of dates.")
279 (defvar atom-xhtml-namespace "http://www.w3.org/1999/xhtml")
281 (defun atom-format-time (&optional time)
282 "Format time value TIME according to RFC3339."
283 ;; The time zone must be specified in numeric form, but with a colon between
284 ;; the hour and minute parts.
285 (replace-regexp-in-string
287 (format-time-string atom-time-format-string time)))
289 (defun atom-parse-time (&optional time)
290 "Parse string TIME as specified in RFC3339 into Emacs's native format."
291 ;; Same remark as in `atom-format-time': RFC3339 wants a colon between hour
292 ;; and minute parts of the timezome, so remove it before `date-to-time'.
293 (date-to-time (replace-regexp-in-string ":\\(..\\)$" "\\1" time)))
295 (defun atom-massage-html (content)
296 "Massage CONTENT so it can be used as an HTML fragment in an Atom feed.
298 CONTENT must be a string."
299 (list '((type . "html")) content))
301 (defun atom-string-to-xml (string)
302 "Convert STRING into a Lisp structure as used by `xml.el'."
303 (require 'xml-xhtml-entities)
304 (let ((xml-entity-alist xml-xhtml-entities)
305 (xml-validating-parser t))
307 (insert "<div xmlns=\"" atom-xhtml-namespace "\">")
310 ;; `xml-parse-region' returns a list of elements, even though it
311 ;; requires an only root node. We are only interested in the first
312 ;; one, the DIV we just inserted.
313 (car (xml-parse-region (point-min) (point-max))))))
315 (defun atom-massage-xhtml (content)
316 "Massage CONTENT so it can be used as an XHTML fragment in an Atom feed."
317 (list '((type . "xhtml"))
318 (or (and (stringp content)
319 (atom-string-to-xml content))
320 `(div ((xmlns . ,atom-xhtml-namespace)) ,@content))))
322 (defun atom-massage-author (author)
323 "Return an XML node representing the author. AUTHOR can be:
324 - nil, in which case variables `user-full-name' and `user-mail-address'
326 - a single string, the full name of the author; no email address
328 - a list with two elements, the full name and the email address
330 - something else, assumed to be a complete `atomPersonConstruct'."
332 ((null author) `((name nil ,user-full-name)
333 (email nil ,user-mail-address)))
334 ((stringp author) `((name nil ,author)))
335 ((= 2 (length author)) `((name nil ,(car author))
336 (email nil ,(cadr author))))
337 (t `(author nil ,author)))))
339 (defun atom-xhtml-convert-links (node base)
340 "Make all links in NODE (a fragment of an XHTML document)
341 absolute, in the context of BASE, an URL."
342 (dolist (attr-name (list 'href 'src))
343 (let ((attr (assoc attr-name (xml-node-attributes node))))
344 (when attr (setcdr attr (url-canonalize (cdr attr) base)))))
345 (dolist (child (xml-node-children node))
346 (when (listp child) (atom-xhtml-convert-links child base))))
349 ;;; Functions that should probably not be there
351 (defun url-canonalize (address base)
352 "Make ADDRESS an absolute URL, taking it in the BASE context."
353 ;; I feel such a function should exist in `url-parse'. Did I miss it?
354 (let ((url-base (url-generic-parse-url base))
355 (url-address (url-generic-parse-url address)))
356 (if (url-host url-address)
358 (setf (url-filename url-base)
359 (expand-file-name address
360 (file-name-directory (url-filename url-base))))
361 (url-recreate-url url-base))))
363 (defun xml-node-as-text (node)
364 "Return a string representing NODE, an XML structure."
366 (xml-print (xml-node-children node))
370 ;;; atom.el ends here