blob: 225e58216e0c2d32c056b3e0e45e4d3e5439e692 (
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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
;;; Haunt --- Static site generator for GNU Guile
;;; Copyright © 2015 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 configuration data type.
;;
;;; Code:
(define-module (haunt site)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (haunt artifact)
#:use-module (haunt utils)
#:use-module (haunt reader)
#:use-module (haunt page)
#:use-module (haunt post)
#:use-module (haunt asset)
#:use-module (haunt publisher)
#:export (site
site?
site-title
site-domain
site-scheme
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 publishers)
site?
(title site-title)
(domain site-domain)
(scheme site-scheme) ; https or http
(posts-directory site-posts-directory)
(file-filter site-file-filter)
(build-directory site-build-directory)
(default-metadata site-default-metadata)
(make-slug site-make-slug)
(readers site-readers)
(builders site-builders)
(publishers site-publishers))
(define* (site #:key
(title "This Place is Haunted")
(domain "example.com")
(scheme 'https)
(posts-directory "posts")
(file-filter default-file-filter)
(build-directory "site")
(default-metadata '())
(make-slug post-slug)
(readers '())
(builders '())
(publishers '()))
"Create a new site object. All arguments are optional:
TITLE: The name of the site
DOMAIN: The domain that will host the site
SCHEME: Either 'https' or 'http' ('https' by default)
POSTS-DIRECTORY: The directory where posts are found
FILE-FILTER: A predicate procedure that returns #f when a post file
should be ignored, and #f otherwise. Emacs temp files are ignored by
default.
BUILD-DIRECTORY: The directory that generated pages are stored in
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
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 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))
(read-posts (site-posts-directory site)
(site-file-filter site)
(site-readers site)
(site-default-metadata site))
'()))
(build-dir (site-absolute-build-directory site)))
(when (file-exists? build-dir)
(delete-file-recursively build-dir)
(mkdir build-dir))
(for-each (match-lambda
((? page? page)
(display "warning: page objects are deprecated; switch to serialized-artifact\n")
(format #t "writing page '~a'~%" (page-file-name page))
(write-page page build-dir))
((? asset? asset)
(display "warning: asset objects are deprecated; switch to verbatim-artifact\n")
(format #t "copying asset '~a' → '~a'~%"
(asset-source asset)
(asset-target asset))
(install-asset asset build-dir))
((? artifact? artifact)
(create-artifact artifact build-dir))
(obj
(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)
(not (any (lambda (regexp)
(regexp-match?
(regexp-exec regexp (basename file-name))))
patterns)))))
;; Filter out Emacs temporary files by default.
(define default-file-filter
(make-file-filter '("^\\." "^#" "~$")))
|
