coleslaw/plugins/incremental.lisp

(eval-when (:compile-toplevel :load-toplevel)
  (ql:quickload 'cl-store))

(defpackage :coleslaw-incremental
  (:use :cl)
  (:import-from :alexandria #:when-let)
  (:import-from :coleslaw #:content
                          #:discover
                          #:get-updated-files
                          #:find-content-by-path
                          #:find-all
                          #:add-document
                          #:write-document
                          ;; Private
                          #:all-subclasses
                          #:construct
                          #:rel-path
                          #:index-content
                          #:content-date
                          #:content-tags
                          #:tag-slug
                          )
  (:export #:enable))

(in-package :coleslaw-incremental)

;; KLUDGE: We currently never update the site for config changes.
;; Examples to consider include changing the theme or domain of the site.
;; Both would require full site recompiles. Consequently, it seems reasonable
;; to expect that incremental plugin users:
;;   A) have done a full build of their site
;;   B) have a cl-store dump of the database at ~/.coleslaw.db
;;      ^ we should provide a script or plugin just for this
;;   C) move the original deployment to a location of their choice and set it
;;      as staging-dir in coleslaw's config prior to enabling incremental builds
;;   D) to further simplify *my* life, we assume the date of a piece of content
;;      will never be changed retroactively, only its tags
;;
;; We're gonna be a bit dirty here and monkey patch. The compilation model
;; still isn't an "exposed" part of Coleslaw. After some experimentation maybe
;; we'll settle on an interface.

(defvar *transients* '(coleslaw::numeric-index coleslaw::feed coleslaw::tag-feed)
  "A list of document types that should be regenerated on any change to the blog.")

(defun coleslaw::load-content ()
  (let ((db-file (rel-path (user-homedir-pathname) ".coleslaw.db")))
    (setf coleslaw::*site* (cl-store:restore db-file))
    (loop for (status path) in (get-updated-files)
       do (update-content status path))
    (coleslaw::update-content-metadata)
    (dolist (doc-type *transients*)
      (discover (find-class doc-type)))
    (cl-store:store coleslaw::*site* db-file)))

(defun update-content (status path)
  (cond ((string= "D" status) (process-change :deleted path))
        ((string= "M" status) (process-change :modified path))
        ((string= "A" status) (process-change :added path))))

(defgeneric process-change (status path &key &allow-other-keys)
  (:documentation "Updates the database as needed for the STATUS change to PATH.")
  (:method :around (status path &key)
    (let ((extension (pathname-type path))
          (ctypes (all-subclasses (find-class 'content))))
      ;; This feels way too clever. I wish I could think of a better option.
      (flet ((class-name-p (x class)
               (string-equal x (symbol-name (class-name class)))))
        ;; If the updated file's extension doesn't match one of our content types,
        ;; we don't need to mess with it at all. Otherwise, since the class is
        ;; annoyingly tricky to determine, pass it along.
        (when-let (ctype (find extension ctypes :test #'class-name-p))
          (call-next-method status path :ctype ctype))))))

;; TODO: If the last content from a given month or with a given tag
;; is deleted, delete the index. Unfortunately, the tag/month links
;; won't be updated on all indexes since we only regenerate them for new posts.

(defmethod process-change ((status (eql :deleted)) path &key)
  (let* ((old (find-content-by-path path))
         (month-index (find-month-index (content-date old))))
    (delete old (index-content month-index))
    (dolist (tag (content-tags old))
      (let ((tag-index (find-tag-index tag)))
        (delete old (index-content tag-index))))
    (delete-document old)))

(defmethod process-change ((status (eql :modified)) path &key)
  (let ((old (find-content-by-path path))
        (new (construct ctype (read-content path))))
    (delete-document old)
    ;; TODO:
    ;; Iterate over tags in new, replacing old with new in each tag index's content.
    ;; If there are new tags/date, add it to relevant indices (or create them).
    ;; If tags/date are removed, remove from relevant indices (or delete them).
    (add-document new)
    (write-document new)))

(defmethod process-change ((status (eql :added)) path &key ctype)
  (let* ((new (construct ctype (read-content path)))
         (tags (content-tags new))
         (month (subseq (content-date new) 0 7)))
    (maybe-add-month-index new month)
    (dolist (tag tags)
      (maybe-add-tag-index new tag))
    (add-document new)
    ;; FIXME: New posts won't have prev/next links populated.
    (write-document new)))

(defun coleslaw::compile-blog (staging)
  "lulz. Do it live. DO IT ALL LIVE."
  (dolist (doc-type *transients*)
    (publish (find-class doc-type))))

;; No-op. We'll be updating in place instead.
(defmethod coleslaw:deploy (staging))

(defun enable ())

;;;; Utils

(defun delete-document (document)
  "Given a DOCUMENT, delete it from the staging directory and in-memory DB."
  (let ((url (page-url document)))
    (delete-file (rel-path (staging-dir *config*) (namestring url)))
    (remhash (page-url document) coleslaw::*site*)))

(defun maybe-add-month-index (content month)
  "Add a month index for MONTH containing CONTENT if one does not exist."
(unless (find-month-index month)
    (let ((month-index (coleslaw::index-by-month month (list content))))
      (add-document month-index)
      (write-document month-index))))

(defun maybe-add-tag-index (content tag)
  "Add a tag index for TAG containing CONTENT if one does not exist."
  (unless (find-tag-index tag)
    (let ((tag-index (coleslaw::index-by-tag tag (list content))))
      (add-document tag-index)
      (write-document tag-index))))

(defun find-tag-index (tag)
  (find (tag-slug tag) (find-all 'tag-index) :key #'index-slug :test #'equal))

(defun find-month-index (date)
  (find (subseq date 0 7) (find-all 'month-index) :key #'index-slug :test #'equal))