path: root/haunt.scm

;; -*- geiser-scheme-implementation: guile -*-

(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
             (haunt reader)
             (haunt reader skribe)
             (haunt reader commonmark)
             (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-skribe-reader #:modules '((haunt skribe utils)
                                  (haunt utils)
                                  (skribe-utils))))


(define (photo-snippet post)
  ;; TODO: derive alt-text from "photo" metadata
  (let ((meta (post-ref post 'photo)))
    (if meta
        `(img (@ (class "stretch full")
                 (src ,(string-append "/images/posts/" meta))))
        '())))

;; 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-collection-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 "https://elephly.net/favicon.ico")))
     (script (@ (type "text/javascript") (src "/js/deobfuscate.js")))
     (script (@ (type "text/javascript") (src "/js/hyphenator/Hyphenator.js")))
     (script (@ (type "text/javascript")) "Hyphenator.run();"))
    (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 collection-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)
             ,(license-snippet post)
             (p (@ (class "back"))
                (a (@ (href "/posts"))
                   "← other posts"))
             (div (@ (id "comments"))
              (p "Comments?  Then send me an email!  Interesting comments may be published here."))))
         #:collection-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 "http://elephly.net"
      #:default-metadata
      '((author . "Ricardo Wurmus")
        (email  . "rekado+web@elephly.net"))
      #:make-slug %make-slug
      #:readers (list commonmark-reader skribe-reader html-reader)
      #:builders (list (lambda (args . rest)
                         (wrap-pages "non-posts" "." default-layout
                                     (list skribe-reader html-reader)))
                       (lambda _
                         (directory-assets "static" (const #t) "."))
                       (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 #:blog-prefix "/posts")
                       (atom-feeds-by-tag #:blog-prefix "/posts")))