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

(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))
   (set-busy-handler! *db* (busy-timeout 100000))
   (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 *hits* 0)
   (define *misses* 0)
   (define *flushes* 0)

   (define commit-interval 1000)
   (define *updates-since-last-commit* 0)
   (define (flush!)
     (when (> *updates-since-last-commit* 0)
      (inc! *flushes*)
      (exec (sql *db* "COMMIT;"))
      (exec (sql *db* "BEGIN;"))
      (set! *updates-since-last-commit* 0)))
   (define (maybe-flush!)
     (inc! *updates-since-last-commit*)
     (when (> *updates-since-last-commit* commit-interval)
           ((storage-flush! be))
           (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!))

   (define (cache-clear!)
     (exec (sql *db* "DELETE FROM cache")))

   (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 ()                        ; flush!
        (begin
          ((storage-flush! be))
          (flush!)
          (void)))
      (lambda (key) ; exists?
        (let ((cached-result (cache-get key)))
          (if cached-result
              (begin
                (inc! *hits*)
                cached-result)
              (begin
                (inc! *misses*)
                (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)
        ((storage-flush! be))
        (flush!))
      (lambda (tag) ; tag
         ((storage-tag be) tag))
      (lambda () ; all-tags
         ((storage-all-tags be)))
      (lambda (tag) ; remove-tag!
         ((storage-remove-tag! be) tag)
         ((storage-flush! be))
         (flush!))
      (lambda (tag) ; lock-tag!
         (let ((result ((storage-lock-tag! be) tag)))
           ((storage-flush! be))
           (flush!)
           result))
      (lambda (tag) ; tag-locked?
         ((storage-tag-locked? be) tag))
      (lambda (tag) ; unlock-tag!
         ((storage-unlock-tag! be) tag)
          ((storage-flush! be))
          (flush!))
      (lambda (command) ; admin!
        (match command
               (('info)
                (list (cons 'backend "cache")
                      (cons 'block-size (storage-max-block-size be))
                      (cons 'writable? (storage-writable? be))
                      (cons 'unlinkable? (storage-unlinkable? be))
                      (cons 'cache-file cachepath)
                      (cons 'commit-interval commit-interval)))
               (('help)
                (list (cons 'info "Return information about the archive")
                      (cons 'help "List available admin commands")
                      (cons 'stats "Examine the cache and report back statistics")
                      (cons 'clear! "Clear the cache")))
               (('stats)
                (list (cons 'entries (car (query fetch (sql *db* "SELECT COUNT(*) FROM cache"))))))
               (('clear!)
                (cache-clear!)
                (flush!)
                (list (cons 'result "Done")))
               (else (error "Unknown admin command"))))
      (lambda () ; close!
        (begin
          ((backend-log!) 'info (sprintf "Cache hits: ~A misses: ~A flushes: ~A" *hits* *misses* *flushes*))
          ((storage-close! be))
          (exec (sql *db* "COMMIT;"))
          (close-database *db*)))))


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

	 (else
          (export-storage-error! "Invalid arguments to backend-cache")
	  (printf "USAGE:\nbackend-cache <path-to-cache-file> \"<backend command line>\"\n")
	  #f)))

(if backend
    (export-storage! backend))