Changeset 25479 in project for release/4/ugarit/trunk


Ignore:
Timestamp:
11/07/11 10:43:08 (10 years ago)
Author:
Alaric Snell-Pym
Message:

ugarit: Dotting is, crossing ts...

Location:
release/4/ugarit/trunk
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • release/4/ugarit/trunk/README.txt

    r25478 r25479  
    6969You can then refer to it using the following archive identifier:
    7070
    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
     75The logfile backend works much like the original Venti system. It's
     76append-only - you won't be able to delete old snapshots from a logfile
     77archive, even when I implement deletion. It stores the archive in two
     78sets of files; one is a log of data blocks, split at a specified
     79maximum size, and the other is the metadata: an sqlite database used
     80to track the location of blocks in the log files, the contents of
     81tags, and a count of the logs so a filename can be chosen for a new one.
     82
     83To set up a new logfile archive, just choose where to put the two
     84parts. It would be nice to put the metadata file on a different
     85physical disk to the logs directory, to reduce seeking. If you only
     86have one disk, you can put the metadata file in the log directory
     87("metadata" is a good name).
    7888
    7989You can then refer to it using the following archive identifier:
    8090
    81       splitlog "...log directory..." "...metadata directory..." max-logfile-size
     91      "backend-fs splitlog ...log directory... ...metadata file... max-logfile-size"
    8292
    8393For 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.
     
    96106The 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:
    97107
    98     sudo chicken-install tiger-hash  # for tiger
    99     sudo chicken-install sha2        # for the SHA hashes
     108    chicken-install -s tiger-hash  # for tiger
     109    chicken-install -s sha2        # for the SHA hashes
    100110
    101111`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:
    102112
    103        sudo chicken-install z3       # for deflate
    104        sudo chicken-install lzma     # for lzma
     113       chicken-install -s z3       # for deflate
     114       chicken-install -s lzma     # for lzma
    105115
    106116Likewise, 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:
    107117
    108118      (encryption aes "00112233445566778899AABBCCDDEEFF")
    109      
     119
    110120...for 128-bit AES,
    111121
     
    130140Again, as it is an optional feature, to use encryption, you must install the appropriate Chicken egg:
    131141
    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
     144A file cache, if enabled, significantly speeds up subsequent snapshots
     145of a filesystem tree. The file cache is a file (which Ugarit will
     146create if it doesn't already exist) mapping filenames to
     147(mtime,hash,size) tuples; as it scans the filesystem, if it files a
     148file in the cache and the mtime and size have not changed, it will
     149assume it is already archived under the specified hash. This saves it
     150from having to read the entire file to hash it and then check if the
     151hash is present in the archive. In other words, if only a few files
     152have changed since the last snapshot, then snapshotting a directory
     153tree becomes an O(N) operation, where N is the number of files, rather
     154than an O(M) operation, where M is the total size of files involved.
    135155
    136156For example:
     
    143163Be 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.
    144164
    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.
     165Keep copies of this file safe - you'll need it to do extractions!
     166Print a copy out and lock it in your fire safe! Ok, currently, you
     167might be able to recreate it if you remember where you put the
     168storage, but encryption keys are harder to remember.
    146169
    147170## Your first backup
     
    250273Here's a list of planned developments, in approximate priority order:
    251274
     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
    252285## Backends
    253286
    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.
    268292
    269293* Support for unlinking in backend-splitlog, by marking byte ranges as
     
    308332## Core
    309333
    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
    316335
    317336* More `.ugarit` actions. Right now we just have exclude and include;
     
    400419* Better error messages
    401420
     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
    402429* FUSE support. Mount it as a read-only filesystem :-D Then consider
    403430  adding Fossil-style writing to the `current` of a snapshot, with
     
    407434* Filesystem watching. Even with the hash-caching trick, a snapshot
    408435  will still involve walking the entire directory tree and looking up
    409   every file in the hash cash. We can do better than that - some
     436  every file in the hash cache. We can do better than that - some
    410437  platforms provide an interface for receiving real-time notifications
    411438  of changed or added files. Using this, we could allow ugarit to run
     
    425452  to an on-disk filesystem, while we're at it.
    426453
    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.
    434460
    435461# Acknowledgements
     
    475501
    476502Moving on from the world of backup, I'd like to thank the Chicken Team
    477 for producing Chicken Scheme. Felix, Peter, Elf, and Alex have
    478 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.
     503for producing Chicken Scheme. Felix and the community at #chicken on
     504Freenode have particularly inspired me with their can-do attitudes to
     505combining programming-language elegance and pragmatic engineering -
     506two things many would think un-unitable enemies. Of course, they
     507didn't do it all themselves - R5RS Scheme and the SRFIs provided a
     508solid foundation to build on, and there's a cast of many more in the
     509Chicken community, working on other bits of Chicken or just egging
     510everyone on. And I can't not thank Henry Baker for writing the seminal
     511paper on the technique Chicken uses to implement full tail-calling
     512Scheme with cheap continuations on top of C; Henry already had my
     513admiration for his work on combining elegance and pragmatism in linear
     514logic. Why doesn't he return my calls? I even sent flowers.
    489515
    490516A special thanks should go to Christian Kellermann for porting Ugarit
     
    499525# Version history
    500526
     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
    501534* 0.8: decoupling backends from the core and into separate binaries,
    502535  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)
    12(use sql-de-lite)
     3(use matchable)
    24
    35(define cache-sql-schema
     
    57   "CREATE TABLE cache (key TEXT PRIMARY KEY, type TEST);"))
    68
    7 (define (backend-cache be cachepath)
     9(define (backend-cache cachepath be)
    810   (define *db* (open-database cachepath))
    911   (when (null? (schema *db*))
     
    7476            (close-database *db*)
    7577            (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  
    149149         (void))))
    150150
    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 OK
    165 
    166       (make-storage
    167          (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap
    168          #t ; We are writable
    169          #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) ; get
    192             (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) ; tag
    208             (if (gdbm-exists *tags* (make-index-tag tag))
    209                (gdbm-fetch *tags* (make-index-tag tag))
    210                #f))
    211          (lambda () ; all-tags
    212             (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 FD
    241          (get-log (lambda (index)
    242             (if (hash-table-exists? *logfiles* index)
    243                (hash-table-ref *logfiles* index)
    244                (begin
    245                   (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 OK
    258 
    259       (make-storage
    260          (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap
    261          #t ; We are writable
    262          #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                   (begin
    274                      (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) ; get
    293             (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) ; tag
    311             (if (gdbm-exists *tags* (make-index-tag tag))
    312                (gdbm-fetch *tags* (make-index-tag tag))
    313                #f))
    314          (lambda () ; all-tags
    315             (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 
    336151(define splitlog-sql-schema
    337152  (list
     
    342157   "CREATE TABLE tags (tag TEXT PRIMARY KEY, key TEXT, locked INTEGER DEFAULT 0);"))
    343158
    344 (define (backend-splitlog logdir metadir max-logpart-size)
     159(define (backend-splitlog logdir metapath max-logpart-size)
    345160   (let*
    346161        ((*db*
    347           (let ((db (open-database (string-append metadir "/metadata"))))
     162          (let ((db (open-database metapath)))
    348163            (when (null? (schema db))
    349164                  (for-each (lambda (statement)
     
    482297          (backend-fs base))
    483298
    484          #;(("log" logfile indexfile tagsfile)
    485           (backend-log logfile indexfile tagsfile))
    486 
    487299         (("splitlog" logdir metadir max-logpart-size)
    488300          (backend-splitlog logdir metadir (string->number max-logpart-size)))
    489301
    490302         (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")
    492304          #f)))
    493305
  • release/4/ugarit/trunk/test/run.scm

    r25478 r25479  
    88(use matchable)
    99(include "../backend-devtools.scm")
    10 (include "../backend-cache.scm")
    1110
    1211;; Test egg extensions
     
    112111                 (devnum (vector-ref stats 10)))
    113112            (test-assert "Character special file exists" (eq? type stat/ifchr))
    114             (tets "Character special file has correct devnum" 456 devnum))))
     113            (test "Character special file has correct devnum" 456 devnum))))
    115114
    116115    ;; Directory
     
    535534                                     (fold-archive-node a dir-key (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
    536535                 ; 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))))))
    545553
    546554   "This archive seems to work!")
     
    558566 (test "Close storage" (void) ((storage-close! be))))
    559567
    560 #;(test-group "Log backend"
    561  (create-directory "./tmp/be2")
    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"))
    563571 (test-backend be)
    564572 (test "Close storage" (void) ((storage-close! be))))
    565573
    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 
    572574(test-group "Limited cached splitlog backend"
    573575 (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))
    577578 (test-backend lbe)
    578579 (test "Close storage" (void) ((storage-close! lbe))))
     
    590591 (test "Close archive" (void) (archive-close! be)))
    591592
    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 
    598593(test-group "Splitlog backend archive"
    599594 (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))
    601596 (test-archive be "./tmp/be7")
    602597 (test "Close archive" (void) (archive-close! be)))
     
    604599(test-group "Splitlog backend archive plus file cache"
    605600 (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))
    607602 (test-archive be "./tmp/be8")
    608603 (test "Close archive" (void) (archive-close! be)))
  • release/4/ugarit/trunk/ugarit-core.scm

    r25478 r25479  
    789789
    790790       (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
    841843                                        ; 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>?))
    844846
    845847       ((sexpr-stream-writer-finish! ssw))))))
     
    866868        (atime (assq 'atime props)))
    867869
    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 
    872870    (if mode
    873871        (change-file-mode path (cdr mode)))
    874872
    875873    (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)))))
    879879
    880880    (if (or mtime atime)
     
    911911
    912912    (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...
    920915    (if mode
    921916        (change-link-mode path (cdr mode)))
    922917
    923918    (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)))))))
    927924
    928925(define (extract-fifo! archive props path)
     
    935932  (let ((number (cdr (assq 'number props))))
    936933
    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))))
    941939
    942940(define (extract-character-device! archive props path)
    943941  (let ((number (cdr (assq 'number props))))
    944942
    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))))
    949948
    950949(define (extract-object! archive dirent target-path)
     
    11171116                             (kons #f dirent acc)))))
    11181117                       knil)))))
     1118
  • release/4/ugarit/trunk/ugarit.meta

    r23255 r25479  
    33 (license "BSD")
    44 (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)
    66 (optional lzma z3 tiger-hash sha2 aes)
    77 (author "Alaric Snell-Pym")
  • release/4/ugarit/trunk/ugarit.scm

    r20322 r25479  
    9898
    9999(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))
    100108   (fold-archive-node archive directory-key
    101       (lambda (node-key dirent acc)
    102          (if (string=? (car dirent) name)
    103             (case (cadr dirent)
    104                ((tag) (begin
    105                   (printf "You can't extract an entire tag - choose an actual snapshot at least\n")
    106                   (success-continuation)))
    107                ((snapshot)
    108                   (begin
    109                      (define name (car path)) ; Head of path is the tag name - the best name we have available
    110                      (if (not (directory? name))
    111                         (create-directory name))
    112 
    113                      (extract-directory! archive
    114                         (cdr (assq 'contents (cddr dirent))) ; root directory of snapshot
    115                         name)
    116                      (printf "Extracted ~A\n" name)
    117                      (success-continuation)))
    118                (else
    119                   (begin
    120                      (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)))
    125133
    126134;; To get started, call with '() as directory-key and path
     
    183191                         (lambda ()
    184192                            (explore-archive archive directory-key path quit-continuation)))))
    185                
     193
    186194                  (printf "No such file or directory ~A\n" name)
    187195
  • release/4/ugarit/trunk/ugarit.setup

    r22448 r25479  
     1(define *version* 1.0)
     2
    13(compile -s -O2 -d1 directory-rules.scm -j directory-rules)
    24(compile -s -O2 -d1 directory-rules.import.scm)
     
    46
    57(install-extension 'directory-rules '("directory-rules.so" "directory-rules.o" "directory-rules.import.so")
    6   '( ;(version 0.7)
     8  `((version ,*version*)
    79    (static "directory-rules.o")))
    810
     
    1214
    1315(install-extension 'ugarit-backend '("ugarit-backend.so" "ugarit-backend.o" "ugarit-backend.import.so")
    14   '( ;(version 0.7)
     16  `((version ,*version*)
    1517    (static "ugarit-backend.o")))
    1618
     
    2022
    2123(install-extension 'ugarit-core '("ugarit-core.so" "ugarit-core.o" "ugarit-core.import.so")
    22   '( ;(version 0.7)
     24  `((version ,*version*)
    2325    (static "ugarit-core.o")))
    2426
    2527(compile backend-fs.scm)
    2628(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*)
    2835    ))
    2936
    3037(compile ugarit.scm)
    3138(install-program 'ugarit "ugarit"
    32   '( ;(version 0.7)
     39  `((version ,*version*)
    3340  ))
Note: See TracChangeset for help on using the changeset viewer.