03/03: website: Add export procedure.

[Ludovic Courtès]

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

commit ac542b079a1aeae51c19b847ec5af6a1fcc9e388
Author: Ludovic Courtès <address@hidden>
Date:   Thu May 7 15:02:22 2015 +0200

    website: Add export procedure.
---
 website/www.scm |   52 +++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 files changed, 51 insertions(+), 1 deletions(-)

diff --git a/website/www.scm b/website/www.scm
index c283ccd..38a0d0d 100644
--- a/website/www.scm
+++ b/website/www.scm
@@ -1,5 +1,17 @@
 (define-module (www)
-  #:export (main-page))
+  #:use-module (www packages)
+  #:use-module (www download)
+  #:use-module (www donate)
+  #:use-module (www about)
+  #:use-module (www contribute)
+  #:use-module (www help)
+  #:use-module (sxml simple)
+  #:use-module (ice-9 match)
+  #:export (main-page
+
+            %web-pages
+            export-web-page
+            export-web-site))
 
 (define main-page
   '(html (@ (lange "en"))
@@ -277,3 +289,41 @@ lists")))))
                    ". Made with "
                    (span (@ (class "metta")) "♥")
                    " by humans."))))
+
+
+;;;
+;;; HTML export.
+;;;
+
+(define %web-pages
+  ;; Mapping of web pages to HTML file names.
+  `(("index.html" ,main-page)
+    ("about/index.html" ,about-page)
+    ("contribute/index.html" ,contribute-page)
+    ("donate/index.html" ,donate-page)
+    ("download/index.html" ,download-page)
+    ("help/index.html" ,help-page)
+    ("packages/index.html" ,packages-page)))
+
+(define (mkdir* directory)
+  "Make DIRECTORY unless it already exists."
+  (catch 'system-error
+    (lambda ()
+      (mkdir directory))
+    (lambda args
+      (unless (= EEXIST (system-error-errno args))
+        (apply throw args)))))
+
+(define (export-web-page page file)
+  "Export PAGE, an SXML tree, to FILE."
+  (mkdir* (dirname file))
+  (call-with-output-file file
+    (lambda (port)
+      (sxml->xml page port))))
+
+(define (export-web-site)
+  "Export the whole web site as HTML files created in the current directory."
+  (for-each (match-lambda
+              ((file page)
+               (export-web-page page file)))
+            %web-pages))