Goodbye Hakyll, hello Haunt!

1 files changed, 359 insertions, 0 deletions

diff --git a/haunt.scm b/haunt.scm
new file mode 100644
index 0000000..5d5fd03
--- /dev/null
+++ b/haunt.scm
@@ -0,0 +1,359 @@
+;; TODO:
+;; * Archive page should list *all* tags
+;; * copy posts as static pages (e.g. /elephly.html)
+;; * fix titles of non-posts pages
+
+(use-modules (srfi srfi-1)  ; list stuff
+             (srfi srfi-11) ; let-values
+             (srfi srfi-19) ; date functions
+             (srfi srfi-26) ; cut
+             (ice-9 ftw)    ; file system
+             (ice-9 match)  ; match-lambda
+             (skribe)
+             (haunt reader)
+             (haunt site)
+             (haunt asset)
+             (haunt post) ;post-file-name
+             (haunt page)
+             (haunt html) ;sxml->html
+             (haunt utils) ;absolute-file-name
+             (haunt builder blog)
+             (haunt builder atom))
+
+
+(define skribe-reader
+  (make-reader (make-file-extension-matcher "skr")
+               (lambda (file-name)
+                 (let ((contents (load (absolute-file-name file-name) %skribe-reader)))
+                   (values meta contents)))))
+
+;; Create stubs for each sxml tag
+;; This is needed for the skribe to sxml conversion.
+(for-each
+ (lambda (tag)
+   (eval `(define (,tag . content)
+            (list (quote ,tag) content))
+         (current-module)))
+ '(a blockquote p img h1 h2 h3 code pre strong em ul li dl dt dd))
+
+
+(define (email address)
+  "Obfuscate a given email ADDRESS."
+  `(span (@ (class "obfuscated"))
+         ,(string-map (lambda (c) (integer->char (+ 1 (char->integer c))))
+                      address)))
+
+(define (~)
+  "Non-breaking space."
+  (string #\240))
+
+(define* (table #:key (align '()) headers rows)
+  "Build HTML tables more easily."
+  (let ((alignment (append align
+                           (make-list (- (length headers)
+                                         (length align))
+                                      "left"))))
+    (define (make-row fields)
+      `(tr ,(map (match-lambda
+                  ((field alignment)
+                   `(td (@ (align ,alignment)) ,field)))
+                 (zip fields alignment))))
+    (define (make-header fields)
+      `(tr (@ (class "header"))
+           ,(map (match-lambda
+                  ((field alignment)
+                   `(th (@ (align ,alignment)) ,field)))
+                 (zip fields alignment))))
+    `(table
+      (thead ,(make-header headers))
+      (tbody ,(map make-row rows)))))
+
+(define (lyrics . contents)
+  `(pre (@ (class "lyrics")) ,contents))
+
+(define (ref url text)
+  `(a (@ (href ,url)) ,text))
+
+(define (figure file caption)
+  `(div (@ (class "figure"))
+        (img (@ (src ,(if (string-prefix? "/" file)
+                          file
+                          (string-append "/images/posts/" file)))
+                (alt ,caption)))
+        (p (@ (class "caption")) ,caption)))
+
+(define (wide-img file alt)
+  `(img (@ (class "full stretch")
+           (src ,(if (string-prefix? "/" file)
+                     file
+                     (string-append "/images/posts/" file)))
+           (alt ,alt))))
+
+(define (photo-snippet post)
+  (let ((meta (post-ref post 'photo)))
+    (if meta
+        `(img (@ (class "stretch full")
+                 (src ,(string-append "/images/posts/" meta))))
+        '())))
+
+(define (flattr-snippet post)
+  (let ((meta (post-ref post 'flattr)))
+    (if meta
+        `(a (@ (href ,(string-append "http://flattr.com/thing/" meta)))
+            (img (@ (title "Flattr this")
+                    (alt   "Flattr this")
+                    (src "http://api.flattr.com/button/flattr-badge-large.png"))))
+        '())))
+
+;; TODO: use license
+(define (license-snippet post)
+  (let ((meta (post-ref post 'license)))
+    (if meta
+        `(div (@ (class "fineprint"))
+              (div (@ (class "license"))
+                   (a (@ (rel "license")
+                         (href "http://creativecommons.org/licenses/by-sa/3.0/"))
+                      (img (@ (alt "Creative Commons License")
+                              (style "border-width:0")
+                              (src "http://i.creativecommons.org/l/by-sa/3.0/80x15.png"))))
+                   (span (@ (xmlns:dct "http://purl.org/dc/terms/")
+                            (href "http://purl.org/dc/dcmitype/StillImage")
+                            (property "dct:title")
+                            (rel "dct:type"))
+                         ,(post-ref post 'title))
+                   " by "
+                   (a (@ (xmlns:cc "http://creativecommons.org/ns#")
+                         (href "http://elephly.net")
+                         (property "cc:attributionName")
+                         (rel "cc:attributionURL"))
+                      "Ricardo Wurmus")
+                   " is licensed under a "
+                   (a (@ (rel "license")
+                         (href "http://creativecommons.org/licenses/by-sa/3.0/"))
+                      "Creative Commons Attribution-ShareAlike 3.0 Unported License")))
+        '())))
+
+
+
+(define (drop-extension file-name)
+  (string-join
+   (drop-right (string-split file-name #\.) 1) ""))
+
+
+(define (post/file-base-name post)
+  (drop-extension (basename (post-file-name post))))
+
+
+(define* (read-page reader file-name layout target)
+  "Read a page object from FILE-NAME using READER and wrap it in LAYOUT."
+  (let-values (((metadata sxml) ((reader-proc reader) file-name)))
+    (make-page target
+               (layout #f (assoc-ref metadata 'title) sxml) ; site is #f
+               sxml->html)))
+
+
+(define* (wrap-pages directory dest layout readers)
+  "Read all files in DIRECTORY, wrap them with the given LAYOUT and
+place them in the directory DEST."
+  (define enter? (const #t))
+
+  ;; remove "directory" from the front of "file-name", prepend "dest"
+  (define (leaf file-name stat memo)
+    (let* ((reader      (find (cut reader-match? <> file-name) readers))
+           (base-length (length (file-name-components directory)))
+           (dest*       (file-name-components dest))
+           (file-name*  (file-name-components file-name))
+           (target      (join-file-name-components
+                         (append dest* (drop file-name* base-length))))
+           (target-name (string-append (drop-extension target) ".html")))
+      (if reader
+          (cons (read-page reader file-name default-layout target-name) memo)
+          (error "no reader available for page: " file-name))))
+
+  (define (noop file-name stat memo) memo)
+
+  (define (err file-name stat errno memo)
+    (error "layout processing failed with errno: " file-name errno))
+
+  (file-system-fold enter? leaf noop noop noop err '() directory))
+
+
+(define* (latest-blog-post #:key theme)
+  "Return a builder procedure that copies the latest blog post to posts/latest.html."
+  (lambda (site posts)
+    (make-page "posts/latest.html"
+               ((@@ (haunt builder blog) render-post)
+                theme
+                site
+                (first (posts/reverse-chronological posts)))
+               sxml->html)))
+
+(define* (pin-blog-post file-name pinned-name #:key theme)
+  "Return a builder procedure that copies FILE-NAME as PINNED-NAME."
+  (lambda (site posts)
+    (make-page pinned-name
+               ((@@ (haunt builder blog) render-post) theme site
+                (find (lambda (post)
+                        (equal? (post-file-name post) file-name))
+                      posts))
+               sxml->html)))
+
+(define* (tag-pages #:key
+                    (theme elephly-theme)
+                    (prefix "posts/")
+                    (filter posts/reverse-chronological))
+  "Return a builder procedure that renders a list page for every tag
+used in a post.  All arguments are optional:
+
+PREFIX: The directory in which to write the posts
+FILTER: The procedure called to manipulate the posts list before rendering"
+  (lambda (site posts)
+    (define (tag-list tag posts all-posts)
+      (define (render-list title posts prefix)
+        (let ((body ((theme-list-template theme) site title posts prefix all-posts tag)))
+          ((theme-layout theme) site title body)))
+      (make-page (string-append "tags/" tag ".html")
+                 (render-list (string-append "Posts tagged ‘" tag "’")
+                              (filter posts)
+                              prefix)
+                 sxml->html))
+    (let ((tag-groups (posts/group-by-tag posts)))
+      (map (match-lambda
+            ((tag . tagged-posts) (tag-list tag tagged-posts posts)))
+           tag-groups))))
+
+
+(define (tag-links posts)
+  "Generate an alphabetically sorted list of links to tagged posts.
+The link text consists of the tag name and the number of tagged posts
+in parentheses."
+  `(ul (@ (class "tags"))
+       ,(map (match-lambda
+              ((tag . posts)
+               `(li (a (@ (href ,(string-append "/tags/" tag ".html")))
+                       ,(string-append tag " (" (number->string (length posts)) ")")))))
+             ;; sort by tag
+             (sort (posts/group-by-tag posts)
+                   (lambda (a b) (string<? (car a) (car b)))))))
+
+(define (date->string* date)
+  "Convert DATE to human readable string."
+  (date->string date "~B ~e, ~Y"))
+
+
+
+(define (default-layout site title body)
+  `((doctype "html")
+    (head
+     (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
+     (meta (@ (http-equiv "Content-Language") (content "en")))
+     (meta (@ (name "author") (content "Ricardo Wurmus")))
+     (meta (@ (name "viewport") (content "width=device-width")))
+     (title ,(or title (if site (site-title site) "Rekado")))
+     (link (@ (rel "openid2.provider")
+              (href "https://openid.stackexchange.com/openid/provider")))
+     (link (@ (rel "openid2.local_id")
+              (href "https://openid.stackexchange.com/user/0f8f09d4-a2f3-429f-8752-b53a328c255c")))
+     (link (@ (rel "stylesheet")
+              (media "screen")
+              (type "text/css")
+              (href "/css/reset.css")))
+     (link (@ (rel "stylesheet")
+              (media "screen")
+              (type "text/css")
+              (href "/css/screen.css")))
+     (link (@ (rel "shortcut icon")
+              (href "http://elephly.net/favicon.ico")))
+     (script (@ (type "text/javascript") (src "/js/libs/jquery-1.6.2.min.js")))
+     (script (@ (type "text/javascript") (src "/js/deobfuscate.js")))
+     (script (@ (type "text/javascript") (src "/js/hyphenator/Hyphenator.js")))
+     (script (@ (type "text/javascript")) "Hyphenator.run();")
+     (script (@ (type "text/javascript") (src "/js/loadComments.js"))))
+    (body (@ (id "top"))
+          (div (@ (id "index"))
+               (a (@ (href "/") (title "show index"))
+                  (img (@ (alt "logo")
+                          (src "/images/logo.png")))))
+          (div (@ (id "page") (class "hyphenate"))
+               ,body))))
+
+
+(define elephly-theme
+  (theme #:name "Elephly"
+         #:layout default-layout
+         #:post-template  ; TODO: should also take "site" for "site-post-slug"
+         (lambda (post)
+           ;; TODO: similar version below for list-template
+           (define (post-uri post)
+             (string-append "/posts/" (%make-slug post) ".html"))
+           `((h1 (@ (class "donthyphenate")) ,(post-ref post 'title))
+             (div (@ (class "time"))
+                  (a (@ (href ,(post-uri post)))
+                     ,(date->string* (post-date post))))
+             ,(photo-snippet post)
+             ,(post-sxml post)
+             ,(flattr-snippet post)
+             ,(license-snippet post)
+             (p (@ (class "back"))
+                (a (@ (href "/posts"))
+                   "← other posts"))
+             (div (@ (id "disqus_thread")))
+             (a (@ (id "loadComments") (href "javascript:loadComments()"))
+                "Click to load Disqus comments")))
+         #:list-template
+         (lambda* (site title posts prefix #:optional all-posts tag)
+           (define (post-uri post)
+             (string-append "/" (or prefix "") (site-post-slug site post) ".html"))
+           `((h1 (@ (class "donthyphenate"))
+                 ,title
+                 ,(if tag
+                      `(a (@ (href ,(string-append "/feeds/tags/" tag ".xml")))
+                          (img (@ (class "feed-icon")
+                                  (src "/images/feed.png")
+                                  (alt "subscribe to atom feed"))))
+                               '()))
+             (ul (@ (class "archive"))
+              ,@(map (lambda (post)
+                       `(li
+                         (a (@ (href ,(post-uri post)))
+                            ,(post-ref post 'title))))
+                     posts))
+             (h2 "All tags")
+             ;; TODO: I really want this to be computed only once for
+             ;; all posts
+             ,(tag-links (or all-posts posts))
+             ,(if tag
+                  '(a (@ (href "/posts"))
+                      "← all posts")
+                  '())))))
+
+
+;; needed for post template, because the site is not passed to the
+;; layout function
+(define %make-slug post/file-base-name)
+
+(site #:title "Rekado"
+      #:domain "elephly.net"
+      #:default-metadata
+      '((author . "Ricardo Wurmus")
+        (email  . "rekado+web@elephly.net"))
+      #:make-slug %make-slug
+      #:readers (list skribe-reader html-reader)
+      #:builders (list (lambda (args . rest)
+                         (wrap-pages "non-posts" "." default-layout
+                                     (list skribe-reader html-reader)))
+                       (lambda _
+                         (directory-assets "static" "."))
+                       (blog #:theme elephly-theme
+                             #:prefix "posts/")
+                       (tag-pages #:theme elephly-theme
+                                  #:prefix "posts/")
+                       (latest-blog-post #:theme elephly-theme)
+                       (pin-blog-post "posts/2010-03-28-elephly.skr"
+                                      "elephly.html"
+                                      #:theme elephly-theme)
+                       (pin-blog-post "posts/2010-03-23-fur-man.skr"
+                                      "fur-man.html"
+                                      #:theme elephly-theme)
+                       (atom-feed)
+                       (atom-feeds-by-tag)))