From 3c3a5ca21345b8df791486027ee367130ed45374 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sat, 9 Jul 2022 09:00:26 -0400 Subject: Factor watch implementations into their own modules. This should also hopefully resolve some issues that Christine Lemmer-Webber reported with the old code when resolving all of those inotify bindings at runtime. --- Makefile.am | 5 +- haunt/ui/serve.scm | 125 +++++------------------------------------------ haunt/watch/fallback.scm | 58 ++++++++++++++++++++++ haunt/watch/linux.scm | 81 ++++++++++++++++++++++++++++++ 4 files changed, 155 insertions(+), 114 deletions(-) create mode 100644 haunt/watch/fallback.scm create mode 100644 haunt/watch/linux.scm diff --git a/Makefile.am b/Makefile.am index 1bddaa4..0df352d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -58,6 +58,7 @@ SOURCES = \ haunt/builder/rss.scm \ haunt/reader.scm \ haunt/reader/texinfo.scm \ + haunt/watch/fallback.scm \ haunt/ui.scm \ haunt/ui/build.scm \ haunt/ui/serve.scm \ @@ -82,7 +83,9 @@ endif if HAVE_INOTIFY -SOURCES += haunt/inotify.scm +SOURCES += \ + haunt/inotify.scm \ + haunt/watch/linux.scm endif diff --git a/haunt/ui/serve.scm b/haunt/ui/serve.scm index be917ea..9360359 100644 --- a/haunt/ui/serve.scm +++ b/haunt/ui/serve.scm @@ -108,114 +108,6 @@ 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?) - ;; Lazy load inotify module. Requiring the module in the - ;; define-module definition would cause crashes on non-Linux - ;; platforms where the FFI cannot bind to inotify functions. - (define inotify-module (resolve-module '(haunt inotify))) - (define make-inotify (module-ref inotify-module 'make-inotify)) - (define inotify-add-watch! (module-ref inotify-module 'inotify-add-watch!)) - (define inotify-pending-events? - (module-ref inotify-module 'inotify-pending-events?)) - (define inotify-read-event (module-ref inotify-module 'inotify-read-event)) - (define inotify-watch-file-name - (module-ref inotify-module 'inotify-watch-file-name)) - (define inotify-event-watch (module-ref inotify-module 'inotify-event-watch)) - (define inotify-event-file-name - (module-ref inotify-module 'inotify-event-file-name)) - (define inotify-event-type (module-ref inotify-module 'inotify-event-type)) - (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)) - ;; Drop .scm extension, remove working directory, - ;; and transform into a symbolic module name. - (define (file-name->module-name file-name) - (map string->symbol - (string-split (string-drop (string-take file-name - (- (string-length file-name) - 4)) - (+ (string-length (getcwd)) 1)) - #\/))) - (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) - ;; Reload Scheme modules when they are changed. - (when (%search-load-path file-name) - (let ((module (resolve-module - (file-name->module-name file-name)))) - (when (module-filename module) - (format #t "watch: reload module ~s~%" - (module-name module)) - (reload-module module)))) - (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/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 -site." - - (define cwd (getcwd)) - - (define (any-files-changed? time) - (define (enter? name stat result) - ;; Don't bother descending if we already know that a file has - ;; changed. - (and (not result) (check-dir? name))) - - (define (leaf name stat result) - ;; Test if file has been modified since the last time we - ;; checked. - (or result - (and (check-file? name) - (or (>= (stat:mtime stat) time) - (>= (stat:ctime stat) time))))) - - (define (no-op name stat result) result) - - (file-system-fold enter? leaf no-op no-op no-op no-op #f cwd)) - - (let loop ((time (current-time))) - (when (any-files-changed? time) - (display "watch: file changes detected") - (display "rebuilding...\n") - (call-with-error-handling - (lambda () - (build-site (load-config config-file))))) - (let ((next-time (current-time))) - (sleep 1) - (loop next-time)))) - (define (haunt-serve . args) (let* ((opts (simple-args-fold args %options %default-options)) (port (assq-ref opts 'port)) @@ -227,16 +119,23 @@ site." (format #t "serving ~a on port ~d~%" doc-root port) (when watch? + ;; Resolve correct watch module at runtime so that we don't try + ;; to load inotify bindings on Mac OS or something, which would + ;; crash. (let ((watch (if %linux? - (begin + (let ((module (resolve-module '(haunt watch linux)))) (display "watch: using inotify mode\n") - watch/linux) - (begin + (module-ref module 'watch)) + (let ((module (resolve-module '(haunt watch fallback)))) (display "watch: using fallback mode\n") - watch/fallback)))) + (module-ref module 'watch))))) (call-with-new-thread (lambda () - (watch config + (watch (lambda () + (display "rebuilding...\n") + (call-with-error-handling + (lambda () + (build-site (load-config config))))) (let ((build-dir (string-append (getcwd) "/" (site-build-directory site)))) (lambda (dir) diff --git a/haunt/watch/fallback.scm b/haunt/watch/fallback.scm new file mode 100644 index 0000000..c001776 --- /dev/null +++ b/haunt/watch/fallback.scm @@ -0,0 +1,58 @@ +;;; Haunt --- Static site generator for GNU Guile +;;; Copyright © 2022 David Thompson +;;; +;;; 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 . + +;;; Commentary: +;; +;; Fallback file update watcher that uses a naive tree walking +;; implementation. +;; +;;; Code: + +(define-module (haunt watch fallback) + #:use-module (haunt site) + #:use-module (ice-9 ftw) + #:export (watch)) + +(define (watch thunk check-dir? check-file?) + (define cwd (getcwd)) + + (define (any-files-changed? time) + (define (enter? name stat result) + ;; Don't bother descending if we already know that a file has + ;; changed. + (and (not result) (check-dir? name))) + + (define (leaf name stat result) + ;; Test if file has been modified since the last time we + ;; checked. + (or result + (and (check-file? name) + (or (>= (stat:mtime stat) time) + (>= (stat:ctime stat) time))))) + + (define (no-op name stat result) result) + + (file-system-fold enter? leaf no-op no-op no-op no-op #f cwd)) + + (let loop ((time (current-time))) + (when (any-files-changed? time) + (display "watch: file changes detected") + (thunk)) + (let ((next-time (current-time))) + (sleep 1) + (loop next-time)))) diff --git a/haunt/watch/linux.scm b/haunt/watch/linux.scm new file mode 100644 index 0000000..d600baa --- /dev/null +++ b/haunt/watch/linux.scm @@ -0,0 +1,81 @@ +;;; Haunt --- Static site generator for GNU Guile +;;; Copyright © 2022 David Thompson +;;; +;;; 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 . + +;;; Commentary: +;; +;; Inotify-based file watching for Linux. +;; +;;; Code: + +(define-module (haunt watch linux) + #:use-module (haunt inotify) + #:use-module (haunt site) + #:use-module (ice-9 ftw) + #:export (watch)) + +;; TODO: Detect new directories and watch them, too. +(define (watch thunk 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)) + ;; Drop .scm extension, remove working directory, + ;; and transform into a symbolic module name. + (define (file-name->module-name file-name) + (map string->symbol + (string-split (string-drop (string-take file-name + (- (string-length file-name) + 4)) + (+ (string-length (getcwd)) 1)) + #\/))) + (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) + ;; Reload Scheme modules when they are changed. + (when (%search-load-path file-name) + (let ((module (resolve-module + (file-name->module-name file-name)))) + (when (module-filename module) + (format #t "watch: reload module ~s~%" + (module-name module)) + (reload-module module)))) + (loop #t)) + (loop processed-event?)))) + (processed-event? + (thunk) + (loop #f)) + (else + (sleep 1) + (loop #f)))))) -- cgit v1.2.3