Create a unified type for build artifacts.

Deprecate <page> and <asset>.

5 files changed, 105 insertions, 31 deletions

diff --git a/haunt/artifact.scm b/haunt/artifact.scm
new file mode 100644
index 0000000..7785a20
--- /dev/null
+++ b/haunt/artifact.scm
@@ -0,0 +1,66 @@
+;;; Haunt --- Static site generator for GNU Guile
+;;; Copyright © 2020 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:
+;;
+;; Build artifact data type.
+;;
+;;; Code:
+
+(define-module (haunt artifact)
+  #:use-module (haunt utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (srfi srfi-9)
+  #:export (make-artifact
+            artifact?
+            artifact-file-name
+            artifact-writer
+            create-artifact
+            serialized-artifact
+            verbatim-artifact
+            external-artifact))
+
+(define-record-type <artifact>
+  (make-artifact file-name writer)
+  artifact?
+  (file-name artifact-file-name)
+  (writer artifact-writer))
+
+(define (create-artifact artifact prefix)
+  (let ((output (string-append prefix "/" (artifact-file-name artifact))))
+    (mkdir-p (dirname output))
+    ((artifact-writer artifact) output)
+    (unless (file-exists? output)
+      (error "failed to create artifact output file" output))))
+
+(define (serialized-artifact destination obj serialize)
+  (make-artifact destination
+                 (lambda (output)
+                   (format #t "write '~a'~%" destination)
+                   (call-with-output-file output
+                     (lambda (port)
+                       (serialize obj port))))))
+
+(define (verbatim-artifact source destination)
+  (unless (file-exists? source)
+    (error "verbatim artifact source file does not exist" source))
+  (make-artifact destination
+                 (lambda (output)
+                   (format #t "copy '~a' → '~a'~%" source destination)
+                   (copy-file source output))))
diff --git a/haunt/asset.scm b/haunt/asset.scm
index 2d9e27b..78d539b 100644
--- a/haunt/asset.scm
+++ b/haunt/asset.scm
@@ -27,6 +27,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
+  #:use-module (haunt artifact)
   #:use-module (haunt utils)
   #:export (make-asset
             asset?
@@ -71,7 +72,7 @@ files in DIRECTORY that match KEEP?, recursively."
             (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))
+              (cons (verbatim-artifact file-name target) memo))
             memo))))
 
   (define (noop file-name stat memo) memo)
diff --git a/haunt/builder/atom.scm b/haunt/builder/atom.scm
index 2a6c356..acd74d4 100644
--- a/haunt/builder/atom.scm
+++ b/haunt/builder/atom.scm
@@ -29,6 +29,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:use-module (sxml simple)
+  #:use-module (haunt artifact)
   #:use-module (haunt site)
   #:use-module (haunt post)
   #:use-module (haunt page)
@@ -184,20 +185,20 @@ MAX-ENTRIES: The maximum number of posts to render in the feed"
                 (build-uri (site-scheme site)
                            #:host (site-domain site)
                            #:path (string-append "/" file-name)))))
-      (make-page file-name
-                 `(feed (@ (xmlns "http://www.w3.org/2005/Atom"))
-                        (title ,(site-title site))
-                        (id ,uri)
-                        (subtitle ,subtitle)
-                        (updated ,(date->string* (current-date)))
-                        (link (@ (href ,(string-append (site-domain site)
-                                                       "/" file-name))
-                                 (rel "self")))
-                        (link (@ (href ,(site-domain site))))
-                        ,@(map (cut post->atom-entry site <>
-                                    #:blog-prefix blog-prefix)
-                               (take-up-to max-entries (filter posts))))
-                 sxml->xml*))))
+      (serialized-artifact file-name
+                           `(feed (@ (xmlns "http://www.w3.org/2005/Atom"))
+                                  (title ,(site-title site))
+                                  (id ,uri)
+                                  (subtitle ,subtitle)
+                                  (updated ,(date->string* (current-date)))
+                                  (link (@ (href ,(string-append (site-domain site)
+                                                                 "/" file-name))
+                                           (rel "self")))
+                                  (link (@ (href ,(site-domain site))))
+                                  ,@(map (cut post->atom-entry site <>
+                                              #:blog-prefix blog-prefix)
+                                         (take-up-to max-entries (filter posts))))
+                           sxml->xml*))))
 
 (define* (atom-feeds-by-tag #:key
                             (prefix "feeds/tags")
diff --git a/haunt/builder/blog.scm b/haunt/builder/blog.scm
index 2830881..4cf671f 100644
--- a/haunt/builder/blog.scm
+++ b/haunt/builder/blog.scm
@@ -27,6 +27,7 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-19)
+  #:use-module (haunt artifact)
   #:use-module (haunt site)
   #:use-module (haunt post)
   #:use-module (haunt page)
@@ -127,16 +128,16 @@ decorated by THEME, whose URLs start with PREFIX."
     (define (post->page post)
       (let ((base-name (string-append (site-post-slug site post)
                                       ".html")))
-        (make-page (make-file-name base-name)
-                   (render-post theme site post)
-                   sxml->html)))
+        (serialized-artifact (make-file-name base-name)
+                             (render-post theme site post)
+                             sxml->html)))
 
     (define collection->page
       (match-lambda
        ((title file-name filter)
-        (make-page (make-file-name file-name)
-                   (render-collection theme site title (filter posts) prefix)
-                   sxml->html))))
+        (serialized-artifact (make-file-name file-name)
+                             (render-collection theme site title (filter posts) prefix)
+                             sxml->html))))
 
     (append (map post->page posts)
             (map collection->page collections))))
diff --git a/haunt/site.scm b/haunt/site.scm
index 4b412bb..1dd41a0 100644
--- a/haunt/site.scm
+++ b/haunt/site.scm
@@ -28,6 +28,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (haunt artifact)
   #:use-module (haunt utils)
   #:use-module (haunt reader)
   #:use-module (haunt page)
@@ -112,16 +113,20 @@ BUILDERS: A list of procedures for building pages from posts"
       (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)))
+                ((? page? page)
+                 (display "warning: page objects are deprecated; switch to serialized-artifact\n")
+                 (format #t "writing page '~a'~%" (page-file-name page))
+                 (write-page page build-dir))
+                ((? asset? asset)
+                 (display "warning: asset objects are deprecated; switch to verbatim-artifact\n")
+                 (format #t "copying asset '~a' → '~a'~%"
+                         (asset-source asset)
+                         (asset-target asset))
+                 (install-asset asset build-dir))
+                ((? artifact? artifact)
+                 (create-artifact artifact build-dir))
+                (obj
+                 (error "unrecognized site object: " obj)))
               (flat-map (cut <> site posts) (site-builders site)))))
 
 (define (make-file-filter patterns)