From 06321fbdd8ee13aba3ac1a058cfa56efad56b287 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sat, 11 Apr 2015 23:29:20 -0400
Subject: site: Fix cleaning step before building.

Cleaning the build directory failed when a subdirectory existed.

* haunt/utils.scm (clean-directory): Remove.
  (delete-file-recursively): New procedure.
* haunt/site.scm (build-site): Use delete-file-recursively.
---
 haunt/site.scm  |  2 +-
 haunt/utils.scm | 34 ++++++++++++++++++++++++++--------
 2 files changed, 27 insertions(+), 9 deletions(-)

diff --git a/haunt/site.scm b/haunt/site.scm
index 92146e8..c60e110 100644
--- a/haunt/site.scm
+++ b/haunt/site.scm
@@ -77,7 +77,7 @@ BUILDERS: A list of procedures for building pages from posts"
                            (site-readers site)
                            (site-default-metadata site)))
         (build-dir (absolute-file-name (site-build-directory site))))
-    (clean-directory build-dir)
+    (delete-file-recursively build-dir)
     (for-each (lambda (page)
                 (format #t "writing '~a'~%" (page-file-name page))
                 (write-page page build-dir))
diff --git a/haunt/utils.scm b/haunt/utils.scm
index 7eb1583..a84429d 100644
--- a/haunt/utils.scm
+++ b/haunt/utils.scm
@@ -1,6 +1,6 @@
 ;;; Haunt --- Static site generator for GNU Guile
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of Haunt.
 ;;;
@@ -33,7 +33,7 @@
             flat-map
             string-split-at
             absolute-file-name
-            clean-directory
+            delete-file-recursively
             mkdir-p
             string->date*
             take-up-to))
@@ -68,13 +68,31 @@ flattened."
       file-name
       (string-append (getcwd) "/" file-name)))
 
-(define (clean-directory dir)
-  (define (delete-other-files file-name stat flag)
-    (unless (string=? dir file-name)
-      (delete-file file-name))
-    #t)
+;; Written by Ludovic Courtès for GNU Guix.
+(define* (delete-file-recursively dir
+                                  #:key follow-mounts?)
+  "Delete DIR recursively, like `rm -rf', without following symlinks.  Don't
+follow mount points either, unless FOLLOW-MOUNTS? is true.  Report but ignore
+errors."
+  (let ((dev (stat:dev (lstat dir))))
+    (file-system-fold (lambda (dir stat result)    ; enter?
+                        (or follow-mounts?
+                            (= dev (stat:dev stat))))
+                      (lambda (file stat result)   ; leaf
+                        (delete-file file))
+                      (const #t)                   ; down
+                      (lambda (dir stat result)    ; up
+                        (rmdir dir))
+                      (const #t)                   ; skip
+                      (lambda (file stat errno result)
+                        (format (current-error-port)
+                                "warning: failed to delete ~a: ~a~%"
+                                file (strerror errno)))
+                      #t
+                      dir
 
-  (ftw dir delete-other-files))
+                      ;; Don't follow symlinks.
+                      lstat)))
 
 ;; Written by Ludovic Courtès for GNU Guix.
 (define (mkdir-p dir)
-- 
cgit v1.2.3