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

(module fuse
  (make-filesystem
   start-filesystem
   stop-filesystem
   file/fifo
   file/chr
   file/blk
   file/reg
   file/dir
   file/lnk
   file/sock)
  (import scheme chicken foreign lolevel srfi-18 matchable libfuse)
  (foreign-declare "#define FUSE_USE_VERSION 26")
  (foreign-declare "#include <fuse.h>")
  (foreign-declare "#include <errno.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 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_fill_dir_t
  (function int (c-pointer (const c-string) (c-pointer (const (struct "stat"))) off_t)))

(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, mountpoints, and each mount's dynamic
;; environment (currently, its exception handler).
;;
(define-record filesystem operations mounts)
(define-record mount filesystem channel exception-handler)
(define filesystem make-filesystem)

(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-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:
    init:
    destroy:
    ;; Probably TODO.
    ;ioctl:
    ;poll:
    ;flush:
    ;flushdir:
    ;fsync:
    ;fsyncdir:
    ;statfs:
    ;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 ((not-implemented (lambda _ (raise errno/nosys))))
    (lambda args
      (let ((oper (##sys#make-vector 22 not-implemented)))
        (let loop ((args args))
          (match args
            (()
             (filesystem oper '()))
            (('utime: value . rest)
             (error 'make-filesysem "The utime: option is deprecated - use utimens: instead"))
            (('getdir: value . rest)
             (error 'make-filesysem "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 (current-mount)
  (gc-root-ref (fuse_context_private_data (fuse_get_context))))

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

(define-inline (current-filesystem-callback i)
  (##sys#vector-ref (filesystem-operations (current-filesystem)) i))

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

(define-inline (callback-result l 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
  (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
  (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 'getattr 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
  (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 'readdir v)))))

(define-callback (fuse_open_callback (c-string path) (fuse_file_info 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 'open v)))

(define-callback (fuse_read_callback (c-string path) (c-pointer buf) (size_t len) (off_t off) (fuse_file_info 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 'read v)))))

(define-callback (fuse_write_callback (c-string path) (c-string data) (size_t len) (off_t off) (fuse_file_info 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 'write v)))))

(define-callback (fuse_release_callback (c-string path) (fuse_file_info fi)) int
  (callback-result 'release ((current-filesystem-callback 5) (object-unevict (fuse_file_info_fh fi)))))

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

(define-callback (fuse_create_callback (c-string path) (mode_t mode) (fuse_file_info fi)) int
  (callback-result 'create ((current-filesystem-callback 7) path mode)))

(define-callback (fuse_unlink_callback (c-string path)) int
  (callback-result 'unlink ((current-filesystem-callback 8) path)))

(define-callback (fuse_truncate_callback (c-string path) (off_t off)) int
  (callback-result 'truncate ((current-filesystem-callback 9) path off)))

(define-callback (fuse_readlink_callback (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 (fuse_symlink_callback (c-string to) (c-string from)) int
  (callback-result 'symlink ((current-filesystem-callback 11) to from)))

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

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

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

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

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

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

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

(define-callback (fuse_utimens_callback (c-string path) ((c-pointer (struct "timespec")) 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 'utimens ((current-filesystem-callback 19) path asec msec))))

(define-callback (fuse_init_callback (fuse_conn_info conn)) c-pointer
  (callback-protect (current-filesystem-callback 20))
  (fuse_context_private_data (fuse_get_context)))

(define-callback (fuse_destroy_callback (c-pointer data)) void
  ((current-filesystem-callback 21)))

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

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

(define start-filesystem
  (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_init_set!     ops (location fuse_init_callback))
    (fuse_operations_destroy_set!  ops (location fuse_destroy_callback))
    (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_chan_session chan))
                 (size  (fuse_chan_bufsize chan)))
        (filesystem-mount-add! fs path mount)
        (fuse_set_signal_handlers sess)
        (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))))))))
        (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)
  (and-let* ((chan (alist-ref path (filesystem-mounts fs) string=?)))
    (fuse_session_exit (fuse_chan_session chan))
    ((foreign-lambda int close int) (fuse_chan_fd chan)))))