source: project/release/4/ugarit/trunk/backend-cache.scm @ 25479

(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))
   (when (null? (schema *db*))
         (for-each (lambda (statement)
                     (exec (sql *db* statement)))
                   cache-sql-schema))
   (define *warn-about-delete* #t)

   (define (cache-set! key type)
      (when type
          (exec (sql *db* "INSERT OR REPLACE INTO cache (key, type) VALUES (?,?)") key (symbol->string type)))
      type)

   (define (cache-get key)
      (let ((result
             (query fetch (sql *db* "SELECT type FROM cache WHERE key = ?") key)))
        (if (pair? result)
            (string->symbol (car result))
            #f)))

   (define (cache-delete! key)
     (exec (sql *db* "DELETE FROM cache WHERE key = ?") key))

   (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
                  (if *warn-about-delete*
                     (begin
                        (printf "WARNING: Deleting from a shared storage backend will INVALIDATE\nany OTHER caches. Please flush your caches on any other computers\nthat use the same backend store!\n")
                        (set! *warn-about-delete* #f)))
                  (cache-delete! key)
                  result)
               result)))
      (lambda (tag key) ; set-tag!
         ((storage-set-tag! be) tag key))
      (lambda (tag) ; tag
         ((storage-tag be) tag))
      (lambda () ; all-tags
         ((storage-all-tags be)))
      (lambda (tag) ; remove-tag!
         ((storage-remove-tag! be) tag))
      (lambda (tag) ; lock-tag!
         ((storage-lock-tag! be) tag))
      (lambda (tag) ; tag-locked?
         ((storage-tag-locked? be) tag))
      (lambda (tag) ; unlock-tag!
         ((storage-unlock-tag! be) tag))
      (lambda () ; close!
         ((begin
            (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))