1 files changed, 66 insertions, 0 deletions
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)))