diff options
author | David Thompson <dthompson2@worcester.edu> | 2022-08-20 22:33:49 -0400 |
---|---|---|
committer | David Thompson <dthompson2@worcester.edu> | 2022-08-21 09:03:44 -0400 |
commit | 55cc6b24dcf606db9bd3102344ec0a9aa966189d (patch) | |
tree | c3d496d240d1f8bd4ab71f4c2a19c3f55e7635c2 /haunt | |
parent | 3c3a5ca21345b8df791486027ee367130ed45374 (diff) |
Add publishing interface with built-in support for rsync.
Diffstat (limited to 'haunt')
-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 |
4 files changed, 144 insertions, 7 deletions
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) |