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 ;; A feed is really a Lisp structure as used by the `xml.el' package,
  31 ;; without the parent `feed' element.
  32
  33 ;; A typical usage would look like this:
  34
  35 ;; (let ((my-atom-feed (atom-create "My feed" "http://example.org")))
  36 ;;   ; A simple, text-only entry
  37 ;;   (atom-add-text-entry
  38 ;;    my-atom-feed
  39 ;;    "Hello world"
  40 ;;    "http://example.org/hello"
  41 ;;    "Hello the world!")
  42 ;;
  43 ;;   ; A text-only entry, with all the optional pieces of data
  44 ;;   (atom-add-text-entry
  45 ;;    my-atom-feed
  46 ;;    "Bonjour"
  47 ;;    "http://example.org/bonjour"
  48 ;;    "Bonjour à tout le monde !"
  49 ;;    ;; optional: the last modification time
  50 ;;    (date-to-time "2011-01-30 23:40:12")
  51 ;;    ;; optional: an identifier for this entry; a common way to generate it is
  52 ;;    ;; to use the domain name and the creation date of the entry.
  53 ;;    (atom-generate-id "http://example.org"
  54 ;;                   (date-to-time "2011-01-30 10:01:05"))
  55 ;;    ;; optional: a summary for this entry
  56 ;;    "Bonjour, monde.")
  57 ;;
  58 ;;   (atom-add-xhtml-entry
  59 ;;    my-atom-feed
  60 ;;    "An XHTML example"
  61 ;;    "http://example.org/html-example"
  62 ;;    "<p>One can also use <acronym>XHTML</acronym> in the entries.</p>")
  63 ;;   (atom-print my-atom-feed))
  64
  65 ;;; Code:
  66
  67 (require 'xml)
  68
  69 (defun atom-create (title link &optional subtitle self id author updated)
  70   "Create a new atom structure.
  71
  72 TITLE is the title for the feed, a short, text-only, human
  73 readable string.
  74
  75 LINK is the URL of a page responible for the content of this
  76 feed.
  77
  78 SUBTITLE is a subtitle for the feed; it can be a bit longer than
  79 TITLE, maybe a paragraph long.
  80
  81 SELF is the canonical URL to this feed.
  82
  83 ID is a unique identifier for this feed. If not given, it
  84 defaults to SELF.
  85
  86 AUTHOR is the author of the feed. See `atom-massage-author' for
  87 the possible ways to specify it.
  88
  89 UPDATED is the date the feed was last updated. If not given,
  90 `(current-time)' is used."
  91   (let ((atom-feed (list (list 'title nil title))))
  92     (atom-modify-entry atom-feed 'link `(((href . ,link))))
  93     (atom-modify-entry atom-feed 'author (atom-massage-author author))
  94     (if subtitle (atom-modify-entry atom-feed 'subtitle subtitle))
  95     (if self (atom-modify-entry atom-feed 'link
  96                                 `(((href . ,self) (rel . "self")
  97                                    (type . "application/atom+xml")))))
  98     (atom-modify-entry atom-feed 'updated (atom-format-time updated))
  99     (atom-modify-entry atom-feed 'id (or id self link))
 100     atom-feed))
 101
 102 (defun atom-push-entry (atom entry)
 103   "Add the entry ENTRY to the feed ATOM."
 104   (nconc atom (list `(entry nil ,@entry))))
 105
 106 (defun atom-modify-entry (entry name val)
 107   "Set the NAME element of ENTRY to VAL."
 108   (let ((elem (if (stringp val)
 109                   (list name nil val)
 110                 (cons name val))))
 111     (nconc entry (list elem))))
 112
 113 (defun atom-add-entry (atom title link content
 114                             &optional updated id summary)
 115   "Add an entry to the atom flux ATOM. Return the newly added
 116 entry.
 117
 118 TITLE is a short, text-only, human readable string.
 119
 120 LINK is a permanent link for this entry. For a given entry, LINK
 121 may change between successive generations of the atom feed.
 122
 123 CONTENT is the content of the entry; use `atom-add-html-entry'
 124 or `atom-add-xhtml-entry' when CONTENT is not text-only.
 125
 126 If SUMMARY is not given, the entry will not contain any summary.
 127
 128 UPDATED defaults to `(current-time)' if omitted, which is
 129 probably not a very good default.
 130
 131 ID defaults to LINK, which is not optimal; see `atom-generate-id'
 132 for a way to create good identifiers. For a given entry, it must
 133 not change between successive generations of the atom feed, even
 134 when the content of the entry ."
 135   (let ((entry (list (list 'title nil title))))
 136     (atom-modify-entry entry 'link  (list (list (cons 'href link))))
 137     (atom-modify-entry entry 'id (or id link))
 138     (atom-modify-entry entry 'updated (atom-format-time updated))
 139     (if summary (atom-modify-entry entry 'summary summary))
 140     (atom-modify-entry entry 'content content)
 141     (atom-push-entry atom entry)
 142     entry))
 143
 144 (defalias 'atom-add-text-entry 'atom-add-entry
 145   "Add an entry to ATOM, with a textual content. See
 146 `atom-add-entry' for details.")
 147
 148 (defun atom-add-html-entry (atom title link content
 149                                   &optional updated id summary)
 150   "Add an entry to ATOM, with some HTML content. CONTENT should
 151 be a string enconding a valid HTML fragment. See `atom-add-entry'
 152 for additional details."
 153   (atom-add-entry atom
 154    title link (atom-massage-html content)
 155    updated id (and summary (atom-massage-html summary))))
 156
 157 (defun atom-add-xhtml-entry (atom title link content
 158                                   &optional updated id summary)
 159   "Add an entry to ATOM, with some XHTML content. CONTENT may be
 160 given either as a string, or as an XML tree, of a valid XHTML
 161 fragment. See `atom-add-entry' for additional details."
 162   (atom-add-entry atom
 163    title link (atom-massage-xhtml content)
 164    updated id (and summary (atom-massage-xhtml summary))))
 165
 166 (defun atom-print (atom)
 167   "Print the Atom feed ATOM in the current buffer."
 168   (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
 169   (insert "<feed xmlns=\"http://www.w3.org/2005/Atom\">\n")
 170   (xml-print atom)
 171   (insert "\n</feed>"))
 172
 173 (defun atom-write-file (atom filename)
 174   "Writes the feed ATOM to FILENAME."
 175   (with-temp-buffer
 176     (atom-print atom)
 177     (write-region (point-min) (point-max) filename)))
 178
 179 \f
 180 (defun atom-to-rss (atom)
 181   "Translate an Atom feed into an RSS one, returning the translation.
 182
 183 Some information may be lost or approximated."
 184   (let ((rss (list (assoc 'title atom))))
 185     (atom-to-rss-translator atom rss '((subtitle . description)
 186                                        (updated . pubDate)
 187                                        (link . link)))
 188     (atom-to-rss-modify-time rss)
 189     (atom-to-rss-modify-link rss)
 190     (dolist (entry (xml-get-children atom 'entry))
 191       (push (atom-to-rss-item entry) rss))
 192     (reverse rss)))
 193
 194 (defun atom-to-rss-item (entry)
 195   "Translates an Atom entry into an RSS item."
 196   (let ((item (list (assoc 'title entry))))
 197     (atom-to-rss-translator
 198      (xml-node-children entry) item
 199      '((id . guid) (content . description) (updated . pubDate) (link . link)))
 200     (atom-to-rss-modify-time item)
 201     (atom-to-rss-modify-link item)
 202     (let ((guid (assoc 'guid item))
 203           (descr (assoc 'description item)))
 204       (if guid
 205           (setcar (cdr guid) (list (cons 'isPermaLink "false"))))
 206       (if (and descr
 207                (equal (xml-get-attribute descr 'type) "xhtml"))
 208           (setcar (cddr descr) (xml-node-text descr))))
 209     `(item nil ,@item)))
 210
 211 (defun atom-to-rss-translator (source target translations)
 212   (dolist (translation translations)
 213     (let* ((from (car translation))
 214            (to (cdr translation))
 215            (data (copy-tree (cdr (assoc from source)))))
 216       (when data
 217         (atom-modify-entry target to data)))))
 218
 219 (defun xml-node-text (node)
 220   (with-temp-buffer
 221     (xml-print (xml-node-children node))
 222     (buffer-string)))
 223
 224 (defun atom-to-rss-modify-link (entry)
 225   (let* ((link (assoc 'link entry))
 226          (link-addr (xml-get-attribute-or-nil link 'href)))
 227     (message "%S" link)
 228     (when link
 229       (setcar (cdr link) nil)
 230       (setcdr (cdr link) (cons link-addr nil)))))
 231
 232 (defun atom-print-as-rss (atom)
 233   (let ((rss (atom-to-rss atom)))
 234     (insert "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n")
 235     (insert "<rss version=\"2.0\">\n")
 236     (insert "  <channel>\n")
 237     (xml-print rss "    ")
 238     (insert "\n  </channel>\n")
 239     (insert "</rss>")))
 240
 241 (defun atom-to-rss-time (time)
 242   "Translates a string from the format used by Atom into the
 243 format used by RSS."
 244   ;; Same remark as in `atom-format-time'
 245   (let ((system-time-locale "C"))
 246     (format-time-string "%a, %d %b %Y %T %z" (atom-parse-time time))))
 247
 248 (defun atom-to-rss-modify-time (entry)
 249   "Modify ENTRY, changing the format of the `pubDate' in it."
 250   (let ((pubDate (assoc 'pubDate entry)))
 251     (setcar (cddr pubDate)
 252             (atom-to-rss-time (car (xml-node-children pubDate))))))
 253
 254 (defun atom-to-rss-write-file (atom filename)
 255   "Saves ATOM as a RSS feed into FILENAME."
 256   (with-temp-buffer
 257     (atom-print-as-rss atom)
 258     (write-region nil nil filename)))
 259
 260 \f
 261 (defvar atom-time-format-string "%Y-%m-%dT%T%z"
 262   "The format for string representation of dates.")
 263
 264 (defun atom-format-time (&optional time)
 265   "Format a time according to RFC3339."
 266   ;; The time zone must be specified in numeric form, but with a colon between
 267   ;; the hour and minute parts.
 268   (replace-regexp-in-string
 269    "\\(..\\)$" ":\\1"
 270    (format-time-string atom-time-format-string time)))
 271
 272 (defun atom-parse-time (&optional time)
 273   "Parse a time as specified in RFC3339 into Emacs's native format."
 274   (date-to-time (replace-regexp-in-string ":\\(..\\)$" "\\1" time)))
 275
 276 (defun atom-massage-html (content)
 277   "Massage CONTENT so it can be used as an HTML fragment in an
 278 Atom feed. CONTENT must be a string."
 279   (list '((type . "html")) content))
 280
 281 (defun atom-string-to-xml (string)
 282   "Convert STRING into a Lisp structure as used by `xml.el'."
 283   (with-temp-buffer
 284     (insert "<div xmlns=\"http://www.w3.org/1999/xhtml\">")
 285     (insert string)
 286     (insert "</div>")
 287     (xml-parse-region (point-min) (point-max))))
 288
 289 (defun atom-massage-xhtml (content)
 290   "Massage CONTENT so it can be used as an XHTML fragment in an
 291 Atom feed."
 292   `(((type . "xhtml"))
 293     ,@(or (and (stringp content)
 294                (atom-string-to-xml content))
 295           content)))
 296
 297 (defun atom-massage-author (author)
 298   "Return an XML node representing the author. AUTHOR can be:
 299 - nil, in which case `user-full-name' and `user-mail-address' are
 300   used;
 301 - a single string, the full name of the author;
 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 (require 'url-parse)
 314
 315 (defun atom-generate-id (link creation-date)
 316   "Generate a string suitable for use as an atom:id element. This
 317 implements Mark Pilgrom's tag: URI method, using the
 318 CREATION-DATE of the entry, and the domain part of LINK."
 319     (format "tag:%s,%s:/%s"
 320             (url-host (url-generic-parse-url link))
 321             (format-time-string "%Y-%m-%d" creation-date)
 322             (format-time-string "%Y%m%d%H%M%S" creation-date)))
 323
 324 (provide 'atom)
 325 ;;; atom.el ends here