(use ugarit-backend)
(use sql-de-lite)
(use matchable)

(define cache-sql-schema
  (list
   "CREATE TABLE cache (key TEXT PRIMARY KEY, type TEST);"))

(define (backend-cache cachepath be)
   (define *db* (open-database cachepath))
   (change-file-mode cachepath (bitwise-ior perm/irusr perm/iwusr))
   (when (null? (schema *db*))
         (for-each (lambda (statement)
                     (exec (sql *db* statement)))
                   cache-sql-schema))
   (exec (sql *db* "BEGIN;"))

   (define cache-set-query (sql *db* "INSERT OR REPLACE INTO cache (key, type) VALUES (?,?)"))
   (define cache-get-query (sql *db* "SELECT type FROM cache WHERE key = ?"))
   (define cache-delete-query (sql *db* "DELETE FROM cache WHERE key = ?"))

   (define commit-interval 1000)
   (define *updates-since-last-commit* 0)
   (define (flush!)
     (exec (sql *db* "COMMIT;"))
     (exec (sql *db* "BEGIN;"))
     (set! *updates-since-last-commit* 0))
   (define (maybe-flush!)
     (set! *updates-since-last-commit*
           (+ *updates-since-last-commit* 1))
     (when (> *updates-since-last-commit* commit-interval)
           (flush!)))

   (define (cache-set! key type)
      (when type
            (begin
              (exec cache-set-query key (symbol->string type))
              (maybe-flush!)))
      type)

   (define (cache-get key)
      (let ((result
             (query fetch cache-get-query key)))
        (if (pair? result)
            (string->symbol (car result))
            #f)))

   (define (cache-delete! key)
     (exec cache-delete-query key)
     (maybe-flush!))

   (make-storage
      (storage-max-block-size be)
      (storage-writable? be)
      (storage-unlinkable? be)
      (lambda (key data type) ; put!
         (begin
            ((storage-put! be) key data type)
            (cache-set! key type)
	    (void)))
      (lambda (key) ; exists?
         (or
            (cache-get key)
            (cache-set! key ((storage-exists? be) key))))
      (lambda (key) ; get
         ((storage-get be) key))
      (lambda (key) ; link!
         ((storage-link! be) key))
      (lambda (key) ; unlink!
         (let ((result ((storage-unlink! be) key)))
            (if result
               (begin
                  (cache-delete! key)
                  result)
               result)))
      (lambda (tag key) ; set-tag!
        ((storage-set-tag! be) tag key)
        (flush!))
      (lambda (tag) ; tag
         ((storage-tag be) tag))
      (lambda () ; all-tags
         ((storage-all-tags be)))
      (lambda (tag) ; remove-tag!
         ((storage-remove-tag! be) tag)
         (flush!))
      (lambda (tag) ; lock-tag!
         ((storage-lock-tag! be) tag)
         (flush!))
      (lambda (tag) ; tag-locked?
         ((storage-tag-locked? be) tag))
      (lambda (tag) ; unlock-tag!
         ((storage-unlock-tag! be) tag)
         (flush!))
      (lambda () ; close!
         ((begin
            (exec (sql *db* "COMMIT;"))
            (close-database *db*)
            (storage-close! be))))))


(define backend
  (match (command-line-arguments)
	 ((cachepath backend)
	  (backend-cache cachepath (import-storage backend)))

	 (else
	  (printf "USAGE:\nbackend-cache <path-to-cache-file> \"<backend command line>\"\n")
	  #f)))

(if backend
    (export-storage! backend))