atom.el

   1 ;;; atom.el --- Create an Atom feed  -*- lexical-binding: t -*-
   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-print-as-rss my-atom-feed))
  51
  52 ;; Full documentation is available at <http://tar-jx.bz/code/atom.html>.
  53 ;; See atom-tests.el for usage examples.
  54
  55 ;;; Code:
  56
  57 (require 'xml)
  58 (require 'url-parse)
  59
  60 (defun atom-create (title link &optional props)
  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 PROPS is an optional plist with the following properties:
  70
  71 - :subtitle is a subtitle for the feed; it can be a bit longer than
  72   TITLE, maybe a paragraph long.
  73
  74 - :self is the canonical URL to this feed. If missing, the resulting
  75   feed is non-conforming.
  76
  77 - :id is a unique identifier for this feed. If not given, it
  78   defaults to :self.
  79
  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'.
  83
  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))
  97     atom-feed))
  98
  99 (defun atom-push-entry (atom entry)
 100   "Add the entry ENTRY to the feed ATOM."
 101   (nconc atom (list `(entry nil ,@entry))))
 102
 103 (defun atom-modify-entry (entry name val)
 104   "Set the NAME element of ENTRY to VAL."
 105   (let ((elem (if (stringp val)
 106                   (list name nil val)
 107                 (cons name val))))
 108     (nconc entry (list elem))))
 109
 110 (defun atom-add-entry (atom title link content &optional props)
 111   "Add an entry to the atom flux ATOM.
 112
 113 Return the newly adde dentry.
 114
 115 TITLE is a short, text-only, human readable string.
 116
 117 LINK is a permanent link for this entry. For a given entry, LINK
 118 may change between successive generations of the atom feed.
 119
 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.
 122
 123 PROPS is an optional plist with the following properties:
 124
 125 - :summary, if is not given, the entry will not contain any summary.
 126
 127 - :updated defaults to `(current-time)' if omitted, which is
 128 probably not a very good default.
 129
 130 - :published, if given, is the earliest availability of the
 131   entry. It is optional, and shouldn't change even if the entry
 132   content (etc.) updated after the initial publication.
 133
 134 - :id is a unique ID for the entry; defaulting to LINK. RFC4287
 135   has specific requirements about valid IRI that may be used,
 136   which this library does not try to enforce."
 137   (let ((entry (list (list 'title nil title))))
 138     (atom-modify-entry entry 'link  (list (list (cons 'href link))))
 139     (atom-modify-entry entry 'id (or (plist-get props :id) link))
 140     (atom-modify-entry entry 'updated (atom-format-time (plist-get props :updated)))
 141     (if (plist-member props :summary)
 142         (atom-modify-entry entry 'summary (plist-get props :summary)))
 143     (atom-modify-entry entry 'content content)
 144     (atom-push-entry atom entry)
 145     entry))
 146
 147 (defalias 'atom-add-text-entry 'atom-add-entry
 148   "Add an entry to ATOM, with a textual content. See
 149 `atom-add-entry' for details.")
 150
 151 (defun atom-add-html-entry (atom title link content &optional props)
 152   "Add an entry to ATOM, with some HTML content.
 153
 154 TITLE, LINK, PROPS as in `atom-add-entry'. CONTENT should be a string
 155 enconding a valid HTML fragment. See `atom-add-entry' for
 156 additional details."
 157   (if (plist-member props :summary)
 158       (plist-put props :summary (atom-massage-html (plist-get props :summary))))
 159   (atom-add-entry atom title link (atom-massage-html content) props))
 160
 161 (defun atom-add-xhtml-entry (atom title link content &optional props)
 162   "Add an entry to ATOM, with some XHTML content.
 163
 164 TITLE, LINK, PROPS as in `atom-add-entry'. CONTENT may be given
 165 either as a string, or as an XML tree, of a valid XHTML fragment.
 166 See `atom-add-entry' for additional details."
 167   (if (plist-member props :summary)
 168       (plist-put props :summary (atom-massage-xhtml (plist-get props :summary))))
 169   (atom-add-entry atom title link (atom-massage-xhtml content) props))
 170
 171 (defvar atom-xml-declaration "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
 172
 173 (defun atom-print (atom)
 174   "Print the Atom feed ATOM in the current buffer."
 175   (insert atom-xml-declaration)
 176   (insert "<feed xmlns=\"http://www.w3.org/2005/Atom\">\n")
 177   (xml-print atom)
 178   (insert "\n</feed>"))
 179
 180 (defun atom-write-file (atom filename)
 181   "Writes the feed ATOM to FILENAME."
 182   (with-temp-buffer
 183     (atom-print atom)
 184     (write-file filename)))
 185
 186 \f
 187 (defun atom-to-rss (atom &optional rss-self)
 188   "Translate Atom feed ATOM into an RSS one, returning the translation.
 189
 190 If RSS-SELF is given, it is used as self link of the RSS feed.
 191
 192 Some information may be lost or approximated."
 193   (let ((rss (list (assoc 'title atom))))
 194     (if rss-self
 195         (atom-modify-entry rss 'atom:link
 196                            `(((href . ,rss-self) (rel . "self")
 197                               (type . "application/atom+xml")))))
 198     (atom-to-rss-translator atom rss '((subtitle . description)
 199                                        (updated . pubDate)
 200                                        (link . link)))
 201     (atom-to-rss-modify-time rss)
 202     (atom-to-rss-modify-link rss)
 203     (dolist (entry (xml-get-children atom 'entry))
 204       (push (atom-to-rss-item entry) rss))
 205     (reverse rss)))
 206
 207 (defun atom-to-rss-item (entry)
 208   "Translates the Atom entry ENTRY into an RSS item."
 209   (let ((item (list (assoc 'title entry))))
 210     (atom-to-rss-translator
 211      (xml-node-children entry) item
 212      '((id . guid) (content . description) (updated . pubDate) (link . link)))
 213     (atom-to-rss-modify-time item)
 214     (atom-to-rss-modify-link item)
 215     (let ((guid (assoc 'guid item))
 216           (descr (assoc 'description item)))
 217       (if guid
 218           (setcar (cdr guid) (list (cons 'isPermaLink "false"))))
 219       (if (and descr
 220                (equal (xml-get-attribute descr 'type) "xhtml"))
 221           (setcar (cddr descr) (xml-node-as-text descr)))
 222       (setcar (cdr descr) nil))
 223     `(item nil ,@item)))
 224
 225 (defun atom-to-rss-translator (source target translations)
 226   (dolist (translation translations)
 227     (let* ((from (car translation))
 228            (to (cdr translation))
 229            (data (copy-tree (cdr (assoc from source)))))
 230       (when data
 231         (atom-modify-entry target to data)))))
 232
 233 (defun atom-to-rss-modify-link (entry)
 234   (let* ((link (assoc 'link entry))
 235          (link-addr (xml-get-attribute-or-nil link 'href)))
 236     (when link
 237       (setcar (cdr link) nil)
 238       (setcdr (cdr link) (cons link-addr nil)))))
 239
 240 (defun atom-print-as-rss (atom &optional rss-self)
 241   "Convert Atom feed ATOM to RSS in the current buffer.
 242
 243 If RSS-SELF is given, it is used as self link of the RSS feed."
 244   (let ((rss (atom-to-rss atom rss-self)))
 245     (insert atom-xml-declaration)
 246     ;; xmlns:atom included in order to allow the atom:link rel=self element
 247     (insert "<rss version=\"2.0\" xmlns:atom=\"http://www.w3.org/2005/Atom\">\n")
 248     (insert "  <channel>\n")
 249     (xml-print rss "    ")
 250     (insert "\n  </channel>\n")
 251     (insert "</rss>")))
 252
 253 (defun atom-to-rss-time (time)
 254   "Translate TIME from the format used by Atom into the format used by RSS.
 255
 256 TIME is a string."
 257   (let ((system-time-locale "C"))
 258     (format-time-string "%a, %d %b %Y %T %z" (atom-parse-time time))))
 259
 260 (defun atom-to-rss-modify-time (entry)
 261   "Modify ENTRY, changing the format of the `pubDate' in it."
 262   (let ((pubDate (assoc 'pubDate entry)))
 263     (setcar (cddr pubDate)
 264             (atom-to-rss-time (car (xml-node-children pubDate))))))
 265
 266 (defun atom-to-rss-write-file (atom filename &optional rss-self)
 267   "Save ATOM as a RSS feed into FILENAME.
 268
 269 If RSS-SELF is given, it is used as self link of the RSS feed."
 270   (with-temp-buffer
 271     (atom-print-as-rss atom rss-self)
 272     (write-file filename)))
 273
 274 \f
 275 (defvar atom-time-format-string "%Y-%m-%dT%T%z"
 276   "The format for string representation of dates.")
 277
 278 (defvar atom-xhtml-namespace "http://www.w3.org/1999/xhtml")
 279
 280 (defun atom-format-time (&optional time)
 281   "Format time value TIME according to RFC3339."
 282   ;; The time zone must be specified in numeric form, but with a colon between
 283   ;; the hour and minute parts.
 284   (replace-regexp-in-string
 285    "\\(..\\)$" ":\\1"
 286    (format-time-string atom-time-format-string time)))
 287
 288 (defun atom-parse-time (&optional time)
 289   "Parse string TIME as specified in RFC3339 into Emacs's native format."
 290   ;; Same remark as in `atom-format-time': RFC3339 wants a colon between hour
 291   ;; and minute parts of the timezome, so remove it before `date-to-time'.
 292   (date-to-time (replace-regexp-in-string ":\\(..\\)$" "\\1" time)))
 293
 294 (defun atom-massage-html (content)
 295   "Massage CONTENT so it can be used as an HTML fragment in an Atom feed.
 296
 297 CONTENT must be a string."
 298   (list '((type . "html")) content))
 299
 300 (defun atom-string-to-xml (string)
 301   "Convert STRING into a Lisp structure as used by `xml.el'."
 302   (require 'xml-xhtml-entities)
 303   (let ((xml-entity-alist xml-xhtml-entities)
 304         (xml-validating-parser t))
 305     (with-temp-buffer
 306       (insert "<div xmlns=\"" atom-xhtml-namespace "\">")
 307       (insert string)
 308       (insert "</div>")
 309       ;; `xml-parse-region' returns a list of elements, even though it
 310       ;; requires an only root node. We are only interested in the first
 311       ;; one, the DIV we just inserted.
 312       (car (xml-parse-region (point-min) (point-max))))))
 313
 314 (defun atom-massage-xhtml (content)
 315   "Massage CONTENT so it can be used as an XHTML fragment in an Atom feed."
 316   (list '((type . "xhtml"))
 317         (or (and (stringp content)
 318                  (atom-string-to-xml content))
 319             `(div ((xmlns . ,atom-xhtml-namespace)) ,@content))))
 320
 321 (defun atom-massage-author (author)
 322   "Return an XML node representing the author. AUTHOR can be:
 323 - nil, in which case variables `user-full-name' and `user-mail-address'
 324   are used;
 325 - a single string, the full name of the author; no email address
 326   will be included;
 327 - a list with two elements, the full name and the email address
 328   of the author;
 329 - something else, assumed to be a complete `atomPersonConstruct'."
 330   `(nil ,@(cond
 331            ((null author) `((name nil ,user-full-name)
 332                             (email nil ,user-mail-address)))
 333            ((stringp author) `((name nil ,author)))
 334            ((= 2 (length author)) `((name nil ,(car author))
 335                                     (email nil ,(cadr author))))
 336            (t `(author nil ,author)))))
 337
 338 (defun atom-xhtml-convert-links (node base)
 339   "Make all links in NODE (a fragment of an XHTML document)
 340 absolute, in the context of BASE, an URL."
 341   (dolist (attr-name (list 'href 'src))
 342     (let ((attr (assoc attr-name (xml-node-attributes node))))
 343       (when attr (setcdr attr (url-canonalize (cdr attr) base)))))
 344   (dolist (child (xml-node-children node))
 345     (when (listp child) (atom-xhtml-convert-links child base))))
 346
 347 \f
 348 ;;; Functions that should probably not be there
 349
 350 (defun url-canonalize (address base)
 351   "Make ADDRESS an absolute URL, taking it in the BASE context."
 352   ;; I feel such a function should exist in `url-parse'. Did I miss it?
 353   (let ((url-base (url-generic-parse-url base))
 354         (url-address (url-generic-parse-url address)))
 355     (if (url-host url-address)
 356         address
 357       (setf (url-filename url-base)
 358             (expand-file-name address
 359                               (file-name-directory (url-filename url-base))))
 360       (url-recreate-url url-base))))
 361
 362 (defun xml-node-as-text (node)
 363   "Return a string representing NODE, an XML structure."
 364   (with-temp-buffer
 365     (xml-print (xml-node-children node))
 366     (buffer-string)))
 367
 368 (provide 'atom)
 369 ;;; atom.el ends here