Skip to content


Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

86 lines (76 sloc) 4.276 kb
;;; Copyright (c) 2011, Peter Seibel.
;;; All rights reserved. See COPYING for details.
(in-package :monkeylib-atom)
(define-xml-language atom
:feed :entry :author :content)
:contributor :email :generator :id :link :name :published :rights :subtitle :title :updated :uri
(defclass feed ()
((title :initarg :title :accessor title)
(subtitle :initarg :subtitle :accessor subtitle)
(updated :initarg :updated :accessor updated)
(tag :initarg :tag :accessor tag)
(feed-url :initarg :feed-url :accessor feed-url)
(index-url :initarg :index-url :accessor index-url)
(rights :initarg :rights :accessor rights)
(default-author-name :initarg :default-author-name :accessor default-author-name)
(default-author-email :initarg :default-author-email :accessor default-author-email)
(default-author-uri :initarg :default-author-uri :accessor default-author-uri)
(canonical-host :initarg :canonical-host :accessor canonical-host)
(full-prefix :initarg :full-prefix :accessor full-prefix)
(entries :initarg :entries :accessor entries)))
(defclass entry ()
((file :initarg :file :accessor file)
(title :initarg :title :accessor title)
(body :initarg :body :accessor body)
(published :initarg :published :accessor published)
(updated :initarg :updated :accessor updated)
(categories :initarg :categories :accessor categories)))
(defun feed (feed)
(with-slots (title subtitle updated tag feed-url index-url rights entries) feed
(:? :xml :version "1.0" :encoding "utf-8")
((:feed :xmlns "")
((:title :type "text") title)
(when subtitle (atom ((:subtitle :type "html") subtitle)))
(:updated (:print (timestamp updated)))
(:id tag)
(:link :rel "self" :type "application/atom+xml" :href feed-url)
(:link :rel "alternate" :type "text/html" :href index-url)
(:rights rights)
((:generator :uri "" :version "1.0") "Monkeylib")
(dolist (entry entries) (entry entry feed))))))
(defun entry (entry feed)
(with-slots (default-author-name default-author-uri default-author-email canonical-host full-prefix)
(with-slots (file title body published updated categories) entry
(with-time (year month date) published
(let ((name (pathname-name file)))
(:title title)
(:link :rel "alternate" :type "text/html" :href (:print (absolute-permalink canonical-host full-prefix name year month date)))
(:id (:print (tag-uri "" 2007 name :month month :date date)))
(:updated (:print (timestamp updated)))
(:published (:print (timestamp published)))
(:name default-author-name)
(:uri default-author-uri)
(:email default-author-email))
(dolist (category categories)
(atom (:category :term category)))
((:content :type "xhtml" :xml\:lang "en" :xml\:base "*blog-base-url*")
(emit-xhtml `((:div :xmlns "") ,@body))))))))))
(defun absolute-permalink (canonical-host prefix name year month date)
(format nil "http://~a~a~a" canonical-host prefix (permalink name year month date)))
(defun permalink (name year month date)
(format nil "~4,'0d/~2,'0d/~2,'0d/~a" year month date name))
(defun timestamp (utc)
(format-iso-8601-time utc :time-zone 0))
(defun tag-uri (authority-name year specific &key month date fragment)
"Generate a tag: URL as described in"
(format nil "tag:~a,~4,'0d~@[-~2,'0d~]~@[-~2,'0d~]:~a~@[#~a~]"
authority-name year month date specific fragment))
Jump to Line
Something went wrong with that request. Please try again.