Implement post aliases

1 files changed, 28 insertions, 4 deletions

diff --git a/haunt.scm b/haunt.scm
index ccee372..5c3c101 100644
--- a/haunt.scm
+++ b/haunt.scm
@@ -74,15 +74,26 @@
       ((head . tail)
        (loop tail (cons head result))))))
 
-(define %collections
-  `(("Recent Blog Posts" "index.html" ,posts/reverse-chronological)))
-
 (define (static-page title file-name body)
   (lambda (site posts)
     (make-page file-name
                (with-layout jakob-theme site title body)
                sxml->html)))
 
+(define (article-alias alias target)
+  "Create a page named ALIAS that redirects to TARGET."
+  (make-page (string-append alias "/index.html")
+             `((doctype "html")
+               (html
+                (head
+                 (title ,target)
+                 (link (@ (rel "canonical") (href ,target)))
+                 (meta (@ (name "robots") (content "noindex")))
+                 (meta (@ (charset "utf-8")))
+                 (meta (@ (http-equiv "refresh")
+                          (content ,(string-append "0; " target)))))))
+             sxml->html))
+
 (define jakob-theme
   (theme #:name "jakob"
          #:layout
@@ -161,6 +172,12 @@ free culture works available under the " ,%cc-by-sa-link " license.")
    "projects.html"
    `((h1 "Projects"))))
 
+(define %collections
+  `(("Recent Posts" "index.html" ,posts/reverse-chronological)))
+
+(define %aliases
+  '(("blog/post/Bad BEHAVIOR" . "/reverse-engineering-babbys-first-archive-format.html")))
+
 (site #:title "Jakob's Personal Webpage"
       #:domain "jakob.space"
       #:default-metadata
@@ -175,4 +192,11 @@ free culture works available under the " ,%cc-by-sa-link " license.")
                        (static-directory "css")
                        (static-directory "js")
                        (static-directory "fonts")
-                       (static-directory "images")))
+                       (static-directory "images")
+                       (lambda (site posts)
+                         (map (lambda (alist)
+                                (let ((alias (car alist))
+                                      (target (cdr alist)))
+                                  (article-alias alias target)))
+                              %aliases))))
+