bootstrappable/haunt.scm

;; -*- geiser-scheme-implementation: guile -*-
;;; Bootstrappable.org website
;;; Copyright © 2016, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2018 Gábor Boskovits <boskovits@gmail.com>
;;;
;;; This file is part of the Bootstrappable.org website.
;;;
;;; The Bootstrappable.org website is free software; you can
;;; redistribute it and/or modify it under the terms of the Affero
;;; General Public License as published by the Free Software
;;; Foundation; either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; The Bootstrappable.org website is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
;;; Public License for more details.
;;;
;;; You should have received a copy of the Affero General Public
;;; License along with these source files.  If not, see
;;; <https://www.gnu.org/licenses/>.

;; This is a build file for Haunt.

(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 commonmark)
             (haunt reader skribe)
             (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 (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 blog/latest.html."
  (lambda (site posts)
    (make-page "blog/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 (date->string* date)
  "Convert DATE to human readable string."
  (date->string date "~B ~e, ~Y"))



(define footer
  `(footer
    "Made with " (span (@ (class "highlight")) "♥")
    " by "
    (a (@ (href "/who.html"))
       "humans")
    " and powered by "
    (a (@ (href "https://www.gnu.org/software/guile/"))
       "GNU Guile") ".  "
    (a (@ (href "https://git.savannah.gnu.org/cgit/guix/bootstrappable.git/"))
       "Source code")
    " under the "
    (a (@ (href "https://www.gnu.org/licenses/agpl-3.0.html"))
       "GNU AGPL") "."))

(define top-level-titles
  '(("Benefits" . "/benefits.html")
    ("Best Practices" . "/best-practices.html")
    ("Projects" . "/projects.html")
    ("Contact" . "/who.html")))

(define (menu title)
  `(ul ,@(map (lambda (arg)
		(let ((name (car arg))
		      (link (cdr arg)))
		 `(li (a (@ (href ,link) (class ,(if (equal? name title) "active" "inactive"))) ,name))))
	      top-level-titles)))

(define (make-layout big-banner?)
  (lambda (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) "Bootstrappable --- towards trustable trust")))
       (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 "//bootstrappable.org/favicon.ico"))))
      (body (@ (id "top"))
            ,(if big-banner?
                 '(div (@ (id "banner"))
                       (img (@ (alt "A boot pulled up by its straps.")
                               (src "/images/banner.svg"))))
                 `(div (@ (id "banner-slim"))
                       (a (@ (href "/"))
                          (img (@ (alt "A boot pulled up by its straps.")
                                  (src "/images/banner-slim.svg"))))))
	    (nav (@ (id "menu"))
		 ,(menu title))
            (div (@ (id "page"))
                 ,body)
            ,footer))))

(define default-layout (make-layout #f))
(define index-layout (make-layout #t))

(define bootstrappable-theme
  (theme #:name "Bootstrappable"
         #: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 "/blog/" (%make-slug post) ".html"))
           `((h1 ,(post-ref post 'title))
             (div (@ (class "time"))
                  (a (@ (href ,(post-uri post)))
                     ,(date->string* (post-date post))))
             (p (@ (class "back"))
                (a (@ (href "/blog"))
                   "← other posts"))))
         #: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 ,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))))))


;; needed for post template, because the site is not passed to the
;; layout function
(define %make-slug post/file-base-name)

(site #:title "Bootstrappable"
      #:domain "bootstrappable.org"
      #:default-metadata
      '((author . "Ricardo Wurmus")
        (email  . "rekado@elephly.net"))
      #:make-slug %make-slug
      #:readers (list skribe-reader html-reader commonmark-reader)
      #:builders (list (lambda _
                         (read-page skribe-reader
                                    "index.skr"
                                    index-layout
                                    "index.html"))
                       (lambda (args . rest)
                         (wrap-pages "pages" "." default-layout
                                     (list skribe-reader
                                           html-reader
                                           commonmark-reader)))
                       (lambda _
                         (directory-assets "static" (const #t) "."))
                       (blog #:theme bootstrappable-theme
                             #:prefix "blog/")
                       (atom-feed)
                       (atom-feeds-by-tag)))