#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DBD-FILE - driver wrapper around "atomic" file operations
;;
;; this module will not hold its guarantees for windows file system
;; as windows file cannot gaurantee atomic rename operation
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; file.ss - the driver wrapper
;; yc 9/15/2009 - first version
;; yc 1/18/2010 - added open-port, mtime, and size method

(require (planet bzlib/base)
         (planet bzlib/dbi)
         (planet bzlib/file)
         (planet bzlib/os)
         )

(define (file-connect driver path) 
  (assert! (directory-exists? path))
  (make-handle driver path (make-immutable-hash-registry) 0))

(define (file-disconnect handle)
  (void)) 

(define (file-prepare handle stmt)
  (void)) 

(define (file-query handle stmt (args '())) 
  (define (path-helper path)
    (if (not path)
        (handle-conn handle)
        (build-path* (handle-conn handle) path)))
  (define (convert-path path)
    (relative-abs-path (handle-conn handle) (path-helper path)))
  (define (get-paths)
    (map path-helper (map cdr (filter (lambda (kv)
                                        (equal? (car kv) 'path)) 
                                      args))))
  (case stmt
    ((list)
     (let ((path (path-helper (assoc/cdr 'path args))))
       (if (directory-exists? path)
           (map convert-path (directory-list path))
           #f)))
    ((open)
     (map file->bytes (get-paths)))
    ((open-port) 
     (map open-input-file (get-paths)))
    ((mtime) 
     (map mtime (get-paths)))
    ((size)
     (map file-size (get-paths)))
    ((save!)
     (let/assert! ((path (assoc/cdr 'path args))
                   (content (assoc/cdr 'content args)))
                  (call-with-output-atomic-file 
                      (ensure-parent-path-exists! (path-helper path))
                    (lambda (out) 
                      (write-bytes content out))
                    #:exists 'replace)))
    ((delete!)
     (for-each (lambda (path) 
                 (with-handlers ((exn:fail:filesystem?
                                  (lambda (e)
                                    (when (file-exists? path)
                                      (raise e)))))
                   ((+:windows delete-file! delete-file) path)))
               (get-paths)))
    ((rmdir!) 
     (for-each (lambda (path)
                 (with-handlers ((exn:fail:filesystem?
                                  (lambda (e)
                                    (when (directory-exists? path)
                                      (raise e)))))
                   ((+:windows delete-directory! 
                               delete-directory) path))) 
               (get-paths)))
    ((rm-rf!)
     (for-each (lambda (path) 
                 (with-handlers ((exn:fail:filesystem?
                                  (lambda (e)
                                    (when (or (file-exists? path)
                                              (directory-exists? path))
                                      (raise e)))))
                   ((+:windows delete-directory/files!
                              delete-directory/files) path)) 
               (get-paths))))
    (else 
     (error 'file-query "unknown statement: ~a" stmt))))

(define (file-recordset-query handle stmt (args '())) 
  (let ((value (file-query handle stmt args))) 
    (case stmt 
      ((list) 
       (map list (cons "path" (if (not value) '() value))))
      ((open)
       (map list (cons "content" value))))))

(define (file-begin handle) 
  (void)) 

(define (file-commit handle)
  (void)) 

(define (file-rollback handle) 
  (void))



(registry-set! drivers 'file
               (make-driver file-connect
                            file-disconnect
                            file-query
                            file-prepare
                            file-begin
                            file-commit
                            file-rollback))
         
(registry-set! drivers 'file/rs
               (make-driver file-connect
                            file-disconnect
                            file-recordset-query
                            file-prepare
                            file-begin
                            file-commit
                            file-rollback))