coleslaw/src/documents.lisp - Recently Written

src/documents.lisp (3214 bytes)
1 (in-package :coleslaw)
2 
3 ;;;; The Document Protocol
4 
5 ;; Data Storage
6 
7 (defvar *site* (make-hash-table :test #'equal)
8   "An in-memory database to hold all site documents, keyed on relative URLs.")
9 
10 ;; Class Methods
11 
12 (defgeneric publish (doc-type)
13   (:documentation "Write pages to disk for all documents of the given DOC-TYPE."))
14 
15 (defgeneric discover (doc-type)
16   (:documentation "Load all documents of the given DOC-TYPE into memory.")
17   (:method (doc-type)
18     (let ((file-type (format nil "~(~A~)" (class-name doc-type))))
19       (do-files (file (repo-dir *config*) file-type)
20         (let ((obj (construct (class-name doc-type) (read-content file))))
21           (add-document obj))))))
22 
23 (defmethod discover :before (doc-type)
24   (purge-all (class-name doc-type)))
25 
26 ;; Instance Methods
27 
28 (defgeneric page-url (document)
29   (:documentation "The relative URL to the DOCUMENT."))
30 
31 (defgeneric render (document &key &allow-other-keys)
32   (:documentation "Render the given DOCUMENT to HTML."))
33 
34 ;; Helper Functions
35 
36 (defun compute-url (document unique-id &optional class)
37   "Compute the relative URL for a DOCUMENT based on its UNIQUE-ID. If CLASS
38 is provided, it overrides the route used."
39   (let* ((class-name (or class (class-name (class-of document))))
40          (route (get-route class-name)))
41     (unless route
42       (error "No routing method found for: ~A" class-name))
43     (let* ((result (format nil route unique-id))
44            (type (or (pathname-type result) (page-ext *config*))))
45       (make-pathname :name (funcall (name-fn *config*) (pathname-name result))
46                      :type type
47                      :defaults result))))
48 
49 (defun get-route (doc-type)
50   "Return the route format string for DOC-TYPE."
51   (second (assoc (make-keyword doc-type) (routing *config*))))
52 
53 (defun add-document (document)
54   "Add DOCUMENT to the in-memory database. Error if a matching entry is present."
55   (let ((url (page-url document)))
56     (if (gethash url *site*)
57         (error "There is already an existing document with the url ~a" url)
58         (setf (gethash url *site*) document))))
59 
60 (defun delete-document (document)
61   "Given a DOCUMENT, delete it from the in-memory database."
62   (remhash (page-url document) *site*))
63 
64 (defun write-document (document &optional theme-fn &rest render-args)
65   "Write the given DOCUMENT to disk as HTML. If THEME-FN is present,
66 use it as the template passing any RENDER-ARGS."
67   (let ((html (if (or theme-fn render-args)
68                   (apply #'render-page document theme-fn render-args)
69                   (render-page document nil)))
70         (url (namestring (page-url document))))
71     (write-file (rel-path (staging-dir *config*) url) html)))
72 
73 (defun find-all (doc-type &optional (matches-p (lambda (x) (typep x doc-type))))
74   "Return a list of all instances of a given DOC-TYPE."
75   (loop for val being the hash-values in *site*
76      when (funcall matches-p val) collect val))
77 
78 (defun purge-all (doc-type)
79   "Remove all instances of DOC-TYPE from memory."
80   (flet ((matches-class-name-p (x)
81            (class-name-p (symbol-name doc-type)
82                          (class-of x))))
83     (dolist (obj (find-all doc-type #'matches-class-name-p))
84       (remhash (page-url obj) *site*))))