Changeset 25478 in project

Timestamp:

11/06/11 16:53:10 (9 years ago)

Author:

Alaric Snell-Pym

Message:

ugarit: Seemingly removed all the gdbm taint. Must remember to update the .meta to replace gdbm with sql-de-lite, though!

Location:

release/4/ugarit/trunk

Files:

• README.txt (modified) (1 diff)
• backend-cache.scm (modified) (2 diffs)
• backend-fs.scm (modified) (3 diffs)
• test/run.scm (modified) (3 diffs)
• ugarit-core.scm (modified) (8 diffs)

release/4/ugarit/trunk/README.txt

@@ -82 +82 @@
 
 For most platforms, a max-logfile-size of 900000000 (900 MB) should suffice. For now, don't go much bigger than that on 32-bit systems until Chicken's `file-position` function is fixed to work with files >1GB in size.
-
-### Old Logfile backend
-
-The old logfile backend works much like the original Venti system. It's append-only - you won't be able to delete old snapshots from a logfile archive, even when I implement deletion. It stores the archive in three files; one is a log of data blocks, one is a GDBM index that remembers where in the log each block resides, one is a GDBM of tags.
-
-This worked well, but exposed a bug in Chicken when dealing with files more than about a gigabyte on 32-bit platforms. I fixed that in short order, but it reminded me that some platforms don't like files larger than 2GB anyway, so I wrote a new logfile backend that splits the log file into chunks at a specified point. You probably want to use the new backend - the old backend is kept for compatability only.
-
-To set up an old logfile archive, just choose where to put the three files. It would be nice to put the index and tags on a different physical disk to the log, to reduce seeking.
-
-You can then refer to it using the following archive identifier:
-
-      log "...logfile..." "...indexfile..." "...tagsfile..."
-
-Neither of the files need to exist in advance; Ugarit will create them.
 
 ## Writing a ugarit.conf

release/4/ugarit/trunk/backend-cache.scm

@@ -1 @@
-(use gdbm)
+(use sql-de-lite)
+
+(define cache-sql-schema
+  (list
+   "CREATE TABLE cache (key TEXT PRIMARY KEY, type TEST);"))
 
 (define (backend-cache be cachepath)
-   (define *key-cache* (gdbm-open cachepath))
+   (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)
-      (if type
-         (gdbm-store *key-cache* key (symbol->string type) GDBM_REPLACE)
-         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 (gdbm-fetch *key-cache* key)))
-         (if result
-            (string->symbol result)
+      (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)
-      (gdbm-delete *key-cache* key))
+     (exec (sql *db* "DELETE FROM cache WHERE key = ?") key))
 
    (make-storage
@@ -62 +72 @@
       (lambda () ; close!
          ((begin
-            (gdbm-close *key-cache*)
+            (close-database *db*)
             (storage-close! be))))))

release/4/ugarit/trunk/backend-fs.scm

@@ -1 +1 @@
 (use ugarit-backend)
-(use gdbm)
+(use sql-de-lite)
 (use srfi-69)
 (use matchable)
@@ -228 +228 @@
             (file-close *log*)))))
 
-(define (backend-splitlog logdir metadir max-logpart-size)
+#;(define (backend-splitlog logdir metadir max-logpart-size)
    (let*
         ((*index* (gdbm-open (string-append metadir "/index")))
@@ -334 +334 @@
                   (file-close value)))))))
 
+(define splitlog-sql-schema
+  (list
+   "CREATE TABLE metadata (key TEXT PRIMARY KEY, value TEXT);"
+   "INSERT INTO metadata VALUES ('version','1');"
+   "INSERT INTO metadata VALUES ('current-logfile','0');"
+   "CREATE TABLE blocks (key TEXT PRIMARY KEY, type TEXT, fileno INTEGER, position INTEGER, length INTEGER);"
+   "CREATE TABLE tags (tag TEXT PRIMARY KEY, key TEXT, locked INTEGER DEFAULT 0);"))
+
+(define (backend-splitlog logdir metadir max-logpart-size)
+   (let*
+        ((*db*
+          (let ((db (open-database (string-append metadir "/metadata"))))
+            (when (null? (schema db))
+                  (for-each (lambda (statement)
+                              (exec (sql db statement)))
+                            splitlog-sql-schema))
+            db))
+         (*logcount* (string->number (car (query fetch (sql *db* "SELECT value FROM metadata WHERE key = 'current-logfile'")))))
+         (set-logcount! (lambda (newcount)
+                         (set! *logcount* newcount)
+                         (exec (sql *db* "INSERT OR REPLACE INTO metadata (key,value) VALUES ('current-logfile',?)") newcount)))
+         (*log* (file-open (string-append logdir "/log" (number->string *logcount*))
+                  (+ open/creat open/rdwr open/append) perm/irwxu))
+         (*logfiles* (make-hash-table)) ; hash of file number to FD
+         (get-block-data (lambda (key) ; Returns #f for nonexistant blocks
+                           (let ((bd (query fetch (sql *db* "SELECT type, fileno, position, length FROM blocks WHERE key = ?") key)))
+                             (if (pair? bd)
+                                 (let ((type (string->symbol (first bd)))
+                                       (fileno (second bd))
+                                       (position (third bd))
+                                       (length (fourth bd)))
+                                   (list type fileno position length))
+                                 #f))))
+         (set-block-data! (lambda (key type fileno position length)
+                           (exec (sql *db* "INSERT INTO blocks (key,type,fileno,position,length) VALUES (?,?,?,?,?)") key (symbol->string type) fileno position length)))
+         (set-tag! (lambda (tag key)
+                    (exec (sql *db* "INSERT OR REPLACE INTO tags (tag,key) VALUES (?,?)") tag key)))
+         (remove-tag! (lambda (tag)
+                        (exec (sql *db* "DELETE FROM tags WHERE tag = ?") tag)))
+         (get-tag (lambda (tag)
+                         (let ((td (query fetch (sql *db* "SELECT key FROM tags WHERE tag = ?") tag)))
+                           (if (pair? td)
+                               (car td)
+                               #f))))
+         (set-tag-lock! (lambda (tag lock)
+                      (exec (sql *db* "UPDATE tags SET locked = ? WHERE tag = ?") lock tag)))
+         (get-tag-lock (lambda (tag lock)
+                         (let ((td (query fetch (sql *db* "SELECT locked FROM tags WHERE tag = ?") tag)))
+                           (if (pair? td)
+                               (car td)
+                               #f))))
+         (get-tags (lambda ()
+                     (map car (query fetch-all (sql *db* "SELECT tag FROM tags")))))
+         (get-log (lambda (index)
+            (if (hash-table-exists? *logfiles* index)
+               (hash-table-ref *logfiles* index)
+               (begin
+                  (let ((fd (file-open (string-append logdir "/log" (number->string index)) open/rdonly perm/irwxu)))
+                     (set! (hash-table-ref *logfiles* index) fd)
+                     fd))))))
+
+      ; FIXME: Sanity check that all opened OK
+
+      (make-storage
+         (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap
+         #t ; We are writable
+         #f ; We DO NOT support unlink!
+
+         (lambda (key data type) ; put!
+           (with-transaction *db*
+                             (lambda ()
+                               (when (pair? (get-block-data key))
+                                     (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type))))
+
+                               (set-file-position! *log* 0 seek/end)
+
+                               (let ((header (sprintf "(block ~S ~S ~S)" key type (u8vector-length data)))
+                                     (posn (file-position *log*)))
+                                 (if (> posn max-logpart-size)
+                                     (begin
+                                       (file-close *log*)
+                                       (set! posn 0)
+                                       (set-logcount! (+ *logcount* 1))
+                                       (set! *log* (file-open (string-append logdir "/log" (number->string *logcount*))
+                                                              (+ open/creat open/rdwr open/append) perm/irwxu))))
+                                 (file-write *log* header)
+                                 (file-write *log* (u8vector->blob/shared data))
+                                 (set-block-data! key type *logcount* (+ (string-length header) posn) (u8vector-length data))
+                                 (void)))))
+
+         (lambda (key) ; exists?
+           (let ((bd (get-block-data key)))
+             (if (pair? bd)
+                 (car bd)
+                 #f)))
+
+         (lambda (key) ; get
+            (let* ((entry (get-block-data key)))
+              (if (pair? entry)
+               (let* ((type (first entry))
+                      (index (second entry))
+                      (position (third entry))
+                      (length (fourth entry))
+                      (buffer (make-blob length))
+                      (logpart (get-log index)))
+                 (set-file-position! logpart position seek/set)
+                 (file-read logpart length buffer)
+                 (blob->u8vector/shared buffer))
+               #f)))
+
+         (lambda (key) ; link!
+            (void))
+
+         (lambda (key) ; unlink!
+            (signal (make-property-condition 'exn 'message "Log archives do not support deletion")))
+
+         (lambda (tag key) ; set-tag!
+            (file-write *log* (sprintf "(tag ~S ~S)" tag key))
+            (set-tag! tag key)
+            (void))
+         (lambda (tag) ; tag
+           (get-tag tag))
+         (lambda () ; all-tags
+           (get-tags))
+         (lambda (tag) ; remove-tag!
+           (remove-tag! tag)
+           (void))
+         (lambda (tag) ; lock-tag!
+           (set-tag-lock! tag 1)
+           (void))
+         (lambda (tag) ; tag-locked?
+           (if (zero? (get-tag-lock tag))
+               #f
+               #t))
+         (lambda (tag) ; unlock-tag!
+           (set-tag-lock! tag 0))
+         (lambda () ; close!
+           (close-database *db*)
+           (file-close *log*)
+           (hash-table-for-each *logfiles*
+                                (lambda (key value)
+                                  (file-close value)))))))
 
 (define backend

release/4/ugarit/trunk/test/run.scm

@@ -558 +558 @@
  (test "Close storage" (void) ((storage-close! be))))
 
-(test-group "Log backend"
+#;(test-group "Log backend"
  (create-directory "./tmp/be2")
  (test-define "Open storage" be (import-storage "backend-fs log ./tmp/be2/log ./tmp/be2/index ./tmp/be2/tags"))
@@ -584 +584 @@
  (test "Close archive" (void) (archive-close! be)))
 
-(test-group "Log backend archive"
+(test-group "Filesystem backend archive plus file cache"
+ (create-directory "./tmp/be6")
+ (test-define "Open archive" be (open-archive '((storage "backend-fs fs ./tmp/be6") (file-cache "./tmp/be6-file-cache")) #f #t))
+ (test-archive be "./tmp/be6")
+ (test "Close archive" (void) (archive-close! be)))
+
+#;(test-group "Log backend archive"
  (create-directory "./tmp/be6")
  (test-define "Open archive" be (open-archive '((storage  "backend-fs log ./tmp/be6/log ./tmp/be6/index ./tmp/be6/tags")) #f #t))
@@ -596 +602 @@
  (test "Close archive" (void) (archive-close! be)))
 
+(test-group "Splitlog backend archive plus file cache"
+ (create-directory "./tmp/be8")
+ (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be8 ./tmp/be8 1024") (file-cache "./tmp/be8-file-cache")) #f #t))
+ (test-archive be "./tmp/be8")
+ (test "Close archive" (void) (archive-close! be)))
+
 (printf "Final count of failures: ~a\n" (test-failure-count))
 

release/4/ugarit/trunk/ugarit-core.scm

@@ -100 +100 @@
 (use regex)
 (use ugarit-backend)
-(use gdbm)
+(use sql-de-lite)
 
 
@@ -118 +118 @@
   decrypt ; the decryptor, inverse of the above
   global-directory-rules ; top-level directory rules
-  file-cache ; gdbm map storing filesystem cache (see store-file! procedure); #f if not enabled
+  file-cache ; sqlite db storing filesystem cache (see store-file! procedure); #f if not enabled
   file-cache-hits ; count of file cache hits
   )
 
 (include "posixextras.scm")
+
+(define (file-cache-put! archive file-path mtime size key)
+  (exec (sql (archive-file-cache archive)
+             "INSERT OR REPLACE INTO files (path,mtime,size,key) VALUES (?,?,?,?)")
+        file-path mtime size key))
+
+(define (file-cache-get archive file-path mtime size)
+  (let ((data (query fetch (sql (archive-file-cache archive)
+                                "SELECT key FROM files WHERE path = ? AND mtime = ? AND size = ?")
+                    file-path mtime size)))
+    (if (pair? data)
+        (car data)
+        #f)))
 
 (define (prepend-type-byte b v)
@@ -246 +259 @@
                        (('encryption . conf) (set! *crypto* conf))
                        (('file-cache path)
-                        (set! *file-cache* (gdbm-open path)))
+                        (set! *file-cache* (open-database path))
+                        (when (null? (schema *file-cache*))
+                              (exec (sql *file-cache* "CREATE TABLE files (path TEXT PRIMARY KEY, mtime INTEGER, size INTEGER, key TEXT);"))))
                        (('rule . conf) (set! *global-rules* (cons conf *global-rules*)))
                        (_ (signal (make-property-condition 'exn 'location 'open-archive 'message "Unknown configuration entry" 'arguments (list confentry))))))
@@ -362 +377 @@
 
 (define (archive-close! archive)
+  (when (archive-file-cache archive)
+        (close-database (archive-file-cache archive)))
   ((storage-close! (archive-storage archive))))
 
@@ -555 +572 @@
               (upload-file))))
          (store-file-and-cache!
-          (lambda (mtime)
+          (lambda (mtime size)
             (let-values (((key reused?) (store-file-without-caching!)))
-              (gdbm-store (archive-file-cache archive)
-                          file-path
-                          (with-output-to-string (lambda ()
-                                                   (write (list mtime key))))
-                          GDBM_REPLACE)
+              (file-cache-put! archive file-path mtime size key)
               (values key reused?)))))
 
@@ -571 +584 @@
     (if (archive-file-cache archive)
         (let* ((mtime (vector-ref file-stat 8)) ; Should have used and-let*
-               (cache-result-bytes (gdbm-fetch (archive-file-cache archive) file-path))
-               (cache-result (if cache-result-bytes
-                                 (with-input-from-string cache-result-bytes read)
-                                 #f))
-               (cached-mtime (if cache-result (car cache-result) #f))
-               (cached-hash (if cache-result (cadr cache-result) #f)))
+               (size (vector-ref file-stat 5))
+               (cache-result (file-cache-get archive file-path mtime size)))
           (if cache-result
-              (if (= cached-mtime mtime)
-                  (begin
-                    #;(printf "Found ~a/~a in cache: ~a\n" file-path mtime cached-hash)
-                    (archive-file-cache-hits-set! archive
-                                                  (+ (archive-file-cache-hits archive) 1))
-                    (values cached-hash #t)) ; Found in cache! Woot!
-                  (store-file-and-cache! mtime)) ; in cache, but mtime differs
-              (store-file-and-cache! mtime))) ; not in cache
+              (begin
+                (archive-file-cache-hits-set! archive
+                                              (+ (archive-file-cache-hits archive) 1))
+                (values cache-result #t)) ; Found in cache! Woot!
+              (store-file-and-cache! mtime size))) ; not in cache
         (store-file-without-caching!)))) ; no mtime cache
 
@@ -805 +811 @@
                            (printf "~A is a socket, ignoring...\n" file-path))
                           ((eq? type stat/ifreg)
-                           ;; FIXME: We can store a gdbm cache file
-                           ;; mapping file-path (or device+inode?) to an (mtime hash) pair
-                           ;; We can check the filename in the cache, and if the file's mtime has not changed,
-                           ;; consider it already uploaded and reuse the hash, thus avoiding hashing the entire file.
-                           ;; When we upload a file, we store its mtime and hash in the cache.
                            (let-values (((content-key content-reused?) (with-input-from-file file-path (lambda () (store-file! archive file-path stats)))))
                              ((sexpr-stream-writer-write! ssw)
@@ -1115 +1116 @@
                             (else
                              (kons #f dirent acc)))))
-                       knil))))
-)
+                       knil)))))