117 lines
4.5 KiB
Scheme
117 lines
4.5 KiB
Scheme
(define current-db (make-parameter #f (lambda (value) value)))
|
|
|
|
(define (err msg . irritants)
|
|
(apply error (cons (string-append "dirt-db error: " msg) irritants)))
|
|
(define (write-file file value)
|
|
(when (file-exists? file) (delete-file file))
|
|
(with-output-to-file file (lambda () (write value))))
|
|
(define (read-file file)
|
|
(guard (ex (else (err (string-append "value read error of: "
|
|
(error-object-message ex)
|
|
" in file "
|
|
file)
|
|
file)))
|
|
(with-input-from-file file (lambda () (read)))))
|
|
(define (file-path path key) (string-append path "/" key ".scm"))
|
|
(define (bak-path path key) (string-append path "/" key ".scm.bak"))
|
|
(define (strings-ends-with? str end)
|
|
(and (> (string-length str) (string-length end))
|
|
(string=? (string-copy str (- (string-length str) (string-length end)))
|
|
end)))
|
|
(define (db-keys path . values?)
|
|
(let ((results '()))
|
|
(for-each
|
|
(lambda (file)
|
|
(when (strings-ends-with? file ".scm")
|
|
(let ((key (string-copy file 0 (- (string-length file) 4))))
|
|
(set! results
|
|
(cons
|
|
(if (null? values?)
|
|
key
|
|
(cons key (parameterize ((current-db path)) (read-db key))))
|
|
results)))))
|
|
(if (directory-exists? path) (directory-files path) '()))
|
|
(reverse results)))
|
|
|
|
|
|
(define (directory-exists? path)
|
|
(or (file-exists? path)
|
|
(guard (condition (else #f))
|
|
(file-info-directory? (file-info path #f)))))
|
|
|
|
(define (ensure-directory-exists path)
|
|
(letrec*
|
|
((port (open-input-string path))
|
|
(looper (lambda (c path)
|
|
(let ((full-path (if (eof-object? c)
|
|
path
|
|
(string-append path (string c)))))
|
|
(when (and (or (eof-object? c) (char=? c #\/))
|
|
(not (directory-exists? full-path)))
|
|
(create-directory full-path)))
|
|
(when (not (eof-object? c))
|
|
(looper (read-char port) (string-append path (string c)))))))
|
|
(looper (read-char port) "")))
|
|
|
|
(define (read-db key)
|
|
(when (not (current-db))
|
|
(error "dirt-db error: read-db must be used inside with-db"))
|
|
(let ((path (current-db)))
|
|
(let* ((file (file-path path key))
|
|
(bak-file (bak-path path key)))
|
|
(cond ((file-exists? bak-file) (read-file bak-file))
|
|
((file-exists? file) (read-file file))
|
|
(else #f)))))
|
|
|
|
(define (write-db key value)
|
|
(for-each
|
|
(lambda (c)
|
|
(if (or (char-alphabetic? c) (char-numeric? c))
|
|
#t ;; Do nothing
|
|
(err "key can only contain char-alphabetic? and char-numeric?")))
|
|
(string->list key))
|
|
(when (not (current-db))
|
|
(err "write-db must be used inside with-db"))
|
|
(let ((path (current-db)))
|
|
(when (not (directory-exists? path)) (ensure-directory-exists path))
|
|
(let* ((file (file-path path key))
|
|
(bak-file (bak-path path key))
|
|
(old-value (if (file-exists? file) (read-file file) #f)))
|
|
(obtain-dot-lock file)
|
|
(guard
|
|
(ex (else (release-dot-lock file)
|
|
(err "[bak1] Could not write" path key value)))
|
|
(write-file bak-file old-value))
|
|
(when (not (equal? old-value (read-file bak-file)))
|
|
(guard (ex (else #f)) (delete-file bak-file))
|
|
(release-dot-lock file)
|
|
(err "[bak2] Could not write" path key value))
|
|
(guard
|
|
(ex (else (release-dot-lock file)
|
|
(err "[del] Could not write" path key value)))
|
|
(when (file-exists? file) (delete-file file)))
|
|
(guard
|
|
(ex (else (guard (ex (else #f)) (delete-file file))
|
|
(release-dot-lock file)
|
|
(err "[write] Could not write" path key value)))
|
|
(write-file file value))
|
|
(when (not (equal? value (read-file file)))
|
|
(guard (ex (else #f)) (delete-file file))
|
|
(release-dot-lock file)
|
|
(err "[equal] Could not write" path key value))
|
|
|
|
(guard
|
|
(ex (else (release-dot-lock file)
|
|
(err "[clean]Could not write" path key value)))
|
|
(delete-file bak-file))
|
|
(release-dot-lock file))))
|
|
|
|
(define (with-db path thunk)
|
|
(parameterize ((current-db path)) (thunk)))
|
|
|
|
(define (with-db-keys path thunk)
|
|
(parameterize ((current-db path)) (thunk (db-keys path))))
|
|
|
|
(define (with-db-values path thunk)
|
|
(parameterize ((current-db path)) (thunk (db-keys path #t))))
|