;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; A FUSE library for CHICKEN Scheme.
;;;
;;; See libfuse.scm for lower-level bindings.
;;;
;;; Copyright (c) 2013, Evan Hanson
;;; BSD-style license. See LICENSE for details.
;;;
;;; FUSE is Copyright (C) 2001-2007, Miklos Szeredi <miklos@szeredi.hu>
;;; under the terms of the GNU LGPLv2.
;;;

(require-library lolevel srfi-18 posix)
(require-library concurrent-native-callbacks)
(require-extension-for-syntax setup-api)
(require-extension-for-syntax concurrent-native-callbacks-compile-time matchable)

(module fuse
  (make-filesystem
   filesystem-start!
   filesystem-stop!
   filesystem-running?
   filesystem-wait!
   filesystem?
   file/fifo
   file/chr
   file/blk
   file/reg
   file/dir
   file/lnk
   file/sock)
  (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 "#define C_BLKSIZE 512")
  (foreign-declare "#include <fuse.h>")
  (foreign-declare "#include <errno.h>")
  (foreign-declare "#include <pthread.h>")
  (foreign-declare "#include <signal.h>")

(cond-expand
  (fuse-debug
   (require-extension (only extras pretty-print))
   (foreign-declare "#define DEBUG(...) fprintf(stderr, __VA_ARGS__)")
   (define-syntax debug
     (syntax-rules ()
       ((_ . args)
        (pretty-print (list . args) (current-error-port))))))
  (else
   (foreign-declare "#define DEBUG(...)")
   (define-syntax debug
     (syntax-rules ()
       ((_ . args) (void))))))

(let-syntax ((redefine-c-values ; Compatibility shim for argvector changes.
              (er-macro-transformer
               (lambda (_ _ _)
                 (if (version>=? (chicken-version) "4.10.1")
                     `(foreign-declare "#define C_VALUES(n, ...) \
                                        C_word av[n] = { __VA_ARGS__ }; \
                                        C_values(n, av);")
                     `(foreign-declare "#define C_VALUES(n, ...) \
                                        C_values(n, __VA_ARGS__)"))))))
  (redefine-c-values))

(define-foreign-type dev_t int)
(define-foreign-type off_t integer64) ; libfuse has _FILE_OFFSET_BITS=64
(define-foreign-type gid_t int)
(define-foreign-type uid_t int)
(define-foreign-type mode_t int)
(define-foreign-type time_t long) ; int32_t or int64_t
(define-foreign-type nlink_t int)
(define-foreign-type fsblkcnt_t unsigned-long)
(define-foreign-type fsfilcnt_t unsigned-long)
(define-foreign-type fuse_operations (c-pointer (struct "fuse_operations")))
(define-foreign-type fuse_fill_dir_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)))
    (do ((i 0 (fx+ i 1)))
        ((fx= i l))
      (f (##sys#vector-ref v i)))))

(define-inline (posq o l)
  (let lp ((i 0) (l l))
    (cond ((null? l) #f)
          ((eq? o (##sys#slot l 0)) i)
          (else (lp (fx+ i 1) (##sys#slot l 1))))))

(define-inline (alist-cons k v l)
  (cons (cons k v) l))

(define-inline (alist-ref k l . p)
  (let ((pred? (optional p eq?)))
    (let lp ((l l))
      (cond ((null? l) #f)
            ((pred? k (##sys#slot (##sys#slot l 0) 0))
             (##sys#slot (##sys#slot l 0) 1))
            (else (lp (##sys#slot l 1)))))))

(define-inline (alist-delete k l . p)
  (let ((pred? (optional p eq?)))
    (let lp ((a '()) (l l))
      (cond ((null? l) (##sys#fast-reverse a))
            ((pred? k (##sys#slot (##sys#slot l 0) 0))
             (##sys#append (##sys#fast-reverse a) (##sys#slot l 1)))
            (else (lp (cons (##sys#slot l 0) a) (##sys#slot l 1)))))))

;;
;; The posix unit's missing mode flags (useful for getattr callbacks).
;;
(define file/fifo (foreign-value "S_IFIFO" int))
(define file/chr  (foreign-value "S_IFCHR" int))
(define file/blk  (foreign-value "S_IFBLK" int))
(define file/reg  (foreign-value "S_IFREG" int))
(define file/dir  (foreign-value "S_IFDIR" int))
(define file/lnk  (foreign-value "S_IFLNK" int))
(define file/sock (foreign-value "S_IFSOCK" int))

;;
;; ENOSYS is returned by unimplemented callbacks.
;;
(define errno/nosys (foreign-value "ENOSYS" int))

(define (unimplemented . _) (raise errno/nosys))

;;
;; The filesystem and mount record types are opaque structures that
;; track a filesystem's callbacks, active mounts, shutdown and exception
;; handlers.
;;
(define-record filesystem callbacks mounts)
(define-record mount filesystem file-descriptor synchronization-handler shutdown-handler exception-handler)

(define-inline (filesystem-mount fs path)
  (alist-ref path (filesystem-mounts fs) string=?))

(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-inline (filesystem-callback fs i)
  (or (##sys#vector-ref (filesystem-callbacks fs) i) unimplemented))

(define (mount-status mount)
  ((mount-synchronization-handler mount)
   (lambda (m _) (mutex-specific m))))

(define (mount-status-update! mount f)
  ((mount-synchronization-handler mount)
   (lambda (m c)
     (mutex-lock! m)
     (mutex-specific-set! m (f (mutex-specific m)))
     (condition-variable-broadcast! c)
     (mutex-unlock! m))))

(define (mount-status-set! mount status)
  (mount-status-update! mount (lambda (_) status)))

(define (mount-wait! mount status)
  ((mount-synchronization-handler mount)
   (lambda (m c)
     (do ((_ (mutex-lock! m)
             (mutex-lock! m)))
         ((eq? (mutex-specific m) status)
          (mutex-unlock! m))
       (mutex-unlock! m c)))))

(define (mount-stop! mount)
  (let ((shutdown-handler (mount-shutdown-handler mount)))
    (mount-shutdown-handler-set! mount void)
    (thread-start! shutdown-handler)))

(define-inline (mount-running? mount)
  (let ((s (mount-status mount)))
    (or (eq? s 'started)
        (pair? s))))

(define-inline (mount-stopping? mount)
  (eq? (mount-status mount) 'stopping))

(define-inline (mount-file-handles m)
  (mount-status m))

(define-inline (mount-file-handle mount k)
  (alist-ref k (mount-file-handles mount)))

(define-inline (mount-file-handle-add! mount v . f)
  (mount-status-update!
   mount
   (lambda (s)
     (let ((k (mount-file-descriptor mount)))
       (mount-file-descriptor-set! mount (fx+ k 1))
       (and-let* ((callback (optional f))) (callback k))
       (alist-cons k v s)))))

(define-inline (mount-file-handle-delete! mount k)
  (mount-status-update! mount (lambda (s) (alist-delete k s))))

(define-constant operations ; NB order matters.
  '(getattr:
    readdir:
    open:
    read:
    write:
    release:
    access:
    create:
    unlink:
    truncate:
    readlink:
    symlink:
    mknod:
    mkdir:
    rmdir:
    rename:
    link:
    chmod:
    chown:
    utimens:
    statfs:
    ioctl:
    fsync:
    flush:
    init:
    destroy:
    ;; Probably TODO.
    ;poll:
    ;flushdir:
    ;fsyncdir:
    ;opendir:
    ;releasedir:
    ;lock:
    ;flock:
    ;; Probably not TODO.
    ;fgetattr:
    ;ftruncate:
    ;getxattr:
    ;listxattr:
    ;removexattr:
    ;setxattr:
    ;read_buf:
    ;write_buf:
    ;bmap:
    ;getdir: ; Deprecated.
    ;utime: ; Deprecated.
    ))

(define-constant dispatchers
  (map (lambda (s) (string->symbol (string-append "fuse-" s "-handler")))
       (map keyword->string operations)))

(define-type filesystem (struct filesystem))
(: filesystem? (* -> boolean : filesystem))
(: make-filesystem (#!rest -> filesystem))
(define make-filesystem
  (let ((make-filesystem make-filesystem))
    (lambda args
      (let ((oper (##sys#make-vector 26 #f)))
        (let loop ((args args))
          (match args
            (()
             (make-filesystem oper '()))
            (('utime: value . rest)
             (error 'make-filesystem "The utime: option is deprecated - use utimens: instead"))
            (('getdir: value . rest)
             (error 'make-filesystem "The getdir: option is deprecated - use readdir: instead"))
            ((op val . rest)
             (cond ((posq op operations) =>
                    (lambda (i)
                      (vector-set! oper i val)
                      (loop rest)))
                   (else
                    (error 'make-filesystem "Invalid keyword argument" (car args)))))
            (else
             (error 'make-filesystem "Odd keyword arguments" (car args)))))))))

(define-inline (fuse-context-mount context)
  (gc-root-ref (fuse_context_private_data context)))

(define-inline (mount-filesystem-callback mount i)
  (filesystem-callback (mount-filesystem mount) i))

(define-inline (callback-result v)
  (if v 0 (foreign-value "-ENOENT" int)))

(define-inline (callback-error-result v)
  (if (and (fixnum? v) (fx> v 0))
      (fxneg v)
      (foreign-value "-EIO" int)))

(define (callback-protect mount thunk)
  (call-with-current-continuation
   (lambda (k)
     (with-exception-handler
      (lambda (e)
        (k (callback-error-result
            (cond ((condition? e)
                   ((mount-exception-handler mount) e))
                  (else e)))))
      thunk))))

(define-syntax define-callback
  (er-macro-transformer
   (lambda (e r c)
     (let* ((name        (caadr e))
            (spec        (cdadr e))
            (return-type (caddr e))
            (body        (cdddr e))
            (mount       (cadar spec))
            (dispatcher  (symbol-append 'fuse- name '-handler))
            (handler     (symbol-append 'fuse_ name '_handler))
            (callback    (symbol-append 'fuse_ name '_callback)))
       `(begin
          (define-synchronous-concurrent-native-callback
            ((,handler ,dispatcher) (c-pointer context) ,@(cdr spec)) ,return-type
            (debug ',handler ,@(map (match-lambda ((type arg) arg)) (cdr spec)))
            (let ((,mount (fuse-context-mount context)))
              (callback-protect ,mount (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))))
                        (cdr spec))
                   ",") "){"
                  (if (eq? void return-type) "" "return ")
                  handler "(fuse_get_context(),"
                  (string-intersperse
                   (map (match-lambda ((type arg) (symbol->string arg)))
                        (cdr spec))
                   ",") ");}")))))))

(define-callback (getattr (scheme-object mount) (c-string path) (c-pointer stat)) int
  (let ((v ((mount-filesystem-callback mount 0) path)))
    (match v
      (#(mode nlink uid gid size atime ctime mtime)
       (vector-for-each ##sys#check-number v)
       ((foreign-primitive int (((c-pointer (struct "stat")) stat)
                                (mode_t mode)
                                (nlink_t nlink)
                                (uid_t uid)
                                (gid_t gid)
                                (size_t size)
                                (time_t atime)
                                (time_t ctime)
                                (time_t mtime))
#<<EOC
  stat->st_mode    = mode;
  stat->st_nlink   = nlink;
  stat->st_size    = size;
  stat->st_uid     = uid;
  stat->st_gid     = gid;
  stat->st_atime   = atime;
  stat->st_mtime   = mtime;
  stat->st_ctime   = ctime;
  stat->st_blksize = C_BLKSIZE;
  stat->st_blocks  = size ? ((size + C_BLKSIZE - 1) / C_BLKSIZE) : 0;
  C_return(0);
EOC
)
        stat
        mode
        nlink
        uid
        gid
        size
        atime
        ctime
        mtime))
      (else
       (callback-result v)))))

(define-callback (readdir (scheme-object mount) (c-string path) (c-pointer buf) ((function int (c-pointer c-string c-pointer int)) filler) (integer64 off) (c-pointer fi)) int
  (let ((v ((mount-filesystem-callback mount 1) path)))
    (match v
      ((n ...)
       (##sys#for-each ##sys#check-string v) ; FIXME.
       (do ((v v (##sys#slot v 1)))
           ((null? v) 0)
         (unless (fx= 0 ((foreign-primitive int ((fuse_fill_dir_t filler)
                                                 (c-pointer buf)
                                                 (c-string path))
                           "C_return(filler(buf, path, NULL, 0));")
                         filler
                         buf
                         (##sys#slot v 0)))
           (error 'readdir "Buffer full" (car v)))))
      (else
       (callback-result v)))))

(define-callback (open (scheme-object mount) (c-string path) (c-pointer fi)) int
  (let ((v ((mount-filesystem-callback mount 2) path (fuse_file_info_flags fi))))
    (cond ((not v)
           (foreign-value "-ENOENT" int))
          (else
           (mount-file-handle-add! mount v (lambda (n) (fuse_file_info_fh_set! fi n)))
           (callback-result v)))))

(define-callback (read (scheme-object mount) (c-string path) (c-pointer buf) (size_t len) (integer64 off) (c-pointer fi)) int
  (let ((v ((mount-filesystem-callback mount 3) (mount-file-handle mount (fuse_file_info_fh fi)) len off)))
    (cond ((fixnum? v) v)
          ((string? v)
           (let ((l (string-length v)))
             (move-memory! v buf (fxmin l len))
             l))
          ((callback-result v)))))

(define-callback (write (scheme-object mount) (c-string path) (c-string data) (size_t len) (integer64 off) (c-pointer fi)) int
  (let ((v ((mount-filesystem-callback mount 4) (mount-file-handle mount (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 (release (scheme-object mount) (c-string path) (c-pointer fi)) int
  (let ((v (mount-file-handle mount (fuse_file_info_fh fi))))
    (mount-file-handle-delete! mount (fuse_file_info_fh fi))
    (callback-result ((mount-filesystem-callback mount 5) v))))

(define-callback (access (scheme-object mount) (c-string path) (int mode)) int
  (callback-result ((mount-filesystem-callback mount 6) path mode)))

(define-callback (create (scheme-object mount) (c-string path) (int mode) (c-pointer fi)) int
  (let ((v ((mount-filesystem-callback mount 7) path mode)))
    (mount-file-handle-add! mount v (lambda (n) (fuse_file_info_fh_set! fi n)))
    (callback-result v)))

(define-callback (unlink (scheme-object mount) (c-string path)) int
  (callback-result ((mount-filesystem-callback mount 8) path)))

(define-callback (truncate (scheme-object mount) (c-string path) (integer64 off)) int
  (callback-result ((mount-filesystem-callback mount 9) path off)))

(define-callback (readlink (scheme-object mount) (c-string path) (c-pointer buf) (size_t len)) int
  (let ((r ((mount-filesystem-callback mount 10) path)))
    (cond ((not r)
           (foreign-value "-ENOENT" int))
          ((string? r)
           (move-memory! r buf (fxmin (string-length r) len))
           0)
          (else
           (error 'readlink "Invalid result" r)))))

(define-callback (symlink (scheme-object mount) (c-string to) (c-string from)) int
  (callback-result ((mount-filesystem-callback mount 11) to from)))

(define-callback (mknod (scheme-object mount) (c-string path) (int mode) (int dev)) int
  (callback-result ((mount-filesystem-callback mount 12) path mode)))

(define-callback (mkdir (scheme-object mount) (c-string path) (int mode)) int
  (callback-result ((mount-filesystem-callback mount 13) path mode)))

(define-callback (rmdir (scheme-object mount) (c-string path)) int
  (callback-result ((mount-filesystem-callback mount 14) path)))

(define-callback (rename (scheme-object mount) (c-string from) (c-string to)) int
  (callback-result ((mount-filesystem-callback mount 15) from to)))

(define-callback (link (scheme-object mount) (c-string to) (c-string from)) int
  (callback-result ((mount-filesystem-callback mount 16) to from)))

(define-callback (chmod (scheme-object mount) (c-string path) (int mode)) int
  (callback-result ((mount-filesystem-callback mount 17) path mode)))

(define-callback (chown (scheme-object mount) (c-string path) (int uid) (int gid)) int
  (callback-result ((mount-filesystem-callback mount 18) path uid gid)))

(define-callback (utimens (scheme-object mount) (c-string path) (c-pointer tv)) int ; tv[2]
  (let-values (((asec msec) ; nsecs currently ignored.
                ((foreign-primitive ((c-pointer tv))
                  "C_VALUES(4,
                            C_SCHEME_UNDEFINED,
                            C_k,
                            C_fix(((struct timespec *)tv)[0].tv_sec),
                            C_fix(((struct timespec *)tv)[1].tv_sec));")
                 tv)))
    (callback-result ((mount-filesystem-callback mount 19) path asec msec))))

(define-callback (statfs (scheme-object mount) (c-string path) (c-pointer statvfs)) int
  (let ((v ((mount-filesystem-callback mount 20) path)))
    (match v
      (#(bsize blocks bfree bavail files ffree namemax)
       (vector-for-each ##sys#check-number v)
       ((foreign-primitive int (((c-pointer (struct "statvfs")) statvfs)
                                (unsigned-long bsize)
                                (fsblkcnt_t blocks)
                                (fsblkcnt_t bfree)
                                (fsblkcnt_t bavail)
                                (fsfilcnt_t files)
                                (fsfilcnt_t ffree)
                                (unsigned-long namemax))
#<<EOC
  statvfs->f_bsize   = bsize;
  statvfs->f_blocks  = blocks;
  statvfs->f_bfree   = bfree;
  statvfs->f_bavail  = bavail;
  statvfs->f_files   = files;
  statvfs->f_ffree   = ffree;
  statvfs->f_namemax = namemax;
  C_return(0);
EOC
)
        statvfs
        bsize
        blocks
        bfree
        bavail
        files
        ffree
        namemax))
      (else
       (callback-result v)))))

(define-callback (ioctl (scheme-object mount) (c-string path) (int cmd) (c-pointer arg) (c-pointer fi) (unsigned-int flags) (c-pointer data)) int
  (callback-result ((mount-filesystem-callback mount 21) path cmd arg)))

(define-callback (fsync (scheme-object mount) (c-string path) (bool sync) (c-pointer fi)) int
  (callback-result ((mount-filesystem-callback mount 22) path)))

(define-callback (flush (scheme-object mount) (c-string path) (c-pointer fi)) int
  (callback-result ((mount-filesystem-callback mount 23) path)))

(define-callback (init (scheme-object mount) (c-pointer conn)) c-pointer
  (callback-protect mount (mount-filesystem-callback mount 24))
  (mount-status-set! mount 'started)
  (fuse_context_private_data context))

(define-callback (destroy (scheme-object _) (c-pointer data)) void
  ;; On Linux, destroy is called *after* the filesystem has been
  ;; disconnected, so there's no active fuse_context from which
  ;; fuse-context-mount can access the rooted mount record. However,
  ;; we do have the root in private_data, so we use that instead.
  (let ((mount (gc-root-ref data)))
    (mount-finalize! mount)
    (mount-status-set! mount 'stopping)
    (mount-stop! mount)))

(define make-gc-root
  (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 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 "#include <sys/param.h>")
   (foreign-declare "#include <sys/mount.h>")
   (foreign-declare "#define UNMOUNT(...) unmount(__VA_ARGS__)")
   (foreign-declare "#define FUSE_LOOP(...) fuse_loop(__VA_ARGS__)")
   (foreign-declare "#define FUSE_UNMOUNT(...)")
   (foreign-declare "#define FUSE_DESTROY(...)"))
  (else
   (foreign-declare "#define UNMOUNT(...)")
   (foreign-declare "#define FUSE_LOOP(...) fuse_loop_mt(__VA_ARGS__)")
   (foreign-declare "#define FUSE_UNMOUNT(...) fuse_unmount(__VA_ARGS__)")
   (foreign-declare "#define FUSE_DESTROY(...) fuse_destroy(__VA_ARGS__)")))

#>

struct fuse_handle {
  char *path;
  struct fuse *fuse;
  struct fuse_chan *chan;
};

struct fuse_handle *make_handle(char *path, struct fuse *fuse, struct fuse_chan *chan) {
  struct fuse_handle *handle =  (struct fuse_handle *) C_malloc(sizeof(struct fuse_handle));
  handle->path = strdup(path);
  handle->fuse = fuse;
  handle->chan = chan;
  C_return(handle);
}

void destroy_handle(struct fuse_handle *handle) {
  free(handle->path);
  free(handle);
}

void *fuse_shutdown_worker(void *data) {
  struct fuse_handle *h = (struct fuse_handle *) data;
  UNMOUNT(h->path, MNT_UPDATE);
  open(h->path, O_RDONLY);
  C_return(NULL);
}

void *fuse_loop_worker(void *data) {
  struct fuse_handle *h = (struct fuse_handle *) data;
  sigset_t s;
  sigemptyset(&s);
  sigaddset(&s, SIGHUP);
  sigaddset(&s, SIGINT);
  sigaddset(&s, SIGTERM);
  pthread_sigmask(SIG_BLOCK, &s, NULL);
  FUSE_LOOP(h->fuse);
  FUSE_UNMOUNT(h->path, h->chan);
  FUSE_DESTROY(h->fuse);
  C_return(NULL);
}

C_word thread_start(void *worker, void *data) {
  pthread_t thread;
  if (pthread_create(&thread, NULL, worker, data))
    C_return(C_SCHEME_FALSE);
  pthread_detach(thread);
  C_return(C_fix(thread));
}

int thread_join(long thread) {
  C_return(pthread_join((pthread_t) thread, NULL) == 0);
}

int thread_kill(long thread) {
  C_return(pthread_cancel((pthread_t) thread) == 0);
}

<#

(define make-fuse-handle
  (foreign-lambda
    (c-pointer (struct "fuse_handle"))
    make_handle
    c-string
    (c-pointer (struct "fuse"))
    (c-pointer (struct "fuse_chan"))))

(define fuse-handle-destroy!
  (foreign-lambda void destroy_handle (c-pointer (struct "fuse_handle"))))

(define native-thread-start!
  (foreign-lambda scheme-object thread_start c-pointer c-pointer))

(define native-thread-join!
  (foreign-lambda bool thread_join long))

(define native-thread-kill!
  (foreign-lambda bool thread_kill long))

(define (mount-finalize! mount)
  (let ((fs (mount-filesystem mount)))
    (do ((fhs (mount-file-handles mount) (##sys#slot fhs 1)))
        ((not (pair? fhs)))
      (callback-protect
       mount
       (lambda ()
         ((filesystem-callback fs 5)
          (##sys#slot (##sys#slot fhs 0) 1)))))
    (callback-protect mount (filesystem-callback fs 25))))

(: filesystem-start! (string filesystem -> *))
(define filesystem-start!
  (let* ((opsize (foreign-type-size "struct fuse_operations"))
         (ops    (allocate opsize)))
    (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_fsync_set!    ops (foreign-value "fuse_fsync_callback" c-pointer))
    (fuse_operations_flush_set!    ops (foreign-value "fuse_flush_callback" c-pointer))
    (fuse_operations_init_set!     ops (foreign-value "fuse_init_callback" c-pointer))
    (fuse_operations_destroy_set!  ops (foreign-value "fuse_destroy_callback" c-pointer))
    (cond-expand
      (openbsd) ; No ioctl on OpenBSD.
      (else
       (fuse_operations_ioctl_set! ops (foreign-value "fuse_ioctl_callback" c-pointer))))
    (lambda (path fs)
      (and-let* ((chan   (fuse_mount path #f))
                 (mount  (make-mount fs most-negative-fixnum void void (current-exception-handler)))
                 (root   (make-gc-root mount))
                 (fuse   (fuse_new chan #f ops opsize root))
                 (handle (make-fuse-handle path fuse chan))
                 (thread (native-thread-start! (foreign-value "fuse_loop_worker" c-pointer) handle)))
        (filesystem-mount-add! fs path mount)
        (mount-synchronization-handler-set!
         mount
         (let ((m (make-mutex))
               (c (make-condition-variable)))
           (mutex-specific-set! m 'starting)
           (lambda (f) (f m c))))
        (mount-shutdown-handler-set!
         mount
         (lambda ()
           (unless (mount-stopping? mount)
             (fuse_exit fuse)
             (native-thread-start! (foreign-value "fuse_shutdown_worker" c-pointer) handle))
           (mount-wait! mount 'stopping)
           (filesystem-mount-delete! fs path)
           (gc-root-destroy! root)
           (fuse-handle-destroy! handle)
           (mount-status-set! mount 'stopped)))))))

(: filesystem-wait! (string filesystem #!optional symbol -> void))
(define (filesystem-wait! path fs #!optional (status 'stopped))
  (when-let* ((mount (filesystem-mount fs path)))
    (mount-wait! mount status)))

(: filesystem-stop! (string filesystem -> void))
(define (filesystem-stop! path fs)
  (when-let* ((mount (filesystem-mount fs path)))
    (mount-stop! mount)))

(: filesystem-running? (string filesystem -> boolean))
(define (filesystem-running? path fs)
  (and-let* ((mount (filesystem-mount fs path)))
    (mount-running? mount))))