Initial pass at the Document Protocol.

coleslaw.asd

@@ -19,6 +19,7 @@
                (:file "util")
                (:file "config")
                (:file "themes")
+               (:file "documents")
                (:file "content")
                (:file "posts")
                (:file "indexes")

src/coleslaw.lisp

@@ -1,8 +1,5 @@
 (in-package :coleslaw)
 
-(defgeneric render (object &key &allow-other-keys)
-  (:documentation "Render the given OBJECT to HTML."))
-
 (defgeneric render-content (text format)
   (:documentation "Compile TEXT from the given FORMAT to HTML for display.")
   (:method (text (format (eql :html)))
@@ -12,15 +9,6 @@
       (with-output-to-string (str)
         (3bmd:parse-string-and-print-to-stream text str)))))
 
-(defgeneric page-url (object)
-  (:documentation "The url to the object, without the domain."))
-
-(defmethod page-url :around ((object t))
-  (let ((result (call-next-method)))
-    (if (pathname-type result)
-        result
-        (make-pathname :type "html" :defaults result))))
-
 (defun page-path (object)
   "The path to store OBJECT at once rendered."
   (rel-path (staging-dir *config*) (namestring (page-url object))))

src/content.lisp

@@ -1,8 +1,5 @@
 (in-package :coleslaw)
 
-(defparameter *content* (make-hash-table :test #'equal)
-  "A hash table to store all the site content and metadata.")
-
 (defclass tag ()
   ((name :initform nil :initarg :name :accessor tag-name)
    (slug :initform nil :Initarg :slug :accessor tag-slug)))
@@ -30,9 +27,6 @@
   "Test if OBJ was written in MONTH."
   (search month (content-date obj)))
 
-(defgeneric publish (content-type)
-  (:documentation "Write pages to disk for all content of the given CONTENT-TYPE."))
-
 (defun read-content (file)
   "Returns a plist of metadata from FILE with :text holding the content as a string."
   (flet ((slurp-remainder (stream)
@@ -57,27 +51,6 @@
         (setf (getf meta :tags) (read-tags (getf meta :tags)))
         (append meta (list :text content))))))
 
-(defun find-all (content-type)
-  "Return a list of all instances of a given CONTENT-TYPE."
-  (loop for val being the hash-values in *content*
-     when (typep val content-type) collect val))
-
-(defun purge-all (content-type)
-  "Remove all instances of CONTENT-TYPE from *content*."
-  (dolist (obj (find-all content-type))
-    (remhash (content-slug obj) *content*)))
-
-(defun discover (content-type)
-  "Load all content of the given CONTENT-TYPE from disk."
-  (purge-all content-type)
-  (let ((file-type (string-downcase (symbol-name content-type))))
-    (do-files (file (repo *config*) file-type)
-      (let ((obj (construct content-type (read-content file))))
-        (if (gethash (content-slug obj) *content*)
-            (error "There is already existing content with the slug ~a."
-                   (content-slug obj))
-            (setf (gethash (content-slug obj) *content*) obj))))))
-
 (defun load-content ()
   "Load all content stored in the blog's repo."
   (do-subclasses (ctype content)

src/documents.lisp

@@ -0,0 +1,50 @@
+(in-package :coleslaw)
+
+;;;; The Document Protocol
+
+;; Data Storage
+
+(defvar *site* (make-hash-table :test #'equal)
+  "An in-memory database to hold all site documents, keyed on page-url.")
+
+;; Class Methods
+
+(defun find-all (doc-type)
+  "Return a list of all instances of a given DOC-TYPE."
+  (loop for val being the hash-values in *site*
+     when (typep val doc-type) collect val))
+
+(defun purge-all (doc-type)
+  "Remove all instances of DOC-TYPE from memory."
+  (dolist (obj (find-all doc-type))
+    (remhash (page-url obj) *site*)))
+
+(defgeneric publish (doc-type)
+  (:documentation "Write pages to disk for all documents of the given DOC-TYPE."))
+
+(defgeneric discover (doc-type)
+  (:documentation "Load all documents of the given DOC-TYPE into memory.")
+  (:method (doc-type)
+    (purge-all doc-type)
+    (let* ((class-name (class-name doc-type))
+           (file-type (string-downcase (symbol-name class-name))))
+      (do-files (file (repo *config*) file-type)
+        (let ((obj (construct class-name (read-content file))))
+          (if (gethash (page-url obj) *site*)
+              (error "There is already existing content with the url ~a."
+                     (page-url obj))
+              (setf (gethash (page-url obj) *site*) obj)))))))
+
+;; Instance Methods
+
+(defgeneric page-url (document)
+  (:documentation "The url to the document, without the domain."))
+
+(defmethod page-url :around ((document t))
+  (let ((result (call-next-method)))
+    (if (pathname-type result)
+        result
+        (make-pathname :type "html" :defaults result))))
+
+(defgeneric render (document &key &allow-other-keys)
+  (:documentation "Render the given DOCUMENT to HTML."))

src/indexes.lisp

@@ -11,6 +11,7 @@
 
 (defclass feed (index)
   ((format :initform nil :initarg :format :accessor feed-format)))
+;; TODO: tag-feed isn't reached by do-subclasses!
 (defclass tag-feed (feed) ())
 
 (defmethod page-url ((object tag-index))

src/util.lisp

@@ -7,9 +7,10 @@
 (defmacro do-subclasses ((var class) &body body)
   "Iterate over the subclasses of CLASS performing BODY with VAR
 lexically bound to the current subclass' class-name."
-  (alexandria:with-gensyms (klasses)
+  (alexandria:with-gensyms (klass klasses)
-    `(let ((,klasses (closer-mop:class-direct-subclasses (find-class ',class))))
+    `(let* ((,klass (if (typep ,class 'class) ,class (find-class ',class)))
-       (loop for ,var in (mapcar #'class-name ,klasses) do ,@body))))
+            (,klasses (closer-mop:class-direct-subclasses ,klass)))
+       (loop for ,var in ,klasses do ,@body))))
 
 (defun fmt (fmt-str args)
   "A convenient FORMAT interface for string building."