summaryrefslogtreecommitdiff
path: root/haunt.scm
diff options
context:
space:
mode:
Diffstat (limited to 'haunt.scm')
-rw-r--r--haunt.scm211
1 files changed, 211 insertions, 0 deletions
diff --git a/haunt.scm b/haunt.scm
new file mode 100644
index 0000000..c5744c4
--- /dev/null
+++ b/haunt.scm
@@ -0,0 +1,211 @@
+;; -*- geiser-scheme-implementation: guile -*-
+;;; Bootstrappable.org website
+;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; 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)
+ (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 (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)))))
+
+(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)))
generated by cgit v1.2.3 (git 2.46.0) at 2024-11-21 11:36:31 +0000