From ea16d24be85147120f6bcb26b258614d7d3a61eb Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Fri, 11 May 2018 09:58:25 +0100
Subject: [PATCH] filesystem driver

---
 syndicate/drivers/filesystem.rkt  | 80 +++++++++++++++++++++++++++++++
 syndicate/examples/filesystem.rkt | 31 ++++++++++++
 2 files changed, 111 insertions(+)
 create mode 100644 syndicate/drivers/filesystem.rkt
 create mode 100644 syndicate/examples/filesystem.rkt

diff --git a/syndicate/drivers/filesystem.rkt b/syndicate/drivers/filesystem.rkt
new file mode 100644
index 0000000..c102796
--- /dev/null
+++ b/syndicate/drivers/filesystem.rkt
@@ -0,0 +1,80 @@
+#lang imperative-syndicate
+;; Filesystem change monitor driver
+
+(provide (struct-out file-content)
+         spawn-filesystem-driver)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(assertion-struct file-content (name reader-proc content))
+
+;; Internal driver ground-level protocol
+(message-struct file-changed (name))
+(message-struct file-container-changed (parent-path))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (spawn-filesystem-driver)
+  (spawn #:name 'drivers/filesystem
+         (during/spawn (observe (file-content $name $reader-proc _))
+           #:name (list 'file-content name reader-proc)
+           (track-file name reader-proc))
+         (during (observe (inbound (file-changed $name)))
+           (monitor-thread name))))
+
+(define (read-file name reader-proc)
+  (and (or (file-exists? name) (directory-exists? name))
+       (reader-proc name)))
+
+(define (path->parent-path name)
+  (let-values (((parent-path _leaf _syntactically-dir?)
+                (split-path (path->complete-path name))))
+    parent-path))
+
+(define (track-file name reader-proc)
+  (field [content (read-file name reader-proc)])
+  (assert (file-content name reader-proc (content)))
+  (on (message (inbound (file-changed name)))
+      (content (read-file name reader-proc)))
+  ;; This horrible hack is required to work around limitations in the
+  ;; OS's file-change reporting. It seems (?) as if, monitoring both
+  ;; "a/b" and "a/", that only the event for "a/" will be fired when
+  ;; "a/b" changes. This manifests as follows: if I monitor "a/b" and
+  ;; "a/nonexistent", then when "a/b" changes, only "a/nonexistent"'s
+  ;; event will fire. Therefore, I've kludged in the
+  ;; `file-container-changed` message, which copes with one level of
+  ;; directory hierarchy of this problem.
+  ;;
+  ;; TODO: Consider whether it will actually be required to listen for
+  ;; file-container-changed events for ALL recursive parents of the
+  ;; path of interest up to the root.
+  ;;
+  (on (message (inbound (file-container-changed (path->parent-path name))))
+      (content (read-file name reader-proc))))
+
+(define (monitor-thread name)
+  (define control-ch (make-channel))
+  (thread (lambda ()
+            (define parent-path (path->parent-path name))
+            (let loop ()
+              (sync (handle-evt control-ch
+                                (lambda (msg)
+                                  ;; (log-info "track-file-changes ~v: ~v" name msg)
+                                  (match msg
+                                    ['quit (void)])))
+                    (if (or (file-exists? name) (directory-exists? name)) ;; TODO: TOCTTOU :-(
+                        (handle-evt (filesystem-change-evt name)
+                                    (lambda (_dummy)
+                                      ;; (log-info "track-file-changes ~v: changed" name)
+                                      (ground-send! (inbound (file-changed name)))
+                                      (loop)))
+                        (handle-evt (filesystem-change-evt parent-path)
+                                    (lambda (_dummy)
+                                      ;; (log-info "track-file-changes ~v: directory changed" name)
+                                      (ground-send! (inbound (file-container-changed parent-path)))
+                                      (loop))))))))
+  (on-stop (channel-put control-ch 'quit)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(spawn-filesystem-driver)
diff --git a/syndicate/examples/filesystem.rkt b/syndicate/examples/filesystem.rkt
new file mode 100644
index 0000000..7802ede
--- /dev/null
+++ b/syndicate/examples/filesystem.rkt
@@ -0,0 +1,31 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/drivers/external-event)
+(require/activate imperative-syndicate/drivers/filesystem)
+(require racket/file)
+
+(require (only-in racket/port read-bytes-line-evt))
+(require (only-in racket/string string-trim string-split))
+
+(spawn #:name 'monitor-shell
+       (define e (read-bytes-line-evt (current-input-port) 'any))
+       (on (message (inbound (external-event e (list $line))))
+           (match line
+             [(? eof-object?)
+              (stop-current-facet (send! (list "close" 'all)))]
+             [(? bytes? command-bytes)
+              (send! (string-split (string-trim (bytes->string/utf-8 command-bytes))))])))
+
+(spawn #:name 'monitor-opener
+
+       (define (monitor name reader-proc)
+         (spawn #:name (list 'monitor name)
+                (stop-when (message (list "close" 'all))) ;; old-syndicate version used wildcard
+                (stop-when (message (list "close" name)))
+                (on (asserted (file-content name reader-proc $data))
+                    (log-info "~a: ~v" name data))))
+
+       (on (message (list "open" $name)) (monitor name file->bytes))
+
+       ;; The driver can track directory "contents" just as well as files.
+       (on (message (list "opendir" $name)) (monitor name directory-list)))