246 lines
9.2 KiB
Scheme
246 lines
9.2 KiB
Scheme
;; -*- 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)))
|