filesystem driver
This commit is contained in:
parent
43f1eab1f3
commit
ea16d24be8
|
@ -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)
|
|
@ -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)))
|
Loading…
Reference in New Issue