guix-hpc.scm 8.59 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)
Ludovic Courtès's avatar
Ludovic Courtès committed
22
  #:use-module (srfi srfi-11)
23
  #:use-module (srfi srfi-19)
24
  #:use-module (srfi srfi-26)
25 26 27 28
  #:export (base-url
            image-url
            css-url
            post-url
Ludovic Courtès's avatar
Ludovic Courtès committed
29

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

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

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

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

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

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

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

           (div (@ (id "content")
                   (class "width-control"))
                (div (@ (id "content-inner"))
                     (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")))))
145 146
                           (li (img (@ (alt "UBC")
                                       (src ,(image-url "/ubc.png")))))))))
Ludovic Courtès's avatar
Ludovic Courtès committed
147 148
           (div (@ (id "footer-box")
                   (class "width-control"))
149 150
                (p (a (@ (href "https://gitlab.inria.fr/guix-hpc/website"))
                      "Source of this site")))))))
Ludovic Courtès's avatar
Ludovic Courtès committed
151

152

153 154 155 156
;;;
;;; Static pages.
;;;

Ludovic Courtès's avatar
Ludovic Courtès committed
157 158 159 160 161 162 163
(define %cwd
  (and=> (assq-ref (current-source-location) 'filename)
         dirname))

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

Ludovic Courtès's avatar
Ludovic Courtès committed
164 165 166 167 168 169
(define (read-markdown-page file)
  "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"))
170 171
                       (div (@ (class "post-body"))
                            ,(syntax-highlight body)))
Ludovic Courtès's avatar
Ludovic Courtès committed
172
                 #:title (string-append "Guix-HPC — "
173 174
                                        (assoc-ref meta 'title))
                 #:meta meta)))
Ludovic Courtès's avatar
Ludovic Courtès committed
175

Ludovic Courtès's avatar
Ludovic Courtès committed
176
(define (static-pages)
177 178 179 180
  (define (markdown-page html md)
    (make-page html (read-markdown-page md)
               sxml->html))

181
  (list (markdown-page "about/index.html" "about.md")
182
        (markdown-page "index.html" "getting-started.md")))
183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 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


;;;
;;; 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*)))