Initial commit.

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)))