Changeset 25478 in project
- Timestamp:
- 11/06/11 16:53:10 (9 years ago)
- Location:
- release/4/ugarit/trunk
- Files:
-
- 5 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/ugarit/trunk/README.txt
r25477 r25478 82 82 83 83 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. 84 85 ### Old Logfile backend86 87 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.88 89 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.90 91 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.92 93 You can then refer to it using the following archive identifier:94 95 log "...logfile..." "...indexfile..." "...tagsfile..."96 97 Neither of the files need to exist in advance; Ugarit will create them.98 84 99 85 ## Writing a ugarit.conf -
release/4/ugarit/trunk/backend-cache.scm
r21301 r25478 1 (use gdbm) 1 (use sql-de-lite) 2 3 (define cache-sql-schema 4 (list 5 "CREATE TABLE cache (key TEXT PRIMARY KEY, type TEST);")) 2 6 3 7 (define (backend-cache be cachepath) 4 (define *key-cache* (gdbm-open cachepath)) 8 (define *db* (open-database cachepath)) 9 (when (null? (schema *db*)) 10 (for-each (lambda (statement) 11 (exec (sql *db* statement))) 12 cache-sql-schema)) 5 13 (define *warn-about-delete* #t) 6 14 7 15 (define (cache-set! key type) 8 (if type 9 (gdbm-store *key-cache* key (symbol->string type) GDBM_REPLACE) 10 type) 16 (when type 17 (exec (sql *db* "INSERT OR REPLACE INTO cache (key, type) VALUES (?,?)") key (symbol->string type))) 11 18 type) 19 12 20 (define (cache-get key) 13 (let ((result (gdbm-fetch *key-cache* key))) 14 (if result 15 (string->symbol result) 21 (let ((result 22 (query fetch (sql *db* "SELECT type FROM cache WHERE key = ?") key))) 23 (if (pair? result) 24 (string->symbol (car result)) 16 25 #f))) 26 17 27 (define (cache-delete! key) 18 (gdbm-delete *key-cache*key))28 (exec (sql *db* "DELETE FROM cache WHERE key = ?") key)) 19 29 20 30 (make-storage … … 62 72 (lambda () ; close! 63 73 ((begin 64 ( gdbm-close *key-cache*)74 (close-database *db*) 65 75 (storage-close! be)))))) -
release/4/ugarit/trunk/backend-fs.scm
r25477 r25478 1 1 (use ugarit-backend) 2 (use gdbm)2 (use sql-de-lite) 3 3 (use srfi-69) 4 4 (use matchable) … … 228 228 (file-close *log*))))) 229 229 230 (define (backend-splitlog logdir metadir max-logpart-size)230 #;(define (backend-splitlog logdir metadir max-logpart-size) 231 231 (let* 232 232 ((*index* (gdbm-open (string-append metadir "/index"))) … … 334 334 (file-close value))))))) 335 335 336 (define splitlog-sql-schema 337 (list 338 "CREATE TABLE metadata (key TEXT PRIMARY KEY, value TEXT);" 339 "INSERT INTO metadata VALUES ('version','1');" 340 "INSERT INTO metadata VALUES ('current-logfile','0');" 341 "CREATE TABLE blocks (key TEXT PRIMARY KEY, type TEXT, fileno INTEGER, position INTEGER, length INTEGER);" 342 "CREATE TABLE tags (tag TEXT PRIMARY KEY, key TEXT, locked INTEGER DEFAULT 0);")) 343 344 (define (backend-splitlog logdir metadir max-logpart-size) 345 (let* 346 ((*db* 347 (let ((db (open-database (string-append metadir "/metadata")))) 348 (when (null? (schema db)) 349 (for-each (lambda (statement) 350 (exec (sql db statement))) 351 splitlog-sql-schema)) 352 db)) 353 (*logcount* (string->number (car (query fetch (sql *db* "SELECT value FROM metadata WHERE key = 'current-logfile'"))))) 354 (set-logcount! (lambda (newcount) 355 (set! *logcount* newcount) 356 (exec (sql *db* "INSERT OR REPLACE INTO metadata (key,value) VALUES ('current-logfile',?)") newcount))) 357 (*log* (file-open (string-append logdir "/log" (number->string *logcount*)) 358 (+ open/creat open/rdwr open/append) perm/irwxu)) 359 (*logfiles* (make-hash-table)) ; hash of file number to FD 360 (get-block-data (lambda (key) ; Returns #f for nonexistant blocks 361 (let ((bd (query fetch (sql *db* "SELECT type, fileno, position, length FROM blocks WHERE key = ?") key))) 362 (if (pair? bd) 363 (let ((type (string->symbol (first bd))) 364 (fileno (second bd)) 365 (position (third bd)) 366 (length (fourth bd))) 367 (list type fileno position length)) 368 #f)))) 369 (set-block-data! (lambda (key type fileno position length) 370 (exec (sql *db* "INSERT INTO blocks (key,type,fileno,position,length) VALUES (?,?,?,?,?)") key (symbol->string type) fileno position length))) 371 (set-tag! (lambda (tag key) 372 (exec (sql *db* "INSERT OR REPLACE INTO tags (tag,key) VALUES (?,?)") tag key))) 373 (remove-tag! (lambda (tag) 374 (exec (sql *db* "DELETE FROM tags WHERE tag = ?") tag))) 375 (get-tag (lambda (tag) 376 (let ((td (query fetch (sql *db* "SELECT key FROM tags WHERE tag = ?") tag))) 377 (if (pair? td) 378 (car td) 379 #f)))) 380 (set-tag-lock! (lambda (tag lock) 381 (exec (sql *db* "UPDATE tags SET locked = ? WHERE tag = ?") lock tag))) 382 (get-tag-lock (lambda (tag lock) 383 (let ((td (query fetch (sql *db* "SELECT locked FROM tags WHERE tag = ?") tag))) 384 (if (pair? td) 385 (car td) 386 #f)))) 387 (get-tags (lambda () 388 (map car (query fetch-all (sql *db* "SELECT tag FROM tags"))))) 389 (get-log (lambda (index) 390 (if (hash-table-exists? *logfiles* index) 391 (hash-table-ref *logfiles* index) 392 (begin 393 (let ((fd (file-open (string-append logdir "/log" (number->string index)) open/rdonly perm/irwxu))) 394 (set! (hash-table-ref *logfiles* index) fd) 395 fd)))))) 396 397 ; FIXME: Sanity check that all opened OK 398 399 (make-storage 400 (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap 401 #t ; We are writable 402 #f ; We DO NOT support unlink! 403 404 (lambda (key data type) ; put! 405 (with-transaction *db* 406 (lambda () 407 (when (pair? (get-block-data key)) 408 (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type)))) 409 410 (set-file-position! *log* 0 seek/end) 411 412 (let ((header (sprintf "(block ~S ~S ~S)" key type (u8vector-length data))) 413 (posn (file-position *log*))) 414 (if (> posn max-logpart-size) 415 (begin 416 (file-close *log*) 417 (set! posn 0) 418 (set-logcount! (+ *logcount* 1)) 419 (set! *log* (file-open (string-append logdir "/log" (number->string *logcount*)) 420 (+ open/creat open/rdwr open/append) perm/irwxu)))) 421 (file-write *log* header) 422 (file-write *log* (u8vector->blob/shared data)) 423 (set-block-data! key type *logcount* (+ (string-length header) posn) (u8vector-length data)) 424 (void))))) 425 426 (lambda (key) ; exists? 427 (let ((bd (get-block-data key))) 428 (if (pair? bd) 429 (car bd) 430 #f))) 431 432 (lambda (key) ; get 433 (let* ((entry (get-block-data key))) 434 (if (pair? entry) 435 (let* ((type (first entry)) 436 (index (second entry)) 437 (position (third entry)) 438 (length (fourth entry)) 439 (buffer (make-blob length)) 440 (logpart (get-log index))) 441 (set-file-position! logpart position seek/set) 442 (file-read logpart length buffer) 443 (blob->u8vector/shared buffer)) 444 #f))) 445 446 (lambda (key) ; link! 447 (void)) 448 449 (lambda (key) ; unlink! 450 (signal (make-property-condition 'exn 'message "Log archives do not support deletion"))) 451 452 (lambda (tag key) ; set-tag! 453 (file-write *log* (sprintf "(tag ~S ~S)" tag key)) 454 (set-tag! tag key) 455 (void)) 456 (lambda (tag) ; tag 457 (get-tag tag)) 458 (lambda () ; all-tags 459 (get-tags)) 460 (lambda (tag) ; remove-tag! 461 (remove-tag! tag) 462 (void)) 463 (lambda (tag) ; lock-tag! 464 (set-tag-lock! tag 1) 465 (void)) 466 (lambda (tag) ; tag-locked? 467 (if (zero? (get-tag-lock tag)) 468 #f 469 #t)) 470 (lambda (tag) ; unlock-tag! 471 (set-tag-lock! tag 0)) 472 (lambda () ; close! 473 (close-database *db*) 474 (file-close *log*) 475 (hash-table-for-each *logfiles* 476 (lambda (key value) 477 (file-close value))))))) 336 478 337 479 (define backend -
release/4/ugarit/trunk/test/run.scm
r25477 r25478 558 558 (test "Close storage" (void) ((storage-close! be)))) 559 559 560 (test-group "Log backend"560 #;(test-group "Log backend" 561 561 (create-directory "./tmp/be2") 562 562 (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))) 585 585 586 (test-group "Log backend archive" 586 (test-group "Filesystem backend archive plus file cache" 587 (create-directory "./tmp/be6") 588 (test-define "Open archive" be (open-archive '((storage "backend-fs fs ./tmp/be6") (file-cache "./tmp/be6-file-cache")) #f #t)) 589 (test-archive be "./tmp/be6") 590 (test "Close archive" (void) (archive-close! be))) 591 592 #;(test-group "Log backend archive" 587 593 (create-directory "./tmp/be6") 588 594 (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))) 597 603 604 (test-group "Splitlog backend archive plus file cache" 605 (create-directory "./tmp/be8") 606 (test-define "Open archive" be (open-archive '((storage "backend-fs splitlog ./tmp/be8 ./tmp/be8 1024") (file-cache "./tmp/be8-file-cache")) #f #t)) 607 (test-archive be "./tmp/be8") 608 (test "Close archive" (void) (archive-close! be))) 609 598 610 (printf "Final count of failures: ~a\n" (test-failure-count)) 599 611 -
release/4/ugarit/trunk/ugarit-core.scm
r25477 r25478 100 100 (use regex) 101 101 (use ugarit-backend) 102 (use gdbm)102 (use sql-de-lite) 103 103 104 104 … … 118 118 decrypt ; the decryptor, inverse of the above 119 119 global-directory-rules ; top-level directory rules 120 file-cache ; gdbm mapstoring filesystem cache (see store-file! procedure); #f if not enabled120 file-cache ; sqlite db storing filesystem cache (see store-file! procedure); #f if not enabled 121 121 file-cache-hits ; count of file cache hits 122 122 ) 123 123 124 124 (include "posixextras.scm") 125 126 (define (file-cache-put! archive file-path mtime size key) 127 (exec (sql (archive-file-cache archive) 128 "INSERT OR REPLACE INTO files (path,mtime,size,key) VALUES (?,?,?,?)") 129 file-path mtime size key)) 130 131 (define (file-cache-get archive file-path mtime size) 132 (let ((data (query fetch (sql (archive-file-cache archive) 133 "SELECT key FROM files WHERE path = ? AND mtime = ? AND size = ?") 134 file-path mtime size))) 135 (if (pair? data) 136 (car data) 137 #f))) 125 138 126 139 (define (prepend-type-byte b v) … … 246 259 (('encryption . conf) (set! *crypto* conf)) 247 260 (('file-cache path) 248 (set! *file-cache* (gdbm-open path))) 261 (set! *file-cache* (open-database path)) 262 (when (null? (schema *file-cache*)) 263 (exec (sql *file-cache* "CREATE TABLE files (path TEXT PRIMARY KEY, mtime INTEGER, size INTEGER, key TEXT);")))) 249 264 (('rule . conf) (set! *global-rules* (cons conf *global-rules*))) 250 265 (_ (signal (make-property-condition 'exn 'location 'open-archive 'message "Unknown configuration entry" 'arguments (list confentry)))))) … … 362 377 363 378 (define (archive-close! archive) 379 (when (archive-file-cache archive) 380 (close-database (archive-file-cache archive))) 364 381 ((storage-close! (archive-storage archive)))) 365 382 … … 555 572 (upload-file)))) 556 573 (store-file-and-cache! 557 (lambda (mtime )574 (lambda (mtime size) 558 575 (let-values (((key reused?) (store-file-without-caching!))) 559 (gdbm-store (archive-file-cache archive) 560 file-path 561 (with-output-to-string (lambda () 562 (write (list mtime key)))) 563 GDBM_REPLACE) 576 (file-cache-put! archive file-path mtime size key) 564 577 (values key reused?))))) 565 578 … … 571 584 (if (archive-file-cache archive) 572 585 (let* ((mtime (vector-ref file-stat 8)) ; Should have used and-let* 573 (cache-result-bytes (gdbm-fetch (archive-file-cache archive) file-path)) 574 (cache-result (if cache-result-bytes 575 (with-input-from-string cache-result-bytes read) 576 #f)) 577 (cached-mtime (if cache-result (car cache-result) #f)) 578 (cached-hash (if cache-result (cadr cache-result) #f))) 586 (size (vector-ref file-stat 5)) 587 (cache-result (file-cache-get archive file-path mtime size))) 579 588 (if cache-result 580 (if (= cached-mtime mtime) 581 (begin 582 #;(printf "Found ~a/~a in cache: ~a\n" file-path mtime cached-hash) 583 (archive-file-cache-hits-set! archive 584 (+ (archive-file-cache-hits archive) 1)) 585 (values cached-hash #t)) ; Found in cache! Woot! 586 (store-file-and-cache! mtime)) ; in cache, but mtime differs 587 (store-file-and-cache! mtime))) ; not in cache 589 (begin 590 (archive-file-cache-hits-set! archive 591 (+ (archive-file-cache-hits archive) 1)) 592 (values cache-result #t)) ; Found in cache! Woot! 593 (store-file-and-cache! mtime size))) ; not in cache 588 594 (store-file-without-caching!)))) ; no mtime cache 589 595 … … 805 811 (printf "~A is a socket, ignoring...\n" file-path)) 806 812 ((eq? type stat/ifreg) 807 ;; FIXME: We can store a gdbm cache file808 ;; mapping file-path (or device+inode?) to an (mtime hash) pair809 ;; We can check the filename in the cache, and if the file's mtime has not changed,810 ;; consider it already uploaded and reuse the hash, thus avoiding hashing the entire file.811 ;; When we upload a file, we store its mtime and hash in the cache.812 813 (let-values (((content-key content-reused?) (with-input-from-file file-path (lambda () (store-file! archive file-path stats))))) 813 814 ((sexpr-stream-writer-write! ssw) … … 1115 1116 (else 1116 1117 (kons #f dirent acc))))) 1117 knil)))) 1118 ) 1118 knil)))))
Note: See TracChangeset
for help on using the changeset viewer.