From d85ece03edc3669726b50e9c8c193e5626268ea8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 10 Apr 2021 15:48:17 +0200
Subject: Add skeleton of a Haunt web site.

---
 website/haunt.scm | 125 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 125 insertions(+)
 create mode 100644 website/haunt.scm

(limited to 'website/haunt.scm')

diff --git a/website/haunt.scm b/website/haunt.scm
new file mode 100644
index 0000000..18a7b2d
--- /dev/null
+++ b/website/haunt.scm
@@ -0,0 +1,125 @@
+;;; The GNU Assembly Web Site
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This program is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program 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 GNU General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (haunt asset)
+             (haunt site)
+             (haunt page)
+             (haunt html)
+             (haunt builder assets)
+             (haunt reader)
+             (haunt reader commonmark)
+             (srfi srfi-71))
+
+(define %cwd
+  (and=> (assq-ref (current-source-location) 'filename)
+         dirname))
+
+(define (base-url . location)
+  (string-concatenate (cons "" location)))
+
+(define (image-url location)
+  (base-url "/static/images" location))
+
+(define (css-url location)
+  (base-url "/static/css" location))
+
+(define* (base-layout body #:key (title "") (meta '())
+                      (posts '()) site)
+  `((doctype "html")
+    (html (@ (lang "en"))
+          (head
+           (meta (@ (http-equiv "Content-Type")
+                    (content "text/html; charset=utf-8")))
+           (link (@ (rel "icon")
+                    (type "image/x-icon")
+                    (href ,(image-url "/favicon.png"))))
+           (link (@ (rel "stylesheet")
+                    (href ,(css-url "/main.css"))
+                    (type "text/css")
+                    (media "screen")))
+           (title ,title))
+          (body
+           (div (@ (id "header")
+                   ,@(if (assoc-ref meta 'frontpage)
+                         '((class "frontpage"))
+                         '()))
+                (div (@ (id "header-inner")
+                        (class "width-control"))
+                     (a (@ (href ,(base-url "/")))
+                        (img (@ (class "logo")
+                                (src ,(image-url (if (assoc-ref meta 'frontpage)
+                                                     "/logo.png"
+                                                     "/logo-small.png"))))))
+                     ,@(if (assoc-ref meta 'frontpage)
+                           '((div (@ (class "baseline"))
+                                  "Software for human empowerment."))
+                           '())))
+           (div (@ (id "menubar")
+                   (class "width-control"))
+                (ul
+                 (li (a (@ (href ,(base-url "/")))
+                        "About"))
+                 (li (a (@ (href ,(base-url "/blog")))
+                        "Blog"))
+                 (li (a (@ (href ,(base-url "/blog/feed.xml")))
+                        (img (@ (alt "Atom feed")
+                                (src ,(image-url "/feed.png"))))))))
+
+           (div (@ (id "content")
+                   (class "width-control"))
+                (div (@ (id "content-inner"))
+                     (article ,body)))
+
+           (div (@ (id "footer-box")
+                   (class "width-control"))
+                (p (a (@ (href "https://wiki.gnu.tools/git/")) ;FIXME
+                      "Source of this site")))))))
+
+(define read-markdown
+  (reader-proc commonmark-reader))
+
+(define (read-markdown-page file posts site)
+  "Read the CommonMark page from FILE.  Return its final SXML
+representation."
+  (let ((meta body (read-markdown (string-append %cwd "/" file))))
+    (base-layout `(div (@ (class "post"))
+                       (div (@ (class "post-body")) ,body))
+                 #:title (string-append "The GNU Assembly — "
+                                        (assoc-ref meta 'title))
+                 #:meta meta
+                 #:posts posts
+                 #:site site)))
+
+(define (static-pages)
+  "Return the list of static web pages."
+  (define (markdown-page html md)
+    (lambda (site posts)
+      (make-page html (read-markdown-page md posts site)
+                 sxml->html)))
+
+  (list (markdown-page "index.html" "index.md")
+        (markdown-page "/en/documents/social-contract/index.html"
+                       "social-contract.md")))
+
+
+(site #:title "The GNU Assembly"
+      #:domain "gnu.tools"
+      #:default-metadata
+      '((author . "The GNU Assembly")
+        (email  . "assembly@lists.gnu.tools"))
+      #:readers (list commonmark-reader)
+      #:builders (cons (static-directory "static")
+                       (static-pages)))
-- 
cgit v1.2.1