generate.lisp @ 1b2288cf32af

Remove draft entries from RSS too
author Steve Losh <>
date Mon, 18 Apr 2022 21:24:25 -0400
parents 08283802d226
children (none)
(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))

  (:use :cl :iterate :losh)
  (:import-from :cl-who
    :with-html-output :htm :str :fmt)
  (:export :toplevel :build))


;;;; State and Configuration --------------------------------------------------
(defparameter *generate-timestamp* (file-write-date "generate.lisp"))
(defparameter *header-number* 0)

(setf 3bmd-code-blocks:*code-blocks* t)

;;;; Utilities ----------------------------------------------------------------
(defun human-date (timestamp)
  (check-type timestamp local-time:timestamp)
    nil timestamp
    :format `(:long-month " " :ordinal-day ", " :year)))

(defun rfc-822-date (timestamp)
  (check-type timestamp local-time:timestamp)
    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
         (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 -------------------------------------------------------
(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
      (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.:

  2 3 3 2 3 4 4 → ((h2 (h3) (h3))
                   (h2 (h3 (h4) (h4))))

  This will add dummy headers when the level jumps unexpectedly, to keep the
  proper TOC structure even when the source is borked.

      ((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)))
             (values first-header head tail))))
       (section (level header children)
         "Handle a single section (i.e. one header and its children)."
         ;; (node . …recur…)
         (list* (cdr header) (sections (1+ level) children)))
       (sections (level headers)
         "Split `headers` into sibling sections, expecting to be at `level`."
         (if (null headers)
           (let ((l (car (first headers))))
             (if (< level l)
               (sections level (cons (cons (1- l) nil) headers)) ; dummy
               (multiple-value-bind (header children remaining) (split headers)
                 ;;  2 3 3 4 3  2 3 3 2 3 4 4
                 ;; [2 3 3 4 3] 2 3 3 2 3 4 4
                 ;;  section    recur
                   (section level header children)
                   (sections level remaining))))))))
    (sections 2 (subheaders root))))

(defun render-toc (toc)
  "Render a TOC tree from `extract-toc` to HTML."
    (: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)
    (with-open-file (stream path :direction :input)
      (read stream) ; discard metadata this time
      (with-output-to-string (string)
          (alexandria:read-stream-content-into-string stream)

(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)
        #'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))

(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 ()
     (:a :id "logo" :href "/" "Steve Losh")
      (:a :href "/blog/" "Blog")
      " - " (:a :href "/projects/" "Projects")
      " - " (:a :href "/photography/" "Photography")
      " - " (:a :href "/links/" "Links")
      " - " (:a :href "/rss.xml" "Feed")))))

(defun t/footer ()
      (:a :href "" "GitHub")
      " ・ " (:a :href "" "Twitter")
      " ・ " (:a :href "" "Instagram")
      " ・ " (:a :href "" ".plan")))))

(defun t/base (title page-id body)
    (:html :lang "en"
      (:meta :charset "utf-8")
      (:meta :name "pinterest" :content "nopin")
      (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")))))
      (:hr :class "main-separator")
      (:main :id (format nil "page-~A" page-id)
       (funcall body))
      (:hr :class "main-separator")

(defmacro with-base ((page-class &optional title) &body body)
  `(t/base ,title ,page-class (lambda () ,@body)))

;;;; Page Templates -----------------------------------------------------------
(defun t/mathjax ()
  (who "<script type='text/javascript' async

(defun t/index-item (item)
    (: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))
       (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))
       (:h1 (:a :href (url gallery) (str (esc (title gallery)))))
       (:p :class "date"
        "Last updated on " (str (human-date (date gallery))) ".")
       (str (force (body gallery)))
        (map nil #'t/photography/gallery/photo (gallery-photos gallery)))))))

(defun t/simple (content)
  (with-base ("simple" (title content))
       (: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")
      (:p "Hello, I'm Steve.")
      (:p "I'm a photographer, programmer, dancer, and bassist currently living in "
       (:a :href "" "Rochester, New York")
      (:p "If you want to get in touch with me, "
       (:a :href "" "email")
       " is best."))))

(defun t/404 ()
  (with-base ("not-found")
      (:h1 "404 Not Found")
      (:p "If you followed a link to get here, it's bad."))))

(defun t/rss (entries)
    (:rss :version "2.0"
      (:title "Steve Losh")
      (:link "")
      (:description "Steve Losh's blog.")
      (:language "en-us")
      (:copyright "Copyright 2020, Steve Losh")
      (:|webMaster| " (Steve Losh)")
      (:|lastBuildDate| (str (rfc-822-date (local-time:now))))
      (:generator "Common Lisp")
      (:docs "")
      (dolist (entry entries)
        (let ((link (format nil "" (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)))))))))))

;;;; Generation ---------------------------------------------------------------
(defun needs-render-p (path timestamps)
  (or (null (probe-file path))
      (let ((prev (file-write-date path)))
        (or (> *generate-timestamp* prev)
            (some (lambda (time) (> time prev))
                  (alexandria:ensure-list timestamps))))))

(defun render% (path mode timestamps thunk)
  (when (needs-render-p path timestamps)
      (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))))))

(defmacro render (path (&key times (mode :html5)) &body body)
  `(render% ,path ,mode ,times (lambda () ,@body)))

(defun page/home ()
  (render "build/index.html" ()

(defun page/404 ()
  (render "build/404.html" ()

(defun page/blog/index (entries)
  (render "build/blog/index.html"
      (:times (mapcar #'modified-timestamp entries))
    (t/blog/index (remove-if #'draft (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 (remove-if #'draft (remove-if #'hidden 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/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)))

(defun build ()
  (sb-ext:save-lisp-and-die "generate" :executable t :toplevel 'toplevel))

#; Scratch --------------------------------------------------------------------