diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | haunt/asset.scm | 75 | ||||
| -rw-r--r-- | haunt/site.scm | 18 | ||||
| -rw-r--r-- | haunt/utils.scm | 10 |
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 |