summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am10
-rw-r--r--configure.ac3
-rw-r--r--example/haunt.scm4
-rw-r--r--haunt/config.scm.in5
-rw-r--r--haunt/publisher.scm47
-rw-r--r--haunt/publisher/rsync.scm66
-rw-r--r--haunt/site.scm33
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)