summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am1
-rw-r--r--haunt/asset.scm75
-rw-r--r--haunt/site.scm18
-rw-r--r--haunt/utils.scm10
4 files changed, 101 insertions, 3 deletions
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