From 6d47244eac2d12433f16cadab6a47cb76b90843e Mon Sep 17 00:00:00 2001 From: Brit Butler Date: Tue, 1 Jan 2013 17:31:33 -0500 Subject: [PATCH] First pass at support for multiple content-types. WARNING: Indices and feeds are broken. --- coleslaw.asd | 4 ++- src/coleslaw.lisp | 4 +-- src/content.lisp | 81 +++++++++++++++++++++++++++++++++++++++++++++++ src/indices.lisp | 12 +++---- src/posts.lisp | 77 +++++++++++--------------------------------- 5 files changed, 109 insertions(+), 69 deletions(-) create mode 100644 src/content.lisp diff --git a/coleslaw.asd b/coleslaw.asd index e820c94..9151a5a 100644 --- a/coleslaw.asd +++ b/coleslaw.asd @@ -12,12 +12,14 @@ :local-time :inferior-shell :cl-fad - :cl-ppcre) + :cl-ppcre + :closer-mop) :serial t :components ((:file "packages") (:file "util") (:file "config") (:file "themes") + (:file "content") (:file "posts") (:file "indices") (:file "feeds") diff --git a/src/coleslaw.lisp b/src/coleslaw.lisp index ff4476e..b7dcdfe 100644 --- a/src/coleslaw.lisp +++ b/src/coleslaw.lisp @@ -49,7 +49,7 @@ Additional args to render CONTENT can be passed via RENDER-ARGS." (merge-pathnames "static" (repo *config*)))) (when (probe-file dir) (run-program "cp -R ~a ." dir))) - (render-posts) + (do-ctypes (publish (class-name ctype))) (render-indices) (render-feeds (feeds *config*)))) @@ -76,7 +76,7 @@ Additional args to render CONTENT can be passed via RENDER-ARGS." "Load the user's config section corresponding to CONFIG-KEY, then compile and deploy the blog." (load-config config-key) - (load-posts) + (load-content) (compile-theme (theme *config*)) (compile-blog (staging *config*)) (deploy (staging *config*))) diff --git a/src/content.lisp b/src/content.lisp new file mode 100644 index 0000000..cc6ae0d --- /dev/null +++ b/src/content.lisp @@ -0,0 +1,81 @@ +(in-package :coleslaw) + +(defparameter *content* (make-hash-table :test #'equal) + "A hash table to store all the site content and metadata.") + +(defclass content () + ((tags :initform nil :initarg :tags :accessor content-tags) + (slug :initform nil :initarg :slug :accessor content-slug) + (date :initform nil :initarg :date :accessor content-date))) + +(defun construct (content-type args) + "Create an instance of CONTENT-TYPE with the given ARGS." + (apply 'make-instance content-type args)) + +(defgeneric discover (content-type) + (:documentation "Load all content of the given CONTENT-TYPE from disk.")) + +(defgeneric publish (content-type) + (:documentation "Write pages to disk for all content of the given CONTENT-TYPE.")) + +(defun read-content (file &optional plist-p) + "Returns two values, a list of metadata from FILE, and the content as a string. +If PLIST-P is non-nil, a single plist is returned with :content holding the text." + (flet ((slurp-remainder (stream) + (let ((seq (make-string (- (file-length stream) + (file-position stream))))) + (read-sequence seq stream) + (remove #\Nul seq))) + (parse-field (str) + (nth-value 1 (cl-ppcre:scan-to-strings "[a-zA-Z]+: (.*)" str))) + (field-name (line) + (make-keyword (string-upcase (subseq line 0 (position #\: line))))) + (read-delimited (str &optional (delimiter ", ")) + (mapcar #'string-downcase (cl-ppcre:split delimiter str)))) + (with-open-file (in file) + (unless (string= (read-line in) ";;;;;") + (error "The provided file lacks the expected header.")) + (let ((meta (loop for line = (read-line in nil) + until (string= line ";;;;;") + appending (list (field-name line) + (aref (parse-field line) 0)))) + (content (slurp-remainder in))) + (setf (getf meta :tags) (read-delimited (getf meta :tags))) + (if plist-p + (append meta (list :content content)) + (values meta 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 (eql content-type (type-of val)) 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*))) + +(defmacro do-ctypes (&body body) + "Iterate over the subclasses of CONTENT performing BODY with ctype lexically +bound to the current subclass." + `(loop for ctype in (closer-mop:class-direct-subclasses (find-class 'content)) + do ,@body)) + +(defun load-content () + "Load all content stored in the blog's repo." + (do-ctypes (discover (class-name ctype)))) + +(defun by-date (content) + "Sort CONTENT in reverse chronological order." + (sort content #'string> :key #'content-date)) + +(defun slug-char-p (char) + "Determine if CHAR is a valid slug (i.e. URL) character." + (or (char<= #\0 char #\9) + (char<= #\a char #\z) + (char<= #\A char #\Z) + (member char '(#\_ #\- #\.)))) + +(defun slugify (string) + "Return a version of STRING suitable for use as a URL." + (remove-if-not #'slug-char-p (substitute #\- #\Space string))) diff --git a/src/indices.lisp b/src/indices.lisp index 781caca..e2f8fc2 100644 --- a/src/indices.lisp +++ b/src/indices.lisp @@ -29,25 +29,21 @@ (defun all-months () "Retrieve a list of all months with published posts." (sort (remove-duplicates (mapcar (lambda (x) (get-month (post-date x))) - (hash-table-values *posts*)) :test #'string=) + (hash-table-values *content*)) :test #'string=) #'string>)) (defun all-tags () "Retrieve a list of all tags used in posts." - (sort (remove-duplicates (mappend 'post-tags (hash-table-values *posts*)) + (sort (remove-duplicates (mappend 'content-tags (hash-table-values *content*)) :test #'string=) #'string<)) (defun get-month (timestamp) "Extract the YYYY-MM portion of TIMESTAMP." (subseq timestamp 0 7)) -(defun by-date (posts) - "Sort POSTS in reverse chronological order." - (sort posts #'string> :key #'post-date)) - (defun index-by-tag (tag posts) "Return an index of all POSTS matching the given TAG." - (let ((content (remove-if-not (lambda (post) (member tag (post-tags post) + (let ((content (remove-if-not (lambda (post) (member tag (content-tags post) :test #'string=)) posts))) (make-instance 'tag-index :id tag :posts content @@ -71,7 +67,7 @@ (defun render-indices () "Render the indices to view posts in groups of size N, by month, and by tag." - (let ((posts (by-date (hash-table-values *posts*)))) + (let ((posts (by-date (hash-table-values *content*)))) (dolist (tag (all-tags)) (let ((index (index-by-tag tag posts))) (write-page (page-path index) (render-page index)))) diff --git a/src/posts.lisp b/src/posts.lisp index 1102ced..d625bd2 100644 --- a/src/posts.lisp +++ b/src/posts.lisp @@ -1,13 +1,7 @@ (in-package :coleslaw) -(defparameter *posts* (make-hash-table :test #'equal) - "A hash table to store all the posts and their metadata.") - -(defclass post () - ((slug :initform nil :initarg :slug :accessor post-slug) - (title :initform nil :initarg :title :accessor post-title) - (tags :initform nil :initarg :tags :accessor post-tags) - (date :initform nil :initarg :date :accessor post-date) +(defclass post (content) + ((title :initform nil :initarg :title :accessor post-title) (format :initform nil :initarg :format :accessor post-format) (content :initform nil :initarg :content :accessor post-content))) @@ -18,59 +12,26 @@ :next next))) (defmethod page-path ((object post)) - (rel-path (staging *config*) "posts/~a" (post-slug object))) + (rel-path (staging *config*) "posts/~a" (content-slug object))) -(defun read-post (in) - "Make a POST instance based on the data from the stream IN." - (flet ((check-header () - (unless (string= (read-line in) ";;;;;") - (error "The provided file lacks the expected header."))) - (parse-field (str) - (nth-value 1 (cl-ppcre:scan-to-strings "[a-zA-Z]+: (.*)" str))) - (field-name (line) - (subseq line 0 (position #\: line))) - (read-tags (str) - (mapcar #'string-downcase (cl-ppcre:split ", " str))) - (slurp-remainder () - (let ((seq (make-string (- (file-length in) (file-position in))))) - (read-sequence seq in) - (remove #\Nul seq)))) - (check-header) - (let ((args (loop for line = (read-line in nil) until (string= line ";;;;;") - appending (list (make-keyword (string-upcase (field-name line))) - (aref (parse-field line) 0))))) - (setf (getf args :tags) (read-tags (getf args :tags)) - (getf args :format) (make-keyword (string-upcase (getf args :format)))) - (apply 'make-instance 'post - (append args (list :content (render-content (slurp-remainder) - (getf args :format)) - :slug (slugify (getf args :title)))))))) +(defmethod initialize-instance :after ((post post) &key) + (with-accessors ((title post-title) + (format post-format) + (content post-content)) post + (setf (content-slug post) (slugify title) + format (make-keyword (string-upcase format)) + content (render-content content format)))) -(defun load-posts () - "Read the stored .post files from the repo." - (clrhash *posts*) +(defmethod discover ((content-type (eql :post))) + (purge-all 'post) (do-files (file (repo *config*) "post") - (with-open-file (in file) - (let ((post (read-post in))) - (if (gethash (post-slug post) *posts*) - (error "There is already an existing post with the slug ~a." - (post-slug post)) - (setf (gethash (post-slug post) *posts*) post)))))) + (let ((post (construct :post (read-content file t)))) + (if (gethash (content-slug post) *content*) + (error "There is already an existing post with the slug ~a." + (content-slug post)) + (setf (gethash (content-slug post) *content*) post))))) -(defun render-posts () - "Iterate through the files in the repo to render+write the posts out to disk." - (loop for (prev post next) on (append '(nil) (sort (hash-table-values *posts*) - #'string< :key #'post-date)) +(defmethod publish ((content-type (eql :post))) + (loop for (next post prev) on (append '(nil) (by-date (find-all 'post))) while post do (write-page (page-path post) (render-page post nil :prev prev :next next)))) - -(defun slug-char-p (char) - "Determine if CHAR is a valid slug (i.e. URL) character." - (or (char<= #\0 char #\9) - (char<= #\a char #\z) - (char<= #\A char #\Z) - (member char '(#\_ #\- #\.)))) - -(defun slugify (string) - "Return a version of STRING suitable for use as a URL." - (remove-if-not #'slug-char-p (substitute #\- #\Space string)))