Commits

evhan committed 83641f1 Merge

Merge branch 'native-threads'

  • Participants
  • Parent commits d2ecc9b, 3612707

Comments (0)

Files changed (18)

 Installation
 ------------
 Installation requires the libfuse library and headers (API version 26)
-and CHICKEN 4.8.0 or newer.
+and a development snapshot of CHICKEN version 4.8.2 or newer.
 
     $ git clone git://bitbucket.org/evhan/chicken-fuse.git
     $ cd chicken-fuse
-    $ chicken-install
+    $ chicken-install -test
 
 Documentation
 -------------
 Documentation is available on the CHICKEN [wiki][], at [chickadee][],
 and under the `doc/` directory.
 
-Usage examples can be found in the `examples/` directory.
+Usage examples can be found in the `test/` and `examples/` directories.
 
 [wiki]: http://wiki.call-cc.org/egg/fuse
 [chickadee]: http://api.call-cc.org/doc/fuse
 ------
 Evan Hanson <evhan@foldling.org>
 
+Lots of thanks to Jörg Wittenberger and Ivan Raikov.
+
 License
 -------
 3-Clause BSD. See LICENSE for details.

File doc/fuse.wiki

 A [[http://fuse.sourceforge.net/|FUSE]] interface.
 
 Installation requires the libfuse library and headers (API version 26)
-and CHICKEN 4.8.0 or newer.
+and a CHICKEN version 4.8.2 or newer.
 
 The source for this extension is available at
 [[https://bitbucket.org/evhan/chicken-fuse|Bitbucket]].
 '''This extension is not yet stable.''' Its interface is subject to
 change, and I'd appreciate feedback and suggestions regarding the API.
 
+==== Requirements
+
+* [[/egg/concurrent-native-callbacks|concurrent-native-callbacks]]
+* [[/egg/foreigners|foreigners]]
+* [[/egg/matchable|matchable]]
+
 ==== Platform Notes
 
 '''This extension is only officially supported on Linux.''' It has also
 been installed successfully on OpenBSD, FreeBSD and Mac OS X, but tested
 far less thoroughly on those platforms.
 
-On Linux, each filesystem operation is executed in its own green
-({{srfi-18}}) thread.
+==== Architecture
+
+Each filesystem is executed in a separate native thread that
+communicates with the (single, shared) CHICKEN runtime via Unix pipe,
+per ([[/egg/concurrent-native-callbacks|concurrent-native-callbacks]]).
+More than one filesystem can be run at a time, but FUSE operations are
+synchronous across all filesystems so long-running callbacks should be
+avoided.
+
+More importantly, care must be taken not to deadlock the Scheme runtime
+by requesting a filesystem operation from within CHICKEN that will
+itself require a response from CHICKEN, for example by accessing a file
+that's part of a running FUSE filesystem. The easiest way to do this is
+to run each filesystem in a dedicated OS-level process whose sole
+responsibility is to service FUSE requests.
 
-On other platforms, filesystem operations are synchronous
-({{start-filesystem}} is single-threaded) and {{stop-filesystem}} is not
-supported.
+On OpenBSD, each filesystem's FUSE loop is single-threaded.
 
 === API
 
 meanings. A {{path}} is a pathname string. {{bsize}}, {{blocks}},
 {{bfree}}, {{bavail}}, {{files}}, {{ffree}} and {{namemax}} are positive
 numeric values corresponding to the {{statvfs(2)}} struct members of the
-those names.
+same names.
 
-A {{value}} may be any Scheme object and indicates whether the
+A resulting {{value}} may be any Scheme object and indicates whether the
 filesystem operation was successful. When {{#f}}, the filesystem will
 indicate a nonexistent file ({{ENOENT}}); any other value indicates
-success. Callbacks should signal other types of failure by raising an
+success. Callbacks should signal other types of failures by raising an
 appropriate {{errno(3)}} value. For example, to signal insufficient
 permissions, an '''{{access:}}''' operation should {{(raise
 errno/perm)}}.
 returned as the result of an '''{{open:}}''' or
 '''{{create:}}'''callback, this value is provided to that file's
 subsequent '''{{read:}}''', '''{{write:}}''' and '''{{release:}}'''
-operations. Note that this object is evicted until the corresponding
-file is closed, so it is more efficient (as well as memory-safe) to use
-simple values as file handles; the same caveats that apply to
-{{object-evict}} apply here. '''{{release:}}''' is guaranteed to be
-called once for every successful '''{{open:}}''', while '''{{read:}}'''
-and '''{{write:}}''' should be prepared to be called multiple times with
-diverse {{offset}} values.
+operations. Note that this object is evicted into static memory (via
+{{object-evict}}) until just before '''{{release:}}''', so it is more
+efficient (as well as memory-safe) to use simple values as file handles;
+the same caveats that apply to {{object-evict}} apply here.
+'''{{release:}}''' is guaranteed to be called once for every successful
+'''{{open:}}''', while '''{{read:}}''' and '''{{write:}}''' should be
+prepared to be called multiple times with diverse {{offset}} values.
 
-<procedure>(start-filesystem path filesystem) -> object</procedure>
+<procedure>(filesystem-start! path filesystem) -> undefined</procedure>
 
-Mount {{filesystem}} at the given {{path}}.
+Start {{filesystem}} at the given {{path}}.
 
 {{path}} should be a pathname string indicating an empty directory.
 
-On success, this procedure will block until the filesystem is unmounted,
-at which point it will return a non-false value. This may occur due to a
-signal, a call to {{stop-filesystem}}, or a user manually running
-{{fusermount -u path}}.
+On successful startup, the filesystem is mounted, its '''{{init:}}'''
+callback is executed, any threads waiting on the filesystem (via
+{{filesystem-wait!}}) are unblocked, and a non-{{#f}} value is returned.
+On failure, {{#f}} is returned immediately.
 
-On failure, it will return {{#f}} immediately.
+{{filesystem-start!}} does not wait for filesystem initialization before
+returning. To block until the filesystem is becomes available, use
+{{filesystem-wait!}}.
 
 The effective exception handler for the filesystem's operations at
-{{path}} is that of {{start-filesystem}}'s dynamic environment, and must
-''always'' return with a suitable {{errno(3)}} integer value. Failure to
-do so may result in orphaned mounts, infinite loops, and locusts.
+{{path}} is that of the call to {{filesystem-start!}}'s dynamic
+environment, and must ''always'' return with a suitable {{errno(3)}}
+integer value. Failure to do so may result in orphaned mounts, infinite
+loops, and locusts.
 
-<procedure>(stop-filesystem path filesystem) -> void</procedure>
+<procedure>(filesystem-stop! path filesystem) -> undefined</procedure>
 
-Unmount {{filesystem}} from the given {{path}}.
+Stop {{filesystem}} at the given {{path}}.
 
 {{path}} should be a pathname string and must exactly match the value
-provided to {{start-filesystem}} when the {{filesystem}} was mounted
+provided to {{filesystem-start!}} when the {{filesystem}} was started
 (according to {{string=?}}).
 
 If the given {{filesystem}} isn't currently mounted at {{path}}, this
-procedure is a noop.
+procedure is a noop. Otherwise, it is unmounted, its '''{{destroy:}}'''
+callback is executed, and any threads waiting on the filesystem (via
+{{filesystem-wait!}}) are unblocked.
+
+<procedure>(filesystem-wait! path filesystem [status]) -> undefined</procedure>
+
+Block until {{filesystem}} is started or stopped at {{path}}.
+
+{{path}} should be a pathname string and must exactly match the value
+provided to {{filesystem-start!}} when the {{filesystem}} was started
+(according to {{string=?}}).
+
+The optional {{status}} argument should be a symbol indicating the
+filesystem state for which to wait, either {{started}} or {{stopped}}.
+By default, {{(eq? status stopped)}}.
+
+<procedure>(filesystem-running? path filesystem) -> boolean</procedure>
 
-On other platforms, this procedure is a noop.
+Determine whether {{filesystem}} is currently running at {{path}}.
+
+{{path}} should be a pathname string and must exactly match the value
+provided to {{filesystem-start!}} when the {{filesystem}} was started
+(according to {{string=?}}).
 
 <constant>file/fifo</constant>
 <constant>file/chr</constant>

File examples/errorfs.scm

 ;;;     $ csc errorfs.scm
 ;;;     $ ./errorfs <mountpoint>
 ;;;
-;;; Ctrl-C or `fusermount -u <mountpoint>` will exit the filesystem loop.
-;;;
 
 (use fuse posix)
 
        (condition->list e)
        (current-error-port)))
     (lambda ()
-      (start-filesystem path fs))))
+      (set-signal-handler! signal/int (lambda (_) (filesystem-stop! path fs)))
+      (filesystem-start! path fs)
+      (filesystem-wait! path fs))))
  (command-line-arguments))

File examples/hashfs.scm

 ;;;     $ csc hashfs.scm
 ;;;     $ ./hashfs <mountpoint>
 ;;;
-;;; Ctrl-C or `fusermount -u <mountpoint>` will exit the filesystem loop.
-;;;
 
 (use files posix srfi-1 srfi-13 srfi-69 fuse)
 
              (fprintf (current-error-port) "Finished!\n"))))
 
 (for-each
- (lambda (path) (start-filesystem path fs))
+ (lambda (path)
+   (set-signal-handler! signal/int (lambda (_) (filesystem-stop! path fs)))
+   (filesystem-start! path fs)
+   (filesystem-wait! path fs))
  (command-line-arguments))

File examples/hellofs.scm

 ;;;     $ csc hellofs.scm
 ;;;     $ ./hellofs <mountpoint>
 ;;;
-;;; Ctrl-C or `fusermount -u <mountpoint>` will exit the filesystem loop.
-;;;
 
 (use fuse posix)
 
                  (substring hello offset (min size (- len offset))))))))
 
 (for-each
- (lambda (path) (start-filesystem path fs))
+ (lambda (path)
+   (set-signal-handler! signal/int (lambda (_) (filesystem-stop! path fs)))
+   (filesystem-start! path fs)
+   (filesystem-wait! path fs))
  (command-line-arguments))

File examples/portfs.scm

 ;;;     $ csc portfs.scm
 ;;;     $ ./portfs <mountpoint>
 ;;;
-;;; Ctrl-C or `fusermount -u <mountpoint>` will exit the filesystem loop.
-;;;
 
 (use fuse posix srfi-13)
 
-(let ((mountpoint ; strip CWD if present
-       (let ((arg (car (command-line-arguments))))
-         (cond ((string-prefix? (current-directory) arg)
-                (substring arg (add1 (string-length (current-directory)))))
-               (else arg)))))
-  (start-filesystem
-   mountpoint
-   (make-filesystem
-    getattr: (lambda (path)
-               (let ((path (substring path 1))) ; leading "/"
-                 (cond ((string=? path mountpoint) #f) ; avoid loop
-                       ((string=? path "")
-                        (subvector (file-stat ".") 1 9))
-                       ((file-exists? path)
-                        (subvector (file-stat path) 1 9))
-                       (else #f))))
-    readdir: (lambda (path)
-               (let ((path (substring path 1)))
-                 (cond ((string=? path mountpoint) #f)
-                       ((string=? path "")
-                        (directory "." #t))
-                       ((directory-exists? path)
-                        (directory path #t))
-                       (else #f))))
-    open:    (lambda (path mode)
-               (let ((path (substring path 1)))
-                  (and (regular-file? path)
-                       (open-input-file path))))
-    read:    (lambda (port size _) ; XXX offset ignored
-               (read-string size port))
-    release: (lambda (port)
-               (close-input-port port)))))
+(let* ((mountpoint ; strip CWD if present
+        (let ((arg (car (command-line-arguments))))
+          (cond ((string-prefix? (current-directory) arg)
+                 (substring arg (add1 (string-length (current-directory)))))
+                (else arg))))
+       (filesystem
+        (make-filesystem
+         getattr: (lambda (path)
+                    (let ((path (substring path 1))) ; leading "/"
+                      (cond ((string=? path mountpoint) #f) ; avoid loop
+                            ((string=? path "")
+                             (subvector (file-stat ".") 1 9))
+                            ((file-exists? path)
+                             (subvector (file-stat path) 1 9))
+                            (else #f))))
+         readdir: (lambda (path)
+                    (let ((path (substring path 1)))
+                      (cond ((string=? path mountpoint) #f)
+                            ((string=? path "")
+                             (directory "." #t))
+                            ((directory-exists? path)
+                             (directory path #t))
+                            (else #f))))
+         open:    (lambda (path mode)
+                    (let ((path (substring path 1)))
+                       (and (regular-file? path)
+                            (open-input-file path))))
+         read:    (lambda (port size _) ; XXX offset ignored
+                    (read-string size port))
+         release: (lambda (port)
+                    (close-input-port port)))))
+  (set-signal-handler! signal/int (lambda (_) (filesystem-stop! mountpoint filesystem)))
+  (filesystem-start! mountpoint filesystem)
+  (filesystem-wait! mountpoint filesystem))
  (author "Evan Hanson")
  (license "BSD")
  (category os)
- (depends foreigners matchable)
+ (depends concurrent-native-callbacks foreigners matchable)
  (foreign-depends "libfuse"))
 ;;; under the terms of the GNU LGPLv2.
 ;;;
 
-(require-library lolevel srfi-18)
+(require-library lolevel srfi-18 posix)
+(require-library concurrent-native-callbacks)
+(require-extension-for-syntax concurrent-native-callbacks-compile-time matchable)
 
 (module fuse
   (make-filesystem
-   start-filesystem
-   stop-filesystem
+   filesystem-start!
+   filesystem-stop!
+   filesystem-running?
+   filesystem-wait!
+   filesystem?
    file/fifo
    file/chr
    file/blk
    file/dir
    file/lnk
    file/sock)
-  (import scheme chicken foreign lolevel srfi-18 matchable libfuse)
+  (import scheme chicken foreign lolevel srfi-18)
+  (import (except posix errno/nosys))
+  (import concurrent-native-callbacks libfuse matchable)
   (foreign-declare "#define FUSE_USE_VERSION 26")
   (foreign-declare "#include <fuse.h>")
   (foreign-declare "#include <errno.h>")
+  (foreign-declare "#include <pthread.h>")
+  (foreign-declare "#include <signal.h>")
 
 (define-foreign-type dev_t int)
 (define-foreign-type off_t integer64) ; libfuse has _FILE_OFFSET_BITS=64
 (define-foreign-type fuse_file_info (c-pointer (struct "fuse_file_info")))
 (define-foreign-type fuse_conn_info (c-pointer (struct "fuse_conn_info")))
 (define-foreign-type fuse_pollhandle (c-pointer (struct "fuse_pollhandle")))
+(define-foreign-type fuse_operations (c-pointer (struct "fuse_operations")))
 (define-foreign-type fuse_fill_dir_t
-  (function int (c-pointer (const c-string) (c-pointer (const (struct "stat"))) off_t)))
+  (function int (c-pointer c-string (c-pointer (struct "stat")) off_t)))
+
+(define-syntax when-let*
+  (syntax-rules ()
+    ((_ . rest) (or (and-let* . rest) (void)))))
 
 (define-inline (vector-for-each f v) ; . v
   (let ((l (##sys#vector-length v)))
 
 ;;
 ;; The filesystem and mount record types are opaque structures that
-;; track a filesystem's callbacks, mountpoints, and each mount's dynamic
-;; environment (currently, its exception handler).
+;; track a filesystem's callbacks, active mounts, shutdown and exception
+;; handlers.
 ;;
 (define-record filesystem operations mounts)
-(define-record mount filesystem channel exception-handler)
-(define filesystem make-filesystem)
+(define-record mount filesystem synchronization-handler shutdown-handler exception-handler)
 
 (define-inline (filesystem-mount-add! fs path mount)
   (filesystem-mounts-set! fs (alist-cons path mount (filesystem-mounts fs))))
 (define-inline (filesystem-mount-delete! fs path)
   (filesystem-mounts-set! fs (alist-delete path (filesystem-mounts fs) string=?)))
 
+(define (mount-status mount)
+  ((mount-synchronization-handler mount)
+   (lambda (m _ poll-fuse-exit!)
+     (poll-fuse-exit!)
+     (mutex-specific m))))
+
+(define (mount-status-set! mount v)
+  ((mount-synchronization-handler mount)
+   (lambda (m c _)
+     (mutex-specific-set! m v)
+     (condition-variable-signal! c))))
+
+(define (mount-wait! mount status)
+  ((mount-synchronization-handler mount)
+   (lambda (m c _)
+     (do ((s (mount-status mount)
+             (mount-status mount)))
+         ((eq? s status))
+       (mutex-unlock! m c 1)))))
+
+(define (mount-stop! mount)
+  ((mount-synchronization-handler mount)
+   (lambda (m c _)
+     (mutex-lock! m)
+     (let ((shutdown-handler (mount-shutdown-handler mount)))
+       (mount-shutdown-handler-set! mount void)
+       (mount-synchronization-handler-set! mount (cut <> m c void))
+       (call/cc (cut with-exception-handler <> shutdown-handler))
+       (mount-status-set! mount 'stopped)
+       (mutex-unlock! m)))))
+
 (define-constant operations ; NB order matters.
   '(getattr:
     readdir:
     ))
 
 (define make-filesystem
-  (let ((not-implemented (lambda _ (raise errno/nosys))))
+  (let ((make-filesystem make-filesystem))
     (lambda args
-      (let ((oper (##sys#make-vector 23 not-implemented)))
+      (let ((oper (##sys#make-vector 23 #f)))
         (let loop ((args args))
           (match args
             (()
-             (filesystem oper '()))
+             (make-filesystem oper '()))
             (('utime: value . rest)
              (error 'make-filesystem "The utime: option is deprecated - use utimens: instead"))
             (('getdir: value . rest)
             (else
              (error 'make-filesystem "Odd keyword arguments" (car args)))))))))
 
+(define current-fuse-context #f) ; XXX Dynamic variable.
+
 (define-inline (current-mount)
-  (gc-root-ref (fuse_context_private_data (fuse_get_context))))
+  (gc-root-ref (fuse_context_private_data current-fuse-context)))
 
 (define-inline (current-filesystem)
   (mount-filesystem (current-mount)))
 
 (define-inline (current-filesystem-callback i)
-  (##sys#vector-ref (filesystem-operations (current-filesystem)) i))
+  (or (##sys#vector-ref (filesystem-operations (current-filesystem)) i)
+      (lambda _ (raise errno/nosys))))
 
 (define-inline (current-mount-exception-handler)
   (mount-exception-handler (current-mount)))
       thunk))))
 
 (define-syntax define-callback
-  (syntax-rules ()
-    ((_ spec return-type . body)
-     (define-external spec return-type
-       (callback-protect (lambda () . body))))))
-
-(define-callback (fuse_getattr_callback (c-string path) ((c-pointer (struct "stat")) stat)) int
+  (er-macro-transformer
+   (lambda (e r c)
+     (let* ((name        (caadr e))
+            (spec        (cdadr e))
+            (return-type (caddr e))
+            (body        (cdddr e))
+            (handler     (symbol-append 'fuse_ name '_handler))
+            (callback    (symbol-append 'fuse_ name '_callback)))
+       `(begin
+          (define-synchronous-concurrent-native-callback
+            (,handler (c-pointer context) ,@spec) ,return-type
+            (fluid-let ((current-fuse-context context))
+              (callback-protect (lambda () ,@body))))
+          (foreign-declare
+           ,(conc (foreign-type-declaration return-type "")
+                  callback "("
+                  (string-intersperse
+                   (map (match-lambda
+                          ((type arg)
+                           (foreign-type-declaration type (symbol->string arg))))
+                        spec)
+                   ",") "){"
+                  (if (eq? void return-type) "" "return ")
+                  handler "(fuse_get_context(),"
+                  (string-intersperse
+                   (map (match-lambda ((type arg) (symbol->string arg))) spec)
+                   ",") ");}")))))))
+
+(define-callback (getattr (c-string path) (c-pointer stat)) int
   (let ((v ((current-filesystem-callback 0) path)))
     (match v
       (#(mode nlink uid gid size atime ctime mtime)
       (else
        (callback-result v)))))
 
-(define-callback (fuse_readdir_callback (c-string path) (c-pointer buf) (fuse_fill_dir_t filler) (off_t off) (fuse_file_info fi)) int
+(define-callback (readdir (c-string path) (c-pointer buf) ((function int (c-pointer c-string c-pointer int)) filler) (integer64 off) (c-pointer fi)) int
   (let ((v ((current-filesystem-callback 1) path)))
     (match v
       ((n ...)
       (else
        (callback-result v)))))
 
-(define-callback (fuse_open_callback (c-string path) (fuse_file_info fi)) int
+(define-callback (open (c-string path) (c-pointer fi)) int
   (let ((v ((current-filesystem-callback 2) path (fuse_file_info_flags fi))))
     (fuse_file_info_fh_set! fi (object-evict v))
     (callback-result v)))
 
-(define-callback (fuse_read_callback (c-string path) (c-pointer buf) (size_t len) (off_t off) (fuse_file_info fi)) int
+(define-callback (read (c-string path) (c-pointer buf) (size_t len) (integer64 off) (c-pointer fi)) int
   (let ((v ((current-filesystem-callback 3) (fuse_file_info_fh fi) len off)))
     (cond ((fixnum? v) v)
           ((string? v)
              l))
           ((callback-result v)))))
 
-(define-callback (fuse_write_callback (c-string path) (c-string data) (size_t len) (off_t off) (fuse_file_info fi)) int
+(define-callback (write (c-string path) (c-string data) (size_t len) (integer64 off) (c-pointer fi)) int
   (let ((v ((current-filesystem-callback 4) (fuse_file_info_fh fi) (##sys#substring data 0 len) off)))
     (cond ((fixnum? v) v)
           ((string? v) (string-length v))
           ((callback-result v)))))
 
-(define-callback (fuse_release_callback (c-string path) (fuse_file_info fi)) int
+(define-callback (release (c-string path) (c-pointer fi)) int
   (callback-result ((current-filesystem-callback 5) (object-unevict (fuse_file_info_fh fi)))))
 
-(define-callback (fuse_access_callback (c-string path) (mode_t mode)) int
+(define-callback (access (c-string path) (int mode)) int
   (callback-result ((current-filesystem-callback 6) path mode)))
 
-(define-callback (fuse_create_callback (c-string path) (mode_t mode) (fuse_file_info fi)) int
+(define-callback (create (c-string path) (int mode) (c-pointer fi)) int
   (let ((v ((current-filesystem-callback 7) path mode)))
     (fuse_file_info_fh_set! fi (object-evict v))
     (callback-result v)))
 
-(define-callback (fuse_unlink_callback (c-string path)) int
+(define-callback (unlink (c-string path)) int
   (callback-result ((current-filesystem-callback 8) path)))
 
-(define-callback (fuse_truncate_callback (c-string path) (off_t off)) int
+(define-callback (truncate (c-string path) (integer64 off)) int
   (callback-result ((current-filesystem-callback 9) path off)))
 
-(define-callback (fuse_readlink_callback (c-string path) (c-pointer buf) (size_t len)) int
+(define-callback (readlink (c-string path) (c-pointer buf) (size_t len)) int
   (let ((r ((current-filesystem-callback 10) path)))
     (cond ((not r)
            (foreign-value "-ENOENT" int))
           (else
            (error 'readlink "Invalid result" r)))))
 
-(define-callback (fuse_symlink_callback (c-string to) (c-string from)) int
+(define-callback (symlink (c-string to) (c-string from)) int
   (callback-result ((current-filesystem-callback 11) to from)))
 
-(define-callback (fuse_mknod_callback (c-string path) (mode_t mode) (dev_t dev)) int
+(define-callback (mknod (c-string path) (int mode) (int dev)) int
   (callback-result ((current-filesystem-callback 12) path mode)))
 
-(define-callback (fuse_mkdir_callback (c-string path) (mode_t mode)) int
+(define-callback (mkdir (c-string path) (int mode)) int
   (callback-result ((current-filesystem-callback 13) path mode)))
 
-(define-callback (fuse_rmdir_callback (c-string path)) int
+(define-callback (rmdir (c-string path)) int
   (callback-result ((current-filesystem-callback 14) path)))
 
-(define-callback (fuse_rename_callback (c-string from) (c-string to)) int
+(define-callback (rename (c-string from) (c-string to)) int
   (callback-result ((current-filesystem-callback 15) from to)))
 
-(define-callback (fuse_link_callback (c-string to) (c-string from)) int
+(define-callback (link (c-string to) (c-string from)) int
   (callback-result ((current-filesystem-callback 16) to from)))
 
-(define-callback (fuse_chmod_callback (c-string path) (mode_t mode)) int
+(define-callback (chmod (c-string path) (int mode)) int
   (callback-result ((current-filesystem-callback 17) path mode)))
 
-(define-callback (fuse_chown_callback (c-string path) (uid_t uid) (gid_t gid)) int
+(define-callback (chown (c-string path) (int uid) (int gid)) int
   (callback-result ((current-filesystem-callback 18) path uid gid)))
 
-(define-callback (fuse_utimens_callback (c-string path) ((c-pointer (struct "timespec")) tv)) int ; tv[2]
+(define-callback (utimens (c-string path) (c-pointer tv)) int ; tv[2]
   (let-values (((asec msec) ; nsecs currently ignored.
                 ((foreign-primitive ((c-pointer tv))
                   "C_values(4,
                  tv)))
     (callback-result ((current-filesystem-callback 19) path asec msec))))
 
-(define-callback (fuse_statfs_callback (c-string path) ((c-pointer (struct "statvfs")) statvfs)) int
+(define-callback (statfs (c-string path) (c-pointer statvfs)) int
   (let ((v ((current-filesystem-callback 20) path)))
     (match v
       (#(bsize blocks bfree bavail files ffree namemax)
       (else
        (callback-result v)))))
 
-(define-callback (fuse_init_callback (fuse_conn_info conn)) c-pointer
+(define-callback (init (c-pointer data)) c-pointer
   (callback-protect (current-filesystem-callback 21))
-  (fuse_context_private_data (fuse_get_context)))
+  (mount-status-set! (current-mount) 'started)
+  (fuse_context_private_data current-fuse-context))
 
-(define-callback (fuse_destroy_callback (c-pointer data)) void
-  ((current-filesystem-callback 22)))
+(define-callback (destroy (c-pointer data)) void
+  (mount-status-set! (current-mount) 'stopping)
+  (mount-stop! (current-mount)))
 
 (define make-gc-root
-  (foreign-primitive ((scheme-object obj))
-#<<EOC
-  C_word rp, op[C_SIZEOF_POINTER], *pp = op, *root;
-  root = CHICKEN_new_gc_root();
-  CHICKEN_gc_root_set(root, obj);
-  rp = C_mpointer(&pp, (void *)root);
-  C_return(rp);
-EOC
-))
+  (foreign-primitive c-pointer ((scheme-object obj))
+   "C_word *root = CHICKEN_new_gc_root();"
+   "CHICKEN_gc_root_set(root, obj);"
+   "C_return(root);"))
 
 (define gc-root-ref
-  (foreign-primitive ((c-pointer root)) "C_return(CHICKEN_gc_root_ref(root));"))
-
-(define gc-root-destroy
-  (foreign-primitive ((c-pointer root)) "CHICKEN_delete_gc_root(root);"))
+  (foreign-primitive scheme-object ((c-pointer root)) "C_return(CHICKEN_gc_root_ref(root));"))
+
+(define gc-root-destroy!
+  (foreign-primitive void ((c-pointer root)) "CHICKEN_delete_gc_root(root);"))
+
+(cond-expand
+  (openbsd
+   (foreign-declare "#define fuse_loop_mt fuse_loop")
+   (foreign-declare "#define fuse_exit(_)"))
+  (else))
+
+#>
+
+void *fuse_loop_worker(void *fuse) {
+  sigset_t s;
+  sigemptyset(&s);
+  sigaddset(&s, SIGHUP);
+  sigaddset(&s, SIGINT);
+  sigaddset(&s, SIGTERM);
+  pthread_sigmask(SIG_BLOCK, &s, NULL);
+  fuse_loop_mt(fuse);
+  fuse_exit(fuse);
+  return NULL;
+}
+
+void *start_fuse_thread(void *fuse) {
+  pthread_t *thread = malloc(sizeof(pthread_t));
+  if (NULL == thread)
+    C_return(NULL);
+  if (pthread_create(thread, NULL, fuse_loop_worker, fuse))
+    C_return(NULL);
+  else
+    C_return(thread);
+}
+
+int stop_fuse_thread(pthread_t *thread) {
+  int result = 0;
+  if (pthread_cancel(*thread))
+    goto out;
+  if (pthread_join(*thread, NULL))
+    goto out;
+  else
+    result = 1;
+out:
+  free(thread);
+  C_return(result);
+}
+
+<#
+
+(define start-fuse-thread!
+  (foreign-lambda c-pointer start_fuse_thread c-pointer))
+
+(define stop-fuse-thread!
+  (cond-expand
+    (openbsd (foreign-lambda bool stop_fuse_thread c-pointer))
+    (else void)))
 
-(define start-filesystem
+(define filesystem-start!
   (let* ((opsize (foreign-type-size "struct fuse_operations"))
          (ops    (allocate opsize)))
-    (fuse_operations_getattr_set!  ops (location fuse_getattr_callback))
-    (fuse_operations_readdir_set!  ops (location fuse_readdir_callback))
-    (fuse_operations_open_set!     ops (location fuse_open_callback))
-    (fuse_operations_read_set!     ops (location fuse_read_callback))
-    (fuse_operations_write_set!    ops (location fuse_write_callback))
-    (fuse_operations_release_set!  ops (location fuse_release_callback))
-    (fuse_operations_access_set!   ops (location fuse_access_callback))
-    (fuse_operations_create_set!   ops (location fuse_create_callback))
-    (fuse_operations_unlink_set!   ops (location fuse_unlink_callback))
-    (fuse_operations_truncate_set! ops (location fuse_truncate_callback))
-    (fuse_operations_readlink_set! ops (location fuse_readlink_callback))
-    (fuse_operations_symlink_set!  ops (location fuse_symlink_callback))
-    (fuse_operations_mknod_set!    ops (location fuse_mknod_callback))
-    (fuse_operations_mkdir_set!    ops (location fuse_mkdir_callback))
-    (fuse_operations_rmdir_set!    ops (location fuse_rmdir_callback))
-    (fuse_operations_rename_set!   ops (location fuse_rename_callback))
-    (fuse_operations_link_set!     ops (location fuse_link_callback))
-    (fuse_operations_chmod_set!    ops (location fuse_chmod_callback))
-    (fuse_operations_chown_set!    ops (location fuse_chown_callback))
-    (fuse_operations_utimens_set!  ops (location fuse_utimens_callback))
-    (fuse_operations_statfs_set!   ops (location fuse_statfs_callback))
-    (fuse_operations_init_set!     ops (location fuse_init_callback))
-    (fuse_operations_destroy_set!  ops (location fuse_destroy_callback))
+    (fuse_operations_getattr_set!  ops (foreign-value "fuse_getattr_callback" c-pointer))
+    (fuse_operations_readdir_set!  ops (foreign-value "fuse_readdir_callback" c-pointer))
+    (fuse_operations_open_set!     ops (foreign-value "fuse_open_callback" c-pointer))
+    (fuse_operations_read_set!     ops (foreign-value "fuse_read_callback" c-pointer))
+    (fuse_operations_write_set!    ops (foreign-value "fuse_write_callback" c-pointer))
+    (fuse_operations_release_set!  ops (foreign-value "fuse_release_callback" c-pointer))
+    (fuse_operations_access_set!   ops (foreign-value "fuse_access_callback" c-pointer))
+    (fuse_operations_create_set!   ops (foreign-value "fuse_create_callback" c-pointer))
+    (fuse_operations_unlink_set!   ops (foreign-value "fuse_unlink_callback" c-pointer))
+    (fuse_operations_truncate_set! ops (foreign-value "fuse_truncate_callback" c-pointer))
+    (fuse_operations_readlink_set! ops (foreign-value "fuse_readlink_callback" c-pointer))
+    (fuse_operations_symlink_set!  ops (foreign-value "fuse_symlink_callback" c-pointer))
+    (fuse_operations_mknod_set!    ops (foreign-value "fuse_mknod_callback" c-pointer))
+    (fuse_operations_mkdir_set!    ops (foreign-value "fuse_mkdir_callback" c-pointer))
+    (fuse_operations_rmdir_set!    ops (foreign-value "fuse_rmdir_callback" c-pointer))
+    (fuse_operations_rename_set!   ops (foreign-value "fuse_rename_callback" c-pointer))
+    (fuse_operations_link_set!     ops (foreign-value "fuse_link_callback" c-pointer))
+    (fuse_operations_chmod_set!    ops (foreign-value "fuse_chmod_callback" c-pointer))
+    (fuse_operations_chown_set!    ops (foreign-value "fuse_chown_callback" c-pointer))
+    (fuse_operations_utimens_set!  ops (foreign-value "fuse_utimens_callback" c-pointer))
+    (fuse_operations_statfs_set!   ops (foreign-value "fuse_statfs_callback" c-pointer))
+    (fuse_operations_init_set!     ops (foreign-value "fuse_init_callback" c-pointer))
+    (cond-expand
+      (openbsd (fuse_operations_destroy_set! ops (foreign-value "fuse_destroy_callback" c-pointer)))
+      (else))
     (lambda (path fs)
-      (and-let* ((chan  (fuse_mount path #f))
-                 (mount (make-mount fs chan (current-exception-handler)))
-                 (root  (make-gc-root mount))
-                 (fuse  (fuse_new chan #f ops opsize root))
-                 (sess  (fuse_get_session fuse)))
-        (filesystem-mount-add! fs path mount)
-        (fuse_set_signal_handlers sess)
-        (cond-expand
-          (linux
-           (let ((size (fuse_chan_bufsize chan)))
-             (let loop ((buf (allocate size)))
-               (thread-wait-for-i/o! (fuse_chan_fd chan) #:input)
-               (unless (fuse_session_exited sess)
-                 (let-location ((chan* c-pointer chan))
-                   (let ((r (fuse_chan_recv (location chan*) buf size)))
-                     (cond ((fx= r (foreign-value "-EINTR" int))
-                            (loop buf))
-                           ((fx<= r 0)
-                            (free buf)
-                            (fuse_session_exit sess))
-                           (else
-                            (thread-start!
-                             (lambda ()
-                               (fuse_session_process sess buf r chan*)
-                               (free buf)))
-                            (loop (allocate size))))))))))
-          (else
-           (fuse_loop fuse)))
-        (fuse_remove_signal_handlers sess)
-        (fuse_unmount path chan)
-        (fuse_destroy fuse)
-        (gc-root-destroy root)
-        (filesystem-mount-delete! fs path)))))
-
-(define (stop-filesystem path fs)
-  (cond-expand
-    (linux
-     (and-let* ((mount (alist-ref path (filesystem-mounts fs) string=?))
-                (chan  (mount-channel mount)))
-       (fuse_session_exit (fuse_chan_session chan))
-       ((foreign-lambda int close int) (fuse_chan_fd chan))))
-    (else))))
+      (and-let* ((chan   (fuse_mount path #f))
+                 (mount  (make-mount fs void void (current-exception-handler)))
+                 (root   (make-gc-root mount))
+                 (fuse   (fuse_new chan #f ops opsize root))
+                 (thread (start-fuse-thread! fuse)))
+        (mount-synchronization-handler-set!
+         mount
+         (let ((m (make-mutex))
+               (c (make-condition-variable)))
+           (mutex-specific-set! m 'starting)
+           (lambda (f)
+             (f m c (lambda ()
+                      (when (fuse_exited fuse)
+                        (mount-stop! mount)))))))
+        (mount-shutdown-handler-set!
+         mount
+         (lambda ()
+           (cond-expand
+             (openbsd
+              (fuse_destroy fuse)
+              (fuse_unmount path chan)
+              (unless (eq? (mount-status mount) 'stopping)
+                (stop-fuse-thread! thread)))
+             (else
+              (fuse_exit fuse)
+              (fuse_unmount path chan)
+              (fuse_destroy fuse)))
+           (gc-root-destroy! root)
+           (filesystem-mount-delete! fs path)
+           (when-let* ((destroy-callback
+                        (##sys#vector-ref (filesystem-operations fs) 22)))
+             (destroy-callback))))
+        (filesystem-mount-add! fs path mount)))))
+
+(define (filesystem-wait! path fs #!optional (status 'stopped))
+  (when-let* ((mount (alist-ref path (filesystem-mounts fs) string=?)))
+    (mount-wait! mount status)))
+
+(define (filesystem-stop! path fs)
+  (when-let* ((mount (alist-ref path (filesystem-mounts fs) string=?)))
+    (mount-stop! mount)))
+
+(define (filesystem-running? path fs)
+  (and-let* ((mount (alist-ref path (filesystem-mounts fs) string=?)))
+    (eq? (mount-status mount) 'started))))
                  "This is unlikely to work.")
            (cond-expand
              (freebsd '(-lfuse -C -D_FILE_OFFSET_BITS=64 -pthread))
-             (openbsd '(-lfuse))
+             (openbsd '(-lfuse -pthread))
              ;(macosx ...) ; No clue.
-             (else    '(-lfuse -C -D_FILE_OFFSET_BITS=64))))
+             (else    '(-lfuse -C -D_FILE_OFFSET_BITS=64 -pthread))))
           (else
            (foldl (lambda (a s)
                     (if (string-prefix? "-l" s)
   (foreign-declare "#define FUSE_USE_VERSION 26")
   (foreign-declare "#include <fuse.h>")
   (cond-expand
-    (linux (foreign-declare "#include <fuse/fuse_lowlevel.h>"))
+    ((or linux macosx)
+     (foreign-declare "#include <fuse/fuse_lowlevel.h>"))
     (else))
 
   (define-foreign-type off_t "off_t")
   (define-foreign-type mode_t "mode_t")
   (define-foreign-type fuse (c-pointer (struct "fuse")))
   (define-foreign-type fuse_args (c-pointer (struct "fuse_args")))
-  (define-foreign-type fuse_buf (c-pointer (struct "fuse_buf")))
-  (define-foreign-type fuse_bufvec (c-pointer (struct "fuse_bufvec")))
+  ;(define-foreign-type fuse_buf (c-pointer (struct "fuse_buf")))
+  ;(define-foreign-type fuse_bufvec (c-pointer (struct "fuse_bufvec")))
   (define-foreign-type fuse_chan (c-pointer (struct "fuse_chan")))
-  (define-foreign-type fuse_chan_ops (c-pointer (struct "fuse_chan_ops")))
+  ;(define-foreign-type fuse_chan_ops (c-pointer (struct "fuse_chan_ops")))
   (define-foreign-type fuse_conn_info (c-pointer (struct "fuse_conn_info")))
   (define-foreign-type fuse_session (c-pointer (struct "fuse_session")))
-  (define-foreign-type fuse_pollhandle (c-pointer (struct "fuse_pollhandle")))
+  ;(define-foreign-type fuse_pollhandle (c-pointer (struct "fuse_pollhandle")))
   (define-foreign-type fuse_fill_dir_t (function int (c-pointer (const c-string) (c-pointer (const (struct "stat"))) off_t)))
 
   ;(define-foreign-record-type (fuse_args "struct fuse_args")
     ; #;fuse_operations_flock_set!))
 
   (define fuse_new (foreign-lambda fuse fuse_new fuse_chan fuse_args (const fuse_operations) size_t c-pointer))
-  (define fuse_destroy (foreign-safe-lambda void fuse_destroy fuse))
-  (define fuse_exit (foreign-lambda void fuse_exit fuse))
-  (define fuse_loop (foreign-safe-lambda int fuse_loop fuse))
+  (define fuse_destroy (foreign-lambda void fuse_destroy fuse))
+  (define fuse_loop (foreign-lambda int fuse_loop fuse))
   (define fuse_get_context (foreign-lambda fuse_context fuse_get_context))
   (define fuse_get_session (foreign-lambda fuse_session fuse_get_session fuse))
   ;(define fuse_getgroups (foreign-lambda int fuse_getgroups int (c-pointer gid_t)))
   ;(define fuse_interrupted (foreign-lambda bool fuse_interrupted))
   ;(define fuse_notify_poll (foreign-lambda int fuse_notify_poll fuse_pollhandle))
 
+  (cond-expand
+    ((or linux macosx)
+     (define fuse_exit (foreign-lambda void fuse_exit fuse))
+     (define fuse_exited (foreign-lambda bool fuse_exited fuse)))
+    (else
+     (define fuse_exit void)
+     (define fuse_exited (lambda (_) #f))))
+
   (define fuse_mount (foreign-lambda fuse_chan fuse_mount nonnull-c-string fuse_args))
   (define fuse_unmount (foreign-lambda void fuse_unmount nonnull-c-string fuse_chan))
 
   ;(define fuse_version (foreign-lambda int fuse_version))
   ;(define fuse_pollhandle_destroy (foreign-lambda void fuse_pollhandle_destroy fuse_pollhandle))
 
-  ;(define fuse_loop_mt (foreign-safe-lambda int fuse_loop_mt fuse))
+  (define fuse_loop_mt (foreign-lambda int fuse_loop_mt fuse))
   ;(define fuse_start_cleanup_thread (foreign-lambda int fuse_start_cleanup_thread fuse))
   ;(define fuse_start_cleanup_thread (foreign-lambda void fuse_stop_cleanup_thread fuse))
   ;(define fuse_clean_cache (foreign-lambda int fuse_clean_cache fuse))
 
   ;(define fuse_chan_new (foreign-lambda fuse_chan fuse_chan_new fuse_chan_ops int size_t c-pointer))
   (define fuse_chan_fd (foreign-lambda int fuse_chan_fd fuse_chan))
-  (define fuse_chan_bufsize (foreign-lambda size_t fuse_chan_bufsize fuse_chan))
-  (define fuse_chan_session (foreign-lambda fuse_session fuse_chan_session fuse_chan))
-  (define fuse_chan_recv (foreign-lambda int fuse_chan_recv (c-pointer fuse_chan) c-pointer size_t))
+  ;(define fuse_chan_bufsize (foreign-lambda size_t fuse_chan_bufsize fuse_chan))
+  ;(define fuse_chan_session (foreign-lambda fuse_session fuse_chan_session fuse_chan))
+  ;(define fuse_chan_recv (foreign-lambda int fuse_chan_recv (c-pointer fuse_chan) c-pointer size_t))
   ;(define fuse_chan_send (foreign-lambda int fuse_chan_send fuse_chan (c-pointer (struct "iovec")) size_t))
   ;(define fuse_chan_destroy (foreign-lambda void fuse_chan_destroy fuse_chan))
 
   ;(define fuse_session_add_chan (foreign-lambda void fuse_session_add_chan fuse_session fuse_chan))
   ;(define fuse_session_remove_chan (foreign-lambda void fuse_session_remove_chan fuse_chan))
   ;(define fuse_session_next_chan (foreign-lambda fuse_chan fuse_session_next_chan fuse_session fuse_chan))
-  (define fuse_session_process (foreign-safe-lambda void fuse_session_process fuse_session c-pointer size_t fuse_chan))
+  ;(define fuse_session_process (foreign-lambda void fuse_session_process fuse_session c-pointer size_t fuse_chan))
   ;(define fuse_session_process_buf (foreign-lambda void fuse_session_process_buf fuse_session (const fuse_buf) fuse_chan))
   ;(define fuse_session_receive_buf (foreign-lambda int fuse_session_receive_buf fuse_session fuse_buf (c-pointer fuse_chan)))
   ;(define fuse_session_destroy (foreign-lambda void fuse_session_destroy fuse_session))
-  (define fuse_session_exit (foreign-lambda void fuse_session_exit fuse_session))
+  ;(define fuse_session_exit (foreign-lambda void fuse_session_exit fuse_session))
   ;(define fuse_session_reset (foreign-lambda void fuse_session_reset fuse_session))
-  (define fuse_session_exited (foreign-lambda bool fuse_session_exited fuse_session))
+  ;(define fuse_session_exited (foreign-lambda bool fuse_session_exited fuse_session))
   ;(define fuse_session_data (foreign-lambda c-pointer fuse_session_data fuse_session))
-  ;(define fuse_session_loop (foreign-safe-lambda int fuse_session_loop fuse_session))
+  ;(define fuse_session_loop (foreign-lambda int fuse_session_loop fuse_session))
 
   ;; fuse_main is defined as a macro.
   (define (fuse_main argc argv op user_data)
-    ((foreign-safe-lambda* int ((int argc)
-                                ((c-pointer c-string) argv)
-                                (fuse_operations op)
-                                (c-pointer user_data))
+    ((foreign-lambda* int ((int argc)
+                           ((c-pointer c-string) argv)
+                           (fuse_operations op)
+                           (c-pointer user_data))
       "C_return(fuse_main(argc, argv, op, user_data));")
      argc
      argv

File tests/all.scm

+(use test)
+
+(test-group (cond-expand
+              (compiling "fuse (compiled)")
+              (else "fuse (interpreted)"))
+  (test-group "the filesystem record type" (include "fuse.scm"))
+  (test-group "an empty filesystem" (include "empty.scm"))
+  (test-group "unmounting a filesystem" (include "unmount.scm"))
+  (test-group "a hello world filesystem" (include "hello.scm"))
+  (test-group "directory manipulation" (include "dirs.scm"))
+  (test-group "exception handling" (include "exn.scm")))
+
+(test-exit)

File tests/dirs.scm

+(use fuse posix test)
+
+(define u+rwx/reg (bitwise-ior file/reg perm/irusr perm/iwusr perm/ixusr))
+(define u+rwx/dir (bitwise-ior file/dir perm/irusr perm/iwusr perm/ixusr))
+
+(define (process-terminate! pid)
+  (process-signal pid signal/term)
+  (process-wait pid))
+
+(define (test-directories path)
+  (define fs
+    (let ((lst '()))
+      (make-filesystem
+       getattr: (lambda (path)
+                  (and (or (string=? path "/")
+                           (member (substring path 1) lst))
+                       (vector u+rwx/dir
+                               2
+                               (current-user-id)
+                               (current-group-id)
+                               0
+                               (current-seconds)
+                               (current-seconds)
+                               (current-seconds))))
+       readdir: (lambda (path)
+                  (and (string=? path "/")
+                       (append '("." "..") lst)))
+       mkdir:   (lambda (path mode)
+                  (set! lst (cons (substring path 1) lst))))))
+  (define pid
+    (process-fork
+     (lambda ()
+       (set-signal-handler! signal/term (lambda (_) (filesystem-stop! path fs)))
+       (filesystem-start! path fs)
+       (filesystem-wait! path fs))))
+  (sleep 1)
+  (let ((num 1000))
+    (test-assert (equal? (directory path) '()))
+    (list-tabulate num (lambda (n)
+                         (create-directory (string-append path "/" (number->string n)))))
+    (test-assert (equal? (length (directory path)) num))
+    (process-terminate! pid)
+    (test-assert (equal? (directory path) '()))))
+
+(test-assert (create-directory "path" #t))
+(test-directories "path")
+(test-assert (delete-directory "path" #t))

File tests/empty.scm

+(use fuse posix srfi-18 test)
+
+(define (test-empty path)
+  (let ((fs (make-filesystem)))
+    (test-assert (not (filesystem-running? path fs)))
+    (test-assert (filesystem-start! path fs))
+    (test-assert (filesystem-wait! path fs 'started))
+    (test-assert (filesystem-running? path fs))
+    (test-assert (not (filesystem-running? "some-other-path" fs)))
+    (test-assert (filesystem-stop! path fs))
+    (test-assert (filesystem-wait! path fs))
+    (test-assert (not (filesystem-running? path fs)))))
+
+(test-assert (create-directory "path" #t))
+(test-empty "path")
+(test-assert (delete-directory "path" #t))

File tests/exn.scm

+(use fuse posix test)
+
+(define u+rwx/reg (bitwise-ior file/reg perm/irusr perm/iwusr perm/ixusr))
+(define u+rwx/dir (bitwise-ior file/dir perm/irusr perm/iwusr perm/ixusr))
+
+(define (test-exception path)
+  (define pid
+   (let ((fs (make-filesystem
+              getattr: (lambda (path)
+                         (cond
+                           ((string=? path "/")
+                            (vector u+rwx/dir
+                                    2
+                                    (current-user-id)
+                                    (current-group-id)
+                                    0
+                                    (current-seconds)
+                                    (current-seconds)
+                                    (current-seconds)))
+                           ((string=? path "/error")
+                            (vector u+rwx/reg
+                                    1
+                                    (current-user-id)
+                                    (current-group-id)
+                                    0
+                                    (current-seconds)
+                                    (current-seconds)
+                                    (current-seconds)))
+                           (else #f)))
+              readdir: (lambda (path)
+                         (and (string=? path "/")
+                              (list "." ".." "error")))
+              open:    (lambda (path mode)
+                         (error 'open "Error opening path" path mode)))))
+      (process-fork
+       (lambda ()
+         (set-signal-handler! signal/term (lambda (_) (filesystem-stop! path fs)))
+         (let ((n 0))
+           (with-exception-handler
+            (lambda (e)
+              (set! n (add1 n)))
+            (lambda ()
+              (filesystem-start! path fs)
+              (filesystem-wait! path fs)
+              (exit n))))))))
+  (sleep 1)
+  (let ((file (string-append path "/error")))
+    (do ((n 0 (add1 n)))
+        ((= n 10)
+         (process-signal pid signal/term)
+         (let-values (((_ _ exit-status)
+                       (process-wait pid)))
+           (test-assert (>= exit-status n))))
+      (test-error (file-open file open/read)))))
+
+(test-assert (create-directory "path" #t))
+(test-exception "path")
+(test-assert (delete-directory "path" #t))

File tests/fuse.scm

+(use fuse test)
+
+(test-error  (make-filesystem 1))
+(test-error  (make-filesystem foo:))
+(test-error  (make-filesystem foo: void))
+(test-assert (make-filesystem))
+(test-assert (make-filesystem getattr: void))
+(test-assert (not (filesystem? 1)))
+(test-assert (filesystem? (make-filesystem)))
+(test-assert (filesystem? (make-filesystem getattr: void)))

File tests/hello.scm

+(use fuse posix test)
+
+(define u+rwx/reg (bitwise-ior file/reg perm/irusr perm/iwusr perm/ixusr))
+(define u+rwx/dir (bitwise-ior file/dir perm/irusr perm/iwusr perm/ixusr))
+
+(define (process-terminate! pid)
+  (process-signal pid signal/term)
+  (process-wait pid))
+
+(define (read-file f)
+  (call-with-input-file f (lambda (p) (read-string #f p))))
+
+(define (test-hello path)
+  (define str "Hello world!\n")
+  (define now (current-seconds))
+  (define fs
+    (make-filesystem
+     getattr: (lambda (path)
+                (cond
+                  ((string=? path "/")
+                   (vector u+rwx/dir
+                           2
+                           (current-user-id)
+                           (current-group-id)
+                           0
+                           (current-seconds)
+                           now
+                           now))
+                  ((string=? path "/hello")
+                   (vector u+rwx/reg
+                           1
+                           (current-user-id)
+                           (current-group-id)
+                           (string-length str)
+                           (current-seconds)
+                           now
+                           now))
+                  (else #f)))
+     readdir: (lambda (path)
+                (and (string=? path "/")
+                     (list "." ".." "hello")))
+     open:    (lambda (path mode)
+                (string=? path "/hello"))
+     read:    (lambda (_ size offset)
+                (let ((len (string-length str)))
+                  (if (>= offset len)
+                      0
+                      (substring str offset (min size (- len offset))))))))
+  (define pid
+    (process-fork
+     (lambda ()
+       (set-signal-handler! signal/term (lambda (_) (filesystem-stop! path fs)))
+       (filesystem-start! path fs)
+       (filesystem-wait! path fs))))
+  (sleep 1)
+  (let* ((file (string-append path "/hello"))
+         (now* (current-seconds))
+         (stat (file-stat file)))
+    (test-assert (equal? (vector-ref stat 1) u+rwx/reg))
+    (test-assert (equal? (vector-ref stat 2) 1))
+    (test-assert (equal? (vector-ref stat 3) (current-user-id)))
+    (test-assert (equal? (vector-ref stat 4) (current-group-id)))
+    (test-assert (equal? (vector-ref stat 5) (string-length str)))
+    (test-assert (equal? (vector-ref stat 6) now*))
+    (test-assert (equal? (vector-ref stat 7) now))
+    (test-assert (equal? (vector-ref stat 8) now))
+    (test-assert (equal? (directory path) '("hello")))
+    (test-assert (equal? (read-file file) str))
+    (process-terminate! pid)
+    (test-assert (equal? (directory path) '()))))
+
+(test-assert (create-directory "path" #t))
+(test-hello "path")
+(test-assert (delete-directory "path" #t))

File tests/run.scm

+(use test setup-api)
+
+(cond-expand (linux) (else (exit 0)))
+
+(define-syntax test-interpreted
+  (syntax-rules ()
+    ((_ file)
+     (fluid-let ((test-exit void))
+       (load file)))))
+
+(define-syntax test-compiled
+  (syntax-rules ()
+    ((_ file)
+     (let ((exit-status
+            (handle-exceptions _ 1
+             (compile file -o "compiled")
+             (system "./compiled"))))
+       (if (zero? exit-status)
+           (test-exit)
+           (exit exit-status))))))
+
+(test-interpreted "all.scm")
+(test-compiled "all.scm")

File tests/unmount.scm

+(use fuse posix srfi-18 setup-api test)
+
+(cond-expand
+  ((not linux)
+   (test-assert "No fusermount on this platform" #t))
+  (else
+   (let ((path "path")
+         (fs (make-filesystem)))
+     (test-assert (create-directory path #t))
+     (test-assert (not (filesystem-running? path fs)))
+     (test-assert (filesystem-start! path fs))
+     (test-assert (filesystem-wait! path fs 'started))
+     (test-assert (filesystem-running? path fs))
+     (test-assert (zero? (system (format "fusermount -u ~a" path))))
+     (test-assert (filesystem-wait! path fs))
+     (test-assert (not (filesystem-running? path fs)))
+     (test-assert (delete-directory path #t)))))