From 1f1784f9f1290fe9bbc05f5264e2a6815dd00cfa Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Mon, 13 Apr 2015 21:59:29 -0400
Subject: Add static asset support.

* haunt/asset.scm: New file.
* Makefile.am (SOURCES): Add it.
* haunt/site.scm (build-site): Add support for assets.
* haunt/utils.scm (file-name-components, join-file-name-components): New
  procedures.
---
 Makefile.am     |  1 +
 haunt/asset.scm | 75 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 haunt/site.scm  | 18 +++++++++++---
 haunt/utils.scm | 10 ++++++++
 4 files changed, 101 insertions(+), 3 deletions(-)
 create mode 100644 haunt/asset.scm

diff --git a/Makefile.am b/Makefile.am
index 44b107e..8a06dd3 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -45,6 +45,7 @@ SOURCES =					\
   haunt/post.scm				\
   haunt/reader.scm				\
   haunt/page.scm				\
+  haunt/asset.scm				\
   haunt/site.scm				\
   haunt/build/html.scm				\
   haunt/builder/atom.scm			\
diff --git a/haunt/asset.scm b/haunt/asset.scm
new file mode 100644
index 0000000..ba69e77
--- /dev/null
+++ b/haunt/asset.scm
@@ -0,0 +1,75 @@
+;;; Haunt --- Static site generator for GNU Guile
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;;
+;;; This file is part of Haunt.
+;;;
+;;; Haunt is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Haunt is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Haunt.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Static asset data type.
+;;
+;;; Code:
+
+(define-module (haunt asset)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (haunt utils)
+  #:export (make-asset
+            asset?
+            asset-source
+            asset-target
+            install-asset
+            directory-assets))
+
+(define-record-type <asset>
+  (make-asset source target)
+  asset?
+  (source asset-source)
+  (target asset-target))
+
+(define (install-asset asset prefix)
+  "Install ASSET source file into destination directory within
+PREFIX."
+  (match asset
+    (($ <asset> source target)
+     (let ((target* (string-append prefix "/" target)))
+       (mkdir-p (dirname target*))
+       (copy-file source target*)))))
+
+(define (directory-assets directory dest)
+  "Create a list of asset objects to be stored within DEST for all
+files in DIRECTORY, recursively."
+  (define enter? (const #t))
+
+  ;; In order to do accurate file name manipulation, every file name
+  ;; is converted into a list of components, manipulated, then
+  ;; converted back into a string.
+  (define leaf
+    (let ((base-length (length (file-name-components directory)))
+          (dest* (file-name-components dest)))
+      (lambda (file-name stat memo)
+        (let* ((file-name* (file-name-components file-name))
+               (target (join-file-name-components
+                        (append dest* (drop file-name* base-length)))))
+          (cons (make-asset file-name target) memo)))))
+
+  (define (noop file-name stat memo) memo)
+
+  (define (err file-name stat errno memo)
+    (error "asset processing failed with errno: " file-name errno))
+
+  (file-system-fold enter? leaf noop noop noop err '() directory))
diff --git a/haunt/site.scm b/haunt/site.scm
index c60e110..bc90a4e 100644
--- a/haunt/site.scm
+++ b/haunt/site.scm
@@ -25,9 +25,11 @@
 (define-module (haunt site)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
   #:use-module (haunt utils)
   #:use-module (haunt reader)
   #:use-module (haunt page)
+  #:use-module (haunt asset)
   #:export (site
             site?
             site-title
@@ -77,8 +79,18 @@ 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))))
-    (delete-file-recursively build-dir)
-    (for-each (lambda (page)
-                (format #t "writing '~a'~%" (page-file-name page))
+    (when (file-exists? build-dir)
+      (delete-file-recursively build-dir)
+      (mkdir build-dir))
+    (for-each (match-lambda
+               ((? page? page)
+                (format #t "writing page '~a'~%" (page-file-name page))
                 (write-page page build-dir))
+               ((? asset? asset)
+                (format #t "copying asset '~a' -> '~a'~%"
+                        (asset-source asset)
+                        (asset-target asset))
+                (install-asset asset build-dir))
+               (obj
+                (error "unrecognized site object: " obj)))
               (flat-map (cut <> site posts) (site-builders site)))))
diff --git a/haunt/utils.scm b/haunt/utils.scm
index a84429d..b69dab8 100644
--- a/haunt/utils.scm
+++ b/haunt/utils.scm
@@ -32,6 +32,8 @@
   #:export (flatten
             flat-map
             string-split-at
+            file-name-components
+            join-file-name-components
             absolute-file-name
             delete-file-recursively
             mkdir-p
@@ -63,6 +65,14 @@ flattened."
               (string-drop str (1+ i)))
         (list str))))
 
+(define (file-name-components file-name)
+  "Split FILE-NAME into the components delimited by '/'."
+  (string-split file-name #\/))
+
+(define (join-file-name-components components)
+  "Join COMPONENTS into a file name string."
+  (string-join components "/"))
+
 (define (absolute-file-name file-name)
   (if (absolute-file-name? file-name)
       file-name
-- 
cgit v1.2.3