hg.stevelosh.com > stevelosh.com

(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 :build))

(in-package :stevelosh.com)

;;;; 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)
  (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 -------------------------------------------------------
(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.:

  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.

  "
  (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)."
         ;; (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)
           nil
           (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
                 (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 "/rss.xml" "Feed")))))

(defun t/footer ()
  (who
    (:footer
     (:nav
      (:a :href "https://github.com/sjl/" "GitHub")
      " ・ " (:a :href "https://mastodon.social/@sjl" "Mastodon")
      " ・ " (:a :href "https://instagram.com/thirtytwobirds/" "Instagram")))))

(defun t/base (title page-id body)
  (who
    (:html :lang "en"
     (:head
      (: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")))))
     (: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 "<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 Ann Arbor, Michigan.")
      (: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 ---------------------------------------------------------------
(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)
    (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))))))

(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/pubkeys ()
  (uiop:copy-file "static/pubkeys" "build/pubkeys"))

(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/home)
    (page/404)
    (page/pubkeys)
    (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 --------------------------------------------------------------------
author	Steve Losh <steve@stevelosh.com>
date	Mon, 09 Sep 2024 10:31:31 -0400
parents	2daa2d6a1d9e
children	(none)