page: Ensure output directory exists before writing.

* haunt/utils.scm (mkdir-p): New procedure.
* haunt/page.scm (write-page): Create missing directories before writing.

2 files changed, 31 insertions, 2 deletions

diff --git a/haunt/page.scm b/haunt/page.scm
index c496c45..85b2ae6 100644
--- a/haunt/page.scm
+++ b/haunt/page.scm
@@ -26,7 +26,7 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
-  #:use-module (haunt build html)
+  #:use-module (haunt utils)
   #:export (make-page
             page?
             page-file-name
@@ -46,4 +46,5 @@
   (match page
     (($ <page> file-name contents writer)
      (let ((output (string-append output-directory "/" file-name)))
+       (mkdir-p (dirname output))
        (call-with-output-file output (cut writer contents <>))))))
diff --git a/haunt/utils.scm b/haunt/utils.scm
index 8923e13..b49af4e 100644
--- a/haunt/utils.scm
+++ b/haunt/utils.scm
@@ -1,5 +1,6 @@
 ;;; Haunt --- Static site generator for GNU Guile
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of Haunt.
 ;;;
@@ -31,7 +32,8 @@
             flat-map
             string-split-at
             absolute-file-name
-            clean-directory))
+            clean-directory
+            mkdir-p))
 
 (define* (flatten lst #:optional depth)
   "Return a list that recursively concatenates the sub-lists of LST,
@@ -70,3 +72,29 @@ flattened."
     #t)
 
   (ftw dir delete-other-files))
+
+;; Written by Ludovic Courtès for GNU Guix.
+(define (mkdir-p dir)
+  "Create directory DIR and all its ancestors."
+  (define absolute?
+    (string-prefix? "/" dir))
+
+  (define not-slash
+    (char-set-complement (char-set #\/)))
+
+  (let loop ((components (string-tokenize dir not-slash))
+             (root       (if absolute?
+                             ""
+                             ".")))
+    (match components
+      ((head tail ...)
+       (let ((path (string-append root "/" head)))
+         (catch 'system-error
+           (lambda ()
+             (mkdir path)
+             (loop tail path))
+           (lambda args
+             (if (= EEXIST (system-error-errno args))
+                 (loop tail path)
+                 (apply throw args))))))
+      (() #t))))