;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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 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 "#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 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_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 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))

;;
;; 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 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 _) (mutex-specific m))))

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

(define (mount-wait! mount status)
  ((mount-synchronization-handler mount)
   (lambda (m c)
     (do ((_ (mutex-lock! m)
             (mutex-lock! m)))
         ((let ((s (mutex-specific m)))
            (case status
              ((started) (fixnum? s))
              (else (eq? s 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)
  (fixnum? (mount-status mount)))

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

(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 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 current-fuse-context #f) ; XXX Dynamic variable.

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

(define-inline (current-filesystem)
  (mount-filesystem (current-mount)))

(define-inline (current-filesystem-callback i)
  (or (##sys#vector-ref (filesystem-callbacks (current-filesystem)) i)
      (lambda _ (raise errno/nosys))))

(define-inline (current-mount-exception-handler)
  (mount-exception-handler (current-mount)))

(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 thunk)
  (call-with-current-continuation
   (lambda (k)
     (with-exception-handler
      (lambda (e)
        (k (callback-error-result
            (cond ((condition? e) ((current-mount-exception-handler) 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))
            (handler     (symbol-append 'fuse_ name '_handler))
            (callback    (symbol-append 'fuse_ name '_callback)))
       `(begin
          (define-synchronous-concurrent-native-callback
            ((,handler fuse) (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)
       (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;
  /* TODO? */
  C_return(0);
EOC
)
        stat
        mode
        nlink
        uid
        gid
        size
        atime
        ctime
        mtime))
      (else
       (callback-result v)))))

(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 ...)
       (##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 (c-string path) (c-pointer fi)) int
  (let ((v ((current-filesystem-callback 2) path (fuse_file_info_flags fi))))
    (cond ((not v)
           (foreign-value "-ENOENT" int))
          (else
           (mount-status-set! (current-mount) (fx+ (mount-status (current-mount)) 1))
           (fuse_file_info_fh_set! fi (object-evict v))
           (callback-result v)))))

(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)
           (let ((l (string-length v)))
             (move-memory! v buf (fxmin l len))
             l))
          ((callback-result v)))))

(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 (release (c-string path) (c-pointer fi)) int
  (mount-status-set! (current-mount) (fx- (mount-status (current-mount)) 1))
  (callback-result ((current-filesystem-callback 5) (object-unevict (fuse_file_info_fh fi)))))

(define-callback (access (c-string path) (int mode)) int
  (callback-result ((current-filesystem-callback 6) path mode)))

(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 (unlink (c-string path)) int
  (callback-result ((current-filesystem-callback 8) path)))

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

(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))
          ((string? r)
           (move-memory! r buf (fxmin (string-length r) len))
           0)
          (else
           (error 'readlink "Invalid result" r)))))

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

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

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

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

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

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

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

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

(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,
                            C_SCHEME_UNDEFINED,
                            C_k,
                            C_fix(((struct timespec *)tv)[0].tv_sec),
                            C_fix(((struct timespec *)tv)[1].tv_sec));")
                 tv)))
    (callback-result ((current-filesystem-callback 19) path asec msec))))

(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)
       (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-string path) (int cmd) (c-pointer arg) (c-pointer fi) (unsigned-int flags) (c-pointer data)) int
  (callback-result ((current-filesystem-callback 21) path cmd arg)))

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

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

(define-callback (init (c-pointer conn)) c-pointer
  (callback-protect (current-filesystem-callback 24))
  (mount-status-set! (current-mount) 0)
  (fuse_context_private_data current-fuse-context))

(define-callback (destroy (c-pointer data)) void
  ;; On Linux, destroy is called *after* the filesystem has been
  ;; disconnected, so there's no active fuse_context through which
  ;; current-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-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 "#define fuse_loop_mt(f) fuse_loop(f)"))
  (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_destroy(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 = pthread_join(*thread, NULL) == 0;
  free(thread);
  C_return(result);
}

<#

(define start-fuse-thread!
  (foreign-lambda c-pointer start_fuse_thread c-pointer))

(define stop-fuse-thread!
  (foreign-lambda bool stop_fuse_thread c-pointer))

(cond-expand
  (openbsd
   ;; We can't use the destroy callback to coordinate shutdown events
   ;; (since it's only triggered under certain circumstances), so
   ;; instead we simply wait for the FUSE request dispatcher to empty
   ;; its queue before stopping the worker thread. This is safe since
   ;; only one filesystem can be mounted at a time anyway.
   (define-inline (fd-ready? fd)
     (fx= 1 ((foreign-lambda int "C_check_fd_ready" int) fd)))
   (define (dispatcher-queue-empty! name)
     (let ((fd (dispatcher-argument-input-fileno (dispatcher name))))
       (do () ((not (fd-ready? fd))) (thread-yield!)))))
  (else))

(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_ioctl_set!    ops (foreign-value "fuse_ioctl_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))
    (lambda (path fs)
      (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))))
        (mount-shutdown-handler-set!
         mount
         (lambda ()
           (unless (mount-stopping? mount)
             (cond-expand
               (openbsd
                (fuse_unmount path chan)
                (dispatcher-queue-empty! 'fuse))
               (else
                (fuse_exit fuse)
                (mount-wait! mount 0)
                (fuse_unmount path chan)
                (mount-wait! mount 'stopping))))
           (stop-fuse-thread! thread)
           (mount-status-set! mount 'stopped)
           (filesystem-mount-delete! fs path)
           ;; On OpenBSD the destroy callback is only executed on an
           ;; unmount request from the kernel, so to make sure destroy
           ;; handlers are always run we invoke them manually on
           ;; filesystem shutdown rather than in the destroy callback.
           (fluid-let ((current-mount (lambda () mount)))
             (callback-protect (current-filesystem-callback 25)))))
        (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=?)))
    (mount-running? mount))))