haunt.scm 4.68 KB
Newer Older
Ludovic Courtès's avatar
Ludovic Courtès committed
1 2 3
;;; This module is part of Guix-HPC and is licensed under the same terms,
;;; those of the GNU GPL version 3 or (at your option) any later version.
;;;
4
;;; Copyright © 2017, 2019 Inria
Ludovic Courtès's avatar
Ludovic Courtès committed
5 6 7 8 9 10 11

;; This is a build file for Haunt.  Run 'haunt build' to build the web site,
;; and 'haunt serve' to serve it locally.  Alternatively, you can run
;; 'guix build -f guix.scm' to have everything built in the store.
(use-modules (haunt site)
             (haunt reader)
             (haunt reader commonmark)
Roel Janssen's avatar
Roel Janssen committed
12
             (haunt post)
Ludovic Courtès's avatar
Ludovic Courtès committed
13 14 15 16 17 18 19
             (haunt page)
             (haunt html)
             (haunt utils)
             (haunt builder assets)
             (haunt builder blog)
             (ice-9 match)
             (srfi srfi-1)
Roel Janssen's avatar
Roel Janssen committed
20
             (srfi srfi-19)
21
             (srfi srfi-26)
Ludovic Courtès's avatar
Ludovic Courtès committed
22 23
             (guix-hpc))

Ludovic Courtès's avatar
Ludovic Courtès committed
24 25 26
(define %web-site-title
  "Guix-HPC — Reproducible software deployment for high-performance computing")

27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42
(define (post-sxml* post)
  "Add the 'full-width' class attribute to all 'img' tags of POST so that
they get properly displayed in blog articles."
  (let loop ((sxml (post-sxml post)))
    (match sxml
      (('img ('@ attributes ...) rest ...)
       `(img (@ (class "full-width") ,@attributes)
             ,@rest))
      (((? symbol? tag) ('@ attributes ...) rest ...)
       `(,tag (@ ,@attributes) ,@(map loop rest)))
      (((? symbol? tag) rest ...)
       `(,tag ,@(map loop rest)))
      ((lst ...)
       (map loop lst))
      (x x))))

43
(define (summarize-post post uri)
44
  (match (post-sxml* post)
45 46 47 48 49 50 51
    ((('p paragraph ...) _ ...)
     `((p ,@paragraph)
       (p (a (@ (href ,uri)) "Continue reading…"))))
    (body
     body)))

(define* (post->sxml post #:key post-uri summarize?)
Roel Janssen's avatar
Roel Janssen committed
52
  "Return the SXML for POST."
53 54 55
  (define post-body*
    (if summarize?
        (cut summarize-post <> post-uri)
56
        post-sxml*))
57

Roel Janssen's avatar
Roel Janssen committed
58
  `(div (@ (class "post"))
59
        (h1 (@ (class "title"))
Roel Janssen's avatar
Roel Janssen committed
60 61 62 63 64 65 66 67 68
            ,(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"))
69
             ,(syntax-highlight (post-body* post)))))
Roel Janssen's avatar
Roel Janssen committed
70 71 72 73 74 75

(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)
76 77
                       (post->sxml post #:post-uri (post-url post site)
                                   #:summarize? #t))
Roel Janssen's avatar
Roel Janssen committed
78 79
                     posts)))))

80 81 82 83 84
(define (post->page post site)
  (make-page (string-append (post-url post site) "/index.html")
             (render-post %hpc-haunt-theme site post)
             sxml->html))

Roel Janssen's avatar
Roel Janssen committed
85 86
(define %hpc-haunt-theme
  ;; Theme for the rendering of the news pages.
Ludovic Courtès's avatar
Ludovic Courtès committed
87
  (theme #:name "Guix-HPC"
Roel Janssen's avatar
Roel Janssen committed
88
         #:layout (lambda (site title body)
Ludovic Courtès's avatar
Ludovic Courtès committed
89 90 91
                    (base-layout body
                                 #:title (string-append "Guix-HPC — "
                                                        title)))
Roel Janssen's avatar
Roel Janssen committed
92 93 94
         #:post-template post->sxml
         #:collection-template page->sxml))

Ludovic Courtès's avatar
Ludovic Courtès committed
95 96 97 98 99 100 101 102
(define %local-test?
  ;; True when we're testing locally, as opposed to producing things to
  ;; install to gnu.org.
  (or (getenv "WEB_SITE_LOCAL")
      (member "serve" (command-line))))           ;'haunt serve' command

(when %local-test?
  ;; The URLs produced in these pages are only meant for local consumption.
Roel Janssen's avatar
Roel Janssen committed
103
  (format #t "~%Producing Web pages for local tests *only*!~%~%"))
Ludovic Courtès's avatar
Ludovic Courtès committed
104

Ludovic Courtès's avatar
Ludovic Courtès committed
105
(site #:title %web-site-title
Ludovic Courtès's avatar
Ludovic Courtès committed
106 107 108 109
      #:domain "//hpc.guixsd.org/"
      #:default-metadata
      '((author . "Guix-HPC Contributors")
        (email  . "guix-devel@gnu.org"))
110
      #:readers (list sxml-reader commonmark-reader)
Ludovic Courtès's avatar
Ludovic Courtès committed
111
      #:builders
112 113 114 115 116 117 118 119 120
      (cons* (lambda (site posts)
               ;; Pages for each post.
               (map (cut post->page <> site) posts))

             (lambda (site posts)
               ;; The main collection.
               (make-page
                "/blog/index.html"
                (render-collection %hpc-haunt-theme site
Ludovic Courtès's avatar
Ludovic Courtès committed
121 122
                                   "Reproducible software \
deployment for high-performance computing — Blog"         ;title
123 124
                                   (posts/reverse-chronological posts)
                                   "/blog")
125
                sxml->html))
Ludovic Courtès's avatar
Ludovic Courtès committed
126 127 128

             ;; Apparently the <link> tags of Atom entries must be absolute URLs,
             ;; hence this #:blog-prefix.
129
             (atom-feed #:file-name "blog/feed.xml"
130
                        #:blog-prefix "https://hpc.guixsd.org/blog")
Ludovic Courtès's avatar
Ludovic Courtès committed
131

Roel Janssen's avatar
Roel Janssen committed
132
             (static-directory "static")
Ludovic Courtès's avatar
Ludovic Courtès committed
133

134
             (static-pages)))