;;;; -*- coding: utf-8 -*-
;;;;
;;;; hashfs.stk -- Fuse Demo. A file system in a hash table
;;;;
;;;; Copyright © 2005-2023 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; 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 2 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.
;;;;
;;;;           Author: Erick Gallesio [eg@essi.fr]
;;;;    Creation date:  8-Dec-2005 14:30 (eg)
;;;;

;;;; Adapt the load-path.
(when-load-and-compile
 (let ((path (load-path)))
   (unless (member "../lib" path)
     (load-path `("../lib" ,@path)))))

;; to avoid warnings about undefined variables
(%compile-time-define   user-gid user-uid ENOENT EPERM EINVAL ENOTEMPTY
                        S_IFLNK S_IFDIR S_IFREG)



(define-module HASHFS
  (import (stklos fuse)
          (srfi 170))

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

(define-struct hfile meta content)
(define-struct hdir meta)
(define-struct hslink meta link)

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

;; ----------------------------------------------------------------------
;;      mknod ...
;; ----------------------------------------------------------------------
(define (mknod name mode)
  (let* ((tm   (current-seconds))
         (meta (vector (bit-or S_IFREG mode) 1 0
                       (user-uid) (user-gid)
                       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 (bit-or S_IFDIR mode) 2 0
                       (user-uid) (user-gid)
                       tm tm tm)))
    (hash-table-set! *fs* name (make-hdir meta))
    0))

;; ----------------------------------------------------------------------
;;      mksymlink ...
;; ----------------------------------------------------------------------
(define (mksymlink old new)
  (let* ((tm   (current-seconds))
         (meta (vector (bit-or S_IFLNK #o777) 1 (string-length old)
                       (user-uid) (user-gid) tm tm tm)))
    (hash-table-set! *fs* new (make-hslink meta old))
    0))


;; ----------------------------------------------------------------------
;;      hashfs-main ...
;; ----------------------------------------------------------------------
(define (hashfs-main args)
  ;; Enter "/" in the hash table
  (mkdir "/" #o750)
  ;; Mount
  (fuse-mount
       args
       :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
              (- ENOENT)))))

       :readdir
       (lambda (path)
         (let ((files (filter (lambda (x) (equal? (dirname x) path))
                              (hash-table-keys *fs*))))
           (append '("." "..")
                   (map basename files))))

       :mknod mknod

       :open
       (lambda (path mode fd)
         (let ((res (hash-table-ref/default *fs* path #f)))
           (if (not res)
               (- ENOENT)
               (begin
                 (hash-table-set! *fd* fd path)
                 0))))

       :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))
               (- EPERM)
               (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 size offset)
         (let* ((tmp  (hash-table-ref/default *fd* fd #f))
                (file (hash-table-ref/default *fs* tmp #f)))
           (if (not (hfile? file))
               (- EPERM)
               (let* ((content (hfile-content file))
                      (new     (string-blit! content buffer offset)))
                 ;; Store new content
                 (set! (hfile-content file) new)
                 ;; Store the length in meta data
                 (let ((meta (hfile-meta file)))
                   (vector-set! meta 2 (string-length new)))
                 size))))

       :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
                (- ENOENT)))))
       :unlink
       (lambda (path)
         (let ((data (hash-table-ref/default *fs* path #f)))
           (cond
             (data
                ;; decrement the nlinks counter
                (let ((meta (struct-ref data 'meta)))
                  (vector-set! meta 1 (- (vector-ref meta 1) 1)))
                ;; delete the file form the hash table
                (hash-table-delete! *fs* path)
                0)
             (else
               (- EPERM)))))
       :link
       (lambda (old new)
         (let ((data (hash-table-ref/default *fs* old #f)))
           (cond
             ((or (hfile? data) (hslink? data))
              (let ((meta (struct-ref data 'meta)))
                (vector-set! meta 1 (+ (vector-ref meta 1) 1)))
              ;; Create a new entry in *fs*
              (hash-table-set! *fs* new data)
              0)
             (else
              (- EPERM)))))

       :mkdir mkdir

       :rmdir
       (lambda (path)
         (let ((files (filter (lambda (x) (equal? (dirname x) path))
                              (hash-table-keys *fs*))))
           (cond
             ((null? files)
                (hash-table-delete! *fs* path)
                0)
             (else
                (- ENOTEMPTY)))))

       :symlink mksymlink

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

       :chmod
       (lambda (path mode)
         (let ((data (hash-table-ref/default *fs* path #f)))
           (if (not data)
               (- EPERM)
               (let ((meta (struct-ref data 'meta)))
                 (vector-set! meta 0 mode)
                 0))))

       :chown
       (lambda (path uid gid)
         (let ((data (hash-table-ref/default *fs* path #f)))
           (if (not data)
               (- EPERM)
               (let ((meta (struct-ref data 'meta)))
                 (vector-set! meta 3 uid)
                 (vector-set! meta 4 gid)
                 0))))

       :utime
       (lambda (path atime ctime)
         (let ((data (hash-table-ref/default *fs* path #f)))
           (if (not data)
               (- EPERM)
               (let ((meta (struct-ref data 'meta)))
                 (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)
               (- EPERM)
               (let* ((meta (struct-ref data 'meta))
                      (osz  (vector-ref meta 2)))
                 (cond
                   ((= size osz) 0)
                   ((> size osz) (- EPERM))
                   (else (vector-set! meta 2 size)
                         0))))))
       ;;;
       ;;; The following functions are only here for the demo.
       ;;;
;/       :flush
;/       (lambda (path fd)
;/       (format (current-error-port) "... Called flush ~S ~S\n" path fd)
;/       0)
;/       :release
;/       (lambda (path)
;/       (format (current-error-port) "... Called release ~S ~S\n" path fd))
;/       :opendir
;/       (lambda (path)
;/       (format (current-error-port) "... Called opendir ~S ~S\n" path fd)
;/       0)
;/       :fsync
;/       (lambda (path datasync fd)
;/       (format (current-error-port) "... Called fsync ~S ~S ~S\n" path datasync fd)
;/       0)
;/       :fsyncdir
;/       (lambda (path datasync fd)
;/       (format (current-error-port) "... Called fsyncdir ~S ~S ~S\n"
;/               path datasync fd)
;/       0)
;/       :releasedir
;/       (lambda (path)
;/       (format (current-error-port) "... Called releasedir ~S\n" path)
;/       0)
       :init
       (lambda ()
         (format (current-error-port) "Starting fuse ...\n")
         "It works.")
       :destroy
       (lambda (value)
         (format (current-error-port) "Finished and ~A\n" value))
       )
  (format (current-error-port) "hashfs is now unmounted\nBye\n"))

) ;; End of module HASHFS


;; ======================================================================
;;      HASHFS ...
;; ======================================================================
(define main (in-module HASHFS hashfs-main))
