blob: 76461f4c6cf21b07008009848a604ec2adbb9b84 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
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)))
|
