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