Changeset 25479 in project
- Timestamp:
- 11/07/11 10:43:08 (10 years ago)
- Location:
- release/4/ugarit/trunk
- Files:
-
- 8 edited
-
README.txt (modified) (11 diffs)
-
backend-cache.scm (modified) (3 diffs)
-
backend-fs.scm (modified) (3 diffs)
-
test/run.scm (modified) (6 diffs)
-
ugarit-core.scm (modified) (5 diffs)
-
ugarit.meta (modified) (1 diff)
-
ugarit.scm (modified) (2 diffs)
-
ugarit.setup (modified) (4 diffs)
Legend:
- Unmodified
- Added
- Removed
-
release/4/ugarit/trunk/README.txt
r25478 r25479 69 69 You can then refer to it using the following archive identifier: 70 70 71 fs "...path to directory..." 72 73 ### New Logfile backend 74 75 The 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 two sets of files; one is a log of data blocks, split at a specified maximum size, and the other is the metadata: a GDBM file used as an index to locate blocks in the logfiles and to store the blocks' types, a GDBM file of tags, and a counter file used in naming logfiles. 76 77 To set up a new logfile archive, just choose where to put the two sets of files. It would be nice to put the metadata on a different physical disk to the logs, to reduce seeking. Create a directory for each, or if you only have one disk, you can put them all in the same directory. 71 "backend-fs fs ...path to directory..." 72 73 ### Logfile backend 74 75 The logfile backend works much like the original Venti system. It's 76 append-only - you won't be able to delete old snapshots from a logfile 77 archive, even when I implement deletion. It stores the archive in two 78 sets of files; one is a log of data blocks, split at a specified 79 maximum size, and the other is the metadata: an sqlite database used 80 to track the location of blocks in the log files, the contents of 81 tags, and a count of the logs so a filename can be chosen for a new one. 82 83 To set up a new logfile archive, just choose where to put the two 84 parts. It would be nice to put the metadata file on a different 85 physical disk to the logs directory, to reduce seeking. If you only 86 have one disk, you can put the metadata file in the log directory 87 ("metadata" is a good name). 78 88 79 89 You can then refer to it using the following archive identifier: 80 90 81 splitlog "...log directory..." "...metadata directory..." max-logfile-size91 "backend-fs splitlog ...log directory... ...metadata file... max-logfile-size" 82 92 83 93 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. … … 96 106 The hash line chooses a hash algorithm. Currently Tiger-192 (`tiger`), SHA-256 (`sha256`), SHA-384 (`sha384`) and SHA-512 (`sha512`) are supported; if you omit the line then Tiger will still be used, but it will be a simple hash of the block with the block type appended, which reveals to attackers what blocks you have (as the hash is of the unencrypted block, and the hash is not encrypted). This is useful for development and testing or for use with trusted archives, but not advised for use with archives that attackers may snoop at. Providing a secret string produces a hash function that hashes the block, the type of block, and the secret string, producing hashes that attackers who can snoop the archive cannot use to find known blocks. Whichever hash function you use, you will need to install the required Chicken egg with one of the following commands: 97 107 98 sudo chicken-installtiger-hash # for tiger99 sudo chicken-installsha2 # for the SHA hashes108 chicken-install -s tiger-hash # for tiger 109 chicken-install -s sha2 # for the SHA hashes 100 110 101 111 `lzma` is the recommended compression option for low-bandwidth backends or when space is tight, but it's very slow to compress; deflate or no compression at all are better for fast local archives. To have no compression at all, just remove the `(compression ...)` line entirely. Likewise, to use compression, you need to install a Chicken egg: 102 112 103 sudo chicken-installz3 # for deflate104 sudo chicken-installlzma # for lzma113 chicken-install -s z3 # for deflate 114 chicken-install -s lzma # for lzma 105 115 106 116 Likewise, the `(encryption ...)` line may be omitted to have no encryption; the only currently supported algorithm is aes (in CBC mode) with a key given in hex, as a passphrase (hashed to get a key), or a passphrase read from the terminal on every run. The key may be 16, 24, or 32 bytes for 128-bit, 192-bit or 256-bit AES. To specify a hex key, just supply it as a string, like so: 107 117 108 118 (encryption aes "00112233445566778899AABBCCDDEEFF") 109 119 110 120 ...for 128-bit AES, 111 121 … … 130 140 Again, as it is an optional feature, to use encryption, you must install the appropriate Chicken egg: 131 141 132 sudo chicken-install aes 133 134 A file cache, if enabled, significantly speeds up subsequent snapshots of a filesystem tree. The file cache is a file (which Ugarit will create if it doesn't already exist) mapping filenames to (mtime,hash) pairs; as it scans the filesystem, if it files a file in the cache and the mtime has not changed, it will assume it is already archived under the specified hash. This saves it from having to read the entire file to hash it and then check if the hash is present in the archive. In other words, if only a few files have changed since the last snapshot, then snapshotting a directory tree becomes an O(N) operation, where N is the number of files, rather than an O(M) operation, where M is the total size of files involved. 142 chicken-install -s aes 143 144 A file cache, if enabled, significantly speeds up subsequent snapshots 145 of a filesystem tree. The file cache is a file (which Ugarit will 146 create if it doesn't already exist) mapping filenames to 147 (mtime,hash,size) tuples; as it scans the filesystem, if it files a 148 file in the cache and the mtime and size have not changed, it will 149 assume it is already archived under the specified hash. This saves it 150 from having to read the entire file to hash it and then check if the 151 hash is present in the archive. In other words, if only a few files 152 have changed since the last snapshot, then snapshotting a directory 153 tree becomes an O(N) operation, where N is the number of files, rather 154 than an O(M) operation, where M is the total size of files involved. 135 155 136 156 For example: … … 143 163 Be careful to put a set of parentheses around each configuration entry. White space isn't significant, so feel free to indent things and wrap them over lines if you want. 144 164 145 Keep copies of this file safe - you'll need it to do extractions! Print a copy out and lock it in your fire safe! Ok, currently, you might be able to recreate it if you remember where you put the storage, but when I add the `(encryption ...)` option, there will be an encryption key to deal with as well. 165 Keep copies of this file safe - you'll need it to do extractions! 166 Print a copy out and lock it in your fire safe! Ok, currently, you 167 might be able to recreate it if you remember where you put the 168 storage, but encryption keys are harder to remember. 146 169 147 170 ## Your first backup … … 250 273 Here's a list of planned developments, in approximate priority order: 251 274 275 ## General 276 277 * Everywhere I use (sql ...) to create an sqlite prepared statement, 278 don't. Create them all up-front and reuse the resulting statement 279 objects, it'll save memory and time. 280 281 * Migrate the source repo to Fossil (when there's a 282 kitten-technologies.co.uk migration to Fossil), and update the egg 283 locations thingy. 284 252 285 ## Backends 253 286 254 * Eradicate all GPL taint from gdbm by using sqlite for storing 255 metadata in backends! 256 257 * Remove backend-log. Have just backend-fs, backend-splitlog, and 258 maybe a backend-sqlite for everything-in-sqlite storage (plus future 259 S3/SFTP backends). Not including meta-backends such as backend-cache 260 and backend-replicated. 261 262 * Support for recreating the index and tags on a backend-log or 263 backend-splitlog if they get corrupted, from the headers left in the 264 log. Do this by extending the backend protocol with a special 265 "admin" command that allows for arbitrary backend-specific 266 operations, and write an ugarit-backend-admin CLI tool to administer 267 backends with it. 287 * Support for recreating the index and tags on a backend-splitlog if 288 they get corrupted, from the headers left in the log. Do this by 289 extending the backend protocol with a special "admin" command that 290 allows for arbitrary backend-specific operations, and write an 291 ugarit-backend-admin CLI tool to administer backends with it. 268 292 269 293 * Support for unlinking in backend-splitlog, by marking byte ranges as … … 308 332 ## Core 309 333 310 * Eradicate all GPL taint from gdbm by using sqlite for storing 311 the mtime cache! 312 313 * Better error handling. Right now we give up if we can't read a file 314 or directory. It would be awesomer to print a warning but continue 315 to archive everything else. 334 * API documentation for the units we export 316 335 317 336 * More `.ugarit` actions. Right now we just have exclude and include; … … 400 419 * Better error messages 401 420 421 * Line editing in the "explore" CLI, ideally with tab completion 422 423 * API mode: Works something like the backend API, except at the 424 archive level. Supports all the important archive operations, plus 425 access to sexpr stream writers and key stream writers, 426 archive-node-fold, etc. Requested by andyjpb, perhaps I can write 427 the framework for this and then let him add API functions as he desires. 428 402 429 * FUSE support. Mount it as a read-only filesystem :-D Then consider 403 430 adding Fossil-style writing to the `current` of a snapshot, with … … 407 434 * Filesystem watching. Even with the hash-caching trick, a snapshot 408 435 will still involve walking the entire directory tree and looking up 409 every file in the hash ca sh. We can do better than that - some436 every file in the hash cache. We can do better than that - some 410 437 platforms provide an interface for receiving real-time notifications 411 438 of changed or added files. Using this, we could allow ugarit to run … … 425 452 to an on-disk filesystem, while we're at it. 426 453 427 * A more formal test corpus with a unit test script around the 428 `ugarit` command-line tool; the corpus should contain a mix of tiny 429 and huge files and directories, awkward cases for sharing of blocks 430 (many identical files in the same dir, etc), complex forms of file 431 metadata, and so on. It should archive and restore the corpus 432 several times over with each hash, compression, and encryption 433 option. 454 * A unit test script around the `ugarit` command-line tool; the corpus 455 should contain a mix of tiny and huge files and directories, awkward 456 cases for sharing of blocks (many identical files in the same dir, 457 etc), complex forms of file metadata, and so on. It should archive 458 and restore the corpus several times over with each hash, 459 compression, and encryption option. 434 460 435 461 # Acknowledgements … … 475 501 476 502 Moving on from the world of backup, I'd like to thank the Chicken Team 477 for producing Chicken Scheme. Felix , Peter, Elf, and Alex have478 particularly inspired me with their can-do attitudes to combining 479 programming-language elegance and pragmatic engineering - two things 480 many would think un-unitable enemies. Of course, they didn't do it all 481 themselves - R5RS Scheme and the SRFIs provided a solid foundation to 482 build on, and there's a cast of many more in the Chicken community, 483 working on other bits of Chicken or just egging everyone on. And I 484 can't not thank Henry Baker for writing the seminal paper on the 485 technique Chicken uses to implement full tail-calling Scheme with 486 cheap continuations on top of C; Henry already had my admiration for 487 his work on combining elegance and pragmatism in linear logic. Why 488 doesn't he return my calls? I even sent flowers.503 for producing Chicken Scheme. Felix and the community at #chicken on 504 Freenode have particularly inspired me with their can-do attitudes to 505 combining programming-language elegance and pragmatic engineering - 506 two things many would think un-unitable enemies. Of course, they 507 didn't do it all themselves - R5RS Scheme and the SRFIs provided a 508 solid foundation to build on, and there's a cast of many more in the 509 Chicken community, working on other bits of Chicken or just egging 510 everyone on. And I can't not thank Henry Baker for writing the seminal 511 paper on the technique Chicken uses to implement full tail-calling 512 Scheme with cheap continuations on top of C; Henry already had my 513 admiration for his work on combining elegance and pragmatism in linear 514 logic. Why doesn't he return my calls? I even sent flowers. 489 515 490 516 A special thanks should go to Christian Kellermann for porting Ugarit … … 499 525 # Version history 500 526 527 * 1.0: Migrated from gdbm to sqlite for metadata storage, removing the 528 GPL taint. Unit test suite. backend-cache made into a separate 529 backend binary. Removed backend-log. BUGFIX: file caching uses mtime *and* 530 size now, rather than just mtime. Error handling so we skip objects 531 that we cannot do something with, and proceed to try the rest of the 532 operation. 533 501 534 * 0.8: decoupling backends from the core and into separate binaries, 502 535 accessed via standard input and output, so they can be run over SSH -
release/4/ugarit/trunk/backend-cache.scm
r25478 r25479 1 (use ugarit-backend) 1 2 (use sql-de-lite) 3 (use matchable) 2 4 3 5 (define cache-sql-schema … … 5 7 "CREATE TABLE cache (key TEXT PRIMARY KEY, type TEST);")) 6 8 7 (define (backend-cache be cachepath)9 (define (backend-cache cachepath be) 8 10 (define *db* (open-database cachepath)) 9 11 (when (null? (schema *db*)) … … 74 76 (close-database *db*) 75 77 (storage-close! be)))))) 78 79 80 (define backend 81 (match (command-line-arguments) 82 ((cachepath backend) 83 (backend-cache cachepath (import-storage backend))) 84 85 (else 86 (printf "USAGE:\nbackend-cache <path-to-cache-file> \"<backend command line>\"\n") 87 #f))) 88 89 (if backend 90 (export-storage! backend)) -
release/4/ugarit/trunk/backend-fs.scm
r25478 r25479 149 149 (void)))) 150 150 151 #;(define (backend-log logfile indexfile tagsfile)152 (let ((*index* (gdbm-open indexfile))153 (*tags* (gdbm-open tagsfile))154 (*log* (file-open logfile (+ open/creat open/rdwr open/append) perm/irwxu))155 (make-index-key (lambda (key)156 key))157 (make-index-tag (lambda (tag)158 tag))159 (make-index-entry (lambda (type posn len)160 (sprintf "(~A ~A ~A)" type posn len)))161 (parse-index-entry (lambda (str)162 (with-input-from-string str read))))163 164 ; FIXME: Sanity check that all opened OK165 166 (make-storage167 (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap168 #t ; We are writable169 #f ; We DO NOT support unlink!170 171 (lambda (key data type) ; put!172 (if (gdbm-exists *index* (make-index-key key))173 (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type))))174 175 (set-file-position! *log* 0 seek/end)176 177 178 (let ((header (sprintf "(block ~S ~S ~S)" key type (u8vector-length data)))179 (posn (file-position *log*)))180 (file-write *log* header)181 (file-write *log* (u8vector->blob/shared data))182 (gdbm-store *index* (make-index-key key)183 (make-index-entry type (+ (string-length header) posn) (u8vector-length data)))184 (void)))185 186 (lambda (key) ; exists?187 (if (gdbm-exists *index* (make-index-key key))188 (car (parse-index-entry (gdbm-fetch *index* key)))189 #f))190 191 (lambda (key) ; get192 (let* ((entry (parse-index-entry (gdbm-fetch *index* (make-index-key key))))193 (type (car entry))194 (position (cadr entry))195 (length (caddr entry))196 (buffer (make-blob length)))197 (set-file-position! *log* position seek/set)198 (file-read *log* length buffer)199 (blob->u8vector/shared buffer)))200 (lambda (key) ; link!201 (void))202 (lambda (key) ; unlink!203 (signal (make-property-condition 'exn 'message "Log archives do not support deletion")))204 (lambda (tag key) ; set-tag!205 (file-write *log* (sprintf "(tag ~S ~S)" tag key))206 (gdbm-store *tags* (make-index-tag tag) key))207 (lambda (tag) ; tag208 (if (gdbm-exists *tags* (make-index-tag tag))209 (gdbm-fetch *tags* (make-index-tag tag))210 #f))211 (lambda () ; all-tags212 (gdbm-fold *tags* (lambda (key value acc) (cons key acc)) '()))213 (lambda (tag) ; remove-tag!214 (file-write *log* (sprintf "(untag ~S)" tag))215 (gdbm-delete *tags* (make-index-tag tag)))216 (lambda (tag) ; lock-tag!217 ; (printf "FIXME: Implement lock-tag! in backend-fs.scm\n")218 #f)219 (lambda (tag) ; tag-locked?220 ; (printf "FIXME: Implement tag-locked? in backend-fs.scm\n")221 #f)222 (lambda (tag) ; unlock-tag!223 ; (printf "FIXME: Implement unlock-tag! in backend-fs.scm\n")224 #f)225 (lambda () ; close!226 (gdbm-close *index*)227 (gdbm-close *tags*)228 (file-close *log*)))))229 230 #;(define (backend-splitlog logdir metadir max-logpart-size)231 (let*232 ((*index* (gdbm-open (string-append metadir "/index")))233 (*tags* (gdbm-open (string-append metadir "/tags")))234 (countfile (string-append metadir "/count"))235 (*logcount* (if (file-read-access? countfile)236 (with-input-from-file countfile read)237 0))238 (*log* (file-open (string-append logdir "/log" (number->string *logcount*))239 (+ open/creat open/rdwr open/append) perm/irwxu))240 (*logfiles* (make-hash-table)) ; hash of file number to FD241 (get-log (lambda (index)242 (if (hash-table-exists? *logfiles* index)243 (hash-table-ref *logfiles* index)244 (begin245 (let ((fd (file-open (string-append logdir "/log" (number->string index)) open/rdonly perm/irwxu)))246 (set! (hash-table-ref *logfiles* index) fd)247 fd)))))248 (make-index-key (lambda (key)249 key))250 (make-index-tag (lambda (tag)251 tag))252 (make-index-entry (lambda (type index posn len)253 (sprintf "(~A ~A ~A ~A)" type index posn len)))254 (parse-index-entry (lambda (str)255 (with-input-from-string str read))))256 257 ; FIXME: Sanity check that all opened OK258 259 (make-storage260 (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap261 #t ; We are writable262 #f ; We DO NOT support unlink!263 264 (lambda (key data type) ; put!265 (if (gdbm-exists *index* (make-index-key key))266 (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type))))267 268 (set-file-position! *log* 0 seek/end)269 270 (let ((header (sprintf "(block ~S ~S ~S)" key type (u8vector-length data)))271 (posn (file-position *log*)))272 (if (> posn max-logpart-size)273 (begin274 (file-close *log*)275 (set! posn 0)276 (set! *logcount* (+ *logcount* 1))277 (with-output-to-file countfile (lambda ()278 (write *logcount*)))279 (set! *log* (file-open (string-append logdir "/log" (number->string *logcount*))280 (+ open/creat open/rdwr open/append) perm/irwxu))))281 (file-write *log* header)282 (file-write *log* (u8vector->blob/shared data))283 (gdbm-store *index* (make-index-key key)284 (make-index-entry type *logcount* (+ (string-length header) posn) (u8vector-length data)))285 (void)))286 287 (lambda (key) ; exists?288 (if (gdbm-exists *index* (make-index-key key))289 (car (parse-index-entry (gdbm-fetch *index* key)))290 #f))291 292 (lambda (key) ; get293 (let* ((entry (parse-index-entry (gdbm-fetch *index* (make-index-key key))))294 (type (car entry))295 (index (cadr entry))296 (position (caddr entry))297 (length (cadddr entry))298 (buffer (make-blob length))299 (logpart (get-log index)))300 (set-file-position! logpart position seek/set)301 (file-read logpart length buffer)302 (blob->u8vector/shared buffer)))303 (lambda (key) ; link!304 (void))305 (lambda (key) ; unlink!306 (signal (make-property-condition 'exn 'message "Log archives do not support deletion")))307 (lambda (tag key) ; set-tag!308 (file-write *log* (sprintf "(tag ~S ~S)" tag key))309 (gdbm-store *tags* (make-index-tag tag) key))310 (lambda (tag) ; tag311 (if (gdbm-exists *tags* (make-index-tag tag))312 (gdbm-fetch *tags* (make-index-tag tag))313 #f))314 (lambda () ; all-tags315 (gdbm-fold *tags* (lambda (key value acc) (cons key acc)) '()))316 (lambda (tag) ; remove-tag!317 (file-write *log* (sprintf "(untag ~S)" tag))318 (gdbm-delete *tags* (make-index-tag tag)))319 (lambda (tag) ; lock-tag!320 ; (printf "FIXME: Implement lock-tag! in backend-fs.scm\n")321 #f)322 (lambda (tag) ; tag-locked?323 ; (printf "FIXME: Implement tag-locked? in backend-fs.scm\n")324 #f)325 (lambda (tag) ; unlock-tag!326 ; (printf "FIXME: Implement unlock-tag! in backend-fs.scm\n")327 #f)328 (lambda () ; close!329 (gdbm-close *index*)330 (gdbm-close *tags*)331 (file-close *log*)332 (hash-table-for-each *logfiles*333 (lambda (key value)334 (file-close value)))))))335 336 151 (define splitlog-sql-schema 337 152 (list … … 342 157 "CREATE TABLE tags (tag TEXT PRIMARY KEY, key TEXT, locked INTEGER DEFAULT 0);")) 343 158 344 (define (backend-splitlog logdir meta dirmax-logpart-size)159 (define (backend-splitlog logdir metapath max-logpart-size) 345 160 (let* 346 161 ((*db* 347 (let ((db (open-database (string-append metadir "/metadata"))))162 (let ((db (open-database metapath))) 348 163 (when (null? (schema db)) 349 164 (for-each (lambda (statement) … … 482 297 (backend-fs base)) 483 298 484 #;(("log" logfile indexfile tagsfile)485 (backend-log logfile indexfile tagsfile))486 487 299 (("splitlog" logdir metadir max-logpart-size) 488 300 (backend-splitlog logdir metadir (string->number max-logpart-size))) 489 301 490 302 (else 491 (printf "USAGE:\nbackend-fs fs <basedir >\nbackend-fs log <logfile> <indexfile> <tagsfile>\nbackend-fs splitlog <logdir> <metadir> <max-file-size>\n")303 (printf "USAGE:\nbackend-fs fs <basedir-path>\nbackend-fs splitlog <logdir-path> <metadata-file-path> <max-file-size>\n") 492 304 #f))) 493 305 -
release/4/ugarit/trunk/test/run.scm
r25478 r25479 8 8 (use matchable) 9 9 (include "../backend-devtools.scm") 10 (include "../backend-cache.scm")11 10 12 11 ;; Test egg extensions … … 112 111 (devnum (vector-ref stats 10))) 113 112 (test-assert "Character special file exists" (eq? type stat/ifchr)) 114 (te ts"Character special file has correct devnum" 456 devnum))))113 (test "Character special file has correct devnum" 456 devnum)))) 115 114 116 115 ;; Directory … … 535 534 (fold-archive-node a dir-key (lambda (name dirent acc) (cons (cons name dirent) acc)) '())) 536 535 ; FIXME: Write a giant match to match this bad boy... 537 (pp dir) 538 (printf "sk1: ~a\n" sk1) 539 (printf "sk2: ~a\n" sk2) 540 (printf "dir-key: ~a\n" dir-key) 541 (printf "dir2-key: ~a\n" dir2-key) 542 543 544 )) 536 (if (zero? (current-user-id)) 537 (test-assert "Directory history has the expected form (as root)" 538 (match dir 539 (((#f "block-special" 'block-device (number . 123) . _) 540 (#f "character-special" 'character-device (number . 456) . _) 541 (_ "directory" 'dir . _) 542 (#f "fifo" 'fifo . _) 543 (#f "plain-file1" 'file . _) 544 (#f "plain-file2" 'file . _)) #t) 545 (else #f))) 546 (test-assert "Directory history has the expected form (not as root)" 547 (match dir 548 (((_ "directory" 'dir . _) 549 (#f "fifo" 'fifo . _) 550 (#f "plain-file1" 'file . _) 551 (#f "plain-file2" 'file . _)) #t) 552 (else #f)))))) 545 553 546 554 "This archive seems to work!") … … 558 566 (test "Close storage" (void) ((storage-close! be)))) 559 567 560 #;(test-group "Log backend"561 (create-directory "./tmp/be 2")562 (test-define "Open storage" be (import-storage "backend-fs log ./tmp/be2/log ./tmp/be2/index ./tmp/be2/tags"))568 (test-group "Splitlog backend" 569 (create-directory "./tmp/be3") 570 (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be3 ./tmp/be3/metadata 1024")) 563 571 (test-backend be) 564 572 (test "Close storage" (void) ((storage-close! be)))) 565 573 566 (test-group "Splitlog backend"567 (create-directory "./tmp/be3")568 (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be3 ./tmp/be3 1024"))569 (test-backend be)570 (test "Close storage" (void) ((storage-close! be))))571 572 574 (test-group "Limited cached splitlog backend" 573 575 (create-directory "./tmp/be4") 574 (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be4 ./tmp/be4 1024")) 575 (test-define "Wrap in cache" cbe (backend-cache be "./tmp/be4-cache")) 576 (test-define "Wrap in block-limiter" lbe (backend-limit-block-size cbe 1024)) 576 (test-define "Open storage" be (import-storage "backend-cache ./tmp/be4-cache \"backend-fs splitlog ./tmp/be4 ./tmp/be4/metadata 1024\"")) 577 (test-define "Wrap in block-limiter" lbe (backend-limit-block-size be 1024)) 577 578 (test-backend lbe) 578 579 (test "Close storage" (void) ((storage-close! lbe)))) … … 590 591 (test "Close archive" (void) (archive-close! be))) 591 592 592 #;(test-group "Log backend archive"593 (create-directory "./tmp/be6")594 (test-define "Open archive" be (open-archive '((storage "backend-fs log ./tmp/be6/log ./tmp/be6/index ./tmp/be6/tags")) #f #t))595 (test-archive be "./tmp/be6")596 (test "Close archive" (void) (archive-close! be)))597 598 593 (test-group "Splitlog backend archive" 599 594 (create-directory "./tmp/be7") 600 (test-define "Open archive" be (open-archive '((storage "backend-fs splitlog ./tmp/be7 ./tmp/be7 1024")) #f #t))595 (test-define "Open archive" be (open-archive '((storage "backend-fs splitlog ./tmp/be7 ./tmp/be7/metadata 1024")) #f #t)) 601 596 (test-archive be "./tmp/be7") 602 597 (test "Close archive" (void) (archive-close! be))) … … 604 599 (test-group "Splitlog backend archive plus file cache" 605 600 (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))601 (test-define "Open archive" be (open-archive '((storage "backend-fs splitlog ./tmp/be8 ./tmp/be8/metadata 1024") (file-cache "./tmp/be8-file-cache")) #f #t)) 607 602 (test-archive be "./tmp/be8") 608 603 (test "Close archive" (void) (archive-close! be))) -
release/4/ugarit/trunk/ugarit-core.scm
r25478 r25479 789 789 790 790 (for-each (lambda (filename) 791 (let* ((file-path (make-pathname path filename)) 792 (stats (file-stat file-path #t)) 793 (mode (bitwise-and (vector-ref stats 1) (bitwise-not stat/ifmt))) 794 (uid (vector-ref stats 3)) 795 (gid (vector-ref stats 4)) 796 (atime (vector-ref stats 6)) 797 (ctime (vector-ref stats 7)) 798 (mtime (vector-ref stats 8)) 799 (type (bitwise-and (vector-ref stats 1) stat/ifmt)) 800 (standard-file-attributes 801 (list (cons 'mode mode) (cons 'uid uid) (cons 'gid gid) (cons 'mtime mtime))) 802 (file-rules 803 (object-matches filename rules-checker))) 804 (if (archive-store-ctime? archive) 805 (set! standard-file-attributes (cons (cons 'ctime ctime) standard-file-attributes))) 806 (if (archive-store-atime? archive) 807 (set! standard-file-attributes (cons (cons 'atime atime) standard-file-attributes))) 808 (if (not (rules-say-ignore file-rules)) 809 (cond 810 ((eq? type stat/ifsock) 811 (printf "~A is a socket, ignoring...\n" file-path)) 812 ((eq? type stat/ifreg) 813 (let-values (((content-key content-reused?) (with-input-from-file file-path (lambda () (store-file! archive file-path stats))))) 814 ((sexpr-stream-writer-write! ssw) 815 (append (list filename 'file (cons 'contents content-key) (cons 'size (vector-ref stats 5))) standard-file-attributes) 816 (list (cons content-key content-reused?))))) 817 ((eq? type stat/ifdir) 818 (let-values (((content-key content-reused?) (store-directory! archive file-path))) 819 ((sexpr-stream-writer-write! ssw) 820 (append (list filename 'dir (cons 'contents content-key)) standard-file-attributes) 821 (list (cons content-key content-reused?))))) 822 ((eq? type stat/iflnk) 823 ((sexpr-stream-writer-write! ssw) 824 (append (list filename 'symlink (cons 'target (read-symbolic-link file-path))) standard-file-attributes) 825 '())) 826 ((eq? type stat/ifblk) 827 (let ((devnum (vector-ref stats 10))) 828 ((sexpr-stream-writer-write! ssw) 829 (append (list filename 'block-device (cons 'number devnum)) standard-file-attributes) 830 '()))) 831 ((eq? type stat/ifchr) 832 (let ((devnum (vector-ref stats 10))) 833 ((sexpr-stream-writer-write! ssw) 834 (append (list filename 'character-device (cons 'number devnum)) standard-file-attributes) 835 '()))) 836 ((eq? type stat/ififo) 837 ((sexpr-stream-writer-write! ssw) 838 (append (list filename 'fifo) standard-file-attributes) 839 '())) 840 (else 791 (handle-exceptions exn 792 (printf "ERROR: Could not store ~a into the archive, skipping it...\n" (make-pathname path filename)) 793 (let* ((file-path (make-pathname path filename)) 794 (stats (file-stat file-path #t)) 795 (mode (bitwise-and (vector-ref stats 1) (bitwise-not stat/ifmt))) 796 (uid (vector-ref stats 3)) 797 (gid (vector-ref stats 4)) 798 (atime (vector-ref stats 6)) 799 (ctime (vector-ref stats 7)) 800 (mtime (vector-ref stats 8)) 801 (type (bitwise-and (vector-ref stats 1) stat/ifmt)) 802 (standard-file-attributes 803 (list (cons 'mode mode) (cons 'uid uid) (cons 'gid gid) (cons 'mtime mtime))) 804 (file-rules 805 (object-matches filename rules-checker))) 806 (if (archive-store-ctime? archive) 807 (set! standard-file-attributes (cons (cons 'ctime ctime) standard-file-attributes))) 808 (if (archive-store-atime? archive) 809 (set! standard-file-attributes (cons (cons 'atime atime) standard-file-attributes))) 810 (if (not (rules-say-ignore file-rules)) 811 (cond 812 ((eq? type stat/ifsock) 813 (printf "WARNING: ~A is a socket, ignoring...\n" file-path)) 814 ((eq? type stat/ifreg) 815 (let-values (((content-key content-reused?) (with-input-from-file file-path (lambda () (store-file! archive file-path stats))))) 816 ((sexpr-stream-writer-write! ssw) 817 (append (list filename 'file (cons 'contents content-key) (cons 'size (vector-ref stats 5))) standard-file-attributes) 818 (list (cons content-key content-reused?))))) 819 ((eq? type stat/ifdir) 820 (let-values (((content-key content-reused?) (store-directory! archive file-path))) 821 ((sexpr-stream-writer-write! ssw) 822 (append (list filename 'dir (cons 'contents content-key)) standard-file-attributes) 823 (list (cons content-key content-reused?))))) 824 ((eq? type stat/iflnk) 825 ((sexpr-stream-writer-write! ssw) 826 (append (list filename 'symlink (cons 'target (read-symbolic-link file-path))) standard-file-attributes) 827 '())) 828 ((eq? type stat/ifblk) 829 (let ((devnum (vector-ref stats 10))) 830 ((sexpr-stream-writer-write! ssw) 831 (append (list filename 'block-device (cons 'number devnum)) standard-file-attributes) 832 '()))) 833 ((eq? type stat/ifchr) 834 (let ((devnum (vector-ref stats 10))) 835 ((sexpr-stream-writer-write! ssw) 836 (append (list filename 'character-device (cons 'number devnum)) standard-file-attributes) 837 '()))) 838 ((eq? type stat/ififo) 839 ((sexpr-stream-writer-write! ssw) 840 (append (list filename 'fifo) standard-file-attributes) 841 '())) 842 (else 841 843 ; WTF? 842 (printf "ERROR: I can't ascertain the type of ~A. Skipping it...\n" file-path))))))843 (sort! (directory path #t) string <?))844 (printf "ERROR: I can't ascertain the type of ~A. Skipping it...\n" file-path))))))) 845 (sort! (directory path #t) string>?)) 844 846 845 847 ((sexpr-stream-writer-finish! ssw)))))) … … 866 868 (atime (assq 'atime props))) 867 869 868 ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors.869 ; FIXME: Sneak in a configuration variable from above to turn attempts to set metadata off,870 ; for unprived restores.871 872 870 (if mode 873 871 (change-file-mode path (cdr mode))) 874 872 875 873 (if (or uid gid) 876 (change-file-owner path 877 (if uid (cdr uid) (current-user-id)) 878 (if gid (cdr gid) (current-group-id)))) 874 (handle-exceptions exn 875 (printf "WARNING: It was not possible to set the uid/gid of ~a\n" path) 876 (change-file-owner path 877 (if uid (cdr uid) (current-user-id)) 878 (if gid (cdr gid) (current-group-id))))) 879 879 880 880 (if (or mtime atime) … … 911 911 912 912 (create-symbolic-link target path) 913 914 ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors. 915 ; FIXME: Sneak in a configuration variable from above to turn attempts to set metadata off, 916 ; for unprived restores. 917 918 ; Alas, there is no portable way to set the atime/mtime on a link. 919 ; I think, somehow, we will manage to live our lives without the atime and mtime on links... 913 ;; Alas, there is no portable way to set the atime/mtime on a link. 914 ;; I think, somehow, we will manage to live our lives without the atime and mtime on links... 920 915 (if mode 921 916 (change-link-mode path (cdr mode))) 922 917 923 918 (if (or uid gid) 924 (change-link-owner path 925 (or (cdr uid) (current-user-id)) 926 (or (cdr gid) (current-group-id)))))) 919 (handle-exceptions exn 920 (printf "WARNING: It was not possible to set the uid/gid of ~a\n" path) 921 (change-link-owner path 922 (if uid (cdr uid) (current-user-id)) 923 (if gid (cdr gid) (current-group-id))))))) 927 924 928 925 (define (extract-fifo! archive props path) … … 935 932 (let ((number (cdr (assq 'number props)))) 936 933 937 ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors. 938 (create-special-file path stat/ifblk number) 939 940 (set-standard-file-metadata! path props))) 934 (handle-exceptions exn 935 (printf "WARNING: It was not possible to recreate block device ~a\n" path) 936 937 (create-special-file path stat/ifblk number) 938 (set-standard-file-metadata! path props)))) 941 939 942 940 (define (extract-character-device! archive props path) 943 941 (let ((number (cdr (assq 'number props)))) 944 942 945 ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors. 946 (create-special-file path stat/ifchr number) 947 948 (set-standard-file-metadata! path props))) 943 (handle-exceptions exn 944 (printf "WARNING: It was not possible to recreate character device ~a\n" path) 945 946 (create-special-file path stat/ifchr number) 947 (set-standard-file-metadata! path props)))) 949 948 950 949 (define (extract-object! archive dirent target-path) … … 1117 1116 (kons #f dirent acc))))) 1118 1117 knil))))) 1118 -
release/4/ugarit/trunk/ugarit.meta
r23255 r25479 3 3 (license "BSD") 4 4 (category data) 5 (needs miscmacros gdbm crypto-tools srfi-37 stty matchable autoload regex)5 (needs miscmacros sql-de-lite crypto-tools srfi-37 stty matchable autoload regex tiger-hash) 6 6 (optional lzma z3 tiger-hash sha2 aes) 7 7 (author "Alaric Snell-Pym") -
release/4/ugarit/trunk/ugarit.scm
r20322 r25479 98 98 99 99 (define (extract-file-from-node! archive directory-key name path success-continuation) 100 (handle-exceptions exn 101 (begin 102 (printf "ERROR: Could not extract ~a: ~a in ~a\n" 103 name 104 ((condition-property-accessor 'exn 'message "Unknown error") exn) 105 (cons ((condition-property-accessor 'exn 'location (void)) exn) 106 ((condition-property-accessor 'exn 'arguments (void)) exn))) 107 (success-continuation)) 100 108 (fold-archive-node archive directory-key 101 (lambda (node-key dirent acc)102 (if (string=? (car dirent) name)103 (case (cadr dirent)104 ((tag) (begin105 (printf "You can't extract an entire tag - choose an actual snapshot at least\n")106 (success-continuation)))107 ((snapshot)108 (begin109 (define name (car path)) ; Head of path is the tag name - the best name we have available110 (if (not (directory? name))111 (create-directory name))112 113 (extract-directory! archive114 (cdr (assq 'contents (cddr dirent))) ; root directory of snapshot115 name)116 (printf "Extracted ~A\n" name)117 (success-continuation)))118 (else119 (begin120 (extract-object! archive dirent ".")121 (printf "Extracted ~A\n" name)122 (success-continuation))))123 acc))124 #f))109 (lambda (node-key dirent acc) 110 (if (string=? (car dirent) name) 111 (case (cadr dirent) 112 ((tag) (begin 113 (printf "You can't extract an entire tag - choose an actual snapshot at least\n") 114 (success-continuation))) 115 ((snapshot) 116 (begin 117 (define name (car path)) ; Head of path is the tag name - the best name we have available 118 (if (not (directory? name)) 119 (create-directory name)) 120 121 (extract-directory! archive 122 (cdr (assq 'contents (cddr dirent))) ; root directory of snapshot 123 name) 124 (printf "Extracted ~A\n" name) 125 (success-continuation))) 126 (else 127 (begin 128 (extract-object! archive dirent ".") 129 (printf "Extracted ~A\n" name) 130 (success-continuation)))) 131 acc)) 132 #f))) 125 133 126 134 ;; To get started, call with '() as directory-key and path … … 183 191 (lambda () 184 192 (explore-archive archive directory-key path quit-continuation))))) 185 193 186 194 (printf "No such file or directory ~A\n" name) 187 195 -
release/4/ugarit/trunk/ugarit.setup
r22448 r25479 1 (define *version* 1.0) 2 1 3 (compile -s -O2 -d1 directory-rules.scm -j directory-rules) 2 4 (compile -s -O2 -d1 directory-rules.import.scm) … … 4 6 5 7 (install-extension 'directory-rules '("directory-rules.so" "directory-rules.o" "directory-rules.import.so") 6 '( ;(version 0.7)8 `((version ,*version*) 7 9 (static "directory-rules.o"))) 8 10 … … 12 14 13 15 (install-extension 'ugarit-backend '("ugarit-backend.so" "ugarit-backend.o" "ugarit-backend.import.so") 14 '( ;(version 0.7)16 `((version ,*version*) 15 17 (static "ugarit-backend.o"))) 16 18 … … 20 22 21 23 (install-extension 'ugarit-core '("ugarit-core.so" "ugarit-core.o" "ugarit-core.import.so") 22 '( ;(version 0.7)24 `((version ,*version*) 23 25 (static "ugarit-core.o"))) 24 26 25 27 (compile backend-fs.scm) 26 28 (install-program 'backend-fs "backend-fs" 27 '( ;(version 0.7) 29 `((version ,*version*) 30 )) 31 32 (compile backend-cache.scm) 33 (install-program 'backend-cache "backend-cache" 34 `((version ,*version*) 28 35 )) 29 36 30 37 (compile ugarit.scm) 31 38 (install-program 'ugarit "ugarit" 32 '( ;(version 0.7)39 `((version ,*version*) 33 40 ))
Note: See TracChangeset
for help on using the changeset viewer.
