Tables of contents and RSS
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Wed, 08 Jan 2020 22:05:32 -0800 |
| parents |
3a93ce0b1bd2 |
| children |
d70b175d5479 |
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload (list :alexandria :iterate :losh :local-time
:cl-who :3bmd :3bmd-ext-code-blocks
:plump :cl-slug)
:silent t))
(defpackage :stevelosh.com
(:use :cl :iterate :losh)
(:import-from :cl-who
:with-html-output :htm :str :fmt)
(:export :toplevel))
(in-package :stevelosh.com)
;;;; State and Configuration --------------------------------------------------
(setf 3bmd-code-blocks:*code-blocks* t)
;;;; Utilities ----------------------------------------------------------------
(defun human-date (timestamp)
(check-type timestamp local-time:timestamp)
(local-time:format-timestring
nil timestamp
:format `(:long-month " " :ordinal-day ", " :year)))
(defun rfc-822-date (timestamp)
(check-type timestamp local-time:timestamp)
(local-time:format-timestring
nil timestamp
:format `(:short-weekday ", " (:day 2) " " :short-month " " :year
" " (:hour 2) ":" (:min 2) ":" (:sec 2) " " :timezone)
:timezone local-time:+gmt-zone+))
(defmacro who (&body body)
`(with-html-output (*standard-output*) ,@body))
(defmacro whos (&body body)
`(with-output-to-string (s)
(with-html-output (s) ,@body)))
(defmacro delay (&body body)
`(let (result done)
(lambda ()
(if done
result
(setf done t result (progn ,@body))))))
(defun force (delay)
(funcall delay))
(defun cat (&rest strings)
(apply #'concatenate 'string strings))
(defun esc (string)
(cl-who:escape-string string))
;;;; Tables of Contents -------------------------------------------------------
(defparameter *header-number* 0)
(defun subheaderp (node)
(and (plump:element-p node)
(member (plump:tag-name node) '("h2" "h3" "h4" "h5" "h6") :test #'string=)))
(defun replace-node (node html)
(plump:replace-child node (elt (plump:children (plump:parse html)) 0)))
(defun replace-content (node html)
(plump:clear node)
(loop :for child :across (plump:children (plump:parse html))
:do (plump:append-child node child)))
(defun linkify-subheader (node)
(let* ((text (plump:text node))
(id (format nil "s~D-~A" (incf *header-number*) (slug:slugify text)))
(href (concatenate 'string "#" id)))
(plump:set-attribute node "id" id)
(replace-content node (whos (:a :href href (str text))))))
(defun linkify-subheaders (root)
(let ((*header-number* 0))
(plump:traverse root #'linkify-subheader :test #'subheaderp)))
(defun header-level (node)
(digit-char-p (char (plump:tag-name node) 1)))
(defun subheaders (root)
(-<> root
(gathering
(plump:traverse <> #'gather :test #'subheaderp))
(mapcar (lambda (node) (cons (header-level node) node)) <>)))
(defun split-if (pred list)
"Split list into two pieces, at the point where pred first becomes true.
The first element of the second list will be the point where pred becomes true.
"
(loop :for tail :on list
:for (next . more) = tail
:until (funcall pred next)
:collect next :into head
:finally (return (values head tail))))
(defun extract-toc (root)
"Extract a table of contents from `root` as a tree.
The result will be a tree of `(node &rest children)`, e.g.:
h2 ((h2 (h3)
h3 (h3))
h3 (h2 (h3 (h4)
h2 (h4))
h3 → (h3 (h4
h4 (h5)
h4 (h5))))
h3 (h2 (nil (h4)
h4 (h4))
h5 (h3))
h5
h2
h4
h4
h3
Note the addition of dummy headers when the level jumps unexpectedly, to keep
the proper TOC structure even when the source is borked.
"
(labels
((split (headers)
"Split `headers` into the first header, its children, and whatever else remains."
(destructuring-bind (first-header . remaining) headers
(multiple-value-bind (head tail)
(split-if (lambda (header)
(<= (car header) (car first-header)))
remaining)
(values first-header head tail))))
(section (level header children)
"Handle a single section (i.e. one header and its children)."
(list* (cdr header) (sections (1+ level) children)))
(sections (level headers)
"Split `headers` into sibling sections, expecting to be at `level`."
(if (null headers)
nil
(let ((l (car (first headers))))
(if (< level l)
(sections level (cons (cons (1- l) nil) headers))
(multiple-value-bind (header children remaining) (split headers)
(list*
(section level header children)
(sections level remaining))))))))
(sections 2 (subheaders root))))
(defun render-toc (toc)
"Render a TOC tree from `extract-toc` to HTML."
(whos
(:ol :class "table-of-contents"
(recursively ((sections toc))
(unless (null sections)
(destructuring-bind ((header &rest children) . remaining) sections
(htm (:li
(when header
(htm (:a :href (format nil "#~A" (plump:attribute header "id"))
(str (plump:text header)))))
(when children
(htm (:ol (recur children))))))
(recur remaining)))))))
(defun insert-toc (html)
(let* ((root (plump:parse html))
(div (plump:get-element-by-id root "toc")))
(when div
(linkify-subheaders root)
(replace-node div (render-toc (extract-toc root))))
(plump:serialize root nil)))
;;;; Content ------------------------------------------------------------------
(defclass* content ()
(input-path output-path date modified-timestamp body
url title gallery snip
(draft :initform nil)
(hidden :initform nil)
(mathjax :initform nil)))
(defun parse-markdown (path)
(insert-toc
(with-open-file (stream path :direction :input)
(read stream) ; discard metadata this time
(with-output-to-string (string)
(3bmd:parse-string-and-print-to-stream
(alexandria:read-stream-content-into-string stream)
string)))))
(defun read-content (path)
(with-open-file (s path :direction :input)
(let ((metadata (if (string= #\left_parenthesis (peek-char nil s))
(read s)
(return-from read-content nil))))
(callf (getf metadata :date) #'local-time:parse-rfc3339-timestring)
(apply
#'make-instance 'content
:input-path path
:output-path (ppcre:regex-replace "content/(.*)\\.markdown" path "build/\\1/index.html")
:url (ppcre:regex-replace "content/(.*)\\.markdown" path "/\\1/")
:modified-timestamp (file-write-date path)
:body (delay (parse-markdown path))
metadata))))
(defun walk (path)
(-<> (sh (list "find" path "-name" "*.markdown") :result-type 'list)
(mapcar #'read-content <>)
(remove nil <>)
(sort <> #'local-time:timestamp> :key #'date)))
(defun gallery-photos (gallery)
(let* ((slug (gallery gallery))
(photo-path (cat "static/images/photography/photos/" slug))
(thumb-path (cat "static/images/photography/thumbnails/" slug))
(files (sh (list "ls" "-1" photo-path) :result-type 'list)))
(loop :for file :in files
:collect (cons (cat "/" photo-path "/" file)
(cat "/" thumb-path "/" file)))))
;;;; Base Templates -----------------------------------------------------------
(defmacro css (href &rest more)
`(who (:link :href ,href :rel "stylesheet" :type "text/css" ,@more)))
(defun t/header ()
(who
(:header
(:a :id "logo" :href "/" "Steve Losh")
(:nav
(:a :href "/blog/" "Blog")
" - " (:a :href "/projects/" "Projects")
" - " (:a :href "/photography/" "Photography")
" - " (:a :href "/links/" "Links")
" - " (:a :href "/feed/" "Feed")))))
(defun t/footer ()
(who
(:footer
(:nav
(:a :href "https://meta.sr.ht/~sjl/" "Source Hut")
" ・ " (:a :href "https://github.com/sjl/" "GitHub")
" ・ " (:a :href "https://twitter.com/stevelosh/" "Twitter")
" ・ " (:a :href "https://instagram.com/thirtytwobirds/" "Instagram")
" ・ " (:a :href "https://hg.sr.ht/~sjl/.plan/" ".plan")))))
(defun t/base (title page-id body)
(who
(:html :lang "en"
(:head
(:meta :charset "utf-8")
(css "/static/css/style.css")
(css "/static/css/print.css" :media "print")
(:title (str (esc (if title
(format nil "~A / Steve Losh" title)
"Steve Losh")))))
(:body
(t/header)
(:hr :class "main-separator")
(:main :id (format nil "page-~A" page-id)
(funcall body))
(:hr :class "main-separator")
(t/footer)))))
(defmacro with-base ((page-class &optional title) &body body)
`(t/base ,title ,page-class (lambda () ,@body)))
;;;; Page Templates -----------------------------------------------------------
(defun t/mathjax ()
(who (str "<script type='text/javascript' async
src='https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML'></script>")))
(defun t/index-item (item)
(who
(:li :class "item"
(:a :href (url item) (str (esc (title item))))
(:p :class "date" (str (human-date (date item))))
(:p :class "snippet" (str (esc (snip item)))))))
(defun t/index (items)
(who (:ol :class "index" (map nil #'t/index-item items))))
(defun t/blog/index (entries)
(with-base ("blog-index" "Blog")
(t/index entries)))
(defun t/blog/entry (entry)
(with-base ("blog-entry" (title entry))
(who
(:article
(when (mathjax entry) (t/mathjax))
(:h1 (:a :href (url entry) (str (esc (title entry)))))
(:p :class "date"
"Posted on " (str (human-date (date entry))) ".")
(str (force (body entry)))))))
(defun t/photography/index (galleries)
(with-base ("photography-index" "Photography")
(t/index galleries)))
(defun t/photography/gallery/photo (photo)
(destructuring-bind (photo . thumb) photo
(who (:li (:a :href photo (:img :src thumb))))))
(defun t/photography/gallery (gallery)
(with-base ("photography-gallery" (title gallery))
(who
(:article
(:h1 (:a :href (url gallery) (str (esc (title gallery)))))
(:p :class "date"
"Last updated on " (str (human-date (date gallery))) ".")
(str (force (body gallery)))
(:ul
(map nil #'t/photography/gallery/photo (gallery-photos gallery)))))))
(defun t/simple (content)
(with-base ("simple" (title content))
(who
(:article
(:h1 (:a :href (url content) (str (esc (title content)))))
(:p :class "date"
"Last updated on " (str (human-date (date content))) ".")
(str (force (body content)))))))
(defun t/home ()
(with-base ("home")
(who
(:p "Hello, I'm Steve.")
(:p "I'm a photographer, programmer, dancer, and bassist currently living in "
(:a :href "https://rochestermade.com/" "Rochester, New York")
".")
(:p "If you want to get in touch with me, "
(:a :href "mailto:steve@stevelosh.com" "email")
" is best."))))
(defun t/404 ()
(with-base ("not-found")
(who
(:h1 "404 Not Found")
(:p "If you followed a link to get here, it's bad."))))
(defun t/rss (entries)
(who
(:rss :version "2.0"
(:channel
(:title "Steve Losh")
(:link "https://stevelosh.com/")
(:description "Steve Losh's blog.")
(:language "en-us")
(:copyright "Copyright 2020, Steve Losh")
(:|webMaster| "steve@stevelosh.com (Steve Losh)")
(:|lastBuildDate| (str (rfc-822-date (local-time:now))))
(:generator "Common Lisp")
(:docs "https://validator.w3.org/feed/docs/rss2.html")
(dolist (entry entries)
(let ((link (format nil "https://stevelosh.com~A" (url entry))))
(htm (:item
(:title (str (esc (title entry))))
(:link (str link))
(:guid :|isPermaLink| "true" (str link))
(:description (str (esc (snip entry))))
(:|pubDate| (str (rfc-822-date (date entry)))))))))))
(values))
;;;; Generation ---------------------------------------------------------------
(defparameter *generate-timestamp* (file-write-date "generate.lisp"))
(defun needs-render-p (path times)
(or (null (probe-file path))
(let ((prev (file-write-date path)))
(or (> *generate-timestamp* prev)
(some (lambda (time) (> time prev))
(alexandria:ensure-list times))))))
(defun render% (path mode times thunk)
(if (needs-render-p path times)
(progn
(format t "Rendering ~S~%" path)
(ensure-directories-exist path)
(with-open-file (*standard-output* path
:direction :output
:if-exists :supersede)
(setf (cl-who:html-mode) mode)
(ecase mode
(:html5 (write-line "<!DOCTYPE html>"))
(:xml (write-line "<?xml version='1.0'?>")))
(who (funcall thunk))))
#+no (format t "Skipping ~S, file is up to date.~%" path)))
(defmacro render (path (&key times (mode :html5)) &body body)
`(render% ,path ,mode ,times (lambda () ,@body)))
(defun page/home ()
(render "build/index.html" ()
(t/home)))
(defun page/404 ()
(render "build/404.html" ()
(t/404)))
(defun page/blog/index (entries)
(render "build/blog/index.html"
(:times (mapcar #'modified-timestamp entries))
(t/blog/index (remove-if #'hidden entries))))
(defun page/photography/index (galleries)
(render "build/photography/index.html"
(:times (mapcar #'modified-timestamp galleries))
(t/photography/index galleries)))
(defun page/blog/entries (entries)
(dolist (entry entries)
(render (output-path entry) (:times (modified-timestamp entry))
(t/blog/entry entry))))
(defun page/photography/galleries (galleries)
(dolist (gallery galleries)
(render (output-path gallery) (:times (modified-timestamp gallery))
(t/photography/gallery gallery))))
(defun page/simple (content)
(render (output-path content) (:times (modified-timestamp content))
(t/simple content)))
(defun page/rss (entries)
(render "build/rss.xml"
(:times (mapcar #'modified-timestamp entries)
:mode :xml)
(t/rss entries)))
;;;; Toplevel -----------------------------------------------------------------
(defun toplevel ()
(let ((blog-entries (walk "content/blog"))
(photo-galleries (walk "content/photography"))
(links (read-content "content/links.markdown"))
(projects (read-content "content/projects.markdown"))
(resume (read-content "content/resume.markdown")))
(page/home)
(page/404)
(page/blog/index blog-entries)
(page/blog/entries blog-entries)
(page/photography/index photo-galleries)
(page/photography/galleries photo-galleries)
(page/simple links)
(page/simple projects)
(page/simple resume)
(page/rss blog-entries)))
#; Scratch --------------------------------------------------------------------
(defparameter *blog-entries*
(walk "content/blog"))
(plump:parse *x*)