summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am8
-rw-r--r--doc/haunt.texi36
-rw-r--r--doc/manual.css21
-rw-r--r--haunt/inotify.scm224
-rw-r--r--haunt/reader.scm15
-rw-r--r--haunt/reader/skribe.scm15
-rw-r--r--haunt/ui.scm15
-rw-r--r--haunt/ui/serve.scm77
8 files changed, 377 insertions, 34 deletions
diff --git a/Makefile.am b/Makefile.am
index 2fbcf26..f831acb 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -46,6 +46,7 @@ bin_SCRIPTS = \
SOURCES = \
haunt/config.scm \
haunt/utils.scm \
+ haunt/inotify.scm \
haunt/post.scm \
haunt/page.scm \
haunt/asset.scm \
@@ -90,6 +91,11 @@ AM_SCM_LOG_FLAGS = --no-auto-compile -L "$(top_srcdir)"
info_TEXINFOS = doc/haunt.texi
doc_haunt_TEXINFOS = doc/fdl-1.3.texi
+
+AM_MAKEINFOHTMLFLAGS = \
+ --css-ref=https://dthompson.us/css/dthompson.css \
+ --css-include=doc/manual.css
+
dvi: # Don't build dvi docs
EXTRA_DIST += \
@@ -107,6 +113,6 @@ CLEANFILES = \
$(TESTS:tests/%.scm=%.log)
publish: distcheck
- gpg --sign --armor --yes haunt-$(VERSION).tar.gz && \
+ gpg --sign --detach-sign --armor --yes haunt-$(VERSION).tar.gz && \
scp haunt-$(VERSION).tar.gz haunt-$(VERSION).tar.gz.asc \
publish@dthompson.us:/var/www/files/haunt/
diff --git a/doc/haunt.texi b/doc/haunt.texi
index c5207af..b8c2b2a 100644
--- a/doc/haunt.texi
+++ b/doc/haunt.texi
@@ -10,7 +10,7 @@
@include version.texi
@copying
-Copyright @copyright{} 2015 David Thompson@*
+Copyright @copyright{} 2015-2021 David Thompson@*
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or
@@ -53,21 +53,9 @@ functional static site generator.
* Command-line Interface:: Using Haunt from the command-line.
* Programming Interface:: Using the Haunt API in Scheme.
* Contributing:: How to contribute to Haunt.
-
* GNU Free Documentation License:: The license of this manual.
* Concept Index:: Concepts.
* Programming Index:: Data types, procedures, syntax, and variables.
-
-@detailmenu
- --- The Detailed Node Listing ---
-
-Installation
-
-* Downloading:: Downloading the source code.
-* Requirements:: Software needed to build and run Haunt.
-* Building:: Building from source code.
-
-@end detailmenu
@end menu
@node Introduction
@@ -182,6 +170,26 @@ make
make install
@end example
+This will install Haunt to @file{/usr/local/}. This is not part of
+the default load path for GNU Guile if you installed it from your
+distribution's package manager (@file{/usr} is.) You may choose to
+change the prefix to your GNU Guile's location with @code{./configure
+--prefix=/usr} or add @file{/usr/local/} to GNU Guile's load path in
+your shell environment like this (replacing 3.0 with your GNU Guile
+version):
+
+@example
+export GUILE_LOAD_PATH="/usr/local/share/guile/site/3.0\
+$@{GUILE_LOAD_PATH:+:@}$GUILE_LOAD_PATH"
+
+export GUILE_LOAD_COMPILED_PATH="/usr/local/lib/guile/3.0/site-ccache\
+$@{GUILE_LOAD_COMPILED_PATH:+:@}$GUILE_COMPILED_LOAD_PATH"
+@end example
+
+(@pxref{Environment Variables, Environment Variables,, guile, GNU
+Guile Reference Manual} for more details on @env{GUILE_LOAD_PATH} and
+@env{GUILE_LOAD_COMPILED_PATH}.)
+
@node Tutorial
@chapter Tutorial
@@ -945,6 +953,8 @@ The maximum number of posts to render in each feed. The default is
@node Contributing
@chapter Contributing
+Send patches and bug reports to @email{davet@@gnu.org}.
+
@c *********************************************************************
@node GNU Free Documentation License
@appendix GNU Free Documentation License
diff --git a/doc/manual.css b/doc/manual.css
new file mode 100644
index 0000000..b433c4b
--- /dev/null
+++ b/doc/manual.css
@@ -0,0 +1,21 @@
+@media (min-width: 1140px) {
+ body {
+ margin-left: 14rem;
+ margin-right: 4rem;
+ max-width: 52rem;
+ }
+}
+
+@media (min-width: 800px) and (max-width: 1140px) {
+ body {
+ margin-left: 6rem;
+ margin-right: 4rem;
+ max-width: 52rem;
+ }
+}
+
+@media (max-width: 800px) {
+ body {
+ margin: 1rem;
+ }
+}
diff --git a/haunt/inotify.scm b/haunt/inotify.scm
new file mode 100644
index 0000000..156ed9f
--- /dev/null
+++ b/haunt/inotify.scm
@@ -0,0 +1,224 @@
+;;;;; 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:
+;;
+;; Inotify bindings.
+;;
+;;; Code:
+
+(define-module (haunt inotify)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (system foreign)
+ #:export (make-inotify
+ inotify?
+ inotify-watches
+ inotify-add-watch!
+ inotify-pending-events?
+ inotify-read-event
+ inotify-watch?
+ inotify-watch-id
+ inotify-watch-file-name
+ inotify-watch-remove!
+ inotify-event?
+ inotify-event-watch
+ inotify-event-type
+ inotify-event-cookie
+ inotify-event-file-name
+ inotify-event-within-directory?))
+
+(define libc (dynamic-link))
+
+(define inotify-init
+ (pointer->procedure int (dynamic-func "inotify_init" libc) '()))
+
+(define inotify-add-watch
+ (pointer->procedure int (dynamic-func "inotify_add_watch" libc)
+ (list int '* uint32)))
+
+(define inotify-rm-watch
+ (pointer->procedure int (dynamic-func "inotify_rm_watch" libc)
+ (list int int)))
+
+(define IN_ACCESS #x00000001) ; file was accessed.
+(define IN_MODIFY #x00000002) ; file was modified.
+(define IN_ATTRIB #x00000004) ; metadata changed
+(define IN_CLOSE_WRITE #x00000008) ; file opened for writing closed
+(define IN_CLOSE_NOWRITE #x00000010) ; file not opened for writing closed
+(define IN_OPEN #x00000020) ; file was opened
+(define IN_MOVED_FROM #x00000040) ; file was moved from X
+(define IN_MOVED_TO #x00000080) ; file was moved to Y
+(define IN_CREATE #x00000100) ; subfile was created
+(define IN_DELETE #x00000200) ; subfile was deleted
+(define IN_DELETE_SELF #x00000400) ; self was deleted
+(define IN_MOVE_SELF #x00000800) ; self was moved
+;; Kernel flags
+(define IN_UNMOUNT #x00002000) ; backing fs was unmounted
+(define IN_Q_OVERFLOW #x00004000) ; event queue overflowed
+(define IN_IGNORED #x00008000) ; file was ignored
+;; Special flags
+(define IN_ONLYDIR #x01000000) ; only watch if directory
+(define IN_DONT_FOLLOW #x02000000) ; do not follow symlink
+(define IN_EXCL_UNLINK #x04000000) ; exclude events on unlinked objects
+(define IN_MASK_ADD #x20000000) ; add to the mask of an existing watch
+(define IN_ISDIR #x40000000) ; event occurred against directory
+(define IN_ONESHOT #x80000000) ; only send event once
+
+(define mask/symbol (make-hash-table))
+(define symbol/mask (make-hash-table))
+
+(for-each (match-lambda
+ ((sym mask)
+ (hashq-set! symbol/mask sym mask)
+ (hashv-set! mask/symbol mask sym)))
+ `((access ,IN_ACCESS)
+ (modify ,IN_MODIFY)
+ (attrib ,IN_ATTRIB)
+ (close-write ,IN_CLOSE_WRITE)
+ (close-no-write ,IN_CLOSE_NOWRITE)
+ (open ,IN_OPEN)
+ (moved-from ,IN_MOVED_FROM)
+ (moved-to ,IN_MOVED_TO)
+ (create ,IN_CREATE)
+ (delete ,IN_DELETE)
+ (delete-self ,IN_DELETE_SELF)
+ (move-self ,IN_MOVE_SELF)
+ (only-dir ,IN_ONLYDIR)
+ (dont-follow ,IN_DONT_FOLLOW)
+ (exclude-unlink ,IN_EXCL_UNLINK)
+ (is-directory ,IN_ISDIR)
+ (once ,IN_ONESHOT)))
+
+(define (symbol->mask sym)
+ (hashq-ref symbol/mask sym))
+
+(define (mask->event-symbol mask)
+ ;; Only check the first 4 bits, of which only one bit should be set
+ ;; containing the event type. The other 4 bits may have additional
+ ;; information.
+ (hashq-ref mask/symbol (logand #x0000ffff mask)))
+
+(define-record-type <inotify>
+ (%make-inotify port buffer buffer-pointer watches)
+ inotify?
+ (port inotify-port)
+ (buffer inotify-buffer)
+ (buffer-pointer inotify-buffer-pointer)
+ (watches inotify-watches))
+
+(define-record-type <inotify-watch>
+ (make-inotify-watch id file-name owner)
+ inotify-watch?
+ (id inotify-watch-id)
+ (file-name inotify-watch-file-name)
+ (owner inotify-watch-owner))
+
+(define-record-type <inotify-event>
+ (make-inotify-event watch type cookie file-name)
+ inotify-event?
+ (watch inotify-event-watch)
+ (type inotify-event-type)
+ (cookie inotify-event-cookie)
+ (file-name inotify-event-file-name))
+
+(define (display-inotify inotify port)
+ (format port "#<inotify port: ~a>" (inotify-port inotify)))
+
+(define (display-inotify-watch watch port)
+ (format port "#<inotify-watch id: ~d file-name: ~a>"
+ (inotify-watch-id watch)
+ (inotify-watch-file-name watch)))
+
+(define (display-inotify-event event port)
+ (format port "#<inotify-event type: ~s cookie: ~d file-name: ~a watch: ~a>"
+ (inotify-event-type event)
+ (inotify-event-cookie event)
+ (inotify-event-file-name event)
+ (inotify-event-watch event)))
+
+(set-record-type-printer! <inotify> display-inotify)
+(set-record-type-printer! <inotify-watch> display-inotify-watch)
+(set-record-type-printer! <inotify-event> display-inotify-event)
+
+(define (make-inotify)
+ (let ((fd (inotify-init))
+ (buffer (make-bytevector 4096)))
+ (%make-inotify (fdopen fd "r")
+ buffer
+ (bytevector->pointer buffer)
+ (make-hash-table))))
+
+(define (inotify-fd inotify)
+ (port->fdes (inotify-port inotify)))
+
+(define (absolute-file-name file-name)
+ (if (absolute-file-name? file-name)
+ file-name
+ (string-append (getcwd) "/" file-name)))
+
+(define (inotify-add-watch! inotify file-name modes)
+ (let* ((abs-file-name (absolute-file-name file-name))
+ (wd (inotify-add-watch (inotify-fd inotify)
+ (string->pointer abs-file-name)
+ (apply logior (map symbol->mask modes))))
+ (watch (make-inotify-watch wd abs-file-name inotify)))
+ (hashv-set! (inotify-watches inotify) wd watch)
+ watch))
+
+(define (inotify-watch-remove! watch)
+ (inotify-rm-watch (inotify-fd (inotify-watch-owner watch))
+ (inotify-watch-id watch))
+ (hashv-remove! (inotify-watches (inotify-watch-owner watch))
+ (inotify-watch-id watch)))
+
+(define (inotify-pending-events? inotify)
+ ;; Sometimes an interrupt happens during the char-ready? call and an
+ ;; exception is thrown. Just return #f in that case and move on
+ ;; with life.
+ (false-if-exception (char-ready? (inotify-port inotify))))
+
+(define (read-int port buffer)
+ (get-bytevector-n! port buffer 0 (sizeof int))
+ (bytevector-sint-ref buffer 0 (native-endianness) (sizeof int)))
+
+(define (read-uint32 port buffer)
+ (get-bytevector-n! port buffer 0 (sizeof uint32))
+ (bytevector-uint-ref buffer 0 (native-endianness) (sizeof uint32)))
+
+(define (read-string port buffer buffer-pointer length)
+ (and (> length 0)
+ (begin
+ (get-bytevector-n! port buffer 0 length)
+ (pointer->string buffer-pointer))))
+
+(define (inotify-read-event inotify)
+ (let* ((port (inotify-port inotify))
+ (buffer (inotify-buffer inotify))
+ (wd (read-int port buffer))
+ (event-mask (read-uint32 port buffer))
+ (cookie (read-uint32 port buffer))
+ (len (read-uint32 port buffer))
+ (name (read-string port buffer (inotify-buffer-pointer inotify) len)))
+ (make-inotify-event (hashv-ref (inotify-watches inotify) wd)
+ (mask->event-symbol event-mask)
+ cookie name)))
diff --git a/haunt/reader.scm b/haunt/reader.scm
index 028b996..cc9ed67 100644
--- a/haunt/reader.scm
+++ b/haunt/reader.scm
@@ -22,8 +22,19 @@
;;
;;; Code:
-(define-module (haunt reader)
- #:declarative? #f
+;; Hack to mark this module as non-declarative on Guile 3+ (which
+;; would otherwise print a warning) but not break when compiling on
+;; earlier versions of Guile.
+(define-syntax-rule (define-module* name args ...)
+ (cond-expand
+ (guile-3
+ (define-module name
+ #:declarative? #f
+ args ...))
+ (guile
+ (define-module name args ...))))
+
+(define-module* (haunt reader)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
diff --git a/haunt/reader/skribe.scm b/haunt/reader/skribe.scm
index 7ffa3cf..c02d54c 100644
--- a/haunt/reader/skribe.scm
+++ b/haunt/reader/skribe.scm
@@ -22,8 +22,19 @@
;;
;;; Code:
-(define-module (haunt reader skribe)
- #:declarative? #f
+;; Hack to mark this module as non-declarative on Guile 3+ (which
+;; would otherwise print a warning) but not break when compiling on
+;; earlier versions of Guile.
+(define-syntax-rule (define-module* name args ...)
+ (cond-expand
+ (guile-3
+ (define-module name
+ #:declarative? #f
+ args ...))
+ (guile
+ (define-module name args ...))))
+
+(define-module* (haunt reader skribe)
#:use-module (haunt reader)
#:use-module (haunt skribe)
#:use-module (haunt skribe utils)
diff --git a/haunt/ui.scm b/haunt/ui.scm
index 8c7c549..5af4ee3 100644
--- a/haunt/ui.scm
+++ b/haunt/ui.scm
@@ -22,8 +22,19 @@
;;
;;; Code:
-(define-module (haunt ui)
- #:declarative? #f
+;; Hack to mark this module as non-declarative on Guile 3+ (which
+;; would otherwise print a warning) but not break when compiling on
+;; earlier versions of Guile.
+(define-syntax-rule (define-module* name args ...)
+ (cond-expand
+ (guile-3
+ (define-module name
+ #:declarative? #f
+ args ...))
+ (guile
+ (define-module name args ...))))
+
+(define-module* (haunt ui)
#:use-module (ice-9 format)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
diff --git a/haunt/ui/serve.scm b/haunt/ui/serve.scm
index 2e8d7aa..7e27aa8 100644
--- a/haunt/ui/serve.scm
+++ b/haunt/ui/serve.scm
@@ -1,5 +1,5 @@
;;; Haunt --- Static site generator for GNU Guile
-;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2015, 2022 David Thompson <davet@gnu.org>
;;;
;;; This file is part of Haunt.
;;;
@@ -29,12 +29,16 @@
#:use-module (ice-9 format)
#:use-module (ice-9 ftw)
#:use-module (ice-9 threads)
- #:use-module (haunt site)
#:use-module (haunt config)
- #:use-module (haunt ui)
+ #:use-module (haunt inotify)
#:use-module (haunt serve web-server)
+ #:use-module (haunt site)
+ #:use-module (haunt ui)
#:export (haunt-serve))
+(define %linux?
+ (string=? (utsname:sysname (uname)) "Linux"))
+
(define (show-help)
(format #t "Usage: haunt serve [OPTION]
Start an HTTP server for the current site.~%")
@@ -84,8 +88,46 @@ Start an HTTP server for the current site.~%")
(apply display-error (stack-ref stack 0) cep args)
(newline cep)))))
+;; TODO: Detect new directories and watch them, too.
+(define (watch/linux config-file check-dir? check-file?)
+ (let ((inotify (make-inotify)))
+ (define (no-op name stat result) result)
+ (define (watch-directory name stat result)
+ (and (check-dir? name)
+ (inotify-add-watch! inotify name
+ '(create delete close-write moved-to moved-from))
+ #t))
+ (file-system-fold watch-directory no-op no-op no-op no-op no-op #t (getcwd))
+ (let loop ((processed-event? #f))
+ (cond
+ ((inotify-pending-events? inotify)
+ (let* ((event (inotify-read-event inotify))
+ (type (inotify-event-type event))
+ (file-name (string-append (inotify-watch-file-name
+ (inotify-event-watch event))
+ "/"
+ (inotify-event-file-name event))))
+ (if (and (check-dir? file-name) (check-file? file-name))
+ (let ((action (case type
+ ((create) "create")
+ ((delete) "delete")
+ ((close-write) "write")
+ ((moved-to moved-from) "move"))))
+ (format #t "watch: observed ~a '~a'~%" action file-name)
+ (loop #t))
+ (loop processed-event?))))
+ (processed-event?
+ (display "rebuilding...\n")
+ (call-with-error-handling
+ (lambda ()
+ (build-site (load-config config-file))))
+ (loop #f))
+ (else
+ (sleep 1)
+ (loop #f))))))
+
;; XXX: Make this less naive.
-(define (watch config-file check-dir? check-file?)
+(define (watch/fallback config-file check-dir? check-file?)
"Watch the current working directory for changes to any of its files
that match CHECK-FILE? and any subdirectories that match CHECK-DIR?.
When a file has been changed, reload CONFIG-FILE and rebuild the
@@ -113,6 +155,7 @@ site."
(let loop ((time (current-time)))
(when (any-files-changed? time)
+ (display "watch: file changes detected")
(display "rebuilding...\n")
(call-with-error-handling
(lambda ()
@@ -131,14 +174,20 @@ site."
(format #t "serving ~a on port ~d~%" doc-root port)
(when watch?
- (call-with-new-thread
- (lambda ()
- (watch config
- (let ((cwd (getcwd))
- (build-dir (site-build-directory site)))
- (lambda (dir)
- (not
- (string-prefix? (string-append cwd "/" build-dir) dir))))
- (site-file-filter site)))))
-
+ (let ((watch (if %linux?
+ (begin
+ (display "watch: using inotify mode\n")
+ watch/linux)
+ (begin
+ (display "watch: using fallback mode\n")
+ watch/fallback))))
+ (call-with-new-thread
+ (lambda ()
+ (watch config
+ (let ((build-dir (string-append (getcwd) "/"
+ (site-build-directory site))))
+ (lambda (dir)
+ (not
+ (string-prefix? build-dir dir))))
+ (site-file-filter site))))))
(serve doc-root #:open-params `(#:port ,port))))