Add publishing interface with built-in support for rsync.

7 files changed, 159 insertions, 9 deletions

diff --git a/Makefile.am b/Makefile.am
index 0df352d..1b12737 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -50,17 +50,19 @@ SOURCES =					\
   haunt/page.scm				\
   haunt/asset.scm				\
   haunt/artifact.scm				\
+  haunt/reader.scm				\
+  haunt/publisher.scm				\
   haunt/site.scm				\
   haunt/html.scm				\
   haunt/builder/assets.scm			\
   haunt/builder/atom.scm			\
   haunt/builder/blog.scm			\
   haunt/builder/rss.scm				\
-  haunt/reader.scm				\
   haunt/reader/texinfo.scm			\
   haunt/watch/fallback.scm			\
   haunt/ui.scm					\
   haunt/ui/build.scm				\
+  haunt/ui/publish.scm				\
   haunt/ui/serve.scm				\
   haunt/serve/mime-types.scm			\
   haunt/serve/web-server.scm
@@ -89,6 +91,12 @@ SOURCES += 					\
 
 endif
 
+if HAVE_RSYNC
+
+SOURCES += haunt/publisher/rsync.scm
+
+endif
+
 TESTS =						\
   tests/helper.scm				\
   tests/post.scm				\
diff --git a/configure.ac b/configure.ac
index 67e287c..df60089 100644
--- a/configure.ac
+++ b/configure.ac
@@ -33,4 +33,7 @@ AM_CONDITIONAL([HAVE_GUILE_COMMONMARK], [test "x$have_guile_commonmark" = "xyes"
 
 AC_CHECK_FUNC([inotify_init], [AM_CONDITIONAL(HAVE_INOTIFY, true)], [AM_CONDITIONAL(HAVE_INOTIFY, false)])
 
+AC_PATH_PROG([RSYNC], [rsync])
+AM_CONDITIONAL([HAVE_RSYNC], [test "x$RSYNC" != "x"])
+
 AC_OUTPUT
diff --git a/example/haunt.scm b/example/haunt.scm
index 536e64c..07f7601 100644
--- a/example/haunt.scm
+++ b/example/haunt.scm
@@ -3,6 +3,7 @@
              (haunt builder atom)
              (haunt builder assets)
              (haunt builder rss)
+             (haunt publisher rsync)
              (haunt reader)
              (haunt reader skribe)
              (haunt reader texinfo)
@@ -19,4 +20,5 @@
                        (atom-feed)
                        (atom-feeds-by-tag)
                        (rss-feed)
-                       (static-directory "images")))
+                       (static-directory "images"))
+      #:publishers (list (rsync-publisher #:destination "/tmp/haunt-example")))
diff --git a/haunt/config.scm.in b/haunt/config.scm.in
index e39d53f..945dfa5 100644
--- a/haunt/config.scm.in
+++ b/haunt/config.scm.in
@@ -23,6 +23,9 @@
 ;;; Code:
 
 (define-module (haunt config)
-  #:export (%haunt-version))
+  #:export (%haunt-version
+            %rsync))
 
 (define %haunt-version "@PACKAGE_VERSION@")
+
+(define %rsync "@RSYNC@")
diff --git a/haunt/publisher.scm b/haunt/publisher.scm
new file mode 100644
index 0000000..f3a8d4d
--- /dev/null
+++ b/haunt/publisher.scm
@@ -0,0 +1,47 @@
+;;; Haunt --- Static site generator for GNU Guile
+;;; Copyright © 2022 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:
+;;
+;; Site publishing abstraction.
+;;
+;;; Code:
+
+(define-module (haunt publisher)
+  #:use-module (srfi srfi-9)
+  #:export (%default-publisher-name
+            make-publisher
+            publisher?
+            publisher-name
+            publisher-proc
+            publish
+            run-command))
+
+(define %default-publisher-name 'production)
+
+(define-record-type <publisher>
+  (make-publisher name proc)
+  publisher?
+  (name publisher-name)
+  (proc publisher-proc))
+
+(define (publish publisher site)
+  ((publisher-proc publisher) site))
+
+(define (run-command program . args)
+  (zero? (apply system* program args)))
diff --git a/haunt/publisher/rsync.scm b/haunt/publisher/rsync.scm
new file mode 100644
index 0000000..76461f4
--- /dev/null
+++ b/haunt/publisher/rsync.scm
@@ -0,0 +1,66 @@
+;;; Haunt --- Static site generator for GNU Guile
+;;; Copyright © 2022 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:
+;;
+;; Rsync publisher.
+;;
+;;; Code:
+
+(define-module (haunt publisher rsync)
+  #:use-module (haunt config)
+  #:use-module (haunt publisher)
+  #:use-module (haunt site)
+  #:use-module (haunt utils)
+  #:export (%default-rsync-flags
+            rsync-publisher))
+
+(define %default-rsync-flags
+  '("--compress" "--delete" "--progress" "--recursive" "--verbose"))
+
+(define* (rsync-publisher #:key destination user host
+                          (name %default-publisher-name)
+                          (flags %default-rsync-flags)
+                          ;; Attempt to use the rsync found at
+                          ;; configure time, but if something wacky is
+                          ;; going on then try to use whatever rsync
+                          ;; might be on $PATH.
+                          (rsync (if (file-exists? %rsync) %rsync "rsync")))
+  "Return a new publisher named NAME that publishes a site to
+DESTINATION, either locally or to a remote host if HOST and/or USER
+arguments are specified.  Passing RSYNC overrides the default rsync
+executable used.  Passing FLAGS overrides the default set of command
+line flags used."
+  (let ((dest (cond
+               ((and user host)
+                (string-append user "@" host ":" destination))
+               (host
+                (string-append host ":" destination))
+               (else
+                destination))))
+    (define (publish site)
+      ;; Trailing slash so rsync copies the contents of the site build
+      ;; directory to the destination but doesn't include the
+      ;; directory itself.
+      ;;
+      ;; Good: /my/destination/index.html
+      ;; Bad: /my/destination/site/index.html
+      (let ((build-dir (string-append (site-absolute-build-directory site)
+                                      "/")))
+        (apply run-command rsync (append flags (list build-dir dest)))))
+    (make-publisher name publish)))
diff --git a/haunt/site.scm b/haunt/site.scm
index 1dd41a0..225e582 100644
--- a/haunt/site.scm
+++ b/haunt/site.scm
@@ -34,6 +34,7 @@
   #:use-module (haunt page)
   #:use-module (haunt post)
   #:use-module (haunt asset)
+  #:use-module (haunt publisher)
   #:export (site
             site?
             site-title
@@ -42,19 +43,22 @@
             site-posts-directory
             site-file-filter
             site-build-directory
+            site-absolute-build-directory
             site-default-metadata
             site-make-slug
             site-readers
             site-builders
+            site-publishers
             site-post-slug
             build-site
+            publish-site
 
             make-file-filter
             default-file-filter))
 
 (define-record-type <site>
   (make-site title domain scheme posts-directory file-filter build-directory
-             default-metadata make-slug readers builders)
+             default-metadata make-slug readers builders publishers)
   site?
   (title site-title)
   (domain site-domain)
@@ -65,7 +69,8 @@
   (default-metadata site-default-metadata)
   (make-slug site-make-slug)
   (readers site-readers)
-  (builders site-builders))
+  (builders site-builders)
+  (publishers site-publishers))
 
 (define* (site #:key
                (title "This Place is Haunted")
@@ -77,7 +82,8 @@
                (default-metadata '())
                (make-slug post-slug)
                (readers '())
-               (builders '()))
+               (builders '())
+               (publishers '()))
   "Create a new site object.  All arguments are optional:
 
 TITLE: The name of the site
@@ -92,14 +98,18 @@ DEFAULT-METADATA: An alist of arbitrary default metadata for posts
 whose keys are symbols
 MAKE-SLUG: A procedure generating a file name slug from a post
 READERS: A list of reader objects for processing posts
-BUILDERS: A list of procedures for building pages from posts"
+BUILDERS: A list of procedures for building pages from posts
+PUBLISHERS: A list of publisher objects for upload site contents to a remote location"
   (make-site title domain scheme posts-directory file-filter build-directory
-             default-metadata make-slug readers builders))
+             default-metadata make-slug readers builders publishers))
 
 (define (site-post-slug site post)
   "Return a slug string for POST using the slug generator for SITE."
   ((site-make-slug site) post))
 
+(define (site-absolute-build-directory site)
+  (absolute-file-name (site-build-directory site)))
+
 (define (build-site site)
   "Build SITE in the appropriate build directory."
   (let ((posts (if (file-exists? (site-posts-directory site))
@@ -108,7 +118,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))))
+        (build-dir (site-absolute-build-directory site)))
     (when (file-exists? build-dir)
       (delete-file-recursively build-dir)
       (mkdir build-dir))
@@ -129,6 +139,17 @@ BUILDERS: A list of procedures for building pages from posts"
                  (error "unrecognized site object: " obj)))
               (flat-map (cut <> site posts) (site-builders site)))))
 
+(define* (publish-site site name)
+  "Publish SITE to another location using the publisher named NAME."
+  (unless (file-exists? (site-absolute-build-directory site))
+    (error "site has not been built yet"))
+  (let ((publisher (or (find (lambda (publisher)
+                               (eq? (publisher-name publisher) name))
+                             (site-publishers site))
+                       (error "no publisher found for name" name))))
+    (unless (publish publisher site)
+      (error "publish failed"))))
+
 (define (make-file-filter patterns)
   (let ((patterns (map make-regexp patterns)))
     (lambda (file-name)