Goodbye Hakyll, hello Haunt!

2 files changed, 359 insertions, 180 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)))
diff --git a/site.hs b/site.hs
deleted file mode 100644
index f854817..0000000
--- a/site.hs
+++ /dev/null
@@ -1,180 +0,0 @@
---------------------------------------------------------------------------------
-{-# LANGUAGE OverloadedStrings #-}
-import           Control.Applicative ((<$>))
-import           Data.Monoid         ((<>))
-import           Hakyll
-import           Data.Map as M
-import qualified Data.Set as S
-import           Data.Maybe          (fromMaybe)
-import           Text.Pandoc.Options
-
-config :: Configuration
-config = defaultConfiguration
-  { deployCommand =
-      "rsync -Havz _site/ rekado@elephly.net:/home/rekado/elephly.net" }
-
-myFeedConfiguration :: FeedConfiguration
-myFeedConfiguration = FeedConfiguration
-  { feedTitle       = "Rekado's website"
-  , feedDescription = "Music, words, and hacking"
-  , feedAuthorName  = "Rekado"
-  , feedAuthorEmail = "rekado+feed@elephly.net"
-  , feedRoot        = "http://elephly.net"
-  }
-
---------------------------------------------------------------------------------
-main :: IO ()
-main = hakyllWith config $ do
-    tags <- buildTags "posts/*.markdown" (fromCapture "tags/*.html")
-
-    match (    "js/libs/*"
-          .||. "js/hyphenator/*"
-          .||. "js/hyphenator/patterns/*"
-          .||. "js/*"
-          .||. "css/*.woff"
-          .||. "downies/*"
-          .||. "downies/music/*"
-          .||. "images/*"
-          .||. "images/posts/*"
-          .||. "images/posts/*/*"
-          .||. "favicon.ico"
-          .||. "rekado.pubkey"
-          ) $ do
-      route   idRoute
-      compile copyFileCompiler
-
-    match "css/*" $ do
-        route   idRoute
-        compile compressCssCompiler
-
-    -- place static markdown files in site root
-    match ( "static/*.markdown" .||. "static/*/*.markdown" ) $ do
-      route   $ setExtension "html"
-        `composeRoutes` gsubRoute "static/" (const "")
-      compile $ pandocCompiler
-        >>= loadAndApplyTemplate "templates/default.html" defaultContext
-        >>= relativizeUrls
-
-    -- place static html files in site root
-    match "static/*.html" $ do
-      route   $ gsubRoute "static/" (const "")
-      compile $ do
-        getResourceBody
-          >>= loadAndApplyTemplate "templates/default.html" defaultContext
-          >>= relativizeUrls
-
-    match "posts/*.markdown" $ do
-      route   $ setExtension "html"
-      compile defaultCompiler
-
-    -- direct links
-    match "posts/2010-03-28-elephly.markdown" $ version "direct" $  do
-      route   $ constRoute "elephly.html"
-      compile defaultCompiler
-
-    match "posts/2010-03-23-fur-man.markdown" $ version "direct" $  do
-      route   $ constRoute "fur-man.html"
-      compile defaultCompiler
-
-    -- blog post archive
-    create ["posts/index.html"] $ do
-      let title = "Archive"
-
-      route   idRoute
-      compile $ do
-        let archiveCtx =
-              constField "title" title <>
-              field "posts" (\_ -> postList "posts/*.markdown" recentFirst) <>
-              field "tags" (\_ -> renderTagList tags) <>
-              defaultContext
-
-        makeItem ""
-          >>= loadAndApplyTemplate "templates/archive.html" archiveCtx
-          >>= loadAndApplyTemplate "templates/default.html" archiveCtx
-          >>= relativizeUrls
-
-    create ["rss.xml"] $ postFeed renderRss
-    create ["atom.xml"] $ postFeed renderAtom
-
-    -- always show the most recent blog post
-    create ["posts/latest.html"] $ do
-      route idRoute
-      compile $ do
-        mostRecent <- fmap head . recentFirst =<< loadAllSnapshots "posts/*.markdown" "non-relative"
-        makeItem (itemBody mostRecent) >>= relativizeUrls
-
-
-    tagsRules tags $ \tag pattern -> do
-      let title = "Posts tagged &ldquo;" ++ tag ++ "&rdquo;"
-
-      route idRoute
-      compile $ do
-        let ctx = constField "title" title <>
-                  field "posts" (\_ -> postList pattern recentFirst) <>
-                  tagsField "tags" tags <>
-                  defaultContext
-
-        makeItem ""
-            >>= loadAndApplyTemplate "templates/archive.html" ctx
-            >>= loadAndApplyTemplate "templates/default.html" ctx
-            >>= relativizeUrls
-
-    match "templates/*" $ compile templateCompiler
-
-
---------------------------------------------------------------------------------
-postCtx :: Context String
-postCtx = dateField "date" "%B %e, %Y"
-          <> photoSnippet
-          <> flattrSnippet
-          <> licenseSnippet
-          <> defaultContext
-
--- If a post declares a certain key in the metadata header,
--- load the given template, otherwise ignore.
-snippet :: String -> String -> Identifier -> Context String
-snippet name key templatePath = field name $ \item -> do
-    metadata <- getMetadata (itemIdentifier item)
-    case M.lookup key metadata of
-      Just file -> itemBody <$> loadAndApplyTemplate templatePath postCtx item
-      _         -> return ""
-
-photoSnippet   = snippet "photo-snippet" "photo" "templates/photo.html"
-flattrSnippet  = snippet "flattr-snippet" "flattr" "templates/flattr.html"
-licenseSnippet = snippet "license-snippet" "license" "templates/license.html"
-
-postFeed renderer = do
-  route idRoute
-  compile $ do
-    let feedCtx = postCtx <> bodyField "description"
-    posts <- fmap (take 10) . recentFirst =<<
-      loadAllSnapshots "posts/*.markdown" "content"
-    renderer myFeedConfiguration feedCtx posts
-
---------------------------------------------------------------------------------
-postList :: Pattern -> ([Item String] -> Compiler [Item String]) -> Compiler String
-postList pattern sortFilter = do
-  posts   <- sortFilter =<< loadAll (pattern .&&. hasNoVersion)
-  itemTpl <- loadBody "templates/post-item.html"
-  list    <- applyTemplateList itemTpl postCtx posts
-  return list
-
-customPandocCompiler :: Compiler (Item String)
-customPandocCompiler =
-    pandocCompilerWith
-      (addRExt [Ext_pipe_tables] defaultHakyllReaderOptions)
-      (addWExt [Ext_pipe_tables] defaultHakyllWriterOptions)
-  where
-    addRExt es opts =
-      opts { readerExtensions = S.union (S.fromList es) (readerExtensions opts)
-           , readerSmart = True
-           }
-    addWExt es opts =
-      opts { writerExtensions = S.union (S.fromList es) (writerExtensions opts) }
-
-defaultCompiler = customPandocCompiler
-  >>= loadAndApplyTemplate "templates/post.html"    postCtx
-  >>= saveSnapshot "content"
-  >>= loadAndApplyTemplate "templates/default.html" postCtx
-  >>= saveSnapshot "non-relative"
-  >>= relativizeUrls