From 602d55d01c3d3d30f9d1708423f28a3d79dd67fe Mon Sep 17 00:00:00 2001 From: Mark Wielaard Date: Tue, 13 Apr 2021 02:09:23 +0200 Subject: Move website to gnu-tools-website repo --- website/haunt.scm | 265 ------------------------------------------------------ 1 file changed, 265 deletions(-) delete mode 100644 website/haunt.scm (limited to 'website/haunt.scm') diff --git a/website/haunt.scm b/website/haunt.scm deleted file mode 100644 index a230226..0000000 --- a/website/haunt.scm +++ /dev/null @@ -1,265 +0,0 @@ -;;; The GNU Assembly Web Site -;;; Copyright © 2021 Ludovic Courtès -;;; Copyright © 2021 Ricardo Wurmus -;;; -;;; 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 . - -(use-modules (haunt asset) - (haunt site) - (haunt page) - (haunt html) - (haunt post) - (haunt builder assets) - (haunt builder blog) - (haunt builder atom) - (haunt reader) - (haunt reader commonmark) - (srfi srfi-19) ;dates - (srfi srfi-26) ;cut - (srfi srfi-71) ;multiple-value let - (ice-9 match)) - -(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) - (define (menubar where) - (let ((locations - '(("about" "About" "/") - ("software" "Software" "/en/software") - ("documents" "Documents" "/en/documents") - ("contribute" "contribute" "/en/contribute") - ("blog" "Blog" "/en/blog")))) - `(div (@ (id "menubar") - (class "width-control")) - (ul - ,@(map (match-lambda - ((key text path) - (if (and where (string=? where key)) - `(li (@ (class "selected")) - (span ,text)) - `(li (a (@ (href ,(base-url path))) - ,text))))) - locations) - (li (a (@ (href ,(base-url "/en/blog/feed.xml"))) - (img (@ (alt "Atom feed") - (src ,(image-url "/feed.png")))))))))) - (define front-page? - (assoc-ref meta 'frontpage)) - - `((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.svg")))) - (link (@ (rel "stylesheet") - (href ,(css-url "/main.css")) - (type "text/css") - (media "screen"))) - (title ,title)) - (body - ,@(if front-page? - '((@ (class "frontpage"))) - '()) - (div (@ (id "header")) - (div (@ (id "header-inner") - (class "width-control")) - (a (@ (href ,(base-url "/")) - (class ,(if front-page? - "logo" "logo small"))) - (img (@ (alt "The logo of the GNU Assembly") - (src ,(image-url (if front-page? - "/logo.svg" - "/logo-small.svg")))))) - - ;; Add the large-font welcoming message on the - ;; front page. - ,@(if front-page? - `((p (@ (id "heading") - (class "front-page-heading")) - "Welcome to the GNU Assembly! We write " - (a (@ (href "/en/documents/free-software")) - (emph "free software")) - " — software that empowers users, " - "giving them individual and collective control " - "over their computing, from the operating " - "system to applications.")) - `(,(menubar (assoc-ref meta 'menu)))))) - ,@(if front-page? - `(,(menubar "about")) - '()) - - (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/gnu-tools-wiki/tree/website")) ;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/index.html" - "documents.md") - (markdown-page "/en/software/index.html" - "software.md") - (markdown-page "/en/contribute/index.html" - "contribute.md") - (markdown-page "/en/documents/free-software/index.html" - "free-software.md") - (markdown-page "/en/documents/code-of-conduct/index.html" - "code-of-conduct.md") - (markdown-page "/en/documents/social-contract/index.html" - "social-contract.md"))) - - -;;; -;;; Blog. -;;; - -(define (post-url post site) - "Return the URL of POST, a Haunt blog post, for SITE." - (let ((date (post-date post))) - (base-url "/en/blog/" - (number->string (date-year date)) - "/" - (string-pad (number->string (date-month date)) - 2 #\0) - - ;; There's an implicit "/index.html" here. - "/" (site-post-slug site post)))) - -(define (summarize-post post uri) - (match (post-sxml post) - ((('p paragraph ...) _ ...) - `((p ,@paragraph) - (p (a (@ (href ,uri)) "Continue reading…")))) - (body - body))) - -(define* (post->sxml post #:key post-uri summarize?) - "Return the SXML for POST." - (define post-body* - (if summarize? - (cut summarize-post <> post-uri) - post-sxml)) - - `(div (@ (class "post")) - (h1 (@ (class "title")) - ,(if post-uri - `(a (@ (href ,post-uri)) - ,(post-ref post 'title)) - (post-ref post 'title))) - (div (@ (class "post-about")) - ,(post-ref post 'author) - " — " ,(date->string (post-date post) "~B ~e, ~Y")) - (hr) - (div (@ (class "post-body")) - ,(post-body* post)))) - -(define (page->sxml site title posts prefix) - "Return the SXML for the news page of SITE, containing POSTS." - `((div (@ (class "header")) - (div (@ (class "post-list")) - ,@(map (lambda (post) - (post->sxml post #:post-uri (post-url post site) - #:summarize? #t)) - posts))))) - -(define (post->page post site) - (make-page (string-append (post-url post site) "/index.html") - (render-post %theme site post) - sxml->html)) - -(define %theme - ;; Theme for the rendering of the news pages. - (theme #:name "The GNU Assembly" - #:layout (lambda (site title body) - (base-layout body - #:title - (string-append "The GNU Assembly — " - title))) - #:post-template post->sxml - #:collection-template page->sxml)) - - -(site #:title "The GNU Assembly" - #:domain "gnu.tools" - #:default-metadata - '((author . "The GNU Assembly") - (email . "assembly@lists.gnu.tools")) - #:readers (list commonmark-reader) - #:builders (append (list (static-directory "static")) - (static-pages) - - ;; Blog posts. - (list (lambda (site posts) - ;; Pages for each post. - (map (cut post->page <> site) posts)) - - (lambda (site posts) - ;; The main collection. - (make-page - "/en/blog/index.html" - (render-collection - %theme site - "The GNU Assembly — Blog" ;title - (posts/reverse-chronological posts) - "/en/blog") - sxml->html)) - - ;; Apparently the tags of Atom entries - ;; must be absolute URLs, hence this - ;; #:blog-prefix. - (atom-feed #:file-name "en/blog/feed.xml" - #:blog-prefix "https://gnu.tools/en/blog")))) -- cgit v1.2.1