2016-12-15 16:33:35 +01:00
|
|
|
|
;; -*- geiser-scheme-implementation: guile -*-
|
|
|
|
|
;;; Bootstrappable.org website
|
2019-09-09 17:33:10 +02:00
|
|
|
|
;;; Copyright © 2016, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
|
2018-12-13 18:32:48 +01:00
|
|
|
|
;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
|
|
|
|
|
;;; Copyright © 2018 Gábor Boskovits <boskovits@gmail.com>
|
2016-12-15 16:33:35 +01:00
|
|
|
|
;;;
|
|
|
|
|
;;; 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.
|
|
|
|
|
;;;
|
|
|
|
|
;;; GuixSD 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
|
|
|
|
|
;;; <http://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)
|
2018-12-12 16:32:03 +01:00
|
|
|
|
(haunt reader commonmark)
|
2016-12-15 16:33:35 +01:00
|
|
|
|
(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"))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
2016-12-19 11:31:03 +01:00
|
|
|
|
(define footer
|
|
|
|
|
`(footer
|
|
|
|
|
"Made with " (span (@ (class "highlight")) "♥")
|
|
|
|
|
" by "
|
|
|
|
|
(a (@ (href "/who.html"))
|
|
|
|
|
"humans")
|
|
|
|
|
" and powered by "
|
|
|
|
|
(a (@ (href "https://gnu.org/software/guile"))
|
|
|
|
|
"GNU Guile") ". "
|
|
|
|
|
(a (@ (href "http://git.savannah.gnu.org/cgit/guix/bootstrappable.git/"))
|
|
|
|
|
"Source code")
|
|
|
|
|
" under the "
|
|
|
|
|
(a (@ (href "https://gnu.org/licenses/agpl-3.0.html"))
|
|
|
|
|
"GNU AGPL") "."))
|
|
|
|
|
|
2018-12-13 18:32:48 +01:00
|
|
|
|
(define top-level-titles
|
|
|
|
|
'(("Benefits" . "/benefits.html")
|
|
|
|
|
("Best Practises" . "/best-practises.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)))
|
|
|
|
|
|
2016-12-15 16:33:35 +01:00
|
|
|
|
(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")
|
2019-09-09 17:33:10 +02:00
|
|
|
|
(href "//bootstrappable.org/favicon.ico"))))
|
2016-12-15 16:33:35 +01:00
|
|
|
|
(body (@ (id "top"))
|
|
|
|
|
,(if big-banner?
|
|
|
|
|
'(div (@ (id "banner"))
|
|
|
|
|
(img (@ (alt "A boot pulled up by its straps.")
|
|
|
|
|
(src "/images/banner.svg"))))
|
2018-12-12 16:32:21 +01:00
|
|
|
|
`(div (@ (id "banner-slim"))
|
|
|
|
|
(a (@ (href "/"))
|
|
|
|
|
(img (@ (alt "A boot pulled up by its straps.")
|
|
|
|
|
(src "/images/banner-slim.svg"))))))
|
2018-12-13 18:32:48 +01:00
|
|
|
|
(nav (@ (id "menu"))
|
|
|
|
|
,(menu title))
|
2016-12-15 16:33:35 +01:00
|
|
|
|
(div (@ (id "page"))
|
2016-12-19 11:31:03 +01:00
|
|
|
|
,body)
|
|
|
|
|
,footer))))
|
2016-12-15 16:33:35 +01:00
|
|
|
|
|
|
|
|
|
(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 "http://bootstrappable.org/blog"
|
|
|
|
|
#:default-metadata
|
|
|
|
|
'((author . "Ricardo Wurmus")
|
|
|
|
|
(email . "rekado@elephly.net"))
|
|
|
|
|
#:make-slug %make-slug
|
2018-12-12 16:32:03 +01:00
|
|
|
|
#:readers (list skribe-reader html-reader commonmark-reader)
|
2016-12-15 16:33:35 +01:00
|
|
|
|
#:builders (list (lambda _
|
|
|
|
|
(read-page skribe-reader
|
|
|
|
|
"index.skr"
|
|
|
|
|
index-layout
|
|
|
|
|
"index.html"))
|
|
|
|
|
(lambda (args . rest)
|
|
|
|
|
(wrap-pages "pages" "." default-layout
|
2018-12-12 16:32:03 +01:00
|
|
|
|
(list skribe-reader
|
|
|
|
|
html-reader
|
|
|
|
|
commonmark-reader)))
|
2016-12-15 16:33:35 +01:00
|
|
|
|
(lambda _
|
|
|
|
|
(directory-assets "static" (const #t) "."))
|
|
|
|
|
(blog #:theme bootstrappable-theme
|
|
|
|
|
#:prefix "blog/")
|
|
|
|
|
(atom-feed)
|
|
|
|
|
(atom-feeds-by-tag)))
|