04/04: website: Add "News" page.

[Ludovic Courtès]

civodul pushed a commit to branch wip-haunt
in repository guix-artwork.

commit 16a9d331dc1ab7accae2983387bb245de8e98b39
Author: Ludovic Courtès <address@hidden>
Date:   Wed Oct 26 01:16:53 2016 +0200

    website: Add "News" page.
    
    * website/www/news.scm: New file.
    * website/static/base/css/news.css: New file.
    * website/haunt.scm (with-url-parameters): New macro.
    (parameterized-procedure, parameterized-theme): New procedures.
    <top level>: Use 'with-url-parameters' and add blog and atom feed.
---
 website/haunt.scm                |   38 ++++++++++++++++----
 website/static/base/css/news.css |   22 ++++++++++++
 website/www/news.scm             |   73 ++++++++++++++++++++++++++++++++++++++
 3 files changed, 126 insertions(+), 7 deletions(-)

diff --git a/website/haunt.scm b/website/haunt.scm
index af57d2f..47719d1 100644
--- a/website/haunt.scm
+++ b/website/haunt.scm
@@ -25,9 +25,12 @@
              (haunt html)
              (haunt utils)
              (haunt builder assets)
+             (haunt builder blog)
+             (haunt builder atom)
              (ice-9 match)
              (www)
-             (www utils))
+             (www utils)
+             (www news))
 
 (define %local-test?
   ;; True when we're testing locally, as opposed to producing things to
@@ -39,6 +42,28 @@
   ;; The URLs produced in these pages are only meant for local consumption.
   (format #t "~%Producing Web pages for local tests *only*!~%~%"))
 
+(define-syntax-rule (with-url-parameters body ...)
+  "Run BODY in a context where URL parameters honor %LOCAL-TEST?."
+  (parameterize ((current-url-root (if %local-test?
+                                       ""
+                                       (current-url-root)))
+                 (gnu.org-root (if %local-test?
+                                   "https://www.gnu.org";
+                                   (gnu.org-root))))
+    body ...))
+
+(define (parameterized-procedure proc)
+  (lambda args
+    (with-url-parameters
+     (apply proc args))))
+
+(define (parameterized-theme thm)
+  (theme #:name (theme-name thm)
+         #:layout (parameterized-procedure (theme-layout thm))
+         #:post-template (parameterized-procedure (theme-post-template thm))
+         #:collection-template (parameterized-procedure
+                                (theme-collection-template thm))))
+
 (site #:title "GNU's advanced distro and transactional package manager"
       #:domain "gnu.org/software/guix"
       #:default-metadata
@@ -49,12 +74,11 @@
       `(,@(map (match-lambda
                  ((file-name contents)
                   (lambda (site posts)
-                    (parameterize ((current-url-root (if %local-test?
-                                                         ""
-                                                         (current-url-root)))
-                                   (gnu.org-root (if %local-test?
-                                                     "https://www.gnu.org";
-                                                     (gnu.org-root))))
+                    (with-url-parameters
                       (make-page file-name (contents) sxml->html)))))
                %web-pages)
+        ,(blog #:theme (parameterized-theme %news-haunt-theme)
+               #:prefix "news")
+        ,(atom-feed #:file-name "news/feed.xml"
+                    #:blog-prefix "news")
         ,(static-directory "static")))
diff --git a/website/static/base/css/news.css b/website/static/base/css/news.css
new file mode 100644
index 0000000..99f7992
--- /dev/null
+++ b/website/static/base/css/news.css
@@ -0,0 +1,22 @@
+/*
+    Public domain 2016 Ludovic Courtès <address@hidden>.
+    All rights waived.
+*/
+
address@hidden url("article.css");
+
+.example {
+    border-style: none;
+    border-radius: 0.3em;
+    background-color: #F2EFE4;
+    border-width: thin;
+    color: #4D4D4D;
+    font-size: 0.9em;
+    padding: 10px;
+    text-align: left;
+    font-family: fixed-width;
+}
+
+.post-about {
+    color: #4D4D4D;
+}
diff --git a/website/www/news.scm b/website/www/news.scm
new file mode 100644
index 0000000..3c6ca4a
--- /dev/null
+++ b/website/www/news.scm
@@ -0,0 +1,73 @@
+;;; GuixSD website --- GNU's advanced distro website
+;;; Copyright © 2016 Ludovic Courtès <address@hidden>
+;;;
+;;; This file is part of GuixSD website.
+;;;
+;;; GuixSD website is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU 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 Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public License
+;;; along with GuixSD website.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (www news)
+  #:use-module (www utils)
+  #:use-module (www shared)
+  #:use-module (haunt site)
+  #:use-module (haunt post)
+  #:use-module (haunt builder blog)
+  #:use-module (srfi srfi-19)
+  #:export (%news-haunt-theme))
+
+(define* (post->sxml post #:key post-uri)
+  "Return the SXML for POST."
+  `(div (h2 (@ (class "title"))
+            ,(if post-uri
+                 `(a (@ (href ,post-uri))
+                     ,(post-ref post 'title))
+                 (post-ref post 'title)))
+        (div (@ (class "post-about"))
+             (span (@ (class "by-line"))
+                   ,(post-ref post 'author))
+             " — " ,(date->string (post-date post) "~e ~B ~Y"))
+        (div (@ (class "post-body"))
+             ,(post-sxml post))))
+
+(define (news-page-sxml site title posts prefix)
+  "Return the SXML for the news page of SITE, containing POSTS."
+  (define (post-uri post)
+    (base-url (string-append "news/" (site-post-slug site post) ".html")))
+
+  `((div (@ (class "news-header"))
+         (h1 "Recent News"))
+    (div (@ (class "post-list"))
+         ,@(map (lambda (post)
+                  (post->sxml post #:post-uri (post-uri post)))
+                posts))))
+
+(define (base-layout body)
+  `(html (@ (lang "en"))
+        ,(html-page-header "News" #:css "news.css")
+
+        (body
+         ,(html-page-description)
+         ,(html-page-links)
+
+         (div (@ (id "content-box"))
+               (article ,body))
+
+         ,(html-page-footer))))
+
+(define %news-haunt-theme
+  ;; Theme for the rendering of the news pages.
+  (theme #:name "GuixSD"
+         #:layout (lambda (site title body)
+                    (base-layout body))
+         #:post-template post->sxml
+         #:collection-template news-page-sxml))