diff options
| -rw-r--r-- | Makefile.am | 10 | ||||
| -rw-r--r-- | configure.ac | 3 | ||||
| -rw-r--r-- | example/haunt.scm | 4 | ||||
| -rw-r--r-- | haunt/config.scm.in | 5 | ||||
| -rw-r--r-- | haunt/publisher.scm | 47 | ||||
| -rw-r--r-- | haunt/publisher/rsync.scm | 66 | ||||
| -rw-r--r-- | haunt/site.scm | 33 |
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) |