atom.el

   1 ;;; atom.el --- Create an Atom feed
   2
   3 ;; Copyright (C) 2011  Frédéric Perrin
   4
   5 ;; Author: Frédéric Perrin <frederic.perrin@resel.fr>
   6 ;; Keywords: www, hypermedia, atom, rss
   7
   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.
  12
  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.
  17
  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/>.
  20
  21 ;;; Commentary:
  22
  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.
  29
  30 ;; It is possible to produce both Atom and RSS feeds.
  31
  32 ;; A typical usage would look like this:
  33
  34 ;; (let ((my-atom-feed (atom-create "My feed" "http://example.org")))
  35 ;;   ; A simple, text-only entry
  36 ;;   (atom-add-text-entry
  37 ;;    my-atom-feed
  38 ;;    "Hello world"
  39 ;;    "http://example.org/hello"
  40 ;;    "Hello the world!")
  41 ;;
  42 ;;   (atom-add-xhtml-entry
  43 ;;    my-atom-feed
  44 ;;    "An XHTML example"
  45 ;;    "http://example.org/html-example"
  46 ;;    "<p>One can also use <acronym>XHTML</acronym> in the entries.</p>")
  47 ;;
  48 ;;   (atom-print my-atom-feed)
  49 ;;   ;; If you prefer RSS feeds:
  50 ;;   (atom-to-rss-print my-atom-feed))
  51
  52 ;; Full documentation is available at <http://tar-jx.bz/code/atom.html>.
  53
  54 ;;; Code:
  55
  56 (require 'xml)
  57 (require 'url-parse)
  58 (require 'cl) ; for setf in url-canonalize
  59
  60 (defun atom-create (title link &optional subtitle self id author updated)
  61   "Create a new atom structure.
  62
  63 TITLE is the title for the feed, a short, text-only, human
  64 readable string.
  65
  66 LINK is the URL of a page responible for the content of this
  67 feed.
  68
  69 SUBTITLE is a subtitle for the feed; it can be a bit longer than
  70 TITLE, maybe a paragraph long.
  71
  72 SELF is the canonical URL to this feed.
  73
  74 ID is a unique identifier for this feed. If not given, it
  75 defaults to SELF.
  76
  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'.
  80
  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))
  92     atom-feed))
  93
  94 (defun atom-push-entry (atom entry)
  95   "Add the entry ENTRY to the feed ATOM."
  96   (nconc atom (list `(entry nil ,@entry))))
  97
  98 (defun atom-modify-entry (entry name val)
  99   "Set the NAME element of ENTRY to VAL."
 100   (let ((elem (if (stringp val)
 101                   (list name nil val)
 102                 (cons name val))))
 103     (nconc entry (list elem))))
 104
 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
 108 entry.
 109
 110 TITLE is a short, text-only, human readable string.
 111
 112 LINK is a permanent link for this entry. For a given entry, LINK
 113 may change between successive generations of the atom feed.
 114
 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.
 117
 118 If SUMMARY is not given, the entry will not contain any summary.
 119
 120 UPDATED defaults to `(current-time)' if omitted, which is
 121 probably not a very good default.
 122
 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 ."
 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)
 134     entry))
 135
 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.")
 139
 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."
 145   (atom-add-entry atom
 146    title link (atom-massage-html content)
 147    updated id (and summary (atom-massage-html summary))))
 148
 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.
 154
 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)))
 158     (unless noconvert
 159       (atom-xhtml-convert-links (cadr xhtml-content) link))
 160     (atom-add-entry atom
 161                     title link xhtml-content
 162                     updated id (and summary (atom-massage-xhtml summary)))))
 163
 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")
 168   (xml-print atom)
 169   (insert "\n</feed>"))
 170
 171 (defun atom-write-file (atom filename)
 172   "Writes the feed ATOM to FILENAME."
 173   (with-temp-buffer
 174     (atom-print atom)
 175     (write-region (point-min) (point-max) filename)))
 176
 177 \f
 178 (defun atom-to-rss (atom)
 179   "Translate an Atom feed into an RSS one, returning the translation.
 180
 181 Some information may be lost or approximated."
 182   (let ((rss (list (assoc 'title atom))))
 183     (atom-to-rss-translator atom rss '((subtitle . description)
 184                                        (updated . pubDate)
 185                                        (link . link)))
 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))
 190     (reverse rss)))
 191
 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)))
 202       (if guid
 203           (setcar (cdr guid) (list (cons 'isPermaLink "false"))))
 204       (if (and descr
 205                (equal (xml-get-attribute descr 'type) "xhtml"))
 206           (setcar (cddr descr) (xml-node-as-text descr))))
 207     `(item nil ,@item)))
 208
 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)))))
 214       (when data
 215         (atom-modify-entry target to data)))))
 216
 217 (defun atom-to-rss-modify-link (entry)
 218   (let* ((link (assoc 'link entry))
 219          (link-addr (xml-get-attribute-or-nil link 'href)))
 220     (when link
 221       (setcar (cdr link) nil)
 222       (setcdr (cdr link) (cons link-addr nil)))))
 223
 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")
 229     (xml-print rss "    ")
 230     (insert "\n  </channel>\n")
 231     (insert "</rss>")))
 232
 233 (defun atom-to-rss-time (time)
 234   "Translates a string from the format used by Atom into the
 235 format used by RSS."
 236   (let ((system-time-locale "C"))
 237     (format-time-string "%a, %d %b %Y %T %z" (atom-parse-time time))))
 238
 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))))))
 244
 245 (defun atom-to-rss-write-file (atom filename)
 246   "Saves ATOM as a RSS feed into FILENAME."
 247   (with-temp-buffer
 248     (atom-print-as-rss atom)
 249     (write-region nil nil filename)))
 250
 251 \f
 252 (defvar atom-time-format-string "%Y-%m-%dT%T%z"
 253   "The format for string representation of dates.")
 254
 255 (defvar atom-xhtml-namespace "http://www.w3.org/1999/xhtml")
 256
 257 (defvar atom-xml-declaration "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
 258
 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
 264    "\\(..\\)$" ":\\1"
 265    (format-time-string atom-time-format-string time)))
 266
 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)))
 271
 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))
 276
 277 (defun atom-string-to-xml (string)
 278   "Convert STRING into a Lisp structure as used by `xml.el'."
 279   (with-temp-buffer
 280     (insert "<div xmlns=\"" atom-xhtml-namespace "\">")
 281     (insert string)
 282     (insert "</div>")
 283     ;; `xml-parse-region' doesn't require that the XML parsed be enclosed in a
 284     ;; root node, and accordingly, returns a list of elements. We are only
 285     ;; interested in the first one, the DIV we just inserted.
 286     (car (xml-parse-region (point-min) (point-max)))))
 287
 288 (defun atom-massage-xhtml (content)
 289   "Massage CONTENT so it can be used as an XHTML fragment in an
 290 Atom feed."
 291   (list '((type . "xhtml"))
 292         (or (and (stringp content)
 293                  (atom-string-to-xml content))
 294             `(div ((xmlns . ,atom-xhtml-namespace)) ,@content))))
 295
 296 (defun atom-massage-author (author)
 297   "Return an XML node representing the author. AUTHOR can be:
 298 - nil, in which case `user-full-name' and `user-mail-address' are
 299   used;
 300 - a single string, the full name of the author; no email address
 301   will be included;
 302 - a list with two elements, the full name and the email address
 303   of the author;
 304 - something else, assumed to be a complete `atomPersonConstruct'."
 305   `(nil ,@(cond
 306            ((null author) `((name nil ,user-full-name)
 307                             (email nil ,user-mail-address)))
 308            ((stringp author) `((name nil ,author)))
 309            ((= 2 (length author)) `((name nil ,(car author))
 310                                     (email nil ,(cadr author))))
 311            (t `(author nil ,author)))))
 312
 313 (defun atom-xhtml-convert-links (node base)
 314   "Make all links in NODE (a fragment of an XHTML document)
 315 absolute, in the context of BASE, an URL."
 316   (dolist (attr-name (list 'href 'src))
 317     (let ((attr (assoc attr-name (xml-node-attributes node))))
 318       (when attr (setcdr attr (url-canonalize (cdr attr) base)))))
 319   (dolist (child (xml-node-children node))
 320     (when (listp child) (atom-xhtml-convert-links child base))))
 321
 322 (defun atom-generate-id (link creation-date)
 323   "Generate a string suitable for use as an atom:id element. This
 324 implements Mark Pilgrom's tag: URI method, using the
 325 CREATION-DATE of the entry, and the domain part of LINK."
 326     (format "tag:%s,%s:/%s"
 327             (url-host (url-generic-parse-url link))
 328             (format-time-string "%Y-%m-%d" creation-date)
 329             (format-time-string "%Y%m%d%H%M%S" creation-date)))
 330
 331 \f
 332 ;;; Functions that should probably not be there
 333
 334 (defun url-canonalize (address base)
 335   "Make ADRESS an absolute URL, taking it in the BASE context."
 336   ;; I feel such a function should exist in `url-parse'. Did I miss it?
 337   (let ((url-base (url-generic-parse-url base))
 338         (url-address (url-generic-parse-url address)))
 339     (if (url-host url-address)
 340         address
 341       (setf (url-filename url-base)
 342             (expand-file-name address
 343                               (file-name-directory (url-filename url-base))))
 344       (url-recreate-url url-base))))
 345
 346 (defun xml-node-as-text (node)
 347   "Return a string representing NODE, an XML structure."
 348   (with-temp-buffer
 349     (xml-print (xml-node-children node))
 350     (buffer-string)))
 351
 352 (defun xml-node-create (name attrlist childlist)
 353   "Create a new XML node."
 354   (list name attrlist . childlist))
 355
 356 (provide 'atom)
 357 ;;; atom.el ends here