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
  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.
  75
  76 - :id is a unique identifier for this feed. If not given, it
  77   defaults to :self.
  78
  79 - :author is the author of the feed. See `atom-massage-author' for
  80 the possible ways to specify it. In particular, `nil' uses
  81 `user-full-name' and `user-mail-address'.
  82
  83 - :updated is the date the feed was last updated. If not given,
  84 `(current-time)' is used."
  85   (let ((atom-feed (list (list 'title nil title))))
  86     (atom-modify-entry atom-feed 'link `(((href . ,link))))
  87     (atom-modify-entry atom-feed 'author (atom-massage-author (plist-get props :author)))
  88     (if (plist-member props :subtitle)
  89         (atom-modify-entry atom-feed 'subtitle (plist-get props :subtitle)))
  90     (if (plist-member props :self)
  91         (atom-modify-entry atom-feed 'link
  92                            `(((href . ,(plist-get props :self)) (rel . "self")
  93                               (type . "application/atom+xml")))))
  94     (atom-modify-entry atom-feed 'updated (atom-format-time (plist-get props :updated)))
  95     (atom-modify-entry atom-feed 'id (or (plist-get props :id) (plist-get props :self) link))
  96     atom-feed))
  97
  98 (defun atom-push-entry (atom entry)
  99   "Add the entry ENTRY to the feed ATOM."
 100   (nconc atom (list `(entry nil ,@entry))))
 101
 102 (defun atom-modify-entry (entry name val)
 103   "Set the NAME element of ENTRY to VAL."
 104   (let ((elem (if (stringp val)
 105                   (list name nil val)
 106                 (cons name val))))
 107     (nconc entry (list elem))))
 108
 109 (defun atom-add-entry (atom title link content &optional props)
 110   "Add an entry to the atom flux ATOM. Return the newly added
 111 entry.
 112
 113 TITLE is a short, text-only, human readable string.
 114
 115 LINK is a permanent link for this entry. For a given entry, LINK
 116 may change between successive generations of the atom feed.
 117
 118 CONTENT is the content of the entry; use `atom-add-html-entry'
 119 or `atom-add-xhtml-entry' when CONTENT is not text-only.
 120
 121 If SUMMARY is not given, the entry will not contain any summary.
 122
 123 UPDATED defaults to `(current-time)' if omitted, which is
 124 probably not a very good default.
 125
 126 ID defaults to LINK, which is not optimal; see `atom-generate-id'
 127 for a way to create good identifiers. For a given entry, it must
 128 not change between successive generations of the atom feed, even
 129 when the content of the entry changes."
 130   (let ((entry (list (list 'title nil title))))
 131     (atom-modify-entry entry 'link  (list (list (cons 'href link))))
 132     (atom-modify-entry entry 'id (or (plist-get props :id) link))
 133     (atom-modify-entry entry 'updated (atom-format-time (plist-get props :updated)))
 134     (if (plist-member props :summary)
 135         (atom-modify-entry entry 'summary (plist-get props :summary)))
 136     (atom-modify-entry entry 'content content)
 137     (atom-push-entry atom entry)
 138     entry))
 139
 140 (defalias 'atom-add-text-entry 'atom-add-entry
 141   "Add an entry to ATOM, with a textual content. See
 142 `atom-add-entry' for details.")
 143
 144 (defun atom-add-html-entry (atom title link content &optional props)
 145   "Add an entry to ATOM, with some HTML content. CONTENT should
 146 be a string enconding a valid HTML fragment. See `atom-add-entry'
 147 for additional details."
 148   (if (plist-member props :summary)
 149       (plist-put props :summary (atom-massage-html (plist-get props :summary))))
 150   (atom-add-entry atom title link (atom-massage-html content) props))
 151
 152 (defun atom-add-xhtml-entry (atom title link content &optional props)
 153   "Add an entry to ATOM, with some XHTML content. CONTENT may be
 154 given either as a string, or as an XML tree, of a valid XHTML
 155 fragment. See `atom-add-entry' for additional details."
 156   (if (plist-member props :summary)
 157       (plist-put props :summary (atom-massage-xhtml (plist-get props :summary))))
 158   (atom-add-entry atom title link (atom-massage-xhtml content) props))
 159
 160 (defun atom-print (atom)
 161   "Print the Atom feed ATOM in the current buffer."
 162   (insert atom-xml-declaration)
 163   (insert "<feed xmlns=\"http://www.w3.org/2005/Atom\">\n")
 164   (xml-print atom)
 165   (insert "\n</feed>"))
 166
 167 (defun atom-write-file (atom filename)
 168   "Writes the feed ATOM to FILENAME."
 169   (with-temp-buffer
 170     (atom-print atom)
 171     (write-file filename)))
 172
 173 \f
 174 (defun atom-to-rss (atom &optional rss-self)
 175   "Translate an Atom feed into an RSS one, returning the translation.
 176
 177 Some information may be lost or approximated."
 178   (let ((rss (list (assoc 'title atom))))
 179     (if rss-self
 180         (atom-modify-entry rss 'atom:link
 181                            `(((href . ,rss-self) (rel . "self")
 182                               (type . "application/atom+xml")))))
 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       (setcar (cdr descr) nil))
 208     `(item nil ,@item)))
 209
 210 (defun atom-to-rss-translator (source target translations)
 211   (dolist (translation translations)
 212     (let* ((from (car translation))
 213            (to (cdr translation))
 214            (data (copy-tree (cdr (assoc from source)))))
 215       (when data
 216         (atom-modify-entry target to data)))))
 217
 218 (defun atom-to-rss-modify-link (entry)
 219   (let* ((link (assoc 'link entry))
 220          (link-addr (xml-get-attribute-or-nil link 'href)))
 221     (when link
 222       (setcar (cdr link) nil)
 223       (setcdr (cdr link) (cons link-addr nil)))))
 224
 225 (defun atom-print-as-rss (atom &optional rss-self)
 226   (let ((rss (atom-to-rss atom rss-self)))
 227     (insert atom-xml-declaration)
 228     ;; xmlns:atom included in order to allow the atom:link rel=self element
 229     (insert "<rss version=\"2.0\" xmlns:atom=\"http://www.w3.org/2005/Atom\">\n")
 230     (insert "  <channel>\n")
 231     (xml-print rss "    ")
 232     (insert "\n  </channel>\n")
 233     (insert "</rss>")))
 234
 235 (defun atom-to-rss-time (time)
 236   "Translates a string from the format used by Atom into the
 237 format used by RSS."
 238   (let ((system-time-locale "C"))
 239     (format-time-string "%a, %d %b %Y %T %z" (atom-parse-time time))))
 240
 241 (defun atom-to-rss-modify-time (entry)
 242   "Modify ENTRY, changing the format of the `pubDate' in it."
 243   (let ((pubDate (assoc 'pubDate entry)))
 244     (setcar (cddr pubDate)
 245             (atom-to-rss-time (car (xml-node-children pubDate))))))
 246
 247 (defun atom-to-rss-write-file (atom filename &optional rss-self)
 248   "Saves ATOM as a RSS feed into FILENAME."
 249   (with-temp-buffer
 250     (atom-print-as-rss atom rss-self)
 251     (write-file filename)))
 252
 253 \f
 254 (defvar atom-time-format-string "%Y-%m-%dT%T%z"
 255   "The format for string representation of dates.")
 256
 257 (defvar atom-xhtml-namespace "http://www.w3.org/1999/xhtml")
 258
 259 (defvar atom-xml-declaration "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
 260
 261 (defun atom-format-time (&optional time)
 262   "Format a time according to RFC3339."
 263   ;; The time zone must be specified in numeric form, but with a colon between
 264   ;; the hour and minute parts.
 265   (replace-regexp-in-string
 266    "\\(..\\)$" ":\\1"
 267    (format-time-string atom-time-format-string time)))
 268
 269 (defun atom-parse-time (&optional time)
 270   "Parse a time as specified in RFC3339 into Emacs's native format."
 271   ;; Same remark as in `atom-format-time'
 272   (date-to-time (replace-regexp-in-string ":\\(..\\)$" "\\1" time)))
 273
 274 (defun atom-massage-html (content)
 275   "Massage CONTENT so it can be used as an HTML fragment in an
 276 Atom feed. CONTENT must be a string."
 277   (list '((type . "html")) content))
 278
 279 (defun atom-string-to-xml (string)
 280   "Convert STRING into a Lisp structure as used by `xml.el'."
 281   (require 'xml-xhtml-entities)
 282   (let ((xml-entity-alist xml-xhtml-entities)
 283         (xml-validating-parser t))
 284     (with-temp-buffer
 285       (insert "<div xmlns=\"" atom-xhtml-namespace "\">")
 286       (insert string)
 287       (insert "</div>")
 288       ;; `xml-parse-region' returns a list of elements, even though it
 289       ;; requires an only root node. We are only interested in the first
 290       ;; one, the DIV we just inserted.
 291       (car (xml-parse-region (point-min) (point-max))))))
 292
 293 (defun atom-massage-xhtml (content)
 294   "Massage CONTENT so it can be used as an XHTML fragment in an
 295 Atom feed."
 296   (list '((type . "xhtml"))
 297         (or (and (stringp content)
 298                  (atom-string-to-xml content))
 299             `(div ((xmlns . ,atom-xhtml-namespace)) ,@content))))
 300
 301 (defun atom-massage-author (author)
 302   "Return an XML node representing the author. AUTHOR can be:
 303 - nil, in which case `user-full-name' and `user-mail-address' are
 304   used;
 305 - a single string, the full name of the author; no email address
 306   will be included;
 307 - a list with two elements, the full name and the email address
 308   of the author;
 309 - something else, assumed to be a complete `atomPersonConstruct'."
 310   `(nil ,@(cond
 311            ((null author) `((name nil ,user-full-name)
 312                             (email nil ,user-mail-address)))
 313            ((stringp author) `((name nil ,author)))
 314            ((= 2 (length author)) `((name nil ,(car author))
 315                                     (email nil ,(cadr author))))
 316            (t `(author nil ,author)))))
 317
 318 (defun atom-xhtml-convert-links (node base)
 319   "Make all links in NODE (a fragment of an XHTML document)
 320 absolute, in the context of BASE, an URL."
 321   (dolist (attr-name (list 'href 'src))
 322     (let ((attr (assoc attr-name (xml-node-attributes node))))
 323       (when attr (setcdr attr (url-canonalize (cdr attr) base)))))
 324   (dolist (child (xml-node-children node))
 325     (when (listp child) (atom-xhtml-convert-links child base))))
 326
 327 \f
 328 ;;; Functions that should probably not be there
 329
 330 (defun url-canonalize (address base)
 331   "Make ADRESS an absolute URL, taking it in the BASE context."
 332   ;; I feel such a function should exist in `url-parse'. Did I miss it?
 333   (let ((url-base (url-generic-parse-url base))
 334         (url-address (url-generic-parse-url address)))
 335     (if (url-host url-address)
 336         address
 337       (setf (url-filename url-base)
 338             (expand-file-name address
 339                               (file-name-directory (url-filename url-base))))
 340       (url-recreate-url url-base))))
 341
 342 (defun xml-node-as-text (node)
 343   "Return a string representing NODE, an XML structure."
 344   (with-temp-buffer
 345     (xml-print (xml-node-children node))
 346     (buffer-string)))
 347
 348 (defun xml-node-create (name attrlist childlist)
 349   "Create a new XML node."
 350   (list name attrlist . childlist))
 351
 352 (provide 'atom)
 353 ;;; atom.el ends here