guix-hpc.scm 9.33 KB
Newer Older
Ludovic Courtès's avatar
Ludovic Courtès committed
1 2 3 4
;;; 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.
;;;
;;; Copyright © 2017 Inria
5
;;; Copyright © 2017 Ludovic Courtès
6 7
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
Ludovic Courtès's avatar
Ludovic Courtès committed
8 9

(define-module (guix-hpc)
10
  #:use-module (haunt post)
Ludovic Courtès's avatar
Ludovic Courtès committed
11
  #:use-module (haunt page)
12
  #:use-module (haunt site)
Ludovic Courtès's avatar
Ludovic Courtès committed
13
  #:use-module (haunt html)
14
  #:use-module (haunt utils)
Ludovic Courtès's avatar
Ludovic Courtès committed
15 16
  #:use-module (haunt reader)
  #:use-module (haunt reader commonmark)
17 18 19
  #:use-module (syntax-highlight)
  #:use-module (syntax-highlight scheme)
  #:use-module (syntax-highlight lexers)
20
  #:use-module (sxml simple)
21
  #:use-module (ice-9 match)
22
  #:use-module (srfi srfi-1)
Ludovic Courtès's avatar
Ludovic Courtès committed
23
  #:use-module (srfi srfi-11)
24
  #:use-module (srfi srfi-19)
25
  #:use-module (srfi srfi-26)
26 27 28 29
  #:export (base-url
            image-url
            css-url
            post-url
Ludovic Courtès's avatar
Ludovic Courtès committed
30

31
            syntax-highlight
Ludovic Courtès's avatar
Ludovic Courtès committed
32 33
            base-layout

34 35
            static-pages
            atom-feed))
36 37 38 39 40

(define (base-url . location)
  (string-concatenate (cons "" location)))

(define (image-url location)
41
  (base-url "/static/images" location))
42 43

(define (css-url location)
44
  (base-url "/static/css" location))
45 46 47

(define (post-url post site)
  "Return the URL of POST, a Haunt blog post, for SITE."
48 49 50 51 52 53 54 55 56
  (let ((date (post-date post)))
    (base-url "/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))))
57

Ludovic Courtès's avatar
Ludovic Courtès committed
58

59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
;;;
;;; Syntax highlighting (stolen from Guix's web site.)
;;;

(define %default-special-prefixes
  '("define" "syntax"))

(define lex-scheme/guix
  ;; Specialized lexer for the Scheme we use in Guix.
  ;; TODO: Add #~, #$, etc.
  (make-scheme-lexer (cons* "with-imported-modules"
                            "gexp" "ungexp"
                            "ungexp-native" "ungexp-splicing"
                            "ungexp-native-splicing"
                            "mlet" "mlet*"
                            "match"
                            %default-special-symbols)
                     %default-special-prefixes))

(define (syntax-highlight sxml)
  "Recurse over SXML and syntax-highlight code snippets."
  (match sxml
    (('code ('@ ('class "language-scheme")) code-snippet)
     `(code ,(highlights->sxml
              (highlight lex-scheme/guix code-snippet))))
    ((tag ('@ attributes ...) body ...)
     `(,tag (@ ,@attributes) ,@(map syntax-highlight body)))
    ((tag body ...)
     `(,tag ,@(map syntax-highlight body)))
    ((? string? str)
     str)))

91 92 93 94 95 96 97
(define* (base-layout body #:key (title "Guix-HPC") (meta '())
                      (posts '()) site)
  (define (post->brief post)
    `(li (@ (class "news-brief"))
         (a (@ (href ,(post-url post site)))
            ,(post-ref post 'title))))

Ludovic Courtès's avatar
Ludovic Courtès committed
98 99 100 101 102 103 104 105 106 107 108 109 110
  `((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))
111 112 113 114 115
          (body
           (div (@ (id "header")
                   ,@(if (assoc-ref meta 'frontpage)
                         '((class "frontpage"))
                         '()))
Ludovic Courtès's avatar
Ludovic Courtès committed
116 117
                (div (@ (id "header-inner")
                        (class "width-control"))
118 119
                     (a (@ (href ,(base-url "/")))
                        (img (@ (class "logo")
120 121 122
                                (src ,(image-url (if (assoc-ref meta 'frontpage)
                                                     "/logo.png"
                                                     "/logo-small.png"))))))
123 124
                     (div (@ (class "baseline"))
                          "Reproducible software deployment for high-performance computing.")))
Ludovic Courtès's avatar
Ludovic Courtès committed
125 126 127
           (div (@ (id "menubar")
                   (class "width-control"))
                (ul
128
                 (li (a (@ (href ,(base-url "/about")))
Ludovic Courtès's avatar
Ludovic Courtès committed
129
                        "About"))
130 131
                 (li (a (@ (href ,(base-url "/browse")))
                        "Browse"))
132 133 134
                 (li (a (@ (href ,(base-url "/blog")))
                        "Blog"))
                 (li (a (@ (href ,(base-url "/blog/feed.xml")))
Ludovic Courtès's avatar
Ludovic Courtès committed
135 136 137 138 139 140
                        (img (@ (alt "Atom feed")
                                (src ,(image-url "/feed.png"))))))))

           (div (@ (id "content")
                   (class "width-control"))
                (div (@ (id "content-inner"))
141 142 143 144 145 146 147 148 149

                     ,@(if (assoc-ref meta 'frontpage)
                           `((div (@ (class "latest-news"))
                                  "LATEST ARTICLES"
                                  (ul ,@(map post->brief
                                             (take (posts/reverse-chronological posts) 3))
                                      (li (a (@ (href "/blog")) "More…")))))
                           '())

Ludovic Courtès's avatar
Ludovic Courtès committed
150 151 152 153 154 155 156 157 158 159 160
                     (article ,body)))

           (div (@ (id "collaboration"))
                (div (@ (id "collaboration-inner")
                        (class "width-control"))
                     (div (@ (class "members"))
                          (ul
                           (li (img (@ (alt "MDC")
                                       (src ,(image-url "/mdc.png")))))
                           (li (img (@ (alt "Inria")
                                       (src ,(image-url "/inria.png")))))
161 162
                           (li (img (@ (alt "UBC")
                                       (src ,(image-url "/ubc.png")))))))))
Ludovic Courtès's avatar
Ludovic Courtès committed
163 164
           (div (@ (id "footer-box")
                   (class "width-control"))
165 166
                (p (a (@ (href "https://gitlab.inria.fr/guix-hpc/website"))
                      "Source of this site")))))))
Ludovic Courtès's avatar
Ludovic Courtès committed
167

168

169 170 171 172
;;;
;;; Static pages.
;;;

Ludovic Courtès's avatar
Ludovic Courtès committed
173 174 175 176 177 178 179
(define %cwd
  (and=> (assq-ref (current-source-location) 'filename)
         dirname))

(define read-markdown
  (reader-proc commonmark-reader))

180
(define (read-markdown-page file posts site)
Ludovic Courtès's avatar
Ludovic Courtès committed
181 182 183 184 185
  "Read the CommonMark page from FILE.  Return its final SXML
representation."
  (let-values (((meta body)
                (read-markdown (string-append %cwd "/" file))))
    (base-layout `(div (@ (class "post"))
186 187
                       (div (@ (class "post-body"))
                            ,(syntax-highlight body)))
Ludovic Courtès's avatar
Ludovic Courtès committed
188
                 #:title (string-append "Guix-HPC — "
189
                                        (assoc-ref meta 'title))
190 191 192
                 #:meta meta
                 #:posts posts
                 #:site site)))
Ludovic Courtès's avatar
Ludovic Courtès committed
193

Ludovic Courtès's avatar
Ludovic Courtès committed
194
(define (static-pages)
195
  (define (markdown-page html md)
196 197 198
    (lambda (site posts)
      (make-page html (read-markdown-page md posts site)
                 sxml->html)))
199

200
  (list (markdown-page "about/index.html" "about.md")
201
        (markdown-page "index.html" "getting-started.md")))
202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261


;;;
;;; Atom feed (stolen from Haunt and adjusted).
;;;

;;; We cannot use Haunt's 'atom-feed' because of the non-default post URLs
;;; that we use.  Thus the code below is mostly duplicated from (haunt
;;; builder atom), with the exception of the URLs.

(define (sxml->xml* sxml port)
  "Write SXML to PORT, preceded by an <?xml> tag."
  (display "<?xml version=\"1.0\" encoding=\"utf-8\"?>" port)
  (sxml->xml sxml port))

(define (date->string* date)
  "Convert date to ISO-8601 formatted string."
  (date->string date "~4"))

(define* (post->atom-entry site post #:key (blog-prefix ""))
  "Convert POST into an Atom <entry> XML node."
  `(entry
    (title ,(post-ref post 'title))
    (author
     (name ,(post-ref post 'author))
     ,(let ((email (post-ref post 'email)))
        (if email `(email ,email) '())))
    (updated ,(date->string* (post-date post)))
    (link (@ (href ,(post-url post site))
             (rel "alternate")))
    (summary (@ (type "html"))
             ,(sxml->html-string (post-sxml post)))))

(define* (atom-feed #:key
                    (file-name "feed.xml")
                    (subtitle "Recent Posts")
                    (filter posts/reverse-chronological)
                    (max-entries 20)
                    (blog-prefix ""))
  "Return a builder procedure that renders a list of posts as an Atom
feed.  All arguments are optional:

FILE-NAME: The page file name
SUBTITLE: The feed subtitle
FILTER: The procedure called to manipulate the posts list before rendering
MAX-ENTRIES: The maximum number of posts to render in the feed"
  (lambda (site posts)
    (make-page file-name
               `(feed (@ (xmlns "http://www.w3.org/2005/Atom"))
                      (title ,(site-title site))
                      (subtitle ,subtitle)
                      (updated ,(date->string* (current-date)))
                      (link (@ (href ,(string-append (site-domain site)
                                                     "/" file-name))
                               (rel "self")))
                      (link (@ (href ,(site-domain site))))
                      ,@(map (cut post->atom-entry site <>
                                  #:blog-prefix blog-prefix)
                             (take-up-to max-entries (filter posts))))
               sxml->xml*)))