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