Assorted cleanups.

This commit is contained in:
Brit Butler 2014-05-01 17:28:51 -04:00
parent f602c371ea
commit e96f7f58b9
6 changed files with 36 additions and 41 deletions

View file

@ -47,6 +47,10 @@
(update-symlink prev (truename curr))) (update-symlink prev (truename curr)))
(update-symlink curr new-build)))) (update-symlink curr new-build))))
(defun update-symlink (path target)
"Update the symlink at PATH to point to TARGET."
(run-program "ln -sfn ~a ~a" target path))
(defun preview (path &optional (content-type 'post)) (defun preview (path &optional (content-type 'post))
"Render the content at PATH under user's configured repo and save it to "Render the content at PATH under user's configured repo and save it to
~/tmp.html. Load the user's config and theme if necessary." ~/tmp.html. Load the user's config and theme if necessary."
@ -58,39 +62,12 @@
(content (construct content-type (read-content file)))) (content (construct content-type (read-content file))))
(write-file "tmp.html" (render-page content))))) (write-file "tmp.html" (render-page content)))))
(defgeneric render-text (text format)
(:documentation "Render TEXT of the given FORMAT to HTML for display.")
(:method (text (format (eql :html)))
text)
(:method (text (format (eql :md)))
(let ((3bmd-code-blocks:*code-blocks* t))
(with-output-to-string (str)
(3bmd:parse-string-and-print-to-stream text str)))))
(defun make-pubdate ()
"Make a RFC1123 pubdate representing the current time."
(local-time:format-rfc1123-timestring nil (local-time:now)))
(defun page-path (object)
"The path to store OBJECT at once rendered."
(rel-path (staging-dir *config*) (namestring (page-url object))))
(defun render-page (content &optional theme-fn &rest render-args) (defun render-page (content &optional theme-fn &rest render-args)
"Render the given CONTENT to disk using THEME-FN if supplied. "Render the given CONTENT to HTML using THEME-FN if supplied.
Additional args to render CONTENT can be passed via RENDER-ARGS." Additional args to render CONTENT can be passed via RENDER-ARGS."
(funcall (or theme-fn (theme-fn 'base)) (funcall (or theme-fn (theme-fn 'base))
(list :config *config* (list :config *config*
:content content :content content
:raw (apply 'render content render-args) :raw (apply 'render content render-args)
:pubdate (make-pubdate) :pubdate (format-rfc1123-timestring nil (local-time:now))
:injections (find-injections content)))) :injections (find-injections content))))
(defun write-file (filepath page)
"Write the given PAGE to FILEPATH."
(ensure-directories-exist filepath)
(with-open-file (out filepath
:direction :output
:if-exists :supersede
:if-does-not-exist :create
:external-format '(:utf-8))
(write page :stream out :escape nil)))

View file

@ -76,3 +76,12 @@
(defun by-date (content) (defun by-date (content)
"Sort CONTENT in reverse chronological order." "Sort CONTENT in reverse chronological order."
(sort content #'string> :key #'content-date)) (sort content #'string> :key #'content-date))
(defgeneric render-text (text format)
(:documentation "Render TEXT of the given FORMAT to HTML for display.")
(:method (text (format (eql :html)))
text)
(:method (text (format (eql :md)))
(let ((3bmd-code-blocks:*code-blocks* t))
(with-output-to-string (str)
(3bmd:parse-string-and-print-to-stream text str)))))

View file

@ -5,7 +5,7 @@
;; Data Storage ;; Data Storage
(defvar *site* (make-hash-table :test #'equal) (defvar *site* (make-hash-table :test #'equal)
"An in-memory database to hold all site documents, keyed on page-url.") "An in-memory database to hold all site documents, keyed on relative URLs.")
;; Class Methods ;; Class Methods
@ -46,20 +46,21 @@
;; Helper Functions ;; Helper Functions
(defun add-document (doc) (defun add-document (document)
"Add DOC to the in-memory database. Error if a matching entry is present." "Add DOCUMENT to the in-memory database. Error if a matching entry is present."
(let ((url (page-url doc))) (let ((url (page-url document)))
(if (gethash url *site*) (if (gethash url *site*)
(error "There is already an existing document with the url ~a" url) (error "There is already an existing document with the url ~a" url)
(setf (gethash url *site*) doc)))) (setf (gethash url *site*) document))))
(defun write-document (document &optional theme-fn &rest render-args) (defun write-document (document &optional theme-fn &rest render-args)
"Write the given DOCUMENT to disk as HTML. If THEME-FN is present, "Write the given DOCUMENT to disk as HTML. If THEME-FN is present,
use it as the template passing any RENDER-ARGS." use it as the template passing any RENDER-ARGS."
(let ((html (if (or theme-fn render-args) (let ((html (if (or theme-fn render-args)
(apply #'render-page document theme-fn render-args) (apply #'render-page document theme-fn render-args)
(render-page document nil)))) (render-page document nil)))
(write-file (page-path document) html))) (url (namestring (page-url document))))
(write-file (rel-path (staging-dir *config*) url) html)))
(defun find-all (doc-type) (defun find-all (doc-type)
"Return a list of all instances of a given DOC-TYPE." "Return a list of all instances of a given DOC-TYPE."

View file

@ -87,5 +87,5 @@
(defun all-tags () (defun all-tags ()
"Retrieve a list of all tags used in content." "Retrieve a list of all tags used in content."
(let* ((dupes (mappend #'content-tags (find-all 'post))) (let* ((dupes (mappend #'content-tags (find-all 'post)))
(tags (remove-duplicates dupes :test #'string= :key #'tag-slug))) (tags (remove-duplicates dupes :test #'tag-slug=)))
(sort tags #'string< :key #'tag-name))) (sort tags #'string< :key #'tag-name)))

View file

@ -7,6 +7,7 @@
#:compose) #:compose)
(:import-from :cl-fad #:file-exists-p) (:import-from :cl-fad #:file-exists-p)
(:import-from :closure-template #:compile-template) (:import-from :closure-template #:compile-template)
(:import-from :local-time #:format-rfc1123-timestring)
(:export #:main (:export #:main
#:preview #:preview
#:*config* #:*config*

View file

@ -82,10 +82,17 @@ If ARGS is provided, use (fmt path args) as the value of PATH."
use (fmt program args) as the value of PROGRAM." use (fmt program args) as the value of PROGRAM."
(inferior-shell:run (fmt program args) :show t)) (inferior-shell:run (fmt program args) :show t))
(defun update-symlink (path target)
"Update the symlink at PATH to point to TARGET."
(run-program "ln -sfn ~a ~a" target path))
(defun take-up-to (n seq) (defun take-up-to (n seq)
"Take elements from SEQ until all elements or N have been taken." "Take elements from SEQ until all elements or N have been taken."
(subseq seq 0 (min (length seq) n))) (subseq seq 0 (min (length seq) n)))
(defun write-file (path text)
"Write the given TEXT to PATH. PATH is overwritten if it exists and created
along with any missing parent directories otherwise."
(ensure-directories-exist path)
(with-open-file (out path
:direction :output
:if-exists :supersede
:if-does-not-exist :create
:external-format '(:utf-8))
(write text :stream out :escape nil)))