From 3693e10cbf1549eb9d7779cf3c9f1e62f0364dc7 Mon Sep 17 00:00:00 2001 From: Brit Butler Date: Tue, 15 Apr 2014 11:28:41 -0400 Subject: [PATCH] Initial pass at the Document Protocol. --- coleslaw.asd | 1 + src/coleslaw.lisp | 12 ----------- src/content.lisp | 27 ------------------------- src/documents.lisp | 50 ++++++++++++++++++++++++++++++++++++++++++++++ src/indexes.lisp | 1 + src/util.lisp | 7 ++++--- 6 files changed, 56 insertions(+), 42 deletions(-) create mode 100644 src/documents.lisp diff --git a/coleslaw.asd b/coleslaw.asd index ff5f530..2dd3481 100644 --- a/coleslaw.asd +++ b/coleslaw.asd @@ -19,6 +19,7 @@ (:file "util") (:file "config") (:file "themes") + (:file "documents") (:file "content") (:file "posts") (:file "indexes") diff --git a/src/coleslaw.lisp b/src/coleslaw.lisp index 8f4f910..b413da2 100644 --- a/src/coleslaw.lisp +++ b/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)))) diff --git a/src/content.lisp b/src/content.lisp index ddd386d..5a293df 100644 --- a/src/content.lisp +++ b/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) diff --git a/src/documents.lisp b/src/documents.lisp new file mode 100644 index 0000000..a61d042 --- /dev/null +++ b/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.")) diff --git a/src/indexes.lisp b/src/indexes.lisp index 3b4f3eb..d34c80b 100644 --- a/src/indexes.lisp +++ b/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)) diff --git a/src/util.lisp b/src/util.lisp index 3599ba1..3c6bf3d 100644 --- a/src/util.lisp +++ b/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) - `(let ((,klasses (closer-mop:class-direct-subclasses (find-class ',class)))) - (loop for ,var in (mapcar #'class-name ,klasses) do ,@body)))) + (alexandria:with-gensyms (klass klasses) + `(let* ((,klass (if (typep ,class 'class) ,class (find-class ',class))) + (,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."