(in-package :coleslaw) (defun app-path (path &rest args) "Take a relative PATH and return the corresponding pathname beneath coleslaw. If ARGS is provided, use (apply 'format nil PATH ARGS) as the value of PATH." (merge-pathnames (apply 'format nil path args) coleslaw-conf:*basedir*)) (defun to-pathname (file &optional (parent coleslaw-conf:*basedir*)) "Convert an iolib file-path back to a pathname." (merge-pathnames (file-path-namestring file) parent)) (defun read-symlink (path) "A trivial wrapper over iolib.os that returns the pathname in the symlink PATH." (to-pathname (iolib.os:read-symlink path))) (defmacro do-files ((var path &optional extension) &body body) "For each file under PATH, run BODY. If EXTENSION is provided, only run BODY on files that match the given extension." (alexandria:with-gensyms (ext) `(mapcar (lambda (,var) ,@(if extension `((let ((,ext (pathname-type ,var))) (when (and ,ext (string= ,ext ,extension)) ,@body))) `,body)) (list-directory ,path)))) (defun render-page (path html) "Populate the base template with the provided HTML and write it out to PATH." (let ((filepath (merge-pathnames path (staging *config*)))) (ensure-directories-exist filepath) (with-open-file (out filepath :direction :output :if-does-not-exist :create) (let ((content (funcall (theme-fn "BASE") (list :title (title *config*) :siteroot (domain *config*) :navigation (sitenav *config*) :content html :head-inject (apply #'concatenate 'string (gethash :head *injections*)) :body-inject (apply #'concatenate 'string (gethash :body *injections*)) :license (license *config*) :credits (author *config*))))) (write-line content out))))) (defun compile-blog () "Compile the blog to a staging directory in /tmp." (let ((staging (staging *config*))) ; TODO: More incremental compilation? Don't regen whole blog unnecessarily. (when (probe-file staging) (delete-directory-and-files staging)) (ensure-directories-exist staging) (with-current-directory staging (let ((css-dir (app-path "themes/~a/css" (theme *config*))) (static-dir (merge-pathnames "static" (repo *config*)))) (dolist (dir (list css-dir static-dir)) (when (probe-file dir) (run-program "cp" `("-R" ,(namestring dir) "."))))) (render-posts) (render-indices) (render-feed)) (deploy staging) (setf (last-published) (last-commit)))) (defun update-symlink (path target) "Update the symlink at PATH to point to TARGET." (run-program "ln" (list "-sfn" (namestring target) (namestring path)))) (defgeneric deploy (dir) (:documentation "Deploy DIR, updating the .prev and .curr symlinks.") (:method (dir) (let ((new-build (app-path "generated/~a" (get-universal-time)))) (ensure-directories-exist new-build) (with-current-directory coleslaw-conf:*basedir* (run-program "mv" (mapcar #'namestring (list dir new-build))) (when (probe-file (app-path ".prev")) (delete-directory-and-files (read-symlink (app-path ".prev")))) (when (probe-file (app-path ".curr")) (update-symlink ".prev" (read-symlink (app-path ".curr")))) (update-symlink ".curr" new-build))))) (defun main () (load-config) (compile-theme) (loop do (if (blog-update-p) (compile-blog) (sleep (interval *config*)))))