Skip to content

Instantly share code, notes, and snippets.

@pnathan

pnathan/pnathan.lisp

Created April 9, 2017 06:32
Show Gist options
  • Save pnathan/d57bb0e95fa68552a51755814844d50b to your computer and use it in GitHub Desktop.
Save pnathan/d57bb0e95fa68552a51755814844d50b to your computer and use it in GitHub Desktop.
Download ZIP
pnathan.com
Raw
pnathan.lisp
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; pnathan.com
;;;;
(ql:quickload '(:cl-who
:alexandria
:cl-fad
:cl-ppcre
:cl-markdown
:xml-emitter))
(use-package :cl-who)
(defun compose (&rest fns)
;; from pg
(destructuring-bind (fn1 . rest) (reverse fns)
#'(lambda (&rest args)
(reduce #'(lambda (v f) (funcall f v))
rest
:initial-value (apply fn1 args)))))
(defun gassoc (item alist)
(cdr (assoc item alist)))
(defun index-page (blog-metadata)
(let ((sidebar (get-sidebar blog-metadata)))
(with-output-to-string
(stream)
(with-html-output
(stream nil :prologue t :indent t)
(:html
(:head
(:title "Paul Nathan"))
(:body
(:center (:table
:border 0
:width 800
(:tr
(:td
:valign "top"
(:div
"Paul Nathan - pnathan"
(:p
"essays / blog"
(:ul :style "list-style: square; "
(loop for block in sidebar
do
(htm (:li (:h4 (esc (car block)))))
(loop for blog in (cdr block)
do
(htm
(:li
(:a :href
(car blog)
(esc (cdr blog)))))))
))
(:p
(:a :href "blogs.rss" "blogs for rss"))
(:p
(:a :href "http://pnathan-art.tumblr.com/" "Painting weblog"))))
(:td
:valign "top"
(:table
(:tr (:td (:a :href "mail:pnathan@alumni.uidaho.edu" "pnathan@alumni.uidaho.edu")) (:td "email"))
(:tr (:td (:a :href "https://twitter.com/p_nathan" "@p_nathan")) (:td "twitter"))
(:tr (:td (:a :href "https://github.com/pnathan" "pnathan")) (:td "github"))
(:tr (:td "pnathan@member.fsf.org") (:td "jabber")))
(:p
(:hr))
(:p
"welcome to my home page on the internet")
))))))))))
(defmacro while (condition &body body)
`(do ()
((not ,condition))
(progn ,@body)
))
(defun get-blog-posts (&optional (directories-to-process "blog"))
(when directories-to-process
(loop
for filename in (cl-fad:list-directory directories-to-process)
nconc
(progn
(when (and (not (cl-ppcre:scan "~$" (namestring filename)))
(not (cl-ppcre:scan "^\\." (file-namestring filename))))
(cond ((cl-fad:directory-pathname-p filename)
(get-blog-posts filename))
(t
(when (cl-ppcre:scan "\\.(md|markdown)$" (namestring filename))
(list filename)))))))))
(defun get-blog-metadata (blogpost-names)
(let ((blog-metadata
(mapcar
#'(lambda (path)
(let ((datestring
(cl-ppcre:scan-to-strings
"\\d{4}-\\d{2}-\\d{2}" (file-namestring path)))
(name (substitute
#\Space #\-
(multiple-value-bind (_ name)
(cl-ppcre:scan-to-strings
"\\d+-\\d+-\\d+-(.+)\\.\(markdown|md\)"
(file-namestring path))
(aref name 0))))
(abstract-name
(multiple-value-bind (_ name)
(cl-ppcre:scan-to-strings
"(\\d+-\\d+-\\d+-.+)\\.\(markdown|md\)"
(file-namestring path))
(aref name 0))))
(list
(cons :date datestring)
(cons :name name)
(cons :abstract-name abstract-name)
(cons :filename (file-namestring path))
(cons :category (first (last (pathname-directory path))))
(cons :future-name (format nil "blog/~a/~a.html"
(first (last (pathname-directory path)))
abstract-name))
(cons :path path))))
blogpost-names)))
(sort blog-metadata #'string< :key #'(lambda (e) (cdr (assoc :date e))))))
(defun blog-page (title date sidebar content)
(with-output-to-string (stream)
(with-html-output
(stream nil :prologue t :indent t)
(:html
(:head
( :title (esc title)))
(:body
(:table
:border 0
:width 800
(:tr
(:td
:width 200
:valign "top"
(:a :href "/" "home")
(:ul :style "list-style: square; "
(loop for block in sidebar
do
(htm (:li (:h4 (esc (car block)))))
(loop for blog in (cdr block)
do
(htm
(:li
(:a :href
(car blog)
(esc (cdr blog)))))))
))
(:td
(:h2 (str title))
(:h3 (str date))
(str content) ))))))))
(defun get-sidebar (blog-metadata)
(let ((category-map (make-hash-table :test #'equal)))
(loop for blog in blog-metadata
do
(unless (gethash (gassoc :category blog) category-map)
(setf (gethash (gassoc :category blog) category-map) (list))))
(loop for blog in blog-metadata
do
(push (cons
;; allow access online
(format nil "/~a" (gassoc :future-name blog))
(format nil "~a - ~a" (gassoc :date blog) (gassoc :name blog)))
(gethash (gassoc :category blog) category-map)))
(alexandria:hash-table-alist category-map)))
(defun write-out-blogs (blog-metadata)
(format t "writing out blogs to /blog~%")
(let ((sidebar
(get-sidebar blog-metadata))
(blogs))
(loop for blog in blog-metadata
do
(format t "Processing ~a~%" (gassoc :name blog) )
(let* ((filepath (cdr (assoc :path blog)))
(filetext (alexandria:read-file-into-string filepath))
(markdown (multiple-value-bind (_ information)
(cl-markdown:markdown filetext :stream nil)
information)))
(push (list (gassoc :name blog)
(gassoc :date blog)
markdown
(gassoc :category blog)
(format nil
"http://pnathan.com/~a"
(gassoc :future-name blog)))
blogs)
(alexandria:write-string-into-file
(blog-page
(gassoc :name blog)
(gassoc :date blog)
sidebar
markdown)
(gassoc :future-name blog)
:if-exists :supersede )))
(with-open-file (stream "blogs.rss"
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(xml-emitter:with-rss2
(stream)
(loop for entry in blogs
do
(xml-emitter:rss-item
(first entry)
:description (subseq (third entry)
0
(min (length (third entry))
140))
:category (fourth entry)
:link (fifth entry)
:pubdate (second entry))
)))
))
(defun build ()
(format t "~&reticulating splines~%")
(let ((blog-metadata
(get-blog-metadata (get-blog-posts))))
(alexandria:write-string-into-file
(index-page blog-metadata)
"index.html"
:if-exists :supersede :if-does-not-exist :create)
(write-out-blogs blog-metadata)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment