1 ;;; atom.el --- Create an Atom feed
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-to-rss-print my-atom-feed))
52 ;; Full documentation is available at <http://tar-jx.bz/code/atom.html>.
58 (require 'cl) ; for setf in url-canonalize
60 (defun atom-create (title link &optional subtitle self id author updated)
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 SUBTITLE is a subtitle for the feed; it can be a bit longer than
70 TITLE, maybe a paragraph long.
72 SELF is the canonical URL to this feed.
74 ID is a unique identifier for this feed. If not given, it
77 AUTHOR is the author of the feed. See `atom-massage-author' for
78 the possible ways to specify it. In particular, `nil' uses
79 `user-full-name' and `user-mail-address'.
81 UPDATED is the date the feed was last updated. If not given,
82 `(current-time)' is used."
83 (let ((atom-feed (list (list 'title nil title))))
84 (atom-modify-entry atom-feed 'link `(((href . ,link))))
85 (atom-modify-entry atom-feed 'author (atom-massage-author author))
86 (if subtitle (atom-modify-entry atom-feed 'subtitle subtitle))
87 (if self (atom-modify-entry atom-feed 'link
88 `(((href . ,self) (rel . "self")
89 (type . "application/atom+xml")))))
90 (atom-modify-entry atom-feed 'updated (atom-format-time updated))
91 (atom-modify-entry atom-feed 'id (or id self link))
94 (defun atom-push-entry (atom entry)
95 "Add the entry ENTRY to the feed ATOM."
96 (nconc atom (list `(entry nil ,@entry))))
98 (defun atom-modify-entry (entry name val)
99 "Set the NAME element of ENTRY to VAL."
100 (let ((elem (if (stringp val)
103 (nconc entry (list elem))))
105 (defun atom-add-entry (atom title link content
106 &optional updated id summary)
107 "Add an entry to the atom flux ATOM. Return the newly added
110 TITLE is a short, text-only, human readable string.
112 LINK is a permanent link for this entry. For a given entry, LINK
113 may change between successive generations of the atom feed.
115 CONTENT is the content of the entry; use `atom-add-html-entry'
116 or `atom-add-xhtml-entry' when CONTENT is not text-only.
118 If SUMMARY is not given, the entry will not contain any summary.
120 UPDATED defaults to `(current-time)' if omitted, which is
121 probably not a very good default.
123 ID defaults to LINK, which is not optimal; see `atom-generate-id'
124 for a way to create good identifiers. For a given entry, it must
125 not change between successive generations of the atom feed, even
126 when the content of the entry changes."
127 (let ((entry (list (list 'title nil title))))
128 (atom-modify-entry entry 'link (list (list (cons 'href link))))
129 (atom-modify-entry entry 'id (or id link))
130 (atom-modify-entry entry 'updated (atom-format-time updated))
131 (if summary (atom-modify-entry entry 'summary summary))
132 (atom-modify-entry entry 'content content)
133 (atom-push-entry atom entry)
136 (defalias 'atom-add-text-entry 'atom-add-entry
137 "Add an entry to ATOM, with a textual content. See
138 `atom-add-entry' for details.")
140 (defun atom-add-html-entry (atom title link content
141 &optional updated id summary)
142 "Add an entry to ATOM, with some HTML content. CONTENT should
143 be a string enconding a valid HTML fragment. See `atom-add-entry'
144 for additional details."
146 title link (atom-massage-html content)
147 updated id (and summary (atom-massage-html summary))))
149 (defun atom-add-xhtml-entry (atom title link content
150 &optional updated id summary noconvert)
151 "Add an entry to ATOM, with some XHTML content. CONTENT may be
152 given either as a string, or as an XML tree, of a valid XHTML
153 fragment. See `atom-add-entry' for additional details.
155 If NOCONVERT is nil, translate all links in CONTENT so that they
156 are no longer relative to LINK."
157 (let ((xhtml-content (atom-massage-xhtml content)))
159 (atom-xhtml-convert-links (cadr xhtml-content) link))
161 title link xhtml-content
162 updated id (and summary (atom-massage-xhtml summary)))))
164 (defun atom-print (atom)
165 "Print the Atom feed ATOM in the current buffer."
166 (insert atom-xml-declaration)
167 (insert "<feed xmlns=\"http://www.w3.org/2005/Atom\">\n")
169 (insert "\n</feed>"))
171 (defun atom-write-file (atom filename)
172 "Writes the feed ATOM to FILENAME."
175 (write-file filename)))
178 (defun atom-to-rss (atom)
179 "Translate an Atom feed into an RSS one, returning the translation.
181 Some information may be lost or approximated."
182 (let ((rss (list (assoc 'title atom))))
183 (atom-to-rss-translator atom rss '((subtitle . description)
186 (atom-to-rss-modify-time rss)
187 (atom-to-rss-modify-link rss)
188 (dolist (entry (xml-get-children atom 'entry))
189 (push (atom-to-rss-item entry) rss))
192 (defun atom-to-rss-item (entry)
193 "Translates an Atom entry into an RSS item."
194 (let ((item (list (assoc 'title entry))))
195 (atom-to-rss-translator
196 (xml-node-children entry) item
197 '((id . guid) (content . description) (updated . pubDate) (link . link)))
198 (atom-to-rss-modify-time item)
199 (atom-to-rss-modify-link item)
200 (let ((guid (assoc 'guid item))
201 (descr (assoc 'description item)))
203 (setcar (cdr guid) (list (cons 'isPermaLink "false"))))
205 (equal (xml-get-attribute descr 'type) "xhtml"))
206 (setcar (cddr descr) (xml-node-as-text descr))))
209 (defun atom-to-rss-translator (source target translations)
210 (dolist (translation translations)
211 (let* ((from (car translation))
212 (to (cdr translation))
213 (data (copy-tree (cdr (assoc from source)))))
215 (atom-modify-entry target to data)))))
217 (defun atom-to-rss-modify-link (entry)
218 (let* ((link (assoc 'link entry))
219 (link-addr (xml-get-attribute-or-nil link 'href)))
221 (setcar (cdr link) nil)
222 (setcdr (cdr link) (cons link-addr nil)))))
224 (defun atom-print-as-rss (atom)
225 (let ((rss (atom-to-rss atom)))
226 (insert atom-xml-declaration)
227 (insert "<rss version=\"2.0\">\n")
228 (insert " <channel>\n")
230 (insert "\n </channel>\n")
233 (defun atom-to-rss-time (time)
234 "Translates a string from the format used by Atom into the
236 (let ((system-time-locale "C"))
237 (format-time-string "%a, %d %b %Y %T %z" (atom-parse-time time))))
239 (defun atom-to-rss-modify-time (entry)
240 "Modify ENTRY, changing the format of the `pubDate' in it."
241 (let ((pubDate (assoc 'pubDate entry)))
242 (setcar (cddr pubDate)
243 (atom-to-rss-time (car (xml-node-children pubDate))))))
245 (defun atom-to-rss-write-file (atom filename)
246 "Saves ATOM as a RSS feed into FILENAME."
248 (atom-print-as-rss atom)
249 (write-file filename)))
252 (defvar atom-time-format-string "%Y-%m-%dT%T%z"
253 "The format for string representation of dates.")
255 (defvar atom-xhtml-namespace "http://www.w3.org/1999/xhtml")
257 (defvar atom-xml-declaration "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
259 (defun atom-format-time (&optional time)
260 "Format a time according to RFC3339."
261 ;; The time zone must be specified in numeric form, but with a colon between
262 ;; the hour and minute parts.
263 (replace-regexp-in-string
265 (format-time-string atom-time-format-string time)))
267 (defun atom-parse-time (&optional time)
268 "Parse a time as specified in RFC3339 into Emacs's native format."
269 ;; Same remark as in `atom-format-time'
270 (date-to-time (replace-regexp-in-string ":\\(..\\)$" "\\1" time)))
272 (defun atom-massage-html (content)
273 "Massage CONTENT so it can be used as an HTML fragment in an
274 Atom feed. CONTENT must be a string."
275 (list '((type . "html")) content))
277 (defun atom-string-to-xml (string)
278 "Convert STRING into a Lisp structure as used by `xml.el'."
279 (require 'xml-xhtml-entities)
280 (let ((xml-entity-alist xml-xhtml-entities)
281 (xml-validating-parser t))
283 (insert "<div xmlns=\"" atom-xhtml-namespace "\">")
286 ;; `xml-parse-region' returns a list of elements, even though it
287 ;; requires an only root node. We are only interested in the first
288 ;; one, the DIV we just inserted.
289 (car (xml-parse-region (point-min) (point-max))))))
291 (defun atom-massage-xhtml (content)
292 "Massage CONTENT so it can be used as an XHTML fragment in an
294 (list '((type . "xhtml"))
295 (or (and (stringp content)
296 (atom-string-to-xml content))
297 `(div ((xmlns . ,atom-xhtml-namespace)) ,@content))))
299 (defun atom-massage-author (author)
300 "Return an XML node representing the author. AUTHOR can be:
301 - nil, in which case `user-full-name' and `user-mail-address' are
303 - a single string, the full name of the author; no email address
305 - a list with two elements, the full name and the email address
307 - something else, assumed to be a complete `atomPersonConstruct'."
309 ((null author) `((name nil ,user-full-name)
310 (email nil ,user-mail-address)))
311 ((stringp author) `((name nil ,author)))
312 ((= 2 (length author)) `((name nil ,(car author))
313 (email nil ,(cadr author))))
314 (t `(author nil ,author)))))
316 (defun atom-xhtml-convert-links (node base)
317 "Make all links in NODE (a fragment of an XHTML document)
318 absolute, in the context of BASE, an URL."
319 (dolist (attr-name (list 'href 'src))
320 (let ((attr (assoc attr-name (xml-node-attributes node))))
321 (when attr (setcdr attr (url-canonalize (cdr attr) base)))))
322 (dolist (child (xml-node-children node))
323 (when (listp child) (atom-xhtml-convert-links child base))))
325 (defun atom-generate-id (link creation-date)
326 "Generate a string suitable for use as an atom:id element. This
327 implements Mark Pilgrom's tag: URI method, using the
328 CREATION-DATE of the entry, and the domain part of LINK."
329 (format "tag:%s,%s:/%s"
330 (url-host (url-generic-parse-url link))
331 (format-time-string "%Y-%m-%d" creation-date)
332 (format-time-string "%Y%m%d%H%M%S" creation-date)))
335 ;;; Functions that should probably not be there
337 (defun url-canonalize (address base)
338 "Make ADRESS an absolute URL, taking it in the BASE context."
339 ;; I feel such a function should exist in `url-parse'. Did I miss it?
340 (let ((url-base (url-generic-parse-url base))
341 (url-address (url-generic-parse-url address)))
342 (if (url-host url-address)
344 (setf (url-filename url-base)
345 (expand-file-name address
346 (file-name-directory (url-filename url-base))))
347 (url-recreate-url url-base))))
349 (defun xml-node-as-text (node)
350 "Return a string representing NODE, an XML structure."
352 (xml-print (xml-node-children node))
355 (defun xml-node-create (name attrlist childlist)
356 "Create a new XML node."
357 (list name attrlist . childlist))
360 ;;; atom.el ends here