;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; portfs.scm - open/read/write/release with file ports.
;;;
;;; Serves the current working directory from <mountpoint>.
;;;
;;;     $ csc portfs.scm
;;;     $ ./portfs <mountpoint>
;;;

(import (chicken file)
        (chicken file posix)
        (chicken io)
        (chicken process signal)
        (chicken process-context)
        (fuse)
        (srfi 13))

(let* ((mountpoint ; strip CWD if present
        (let ((arg (car (command-line-arguments))))
          (cond ((string-prefix? (current-directory) arg)
                 (substring arg (add1 (string-length (current-directory)))))
                (else arg))))
       (filesystem
        (make-filesystem
         getattr: (lambda (path)
                    (let ((path (substring path 1))) ; leading "/"
                      (cond ((string=? path mountpoint) #f) ; avoid loop
                            ((string=? path "")
                             (subvector (file-stat ".") 1 9))
                            ((file-exists? path)
                             (subvector (file-stat path) 1 9))
                            (else #f))))
         readdir: (lambda (path)
                    (let ((path (substring path 1)))
                      (cond ((string=? path mountpoint) #f)
                            ((string=? path "")
                             (directory "." #t))
                            ((directory-exists? path)
                             (directory path #t))
                            (else #f))))
         open:    (lambda (path mode)
                    (let ((path (substring path 1)))
                       (and (regular-file? path)
                            (open-input-file path))))
         read:    (lambda (port size _) ; XXX offset ignored
                    (read-string size port))
         release: (lambda (port)
                    (close-input-port port)))))
  (set-signal-handler! signal/int (lambda (_) (filesystem-stop! mountpoint filesystem)))
  (filesystem-start! mountpoint filesystem)
  (filesystem-wait! mountpoint filesystem))