#lang scheme/base
(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)))
((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))