ui: serve: Watch files with inotify on Linux.

1 files changed, 63 insertions, 14 deletions

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))))