;; -*- geiser-scheme-implementation: guile -*- ;;; Bootstrappable.org website ;;; Copyright © 2016 Ricardo Wurmus ;;; ;;; 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 ;;; . ;; 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 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://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") ".")) (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 "http://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")))) `(begin (div (@ (id "banner-slim")) (a (@ (href "/")) (img (@ (alt "A boot pulled up by its straps.") (src "/images/banner-slim.svg"))))) (h1 ,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 "http://bootstrappable.org/blog" #:default-metadata '((author . "Ricardo Wurmus") (email . "rekado@elephly.net")) #:make-slug %make-slug #:readers (list skribe-reader html-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))) (lambda _ (directory-assets "static" (const #t) ".")) (blog #:theme bootstrappable-theme #:prefix "blog/") (atom-feed) (atom-feeds-by-tag)))