;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; hashfs.scm - CHICKEN fuse example (file system in a hash table).
;;;
;;; Ported to CHICKEN by Ivan Raikov
;;; Minor modifications by Evan Hanson
;;; Copyright 2005-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more dtails.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 
;;; USA.
;;;

;;;
;;; To run:
;;;
;;;     $ csc hashfs.scm
;;;     $ ./hashfs <mountpoint>
;;;

(import (chicken bitwise)
        (chicken errno)
        (chicken fixnum)
        (chicken format)
        (chicken pathname)
        (chicken process signal)
        (chicken process-context)
        (chicken process-context posix)
        (chicken time)
        (fuse)
        (srfi 1)
        (srfi 13)
        (srfi 18)
        (srfi 69))

;;
;; Copies the contents of string s2 in string s1, beginning at offset
;;
(define (string-blit! s1 s2 offset)
  (let ((n1 (string-length s1))
        (n2 (string-length s2)))
    (if (<= n1 (- (+ offset n2) 1))
        (let ((ss (make-string (+ offset n2))))
          (string-copy! ss 0 s1 0 (min offset n1))
          (string-copy! ss offset s2)
          ss)
        (begin
          (string-copy! s1 offset s2)
          s1))))

;; ----------------------------------------------------------------------
;; Structures ...
;; ----------------------------------------------------------------------
;; meta file informations are represented with a vector
;; #(mode nlinks size pid gid atime mtime ctime)

(define-record-type hfile
  (make-hfile meta content)
  hfile?
  (meta hfile-meta)
  (content hfile-content hfile-content-set!))

(define-record-type hdir
  (make-hdir meta)
  hdir?
  (meta hdir-meta))

(define-record-type hslink
  (make-hslink meta link)
  hslink?
  (meta hslink-meta)
  (link hslink-link))

(define (h*-meta res)
  (cond ((hdir? res) (hdir-meta res))
        ((hfile? res) (hfile-meta res))
        ((hslink? res) (hslink-meta res))
        ((error "not an hdir, hfile or hslink" res))))

;; ----------------------------------------------------------------------
;; The file system (in fact, a Scheme hash table) ...
;; ----------------------------------------------------------------------
(define *fs* (make-hash-table string=?)) ;; The file system
(define *fd* (make-hash-table =)) ;; Used fds

;; ----------------------------------------------------------------------
;; The current fd is incremented on each `open`
;; ----------------------------------------------------------------------
(define genfd (let ((fd 0)) (lambda () (set! fd (add1 fd)) fd)))

;; ----------------------------------------------------------------------
;; mknod ...
;; ----------------------------------------------------------------------
(define (mknod name mode)
  (let* ((tm   (current-seconds))
         (meta (vector mode
                       1
                       (current-user-id) (current-group-id)
                       0
                       tm tm tm)))
    (hash-table-set! *fs* name (make-hfile meta (make-string 0)))
    0))

;; ----------------------------------------------------------------------
;; mkdir ...
;; ----------------------------------------------------------------------
(define (mkdir name mode)
  (let* ((tm   (current-seconds))
         (meta (vector (bitwise-ior file/dir mode)
                       2
                       (current-user-id) (current-group-id)
                       0
                       tm tm tm)))
    (hash-table-set! *fs* name (make-hdir meta))
    0))

;; ----------------------------------------------------------------------
;; mksymlink ...
;; ----------------------------------------------------------------------
(define (mksymlink old new)
  (let* ((tm   (current-seconds))
         (meta (vector (bitwise-ior file/lnk #o777)
                       1
                       (current-user-id) (current-group-id)
                       (string-length old)
                       tm tm tm)))
    (hash-table-set! *fs* new (make-hslink meta old))
    0))

;; Enter "/" in the hash table
(mkdir "/" #o750)

;; ----------------------------------------------------------------------
;; main ...
;; ----------------------------------------------------------------------

(define fs
 (make-filesystem
  getattr: (lambda (path)
             (let ((res (hash-table-ref/default *fs* path #f)))
               (cond ((hdir? res)
                      (hdir-meta res))
                     ((hfile? res)
                      (hfile-meta res))
                     ((hslink? res)
                      (hslink-meta res))
                     (else
                      (raise errno/noent)))))

  readdir: (lambda (path)
             (let ((files (filter (lambda (x) (equal? (pathname-directory x) path))
                                  (hash-table-keys *fs*))))
               (let ((lst (append '("." "..")
                                  (filter (lambda (x) (not (string-null? x)))
                                          (map pathname-strip-directory files)))))
                 lst)))

  mknod: mknod

  open: (lambda (path mode)
          (let ((res (hash-table-ref/default *fs* path #f)))
            (if (not res)
                (raise errno/noent)
                (let ((fd (genfd)))
                  (hash-table-set! *fd* fd path)
                  fd))))

  read: (lambda (fd size offset)
          (let* ((tmp  (hash-table-ref/default *fd* fd #f))
                 (file (hash-table-ref/default *fs* tmp #f)))
            (if (not (hfile? file))
                (raise errno/perm)
                (let* ((content (hfile-content file))
                       (len     (string-length content)))
                  (cond
                    ((and (= offset 0) (<= len size))
                     content)
                    ((< offset len)
                     (when (> (+ offset size) len)
                       (set! size (- len offset)))
                     (substring content offset (+ offset size)))
                    (else 0))))))

  write: (lambda (fd buffer offset)
           (let* ((tmp  (hash-table-ref/default *fd* fd #f))
                  (file (hash-table-ref/default *fs* tmp #f)))
             (if (not (hfile? file))
                 (raise errno/perm)
                 (let* ((content (hfile-content file))
                        (new     (string-blit! content buffer offset)))
                   ;; Store new content
                   (hfile-content-set! file new)
                   ;; Store the length in meta data
                   (let ((meta (hfile-meta file)))
                     (vector-set! meta 4 (string-length new)))
                   (string-length buffer)))))

  rename: (lambda (from to)
            (let ((data (hash-table-ref/default *fs* from #f)))
              (cond
                (data
                 (hash-table-set! *fs* to data)
                 (hash-table-delete! *fs* from)
                 0)
                (else
                 (raise errno/noent)))))

  unlink: (lambda (path)
            (let ((data (hash-table-ref/default *fs* path #f)))
              (cond
                (data
                 ;; decrement the nlinks counter
                 (let ((meta (cond ((hfile? data) (hfile-meta data))
                                   ((hdir? data) (hdir-meta data))
                                   ((hslink? data) (hslink-meta data)))))
                   (vector-set! meta 1 (- (vector-ref meta 1) 1)))
                 ;; delete the file form the hash table
                 (hash-table-delete! *fs* path)
                 0)
                (else
                 (raise errno/perm)))))

  link: (lambda (old new)
          (let ((data (hash-table-ref/default *fs* old #f)))
            (cond
              ((or (hfile? data) (hslink? data))
               (let ((meta (cond ((hfile? data) (hfile-meta data))
                                 ((hdir? data) (hdir-meta data))
                                 ((hslink? data) (hslink-meta data)))))
                 (vector-set! meta 1 (+ (vector-ref meta 1) 1)))
               ;; Create a new entry in *fs*
               (hash-table-set! *fs* new data)
               0)
              (else
               (raise errno/perm)))))

  mkdir: mkdir

  rmdir: (lambda (path)
           (let ((files (filter (lambda (x) (equal? (pathname-directory x) path))
                                (hash-table-keys *fs*))))
             (cond
               ((null? files)
                (hash-table-delete! *fs* path)
                0)
               (else
                (raise errno/notempty)))))

  symlink: mksymlink

  readlink: (lambda (path)
              (let ((data (hash-table-ref/default *fs* path #f)))
                (cond
                  ((hslink? data)
                   (hslink-link data))
                  (else
                   (raise errno/inval)))))

  chmod: (lambda (path mode)
           (let ((data (hash-table-ref/default *fs* path #f)))
             (if (not data)
                 (raise errno/perm)
                 (let ((meta (cond ((hfile? data) (hfile-meta data))
                                   ((hdir? data) (hdir-meta data))
                                   ((hslink? data) (hslink-meta data)))))
                   (vector-set! meta 0 mode)
                   0))))

  chown: (lambda (path uid gid)
           (let ((data (hash-table-ref/default *fs* path #f)))
             (if (not data)
                 (raise errno/perm)
                 (let ((meta (cond ((hfile? data) (hfile-meta data))
                                   ((hdir? data) (hdir-meta data))
                                   ((hslink? data) (hslink-meta data)))))
                   (vector-set! meta 2 uid)
                   (vector-set! meta 3 gid)
                   0))))

  utimens: (lambda (path atime ctime)
             (let ((data (hash-table-ref/default *fs* path #f)))
               (if (not data)
                   (raise errno/perm)
                   (let ((meta (cond ((hfile? data) (hfile-meta data))
                                     ((hdir? data) (hdir-meta data))
                                     ((hslink? data) (hslink-meta data)))))
                     (vector-set! meta 5 atime)
                     (vector-set! meta 6 atime)
                     0))))

  truncate: (lambda (path size)
              (let ((data (hash-table-ref/default *fs* path #f)))
                (if (not data)
                    (raise errno/perm)
                    (let* ((meta (cond ((hfile? data) (hfile-meta data))
                                       ((hdir? data) (hdir-meta data))
                                       ((hslink? data) (hslink-meta data))))
                           (osz  (vector-ref meta 4)))
                      (cond
                        ((= size osz) 0)
                        ((> size osz) (raise errno/perm))
                        (else (vector-set! meta 4 size)
                              0))))))

  statfs: (lambda (path)
            (let* ((block-size  1024)
                   (block-count 65535)
                   (file-count (hash-table-size *fs*))
                   (blocks-used
                    (* block-size
                       (+ 1 (quotient (hash-table-fold
                                       *fs*
                                       (lambda (_ data size)
                                         (+ (vector-ref (h*-meta data) 4) size))
                                       0)
                                      block-size)))))
              (vector block-size
                      block-count
                      (- block-count blocks-used) ; blocks available
                      (- block-count blocks-used) ; blocks available for user
                      file-count
                      most-positive-fixnum        ; files available
                      1024)))                     ; maximum pathname length

  init: (lambda ()
          (fprintf (current-error-port) "Starting fuse ...\n"))

  destroy: (lambda ()
             (fprintf (current-error-port) "Finished!\n"))))

(for-each
 (lambda (path)
   (set-signal-handler! signal/int (lambda (_) (filesystem-stop! path fs)))
   (filesystem-start! path fs)
   (filesystem-wait! path fs))
 (command-line-arguments))