haunt.scm

   1 ;; -*- geiser-scheme-implementation: guile -*-
   2
   3 (use-modules (srfi srfi-1)  ; list stuff
   4              (srfi srfi-11) ; let-values
   5              (srfi srfi-19) ; date functions
   6              (srfi srfi-26) ; cut
   7              (ice-9 ftw)    ; file system
   8              (ice-9 match)  ; match-lambda
   9              (haunt reader)
  10              (haunt reader skribe)
  11              (haunt reader commonmark)
  12              (haunt site)
  13              (haunt asset)
  14              (haunt post) ;post-file-name
  15              (haunt page)
  16              (haunt html) ;sxml->html
  17              (haunt utils) ;absolute-file-name
  18              (haunt builder blog)
  19              (haunt builder atom))
  20
  21 \f
  22 (define skribe-reader
  23   (make-skribe-reader #:modules '((haunt skribe utils)
  24                                   (haunt utils)
  25                                   (skribe-utils))))
  26
  27 \f
  28 (define (photo-snippet post)
  29   ;; TODO: derive alt-text from "photo" metadata
  30   (let ((meta (post-ref post 'photo)))
  31     (if meta
  32         `(img (@ (class "stretch full")
  33                  (src ,(string-append "/images/posts/" meta))))
  34         '())))
  35
  36 ;; TODO: use license
  37 (define (license-snippet post)
  38   (let ((meta (post-ref post 'license)))
  39     (if meta
  40         `(div (@ (class "fineprint"))
  41               (div (@ (class "license"))
  42                    (a (@ (rel "license")
  43                          (href "http://creativecommons.org/licenses/by-sa/3.0/"))
  44                       (img (@ (alt "Creative Commons License")
  45                               (style "border-width:0")
  46                               (src "http://i.creativecommons.org/l/by-sa/3.0/80x15.png"))))
  47                    (span (@ (xmlns:dct "http://purl.org/dc/terms/")
  48                             (href "http://purl.org/dc/dcmitype/StillImage")
  49                             (property "dct:title")
  50                             (rel "dct:type"))
  51                          ,(post-ref post 'title))
  52                    " by "
  53                    (a (@ (xmlns:cc "http://creativecommons.org/ns#")
  54                          (href "http://elephly.net")
  55                          (property "cc:attributionName")
  56                          (rel "cc:attributionURL"))
  57                       "Ricardo Wurmus")
  58                    " is licensed under a "
  59                    (a (@ (rel "license")
  60                          (href "http://creativecommons.org/licenses/by-sa/3.0/"))
  61                       "Creative Commons Attribution-ShareAlike 3.0 Unported License")))
  62         '())))
  63
  64
  65 \f
  66 (define (drop-extension file-name)
  67   (string-join
  68    (drop-right (string-split file-name #\.) 1) ""))
  69
  70
  71 (define (post/file-base-name post)
  72   (drop-extension (basename (post-file-name post))))
  73
  74
  75 (define* (read-page reader file-name layout target)
  76   "Read a page object from FILE-NAME using READER and wrap it in LAYOUT."
  77   (let-values (((metadata sxml) ((reader-proc reader) file-name)))
  78     (make-page target
  79                (layout #f (assoc-ref metadata 'title) sxml) ; site is #f
  80                sxml->html)))
  81
  82
  83 (define* (wrap-pages directory dest layout readers)
  84   "Read all files in DIRECTORY, wrap them with the given LAYOUT and
  85 place them in the directory DEST."
  86   (define enter? (const #t))
  87
  88   ;; remove "directory" from the front of "file-name", prepend "dest"
  89   (define (leaf file-name stat memo)
  90     (let* ((reader      (find (cut reader-match? <> file-name) readers))
  91            (base-length (length (file-name-components directory)))
  92            (dest*       (file-name-components dest))
  93            (file-name*  (file-name-components file-name))
  94            (target      (join-file-name-components
  95                          (append dest* (drop file-name* base-length))))
  96            (target-name (string-append (drop-extension target) ".html")))
  97       (if reader
  98           (cons (read-page reader file-name default-layout target-name) memo)
  99           (error "no reader available for page: " file-name))))
 100
 101   (define (noop file-name stat memo) memo)
 102
 103   (define (err file-name stat errno memo)
 104     (error "layout processing failed with errno: " file-name errno))
 105
 106   (file-system-fold enter? leaf noop noop noop err '() directory))
 107
 108
 109 (define* (latest-blog-post #:key theme)
 110   "Return a builder procedure that copies the latest blog post to posts/latest.html."
 111   (lambda (site posts)
 112     (make-page "posts/latest.html"
 113                ((@@ (haunt builder blog) render-post)
 114                 theme
 115                 site
 116                 (first (posts/reverse-chronological posts)))
 117                sxml->html)))
 118
 119 (define* (pin-blog-post file-name pinned-name #:key theme)
 120   "Return a builder procedure that copies FILE-NAME as PINNED-NAME."
 121   (lambda (site posts)
 122     (make-page pinned-name
 123                ((@@ (haunt builder blog) render-post) theme site
 124                 (find (lambda (post)
 125                         (equal? (post-file-name post) file-name))
 126                       posts))
 127                sxml->html)))
 128
 129 (define* (tag-pages #:key
 130                     (theme elephly-theme)
 131                     (prefix "posts/")
 132                     (filter posts/reverse-chronological))
 133   "Return a builder procedure that renders a list page for every tag
 134 used in a post.  All arguments are optional:
 135
 136 PREFIX: The directory in which to write the posts
 137 FILTER: The procedure called to manipulate the posts list before rendering"
 138   (lambda (site posts)
 139     (define (tag-list tag posts all-posts)
 140       (define (render-list title posts prefix)
 141         (let ((body ((theme-collection-template theme)
 142                      site title posts prefix all-posts tag)))
 143           ((theme-layout theme) site title body)))
 144       (make-page (string-append "tags/" tag ".html")
 145                  (render-list (string-append "Posts tagged ‘" tag "’")
 146                               (filter posts)
 147                               prefix)
 148                  sxml->html))
 149     (let ((tag-groups (posts/group-by-tag posts)))
 150       (map (match-lambda
 151             ((tag . tagged-posts) (tag-list tag tagged-posts posts)))
 152            tag-groups))))
 153
 154
 155 (define (tag-links posts)
 156   "Generate an alphabetically sorted list of links to tagged posts.
 157 The link text consists of the tag name and the number of tagged posts
 158 in parentheses."
 159   `(ul (@ (class "tags"))
 160        ,(map (match-lambda
 161               ((tag . posts)
 162                `(li (a (@ (href ,(string-append "/tags/" tag ".html")))
 163                        ,(string-append tag " (" (number->string (length posts)) ")")))))
 164              ;; sort by tag
 165              (sort (posts/group-by-tag posts)
 166                    (lambda (a b) (string<? (car a) (car b)))))))
 167
 168 (define (date->string* date)
 169   "Convert DATE to human readable string."
 170   (date->string date "~B ~e, ~Y"))
 171
 172
 173 \f
 174 (define (default-layout site title body)
 175   `((doctype "html")
 176     (head
 177      (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
 178      (meta (@ (http-equiv "Content-Language") (content "en")))
 179      (meta (@ (name "author") (content "Ricardo Wurmus")))
 180      (meta (@ (name "viewport") (content "width=device-width")))
 181      (title ,(or title (if site (site-title site) "Rekado")))
 182      (link (@ (rel "openid2.provider")
 183               (href "https://openid.stackexchange.com/openid/provider")))
 184      (link (@ (rel "openid2.local_id")
 185               (href "https://openid.stackexchange.com/user/0f8f09d4-a2f3-429f-8752-b53a328c255c")))
 186      (link (@ (rel "stylesheet")
 187               (media "screen")
 188               (type "text/css")
 189               (href "/css/reset.css")))
 190      (link (@ (rel "stylesheet")
 191               (media "screen")
 192               (type "text/css")
 193               (href "/css/screen.css")))
 194      (link (@ (rel "shortcut icon")
 195               (href "https://elephly.net/favicon.ico")))
 196      (script (@ (type "text/javascript") (src "/js/deobfuscate.js")))
 197      (script (@ (type "text/javascript") (src "/js/hyphenator/Hyphenator.js")))
 198      (script (@ (type "text/javascript")) "Hyphenator.run();"))
 199     (body (@ (id "top"))
 200           (div (@ (id "index"))
 201                (a (@ (href "/") (title "show index"))
 202                   (img (@ (alt "logo")
 203                           (src "/images/logo.png")))))
 204           (div (@ (id "page") (class "hyphenate"))
 205                ,body))))
 206
 207
 208 (define elephly-theme
 209   (theme #:name "Elephly"
 210          #:layout default-layout
 211          #:post-template  ; TODO: should also take "site" for "site-post-slug"
 212          (lambda (post)
 213            ;; TODO: similar version below for collection-template
 214            (define (post-uri post)
 215              (string-append "/posts/" (%make-slug post) ".html"))
 216            `((h1 (@ (class "donthyphenate")) ,(post-ref post 'title))
 217              (div (@ (class "time"))
 218                   (a (@ (href ,(post-uri post)))
 219                      ,(date->string* (post-date post))))
 220              ,(photo-snippet post)
 221              ,(post-sxml post)
 222              ,(license-snippet post)
 223              (p (@ (class "back"))
 224                 (a (@ (href "/posts"))
 225                    "← other posts"))
 226              (div (@ (id "comments"))
 227               (p "Comments?  Then send me an email!  Interesting comments may be published here."))))
 228          #:collection-template
 229          (lambda* (site title posts prefix #:optional all-posts tag)
 230            (define (post-uri post)
 231              (string-append "/" (or prefix "") (site-post-slug site post) ".html"))
 232            `((h1 (@ (class "donthyphenate"))
 233                  ,title
 234                  ,(if tag
 235                       `(a (@ (href ,(string-append "/feeds/tags/" tag ".xml")))
 236                           (img (@ (class "feed-icon")
 237                                   (src "/images/feed.png")
 238                                   (alt "subscribe to atom feed"))))
 239                                '()))
 240              (ul (@ (class "archive"))
 241               ,@(map (lambda (post)
 242                        `(li
 243                          (a (@ (href ,(post-uri post)))
 244                             ,(post-ref post 'title))))
 245                      posts))
 246              (h2 "All tags")
 247              ;; TODO: I really want this to be computed only once for
 248              ;; all posts
 249              ,(tag-links (or all-posts posts))
 250              ,(if tag
 251                   '(a (@ (href "/posts"))
 252                       "← all posts")
 253                   '())))))
 254
 255
 256 ;; needed for post template, because the site is not passed to the
 257 ;; layout function
 258 (define %make-slug post/file-base-name)
 259
 260 (site #:title "Rekado"
 261       #:domain "http://elephly.net"
 262       #:default-metadata
 263       '((author . "Ricardo Wurmus")
 264         (email  . "rekado+web@elephly.net"))
 265       #:make-slug %make-slug
 266       #:readers (list commonmark-reader skribe-reader html-reader)
 267       #:builders (list (lambda (args . rest)
 268                          (wrap-pages "non-posts" "." default-layout
 269                                      (list skribe-reader html-reader)))
 270                        (lambda _
 271                          (directory-assets "static" (const #t) "."))
 272                        (blog #:theme elephly-theme
 273                              #:prefix "posts/")
 274                        (tag-pages #:theme elephly-theme
 275                                   #:prefix "posts/")
 276                        (latest-blog-post #:theme elephly-theme)
 277                        (pin-blog-post "posts/2010-03-28-elephly.skr"
 278                                       "elephly.html"
 279                                       #:theme elephly-theme)
 280                        (pin-blog-post "posts/2010-03-23-fur-man.skr"
 281                                       "fur-man.html"
 282                                       #:theme elephly-theme)
 283                        (atom-feed #:blog-prefix "/posts")
 284                        (atom-feeds-by-tag #:blog-prefix "/posts")))