(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))))