;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; A FUSE library for CHICKEN Scheme.
;;;
;;; See libfuse.scm for lower-level bindings.
;;;
;;; Copyright (c) 2013-2018, 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.
;;;

(declare
  (module (fuse))
  (export make-filesystem filesystem?
          filesystem-start! filesystem-stop!
          filesystem-running? filesystem-wait!
          file/fifo file/chr file/blk file/reg
          file/dir file/lnk file/sock))

(import (scheme)
        (chicken base)
        (chicken condition)
        (chicken fixnum)
        (chicken foreign)
        (chicken keyword)
        (chicken memory)
        (chicken type)
        (fuse libfuse)
        (srfi 18))

(import-for-syntax (chicken string))

(import-syntax (matchable))

(import-syntax-for-syntax (matchable))

(include "compile-time.scm")

(begin-for-syntax (include "compile-time.scm"))



#>

#define FUSE_USE_VERSION 26
#define C_BLKSIZE 512

#include <fuse.h>
#include <errno.h>
#include <pthread.h>
#include <signal.h>

#ifdef __OpenBSD__
#  include <sys/param.h>
#  include <sys/mount.h>
#endif

<#

(cond-expand
  (fuse-debug
   (import (chicken 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))))))

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



#>

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

int native_thread_join(long thread) {
  return pthread_join((pthread_t)thread, NULL) == 0;
}

int native_thread_terminate(long thread) {
  return pthread_cancel((pthread_t)thread) == 0;
}

<#

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

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

(define native-thread-terminate!
  (foreign-lambda bool native_thread_terminate long))



#>

struct callback_handle *make_callback_handle(void);
struct fuse_handle *make_fuse_handle(char *, struct fuse *, struct fuse_chan *);
struct mount_handle *make_mount_handle(C_word);

void callback_handle_destroy(struct callback_handle *);
void fuse_handle_destroy(struct fuse_handle *);
void mount_handle_destroy(struct mount_handle *);

void *fuse_loop_worker(void *);
void *fuse_shutdown_worker(void *);

struct callback_handle {
  int io[2];
  pthread_mutex_t pthread_mutex;
  pthread_cond_t pthread_cond[2];
  C_word payload[10];
};

struct mount_handle {
  C_word *root;
  struct callback_handle *callbacks[27];
};

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


struct callback_handle *make_callback_handle(void) {
  int n = 0;
  struct callback_handle *handle = (struct callback_handle *)malloc(sizeof(struct callback_handle));
  if (handle == NULL) return NULL;
  memset(handle, 0, sizeof(struct callback_handle));
  pthread_mutex_init(&handle->pthread_mutex, NULL);
  pthread_cond_init(&handle->pthread_cond[0], NULL);
  pthread_cond_init(&handle->pthread_cond[1], NULL);
  if ((n = pipe(handle->io)) < 0) goto fail;
  if ((n = fcntl(handle->io[0], F_GETFL, 0)) < 0) goto fail;
  if ((n = fcntl(handle->io[0], F_SETFL, n | O_NONBLOCK)) < 0) goto fail;
  return handle;
fail:
  callback_handle_destroy(handle);
  return NULL;
}

void callback_handle_destroy(struct callback_handle *handle) {
  pthread_cond_destroy(&handle->pthread_cond[0]);
  pthread_cond_destroy(&handle->pthread_cond[1]);
  pthread_mutex_destroy(&handle->pthread_mutex);
  close(handle->io[0]);
  close(handle->io[1]);
  free(handle);
}

struct mount_handle *make_mount_handle(C_word mount) {
  int i = 0;
  struct mount_handle *handle = (struct mount_handle *)malloc(sizeof(struct mount_handle));
  if (handle == NULL) return NULL;
  memset(handle, 0, sizeof(struct mount_handle));
  handle->root = CHICKEN_new_gc_root();
  CHICKEN_gc_root_set(handle->root, mount);
  while (i < 26)
    if ((handle->callbacks[i++] = make_callback_handle()) == NULL)
      goto fail;
  return handle;
fail:
  mount_handle_destroy(handle);
  return NULL;
}

void mount_handle_destroy(struct mount_handle *handle) {
  int i = 0;
  while (handle->callbacks[i]) callback_handle_destroy(handle->callbacks[i++]);
  CHICKEN_delete_gc_root(handle->root);
  free(handle);
}

struct fuse_handle *make_fuse_handle(char *path, struct fuse *fuse, struct fuse_chan *chan) {
  struct fuse_handle *handle = (struct fuse_handle *)malloc(sizeof(struct fuse_handle));
  if (handle == NULL) return NULL;
  handle->path = strdup(path);
  handle->fuse = fuse;
  handle->chan = chan;
  return handle;
}

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

void *fuse_loop_worker(void *data) {
  struct fuse_handle *handle = (struct fuse_handle *)data;
  sigset_t s;
  sigemptyset(&s);
  sigaddset(&s, SIGHUP);
  sigaddset(&s, SIGINT);
  sigaddset(&s, SIGTERM);
  pthread_sigmask(SIG_BLOCK, &s, NULL);
#ifdef __OpenBSD__
  fuse_loop(handle->fuse);
#else
  fuse_loop_mt(handle->fuse);
#endif
  fuse_unmount(handle->path, handle->chan);
  fuse_destroy(handle->fuse);
  return NULL;
}

void *fuse_shutdown_worker(void *data) {
  struct fuse_handle *handle = (struct fuse_handle *)data;
#ifdef __OpenBSD__
  unmount(handle->path, MNT_UPDATE);
#endif
  int n = open(handle->path, O_RDONLY);
  if (n > 0) close(n);
  return NULL;
}

<#

(define-foreign-type fuse (c-pointer (struct "fuse")))
(define-foreign-type fuse_chan (c-pointer (struct "fuse_chan")))
(define-foreign-type fuse_handle (c-pointer (struct "fuse_handle")))
(define-foreign-type mount_handle (c-pointer (struct "mount_handle")))
(define-foreign-type callback_handle (c-pointer (struct "callback_handle")))

(define-foreign-variable fuse_loop_worker c-pointer)
(define-foreign-variable fuse_shutdown_worker c-pointer)

(define make-fuse-handle
  (foreign-lambda fuse_handle make_fuse_handle c-string fuse fuse_chan))

(define fuse-handle-destroy!
  (foreign-lambda void fuse_handle_destroy fuse_handle))

(define make-mount-handle
  (foreign-lambda mount_handle make_mount_handle scheme-object))

(define mount-handle-destroy!
  (foreign-lambda void mount_handle_destroy mount_handle))

(define mount-handle->mount
  (foreign-primitive scheme-object ((mount_handle mount))
    "C_return(CHICKEN_gc_root_ref(mount->root));"))

(define mount-handle-callback
  (foreign-primitive c-pointer ((mount_handle mount) (integer i))
    "C_return(mount->callbacks[i]);"))

(define callback-handle-file-descriptor
  (foreign-primitive int ((callback_handle callback) (integer i))
    "C_return(callback->io[i]);"))

(define callback-handle-lock!
  (foreign-primitive bool ((callback_handle callback))
    "C_return(pthread_mutex_lock(&callback->pthread_mutex) == 0);"))

(define callback-handle-unlock!
  (foreign-primitive bool ((callback_handle callback))
    "C_return(pthread_mutex_unlock(&callback->pthread_mutex) == 0);"))

(define callback-handle-signal!
  (foreign-primitive bool ((callback_handle callback))
    "C_return(pthread_cond_signal(&callback->pthread_cond[1]) == 0);"))

(define-for-syntax (callback-handle-payload-accessor type)
  `(foreign-primitive ,type ((callback_handle callback) (integer i))
     "C_return(callback->payload[i]);"))

(define callback-handle-payload-set!
  (foreign-primitive ((callback_handle callback) (integer i) (scheme-object x))
    "callback->payload[i] = x;"))



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



(define errno/nosys (foreign-value ENOSYS int))

(define (unimplemented . _) errno/nosys)



(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 (vector-ref (filesystem-callbacks fs) i) unimplemented))

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

(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 (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 (mount-file-handle-delete! mount k)
  (mount-status-update! mount (lambda (s) (alist-delete k s))))

(define (mount-initialize! mount)
  (callback-protect mount (mount-filesystem-callback mount 24)))

(define (mount-finalize! mount)
  (let ((fs (mount-filesystem mount)))
    (do ((fhs (mount-file-handles mount) (cdr fhs)))
        ((not (pair? fhs)))
      (callback-protect
       mount
       (lambda ()
         ((filesystem-callback fs 5)
          (cdr (car fhs))))))
    (callback-protect mount (filesystem-callback fs 25))))



(define (thread-wait! thread)
  (condition-case (thread-join! thread)
    ((uncaught-exception) (void))
    ((terminated-thread-exception) (void))))

(define (make-callback-pool mount*)
  (vector (make-getattr-dispatcher  (mount-handle-callback mount* 0))
          (make-readdir-dispatcher  (mount-handle-callback mount* 1))
          (make-open-dispatcher     (mount-handle-callback mount* 2))
          (make-read-dispatcher     (mount-handle-callback mount* 3))
          (make-write-dispatcher    (mount-handle-callback mount* 4))
          (make-release-dispatcher  (mount-handle-callback mount* 5))
          (make-access-dispatcher   (mount-handle-callback mount* 6))
          (make-create-dispatcher   (mount-handle-callback mount* 7))
          (make-unlink-dispatcher   (mount-handle-callback mount* 8))
          (make-truncate-dispatcher (mount-handle-callback mount* 9))
          (make-readlink-dispatcher (mount-handle-callback mount* 10))
          (make-symlink-dispatcher  (mount-handle-callback mount* 11))
          (make-mknod-dispatcher    (mount-handle-callback mount* 12))
          (make-mkdir-dispatcher    (mount-handle-callback mount* 13))
          (make-rmdir-dispatcher    (mount-handle-callback mount* 14))
          (make-rename-dispatcher   (mount-handle-callback mount* 15))
          (make-link-dispatcher     (mount-handle-callback mount* 16))
          (make-chmod-dispatcher    (mount-handle-callback mount* 17))
          (make-chown-dispatcher    (mount-handle-callback mount* 18))
          (make-utimens-dispatcher  (mount-handle-callback mount* 19))
          (make-statfs-dispatcher   (mount-handle-callback mount* 20))
          (make-ioctl-dispatcher    (mount-handle-callback mount* 21))
          (make-fsync-dispatcher    (mount-handle-callback mount* 22))
          (make-flush-dispatcher    (mount-handle-callback mount* 23))
          (make-init-dispatcher     (mount-handle-callback mount* 24))
          (make-destroy-dispatcher  (mount-handle-callback mount* 25))))

(define (callback-pool-start! pool)
  (vector-for-each thread-start! pool))

(define (callback-pool-terminate! pool)
  (vector-for-each thread-terminate! pool)
  (vector-for-each thread-wait! pool))



(define-foreign-variable errno int)
(define-foreign-variable errno/again int "EAGAIN")
(define-foreign-variable errno/wouldblock int "EWOULDBLOCK")

(define (file-descriptor-read fd)
  (let ((buf (make-string 1 #\0)))
    (let loop ()
      (thread-wait-for-i/o! fd #:input)
      (let ((n ((foreign-lambda int read int scheme-pointer int) fd buf 1)))
        (cond ((= n 1) #t)
              ((= n 0) #f)
              ((= errno errno/again) (loop))
              ((= errno errno/wouldblock) (loop))
              (else #f))))))



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

(define (callback-error f x)
  (cond ((condition? x)
         (handle-exceptions e
             (begin
               (print-error-message e (current-error-port) "fuse: Error in exception handler: ")
               (foreign-value "-EIO" int))
           (callback-error f (f x))))
        ((and (fixnum? x) (fx< 0 x))
         (fxneg x))
        (else
         (foreign-value "-EIO" int))))

(define (callback-protect mount thunk)
  (handle-exceptions e (callback-error (mount-exception-handler mount) e) (thunk)))

(define-for-syntax (foreign-type-declaration . args)
  (apply chicken.compiler.c-backend#foreign-type-declaration args))

(define-syntax define-callback
  (er-macro-transformer
   (lambda (e r c)
     (let* ((name  (caadr e))
            (args  (cdadr e))
            (type  (caddr e))
            (body  (cdddr e))
            (mount (cadar args))
            (index (posq (symbol->keyword name) fuse-operations)))
       (define (foreign-return-statement x)
         (cond ((eq? name 'destroy) "return;")
               ((eq? name 'init) "return mount;")
               ((conc "return (" (foreign-type-declaration type "") ")" x ";"))))
       `(begin
          (foreign-declare
           ,(conc (foreign-type-declaration type "")
                  (symbol-append 'fuse_ name '_callback) "("
                  (string-intersperse
                   (map (match-lambda ((t x) (foreign-type-declaration t (conc x))))
                        (cdr args)) ",") ") {"
                  "struct mount_handle *mount = (struct mount_handle *)fuse_get_context()->private_data;"
                  "struct callback_handle *callback = (struct callback_handle *)mount->callbacks[" index "];"
                  "pthread_mutex_lock(&callback->pthread_mutex);"
                  "while (callback->payload[0])"
                    "pthread_cond_wait(&callback->pthread_cond[0], &callback->pthread_mutex);"
                  (string-intersperse
                   (map-with-index
                    (match-lambda* (((_ x) i) (conc "callback->payload[" i "] = (C_word)" x ";")))
                    (cons (list 'c-pointer "mount") (cdr args))))
                  "if (write(callback->io[1], \".\", 1) < 1) {"
                    "pthread_mutex_unlock(&callback->pthread_mutex);"
                    (foreign-return-statement "-1")
                  "}"
                  "while (callback->payload[0] == (C_word)mount)"
                    "pthread_cond_wait(&callback->pthread_cond[1], &callback->pthread_mutex);"
                  "C_word result = callback->payload[0];"
                  "memset(callback->payload, 0, sizeof(callback->payload));"
                  "pthread_cond_signal(&callback->pthread_cond[0]);"
                  "pthread_mutex_unlock(&callback->pthread_mutex);"
                  (foreign-return-statement "C_unfix(result)") "}"))
          (define (,(symbol-append 'make- name '-dispatcher) callback)
            (make-thread
             (let ((fd (callback-handle-file-descriptor callback 0)))
               (lambda ()
                 (let loop ()
                   (when (file-descriptor-read fd)
                     (callback-handle-lock! callback)
                     ((lambda ,(map cadr args)
                        (debug ',name ,@(map cadr args))
                        (let* ((,mount (mount-handle->mount ,mount))
                               (result (callback-protect ,mount (lambda () . ,body))))
                          (callback-handle-payload-set! callback 0 result)
                          (callback-handle-signal! callback)
                          (callback-handle-unlock! callback)
                          (loop)))
                      ,@(map-with-index
                         (match-lambda*
                           (((t _) i)
                            `(,(callback-handle-payload-accessor t) callback ,i)))
                         args)))))))))))))



(define-callback (getattr (c-pointer 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 (c-pointer 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 (cdr v)))
           ((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
                         (car v)))
           (error 'readdir "Buffer full" (car v)))))
      (else
       (callback-result v)))))

(define-callback (open (c-pointer 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 (c-pointer 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 (c-pointer mount) (c-string path) (c-pointer buf) (size_t len) (integer64 off) (c-pointer fi)) int
  (let ((str (make-string len)))
    (move-memory! buf str len)
    (let ((v ((mount-filesystem-callback mount 4) (mount-file-handle mount (fuse_file_info_fh fi)) str off)))
      (cond ((fixnum? v) v)
            ((string? v) (string-length v))
            ((callback-result v))))))

(define-callback (release (c-pointer 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 (c-pointer mount) (c-string path) (int mode)) int
  (callback-result ((mount-filesystem-callback mount 6) path mode)))

(define-callback (create (c-pointer 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 (c-pointer mount) (c-string path)) int
  (callback-result ((mount-filesystem-callback mount 8) path)))

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

(define-callback (readlink (c-pointer 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))
           (callback-result #t))
          (else
           (error 'readlink "Invalid result" r)))))

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

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

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

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

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

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

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

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

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

(define-callback (statfs (c-pointer 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 (c-pointer 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 (c-pointer mount) (c-string path) (bool sync) (c-pointer fi)) int
  (callback-result ((mount-filesystem-callback mount 22) path)))

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

(define-callback (init (c-pointer mount) (c-pointer conn)) c-pointer
  (mount-initialize! mount)
  (mount-status-set! mount 'started)
  (address->pointer 0))

(define-callback (destroy (c-pointer mount) (c-pointer data)) void
  (mount-finalize! mount)
  (mount-status-set! mount 'stopping)
  (mount-stop! mount))



(define-type filesystem (struct filesystem))
(: filesystem? (* -> boolean : filesystem))
(: make-filesystem (#!rest -> filesystem))
(define make-filesystem
  (let ((make-filesystem make-filesystem))
    (lambda args
      (let ((callbacks (make-vector 26 #f)))
        (let loop ((args args))
          (match args
            (()
             (make-filesystem callbacks '()))
            (('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"))
            ((key handler . rest)
             (cond ((posq key fuse-operations) =>
                    (lambda (i)
                      (vector-set! callbacks i handler)
                      (loop rest)))
                   (else
                    (error 'make-filesystem "Invalid keyword argument" (car args)))))
            (else
             (error 'make-filesystem "Odd keyword arguments" (car args)))))))))

(define fuse_operations_size
  (foreign-type-size "struct fuse_operations"))

(define fuse_operations
  (begin0-let* ((x (allocate fuse_operations_size)))
    (fuse_operations_getattr_set!  x (foreign-value fuse_getattr_callback  c-pointer))
    (fuse_operations_readdir_set!  x (foreign-value fuse_readdir_callback  c-pointer))
    (fuse_operations_open_set!     x (foreign-value fuse_open_callback     c-pointer))
    (fuse_operations_read_set!     x (foreign-value fuse_read_callback     c-pointer))
    (fuse_operations_write_set!    x (foreign-value fuse_write_callback    c-pointer))
    (fuse_operations_release_set!  x (foreign-value fuse_release_callback  c-pointer))
    (fuse_operations_access_set!   x (foreign-value fuse_access_callback   c-pointer))
    (fuse_operations_create_set!   x (foreign-value fuse_create_callback   c-pointer))
    (fuse_operations_unlink_set!   x (foreign-value fuse_unlink_callback   c-pointer))
    (fuse_operations_truncate_set! x (foreign-value fuse_truncate_callback c-pointer))
    (fuse_operations_readlink_set! x (foreign-value fuse_readlink_callback c-pointer))
    (fuse_operations_symlink_set!  x (foreign-value fuse_symlink_callback  c-pointer))
    (fuse_operations_mknod_set!    x (foreign-value fuse_mknod_callback    c-pointer))
    (fuse_operations_mkdir_set!    x (foreign-value fuse_mkdir_callback    c-pointer))
    (fuse_operations_rmdir_set!    x (foreign-value fuse_rmdir_callback    c-pointer))
    (fuse_operations_rename_set!   x (foreign-value fuse_rename_callback   c-pointer))
    (fuse_operations_link_set!     x (foreign-value fuse_link_callback     c-pointer))
    (fuse_operations_chmod_set!    x (foreign-value fuse_chmod_callback    c-pointer))
    (fuse_operations_chown_set!    x (foreign-value fuse_chown_callback    c-pointer))
    (fuse_operations_utimens_set!  x (foreign-value fuse_utimens_callback  c-pointer))
    (fuse_operations_statfs_set!   x (foreign-value fuse_statfs_callback   c-pointer))
    (fuse_operations_fsync_set!    x (foreign-value fuse_fsync_callback    c-pointer))
    (fuse_operations_flush_set!    x (foreign-value fuse_flush_callback    c-pointer))
    (fuse_operations_init_set!     x (foreign-value fuse_init_callback     c-pointer))
    (fuse_operations_destroy_set!  x (foreign-value fuse_destroy_callback  c-pointer))
    #+(not openbsd) ; no ioctl on openbsd
    (fuse_operations_ioctl_set!    x (foreign-value fuse_ioctl_callback    c-pointer))))

(: filesystem-start! (string filesystem -> *))
(define (filesystem-start! path fs)
  (and-let* ((chan   (fuse_mount path #f))
             (mount  (make-mount fs most-negative-fixnum void void void))
             (mount* (make-mount-handle mount))
             (fuse   (fuse_new chan #f fuse_operations fuse_operations_size mount*))
             (fuse*  (make-fuse-handle path fuse chan))
             (pool   (make-callback-pool mount*)))
    (callback-pool-start! pool)
    (filesystem-mount-add! fs path mount)
    (mount-exception-handler-set! mount (current-exception-handler))
    (mount-synchronization-handler-set!
     mount
     (let ((m (make-mutex))
           (c (make-condition-variable)))
       (mutex-specific-set! m 'starting)
       (lambda (f) (f m c))))
    (let ((loop (native-thread-start! fuse_loop_worker fuse*)))
      (mount-shutdown-handler-set!
       mount
       (lambda ()
         (fuse_exit fuse)
         (native-thread-start! fuse_shutdown_worker fuse*)
         (mount-wait! mount 'stopping)
         (native-thread-join! loop)
         (callback-pool-terminate! pool)
         (filesystem-mount-delete! fs path)
         (mount-status-set! mount 'stopped)
         (mount-handle-destroy! mount*)
         (fuse-handle-destroy! fuse*))))))

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

(: filesystem-stop! (string filesystem -> *))
(define (filesystem-stop! path fs)
  (and-let* ((mount (filesystem-mount fs path)))
    (and (mount-stop! mount) #t)))

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