Changeset 25570 in project

Timestamp:

11/25/11 20:58:42 (9 years ago)

Author:

Alaric Snell-Pym

Message:

ugarit: Version 2 of the backend protocol, supporting better reporting back to the user, and administrative interfaces. Backends outfitted with admin interfaces, and a ugarit-archive-admin tool added to drive them.

Location:

release/4/ugarit/trunk

Files:

• README.txt (modified) (9 diffs)
• VERSION.txt (modified) (1 diff)
• backend-cache.scm (modified) (5 diffs)
• backend-devtools.scm (modified) (3 diffs)
• backend-fs.scm (modified) (11 diffs)
• test/run.scm (modified) (16 diffs)
• ugarit-archive-admin.scm (added)
• ugarit-backend.scm (modified) (5 diffs)
• ugarit-core.scm (modified) (38 diffs)
• ugarit.meta (modified) (1 diff)
• ugarit.scm (modified) (2 diffs)
• ugarit.setup (modified) (2 diffs)

release/4/ugarit/trunk/README.txt

@@ -538 +538 @@
       $ ugarit fork <ugarit.conf> <existing tag> <new tag>
 
+## Archive administration
+
+Each backend offers a number of administrative commands for
+administering archives. These are accessible via the
+`ugarit-archive-admin` command line interface.
+
+To use it, run it with the following command:
+
+      $ ugarit-archive-admin '<archive identifier>'
+
+The available commands differ between backends, but all backends
+support the `info` and `help` commands, which give basic information
+about the archive, and list all available commands, respectively. Some
+offer a `stats` command that examines the archive state to give
+interesting statistics, but which may be a time-consuming operation.
+
+### Administering `splitlog` archives
+
+The splitlog backend offers a wide selection of administrative
+commands. See the `help` command on a splitlog archive for
+details. The following facilities are available:
+
+ * Configuring the block size of the archive (this will affect new
+   blocks written to the archive, and leave existing blocks untouched,
+   even if they are larger than the new block size)
+
+ * Configuring the size at which a log file is finished and a new one
+   started (likewise, existing log files will be untouched; this will
+   only affect new log files)
+
+ * Configuring the frequency of automatic synching of the archive
+   state to disk. Lowering this harms performance when writing to the
+   archive, but decreases the number of in-progress block writes that
+   can fail in a crash.
+
+ * Enable or disable write protection of the archive
+
+ * Reindex the archive, rebuilding the block and tag state from the
+   contents of the log. If the metadata file is damaged or lost,
+   reindexing can rebuild it (although any configuration changes made
+   via other admin commands will need manually repeating as they are
+   not logged).
+
 ## `.ugarit` files
 
@@ -824 +867 @@
 * Migrate the source repo to Fossil (when there's a
   kitten-technologies.co.uk migration to Fossil), and update the egg
-  locations thingy.
+  locations thingy. Migrate all these Future Directions items to
+  actual tickets.
 
 * Profile the system. As of 1.0.1, having done the periodic SQLite
@@ -838 +882 @@
 ## Backends
 
-* Create ugarit-backend-protocol-2, and extend import-backend to
-  support it. The differences are:
-
-  * Extend the backend API to have all API calls return a possibly
-    empty list of log messages before the actual result. When
-    importing a backend, provide a logging callback which is passed
-    these lists and feeds them into a logging mechanism which prints
-    them and stores them in the archive object for later logging into
-    the snapshot. The same logging interface can then be used for
-    warnings from within ugarit-core itself as well.
-
-  * Extend the backend API to have an initial list of log messages and
-    a possible error or success for initialisation, inside the
-    header. Make the command-line wrappers for backends use this to
-    indicate startup failure.
-
 * Carefully document backend API for other backend authors: in
   particular note behaviour in crash situations - we assume that after
@@ -874 +902 @@
   not flushed to the metadata) or scan the log onwards from that point
   to find (complete) blocks that did not get flushed to the metadata.
-
-* Make `lock-tag!` fail if the tag is already locked. Make the archive
-  block and retry a few times in that case.
-
-* Extend the backend protocol with a special "admin" command that
-  allows for arbitrary backend-specific operations, and write an
-  ugarit-backend-admin CLI tool to administer backends with it. The
-  input should be a single s-expression as a list, and the result
-  should be an alist which is displayed to the user in a friendly
-  manner, as "Key: Value\n" lines.
-
-* Implement "info" admin commands for all backends, that list any
-  available stats, and at least the backend type and parameters.
-
-* Support for recreating the index and tags on a backend-splitlog if
-  they get corrupted, from the headers left in the log, as a "reindex"
-  admin command.
-
-* Support for flushing the cache on a backend-cache, via an admin
-  command, rather than having to delete the cache file.
 
 * Support for unlinking in backend-splitlog, by marking byte ranges as
@@ -909 +917 @@
   existing archive with no refcounts, default them to NULL, and treat
   a NULL refcount as "infinity".
-
-* Have read-only and unlinkable and block size config flags in the
-  backend-split metadata file, settable via admin commands.
 
 * For people doing remote backups who want to not hog resources, write
@@ -975 +980 @@
 ## Core
 
-* Add the option to support full HMAC for salted hashing; make this
-  the recommended setting, with syntax `(hash tiger hmac "SALT")`, and
-  require `(hash tiger simple "SALT")` to explicitly request legacy
-  mode. Note this in the upgrade notes for existing users.
-
-* Add the option to append HMACed signatures to the post-encryption
+* Add the option to append hash signatures to the post-encryption
   blocks in the archive, to protect against people who tamper with
   blocks in order to try and exploit vulnerabilities in the
@@ -988 +988 @@
   that decrypt to giant amounts of RAM).
 
-* When extracting, wrap each restore operation under
-  extract-directory! with exception handling that logs the error and
-  then continues with the next dirent in the directory.
-
-* Check sensibly-worded conditions are raised when we try and fetch
-  nonexistant or corrupted blocks from the archive in `archive-get`.
-
-* Make `fold-archive-node`'s listing of tags at the top level report
-  the lock status of the tags.
-
 * More stats. Log bytes written AFTER compression and encryption in
   `archive-put!`. Log snapshot start and end times in the snapshot
   object.
-
-* SIGINFO support. Add a SIGINFO handler that sets a flag, and make
-  the `store-file!` and `store-directory!` main loops look for the
-  flag and, if set, display what path we're working on, and perhaps a
-  quick summary of the bytes/blocks stored/skipped stats.
 
 * Clarify what characters are legal in tag names sent to backends, and
@@ -1144 +1129 @@
   node tree
 
-* Better error messages
-
 * API mode: Works something like the backend API, except at the
   archive level. Supports all the important archive operations, plus
@@ -1276 +1259 @@
   metadata. Switched to the `posix-extras` egg and ditched our own
   `posixextras.scm` wrappers. Used the `parley` egg in the `ugarit
-  explore` CLI for line editing. BUGFIX: Made file cache check the
-  file hashes it finds in the cache actually exist in the archive, to
-  protect against the case where a crash of some kind has caused
-  unflushed changes to be lost; the file cache may well have committed
-  changes that the backend hasn't, leading to references to
-  nonexistant blocks. Note that we assume that archives are
-  sequentially safe, eg if the final indirect block of a large file
-  made it, all the partial blocks must have made it too. BUGFIX: Added
-  an explicit `flush!` command to the backend protocol, and put
-  explicit flushes at critical points in higher layers
-  (`backend-cache`, the archive abstraction in the Ugarit core, and
-  when tagging a snapshot) so that we ensure the blocks we point at
-  are flushed before committing references to them in the
-  `backend-cache` or file caches, or into tags, to ensure crash
-  safety. BUGFIX: Made the splitlog backend never exceed the file size
-  limit (except when passed blocks that, plus a header, are larger
-  than it), rather than letting a partial block hang over the
-  'end'. BUGFIX: Fixed tag locking, which was broken all over the
-  place. Concurrent snapshots to the same tag should now block for one
-  another, although why you'd want to *do* that is
-  questionable. BUGFIX: Fixed generation of non-keyed hashes, which
-  was incorrectly appending the type to the hash without an outer
-  hash. This breaks backwards compatability, but nobody was using the
-  old algorithm, right? I'll introduce it as an option if required.
+  explore` CLI for line editing. Added logging infrastructure,
+  recording of snapshot logs in the snapshot. Added recovery from
+  extraction errors. Listed lock state of tags in explore
+  mode. Backend protocol v2 introduced (retaining v1 for
+  compatability) allowing for an error on backend startup, and logging
+  nonfatal errors, warnings, and info on startup and all protocol
+  calls. Added `ugarit-archive-admin` command line interface to
+  backend-specific administrative interfaces. Configuration of the
+  splitlog backend (write protection, adjusting block size and logfile
+  size limit and commit interval) is now possible via the admin
+  interface. The admin interface also permits rebuilding the metadata
+  index of a splitlog archive with the `reindex!` admin command.
+
+  * BUGFIX: Made file cache check the file hashes it finds in the
+    cache actually exist in the archive, to protect against the case
+    where a crash of some kind has caused unflushed changes to be
+    lost; the file cache may well have committed changes that the
+    backend hasn't, leading to references to nonexistant blocks. Note
+    that we assume that archives are sequentially safe, eg if the
+    final indirect block of a large file made it, all the partial
+    blocks must have made it too.
+
+  * BUGFIX: Added an explicit `flush!` command to the backend
+    protocol, and put explicit flushes at critical points in higher
+    layers (`backend-cache`, the archive abstraction in the Ugarit
+    core, and when tagging a snapshot) so that we ensure the blocks we
+    point at are flushed before committing references to them in the
+    `backend-cache` or file caches, or into tags, to ensure crash
+    safety.
+
+  * BUGFIX: Made the splitlog backend never exceed the file size limit
+    (except when passed blocks that, plus a header, are larger than
+    it), rather than letting a partial block hang over the 'end'.
+
+  * BUGFIX: Fixed tag locking, which was broken all over the
+    place. Concurrent snapshots to the same tag should now block for
+    one another, although why you'd want to *do* that is questionable.
+
+  * BUGFIX: Fixed generation of non-keyed hashes, which was
+    incorrectly appending the type to the hash without an outer
+    hash. This breaks backwards compatability, but nobody was using
+    the old algorithm, right? I'll introduce it as an option if
+    required.
 
 * 1.0.1: Consistency check on read blocks by default. Removed warning

release/4/ugarit/trunk/VERSION.txt

@@ -1 @@
-1.0.1
+1.0.2

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

@@ -21 +21 @@
    (define cache-delete-query (sql *db* "DELETE FROM cache WHERE key = ?"))
 
+   (define *hits* 0)
+   (define *misses* 0)
+   (define *flushes* 0)
+
    (define commit-interval 1000)
    (define *updates-since-last-commit* 0)
    (define (flush!)
      (when (> *updates-since-last-commit* 0)
+      (inc! *flushes*)
       (exec (sql *db* "COMMIT;"))
       (exec (sql *db* "BEGIN;"))
@@ -52 +57 @@
      (maybe-flush!))
 
+   (define (cache-clear!)
+     (exec (sql *db* "DELETE FROM cache")))
+
    (make-storage
       (storage-max-block-size be)
@@ -67 +75 @@
           (void)))
       (lambda (key) ; exists?
-         (or
-            (cache-get key)
-            (cache-set! key ((storage-exists? be) key))))
+        (let ((cached-result (cache-get key)))
+          (if cached-result
+              (begin
+                (inc! *hits*)
+                cached-result)
+              (begin
+                (inc! *misses*)
+                (cache-set! key ((storage-exists? be) key))))))
       (lambda (key) ; get
          ((storage-get be) key))
@@ -104 +117 @@
           ((storage-flush! be))
           (flush!))
+      (lambda (command) ; admin!
+        (match command
+               (('info)
+                (list (cons 'backend "cache")
+                      (cons 'block-size (storage-max-block-size be))
+                      (cons 'writable? (storage-writable? be))
+                      (cons 'unlinkable? (storage-unlinkable? be))
+                      (cons 'cache-file cachepath)
+                      (cons 'commit-interval commit-interval)))
+               (('help)
+                (list (cons 'info "Return information about the archive")
+                      (cons 'help "List available admin commands")
+                      (cons 'stats "Examine the cache and report back statistics")
+                      (cons 'clear! "Clear the cache")))
+               (('stats)
+                (list (cons 'entries (car (query fetch (sql *db* "SELECT COUNT(*) FROM cache"))))))
+               (('clear!)
+                (cache-clear!)
+                (flush!)
+                (list (cons 'result "Done")))
+               (else (error "Unknown admin command"))))
       (lambda () ; close!
         (begin
+          ((backend-log!) 'info (sprintf "Cache hits: ~A misses: ~A flushes: ~A" *hits* *misses* *flushes*))
           ((storage-close! be))
           (exec (sql *db* "COMMIT;"))
@@ -114 +149 @@
   (match (command-line-arguments)
          ((cachepath backend)
-          (backend-cache cachepath (import-storage backend)))
+          (lambda () (backend-cache cachepath (import-storage backend))))
 
          (else
+          (export-storage-error! "Invalid arguments to backend-cache")
           (printf "USAGE:\nbackend-cache <path-to-cache-file> \"<backend command line>\"\n")
           #f)))

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

@@ -30 +30 @@
       (lambda (tag) ; unlock-tag!
          ((storage-unlock-tag! be) tag))
+      (lambda (command) ; admin!
+         ((storage-admin! be) command))
       (lambda () ; close!
          ((storage-close! be)))))
@@ -64 +66 @@
       (lambda (tag) ; unlock-tag!
          ((storage-unlock-tag! be) tag))
+      (lambda (command) ; admin!
+         ((storage-admin! be) command))
       (lambda () ; close!
          ((storage-close! be)))))
@@ -133 +137 @@
             (printf "~A: (lock-tag! ~A)\n" name tag)
             ((storage-unlock-tag! be) tag)))
+      (lambda (command) ; admin!
+         (let ((result ((storage-admin! be) command)))
+            (begin
+               (printf "~A: (admin! ~A) = ~A\n" name command result)
+               result)))
       (lambda () ; close!
          (begin

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

@@ -53 +53 @@
 
    (if (not (directory? base))
-      (signal (make-property-condition 'exn 'message "The archive does not exist" 'arguments base)))
+       (error "The archive directory does not exist" base))
+
+   (define block-size (* 1024 1024))
 
    (make-storage
-      (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap
+    block-size
       #t ; We are writable
       #t ; We support unlink!
@@ -162 +164 @@
         (delete-file (make-tag-lock-name tag))
         (void))
+      (lambda (command) ; admin!
+        (match command
+               (('info)
+                (list (cons 'backend "fs")
+                      (cons 'path base)
+                      (cons 'block-size block-size)
+                      (cons 'writable? #t)
+                      (cons 'unlinkable? #t)))
+               (('help)
+                (list (cons 'info "Return information about the archive")
+                      (cons 'help "List available admin commands")))
+               (else (error "Unknown admin command"))))
       (lambda () ; close!
          (void))))
@@ -172 +186 @@
    "CREATE TABLE tags (tag TEXT PRIMARY KEY, key TEXT, locked INTEGER DEFAULT 0);"))
 
-(define (backend-splitlog logdir metapath max-logpart-size)
+(define file-sync (foreign-lambda int "fsync" int))
+
+(define (backend-splitlog logdir metapath)
    (let*
         ((*db*
@@ -204 +220 @@
                                  default)
                                (car result)))))
-         (set-metadata (lambda (key value)
+         (set-metadata! (lambda (key value)
                          (exec set-metadata-query key value)))
+
+         (max-logpart-size (string->number (get-metadata "max-logpart-size" "600000000")))
 
          ; Log file management
@@ -222 +240 @@
                      fd)))))
 
+         ; Basic configurables
+         (block-size (string->number (get-metadata "block-size" "1048576")))
+         (writable? (not (string=? "0" (get-metadata "writable" "1"))))
+         (check-writable (lambda ()
+                           (unless writable?
+                                   (error "This archive is write protected"))))
+
          ; Periodic commit management
          (commit-interval (string->number (get-metadata "commit-interval" "1000")))
@@ -227 +252 @@
          (flush! (lambda ()
                    (when (> *updates-since-last-commit* 0)
-                    (set-metadata "current-logfile" (number->string *logcount*))
+                    (file-sync *log*)
+                    (set-metadata! "current-logfile" (number->string *logcount*))
                     (exec (sql *db* "COMMIT;"))
                     (exec (sql *db* "BEGIN;"))
@@ -280 +306 @@
 
          (get-tags (lambda ()
-                     (map car (query fetch-all get-tags-query)))))
+                     (map car (query fetch-all get-tags-query))))
+
+         (reindex! (lambda ()
+                     (flush!)
+                     (exec (sql *db* "DELETE FROM tags;"))
+                     (exec (sql *db* "DELETE FROM blocks;"))
+
+                     (let loop-over-logs ((log-number 0))
+                       (let* ((log-file-name (string-append logdir "/log" (number->string log-number))))
+                         (if (file-exists? log-file-name)
+                          (begin
+                            ((backend-log!) 'info (sprintf "Reading ~a" log-file-name))
+                            (with-input-from-file log-file-name
+                              (lambda ()
+                                (let loop-over-entries ()
+                                  (let* ((entry (read))
+                                         (posn (file-position (current-input-port))))
+                                    (if (eof-object? entry)
+                                        (loop-over-logs (+ log-number 1))
+                                        (begin
+                                          (match entry
+                                                 (('block key type length)
+                                                  (set-block-data! key type log-number posn length)
+                                                  (set-file-position! (current-input-port) length seek/cur))
+                                                 (('tag tag key)
+                                                  (set-tag! tag key))
+                                                 (else
+                                                  ((backend-log!) 'error "Unknown log entry ~S" entry)))
+                                          (loop-over-entries)))))))))
+                         (void)))
+                     (flush!)
+                     (void))))
 
       (make-storage
-         (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap, right?
-         #t ; We are writable
+         block-size
+         writable?
          #f ; We DO NOT support unlink!
 
          (lambda (key data type) ; put!
+           (check-writable)
            (when (pair? (get-block-data key))
-                 (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type))))
+                 (error "Duplicate block" key type))
 
            (set-file-position! *log* 0 seek/end)
@@ -332 +390 @@
 
          (lambda (key) ; link!
-            (void))
+           (check-writable)
+           (void))
 
          (lambda (key) ; unlink!
-            (signal (make-property-condition 'exn 'message "Log archives do not support deletion")))
+           (check-writable)
+           (error "splitlog archives do not support unlinkined"))
 
          (lambda (tag key) ; set-tag!
-            (file-write *log* (sprintf "(tag ~S ~S)" tag key))
-            (set-tag! tag key)
-            (void))
+           (check-writable)
+           (file-write *log* (sprintf "(tag ~S ~S)" tag key))
+           (set-tag! tag key)
+           (void))
          (lambda (tag) ; tag
            (get-tag tag))
@@ -346 +407 @@
            (get-tags))
          (lambda (tag) ; remove-tag!
+           (check-writable)
            (remove-tag! tag)
            (void))
          (lambda (tag) ; lock-tag!
+           (check-writable)
            (flush!)
            (let ((existing-lock? (not (zero? (get-tag-lock tag)))))
@@ -363 +426 @@
                #t))
          (lambda (tag) ; unlock-tag!
+           (check-writable)
            (set-tag-lock! tag 0)
            (flush!))
+         (lambda (command) ; admin!
+           (match command
+                  (('info)
+                   (list (cons 'backend "splitlog")
+                         (cons 'block-size block-size)
+                         (cons 'writable? writable?)
+                         (cons 'unlinkable? #f)
+                         (cons 'path logdir)
+                         (cons 'metadata-file metapath)
+                         (cons 'max-logfile-size max-logpart-size)
+                         (cons 'currently-writing-to *logcount*)
+                         (cons 'commit-interval commit-interval)))
+                  (('help)
+                   (list (cons 'info "Return information about the archive")
+                         (cons 'help "List available admin commands")
+                         (cons 'stats "Examine the metadata and report back statistics")
+                         (cons 'set-block-size! (sprintf "<size in bytes> Sets a new maximum block size (current: ~a)" block-size))
+                         (cons 'set-max-logfile-size! (sprintf "<size in bytes> Sets a new maximum logfile size (current: ~a)" max-logpart-size))
+                         (cons 'set-commit-interval! (sprintf "<updates> Sets a new commit interval (current: ~a)" commit-interval))
+                         (cons 'write-protect! (sprintf "Disable writing to the archive (currently ~a)" (if writable? "enabled" "disabled")))
+                         (cons 'write-unprotect! (sprintf "Enable writing to the archive (currently ~a)" (if writable? "enabled" "disabled")))
+                         (cons 'reindex! "Rebuild the index in the metadata from scratch by scanning the log (takes a while)")))
+                  (('stats)
+                   (let* ((stats (query fetch (sql *db* "SELECT COUNT(*), SUM(length) FROM blocks"))))
+                    (list (cons 'blocks (first stats))
+                          (cons 'bytes (second stats)))))
+                  (('set-block-size! size)
+                   (assert (integer? size))
+                   (set! block-size size)
+                   (set-metadata! "block-size" (number->string size))
+                   (list (cons 'result "Done")))
+                  (('set-max-logfile-size! size)
+                   (assert (integer? size))
+                   (set! max-logpart-size size)
+                   (set-metadata! "max-logpart-size" (number->string size))
+                   (list (cons 'result "Done")))
+                  (('set-commit-interval! cis)
+                   (assert (integer? cis))
+                   (set! commit-interval cis)
+                   (set-metadata! "commit-interval" (number->string  cis))
+                   (list (cons 'result "Done")))
+                  (('write-protect!)
+                   (set! writable? #f)
+                   (set-metadata! "writable" "0")
+                   (list (cons 'result "Done")))
+                  (('write-unprotect!)
+                   (set! writable? #f)
+                   (set-metadata! "writable" "1")
+                   (list (cons 'result "Done")))
+                  (('reindex!)
+                   (reindex!)
+                   (list (cons 'result "Done")))
+                  (else (error "Unknown admin command"))))
          (lambda () ; close!
            (flush!)
@@ -377 +494 @@
   (match (command-line-arguments)
          (("fs" base)
-          (backend-fs base))
-
-         (("splitlog" logdir metadir max-logpart-size)
-          (backend-splitlog logdir metadir (string->number max-logpart-size)))
+          (lambda ()  (backend-fs base)))
+
+         (("splitlog" logdir metadir)
+          (lambda ()  (backend-splitlog logdir metadir)))
 
          (else
-          (printf "USAGE:\nbackend-fs fs <basedir-path>\nbackend-fs splitlog <logdir-path> <metadata-file-path> <max-file-size>\n")
+          (export-storage-error! "Invalid arguments to backend-fs")
+          (printf "USAGE:\nbackend-fs fs <basedir-path>\nbackend-fs splitlog <logdir-path> <metadata-file-path>\n")
           #f)))
 

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

@@ -39 +39 @@
 
 (define (test-backend w)
-   (test-assert "Storage writable" (storage-writable? w))
-   (test-assert "Storage is empty" (not ((storage-exists? w) "TEST")))
-   (test "Load a block" (void) ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5)) 'test))
-   (test-assert "Block successfully loaded" ((storage-exists? w) "TEST"))
-   (test "Block contents reads back" (list 1 2 3 4 5) (u8vector->list ((storage-get w) "TEST")))
-   (if (storage-unlinkable? w)
-      (begin
-         (test "Unlink returns data" (list 1 2 3 4 5) (u8vector->list ((storage-unlink! w) "TEST")))
-         (test-assert "Unlinked block is gone" (not ((storage-exists? w) "TEST")))))
-   (test "Set a tag" (void) ((storage-set-tag! w) "TEST" "TEST123"))
-   (test "Tag is not locked" #f ((storage-tag-locked? w) "TEST"))
-   (test "Lock a tag" #t ((storage-lock-tag! w) "TEST"))
-   (test "Tag is now locked" #t ((storage-tag-locked? w) "TEST"))
-   (test "Lock a tag again" #f ((storage-lock-tag! w) "TEST"))
-   (test "Tag is still locked" #t ((storage-tag-locked? w) "TEST"))
-   (test "Unlock a tag" (void) ((storage-unlock-tag! w) "TEST"))
-   (test "Tag is no longer locked" #f ((storage-tag-locked? w) "TEST"))
-   (test "Tag reads back" "TEST123" ((storage-tag w) "TEST"))
-   (test "Tag list works" (list "TEST") ((storage-all-tags w)))
-   (test "Remove tag" (void)  ((storage-remove-tag! w) "TEST")))
+(parameterize ((backend-log! (lambda (type message) (void))))
+ (test-assert "Storage writable" (storage-writable? w))
+ (test-assert "Storage is empty" (not ((storage-exists? w) "TEST")))
+ (test "Load a block" (void) ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5)) 'test))
+ (test-assert "Block successfully loaded" ((storage-exists? w) "TEST"))
+ (test "Block contents reads back" (list 1 2 3 4 5) (u8vector->list ((storage-get w) "TEST")))
+ (test "Nonexistant block reacts correctly" #f ((storage-get w) "NONEXISTANT"))
+ (test-error "Cannot update existing blocks" ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5 6)) 'test))
+ (if (storage-unlinkable? w)
+     (begin
+       (test "Unlink returns data" (list 1 2 3 4 5) (u8vector->list ((storage-unlink! w) "TEST")))
+       (test-assert "Unlinked block is gone" (not ((storage-exists? w) "TEST")))))
+
+ (test "Set a tag" (void) ((storage-set-tag! w) "TEST" "TEST123"))
+ (test "Tag is not locked" #f ((storage-tag-locked? w) "TEST"))
+ (test "Lock a tag" #t ((storage-lock-tag! w) "TEST"))
+ (test "Tag is now locked" #t ((storage-tag-locked? w) "TEST"))
+ (test "Lock a tag again" #f ((storage-lock-tag! w) "TEST"))
+ (test "Tag is still locked" #t ((storage-tag-locked? w) "TEST"))
+ (test "Unlock a tag" (void) ((storage-unlock-tag! w) "TEST"))
+ (test "Tag is no longer locked" #f ((storage-tag-locked? w) "TEST"))
+ (test "Tag reads back" "TEST123" ((storage-tag w) "TEST"))
+ (test "Tag list works" (list "TEST") ((storage-all-tags w)))
+ (test "Remove tag" (void) ((storage-remove-tag! w) "TEST"))
+
+ (test "Nonexistant tag is not locked" #f ((storage-tag-locked? w) "NONEXISTANT"))
+ (test "Lock a nonexistant tag" #t ((storage-lock-tag! w) "NONEXISTANT"))
+ (test "Nonexistant tag is now locked" #t ((storage-tag-locked? w) "NONEXISTANT"))
+ (test "Lock a nonexistant tag again" #f ((storage-lock-tag! w) "NONEXISTANT"))
+ (test "Nonexistant tag is still locked" #t ((storage-tag-locked? w) "NONEXISTANT"))
+ (test "Unlock a locked nonexistant tag" (void) ((storage-unlock-tag! w) "NONEXISTANT"))
+ (test "Nonexistant tag is no longer locked" #f ((storage-tag-locked? w) "NONEXISTANT"))
+
+ (test "Close storage" (void) ((storage-close! be)))))
 
 (define (key-stream-cat a ks-hash ks-type level)
@@ -67 +81 @@
             (for-each (lambda (subkey)
                (key-stream-cat a subkey ks-type (+ level 1)))
-               (deserialise-key-stream (archive-get a ks-hash))))
+               (deserialise-key-stream (archive-get a ks-hash type))))
       (printf "kleaf(~A): ~A (~A)\n" level ks-hash type)))
 
@@ -79 +93 @@
                (for-each (lambda (subkey)
                   (sexpr-stream-cat a subkey leaf-type ss-type (+ level 1)))
-                  (deserialise-key-stream (archive-get a ss-hash)))))
+                  (deserialise-key-stream (archive-get a ss-hash type)))))
       ((eq? type leaf-type)
          (begin ; leaf node
@@ -85 +99 @@
                (for-each (lambda (sexpr)
                   (printf " ~A\n" sexpr))
-                  (deserialise-sexpr-stream (archive-get a ss-hash)))))))
+                  (deserialise-sexpr-stream (archive-get a ss-hash type)))))))
 
 (define (check-dir-is-empty store-path)
@@ -135 +149 @@
                (test "Data goes into archive" (void) (archive-put! a test-key test-data 'test))
                (test-assert "Data now exists in archive" (archive-exists? a test-key))
-               (test "Data reads back" test-list (u8vector->list (archive-get a test-key)))
+               (test "Data reads back" test-list (u8vector->list (archive-get a test-key 'test)))
 
                (if (archive-unlinkable? a)
@@ -485 +499 @@
 
                  (test-assert "Directory has the same key" (string=? dir-key dir2-key))
+                 (test "Log a message" (void) (archive-log! a 'info #f "This is a test"))
 
                  (test-define-values "Tag it as a snapshot" (sk2)
@@ -500 +515 @@
                                         ('mtime . _)
                                         ('contents . dir2-key*)
-                                        ('stats . _))
+                                        ('stats . _)
+                                        ('log . (('info _ #f "This is a test"))))
                                        (('mtime . _)
                                         ('contents . dir-key*)
-                                        ('stats . _)))
+                                        ('stats . _)
+                                        ('log)))
                                       (and (string=? sk1 sk1*)
                                            (string=? dir2-key dir2-key*)
@@ -511 +528 @@
                  (test-define-values "Walk the tag list with fold-archive-node" (root)
                                      (fold-archive-node a '() (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
-                 (test-assert "Root history has expected form"
+                 (test-assert "Root listing has expected form"
                               (match root
                                      (((('tag . "Test")
                                         "Test"
                                         'tag
-                                        ('current . sk2*)))
+                                        ('current . sk2*)
+                                        ('locked . #f)))
                                       (string=? sk2 sk2*))
                                      (else #f)))
@@ -529 +547 @@
                                         ('mtime . _)
                                         ('contents . dir-key*)
-                                        ('stats . _))
+                                        ('stats . _)
+                                        ('log . (('info _ #f "This is a test"))))
                                        (dir-key-c**
                                         _
@@ -536 +555 @@
                                         ('mtime . _)
                                         ('contents . dir-key**)
-                                        ('stats . _))
+                                        ('stats . _)
+                                        ('log . (('info _ #f "This is a test"))))
                                        (dir-key-c***
                                         _
@@ -542 +562 @@
                                         ('mtime . _)
                                         ('contents . dir-key***)
-                                        ('stats . _)))
+                                        ('stats . _)
+                                        ('log)))
                                       (and
                                        (string=? sk1 sk1*)
@@ -555 +576 @@
                  (test-define-values "Walk the root directory with fold-archive-node" (dir)
                                      (fold-archive-node a dir-key (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
-                 ; FIXME: Write a giant match to match this bad boy...
                  (if (zero? (current-user-id))
-                     (test-assert "Directory history has the expected form (as root)"
+                     (test-assert "Directory listing has the expected form (as root)"
                                   (match dir
                                          (((#f "block-special" 'block-device (number . 123) . _)
@@ -566 +586 @@
                                            (#f "plain-file2" 'file . _)) #t)
                                          (else #f)))
-                     (test-assert "Directory history has the expected form (not as root)"
+                     (test-assert "Directory listing has the expected form (not as root)"
                                   (match dir
                                          (((_ "directory" 'dir . _)
@@ -585 +605 @@
  (create-directory "./tmp/be1")
  (test-define "Open storage" be (import-storage "backend-fs fs ./tmp/be1"))
- (test-backend be)
- (test "Close storage" (void) ((storage-close! be))))
+ (test-backend be))
 
 (test-group "Splitlog backend"
  (create-directory "./tmp/be3")
- (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be3 ./tmp/be3/metadata 1024"))
- (test-backend be)
- (test "Close storage" (void) ((storage-close! be))))
+ (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be3 ./tmp/be3/metadata"))
+ (test "Set max file size to 1024" '((result . "Done")) ((storage-admin! be) '(set-max-logfile-size! 1024)))
+ (test-backend be))
 
 (test-group "Limited cached splitlog backend"
  (create-directory "./tmp/be4")
- (test-define "Open storage" be (import-storage "backend-cache ./tmp/be4-cache \"backend-fs splitlog ./tmp/be4 ./tmp/be4/metadata 1024\""))
+ (test-define "Open storage" be (import-storage "backend-cache ./tmp/be4-cache \"backend-fs splitlog ./tmp/be4 ./tmp/be4/metadata\""))
  (test-define "Wrap in block-limiter" lbe (backend-limit-block-size be 1024))
- (test-backend lbe)
- (test "Close storage" (void) ((storage-close! lbe))))
+ (test-backend lbe))
 
 (test-group "Filesystem backend archive"
@@ -615 +633 @@
 (test-group "Splitlog backend archive"
  (create-directory "./tmp/be7")
- (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be7 ./tmp/be7/metadata 1024")) #f #t))
+ (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be7 ./tmp/be7/metadata")) #f #t))
+ (test "Set max file size to 1024" '((result . "Done")) (archive-admin! be '(set-max-logfile-size! 1024)))
  (test-archive be "./tmp/be7")
  (test "Close archive" (void) (archive-close! be)))
@@ -621 +640 @@
 (test-group "Splitlog backend archive plus file cache"
  (create-directory "./tmp/be8")
- (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be8 ./tmp/be8/metadata 1024") (file-cache "./tmp/be8-file-cache")) #f #t))
+ (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be8 ./tmp/be8/metadata") (file-cache "./tmp/be8-file-cache")) #f #t))
+ (test "Set max file size to 1024" '((result . "Done")) (archive-admin! be '(set-max-logfile-size! 1024)))
  (test-archive be "./tmp/be8")
  (test "Close archive" (void) (archive-close! be)))

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

@@ -18 +18 @@
          storage-tag-locked?
          storage-unlock-tag!
+         storage-admin!
          storage-close!
 
+         backend-log!
+
          export-storage! ; Export a storage via stdin/stdout
+         export-storage-error!
          import-storage ; Create a storage from a command line
          )
@@ -31 +35 @@
 (use posix)
 (use srfi-4)
-
+(use data-structures)
+(use miscmacros)
+
+; Backends can call the procedure found in this paramter to log
+; things. type should be 'warning, 'error or 'info. message should
+; be any string.
+(define backend-log! (make-parameter
+                      (lambda (type message)
+                        (error "No backend log handler has been defined"))))
 
 (define-record storage
@@ -50 +62 @@
   tag-locked? ; Procedure: (tag-locked? name) - returns #t if the tag is locked, #f otherwise
   unlock-tag! ; Procedure: (unlock-tag! name) - unlocks the named tag
+  admin! ; Procedure: (admin! command) - returns an alist
   close!)  ; Procedure: (close!) - closes the storage engine
 
-(define *magic* 'ugarit-backend-protocol-1)
+(define *magic-v1* 'ugarit-backend-protocol-1)
+(define *magic-v2* 'ugarit-backend-protocol-2)
 
 (define (describe-exception exn)
-  (list (##sys#slot exn 1) (##sys#slot exn 2)))
-
-(define-syntax with-error-reporting
-  (er-macro-transformer
-   (lambda (e r c)
-     (let ((body (cdr e)))
-       `(,(r 'call-with-current-continuation)
-         (,(r 'lambda) (,(r 'escape))
-          (,(r 'with-exception-handler)
-           (,(r 'lambda) (,(r 'k))
-            (,(r 'write) (,(r 'list) "error" (,(r 'describe-exception) ,(r 'k))))
-            (,(r 'escape) #f))
-           (,(r 'lambda) ()
-            ,@body))))))))
+  (sprintf "~a: ~s in ~a"
+           ((condition-property-accessor 'exn 'message "Unknown error") exn)
+           ((condition-property-accessor 'exn 'arguments '()) exn)
+           ((condition-property-accessor 'exn 'location (void)) exn)))
+
+; Return the result of the body, and any logs
+(define-syntax-rule (with-error-reporting-and-result body ...)
+  (handle-exceptions
+   exn (write (list "error" (describe-exception exn)))
+   (let ((log (make-queue)))
+     (parameterize ((backend-log!
+                     (lambda (type message)
+                       (queue-add! log (cons type message))
+                       (void))))
+                   (let ((result (begin body ...)))
+                     (write (list (queue->list log) result)))))))
+
+; Return the result of the body as a data block, and any logs
+(define-syntax-rule (with-error-reporting-and-block body ...)
+  (handle-exceptions
+   exn (write (list "error" (describe-exception exn)))
+   (let ((log (make-queue)))
+     (parameterize ((backend-log!
+                     (lambda (type message)
+                       (queue-add! log (cons type message))
+                       (void))))
+                   (let ((result (begin body ...)))
+                     (if result
+                         (begin
+                           (write (list (queue->list log) (u8vector-length result)))
+                           (write-u8vector result))
+                         (write (list (queue->list log) #f))))))))
+
+; Return any logs
+(define-syntax-rule (with-error-reporting body ...)
+  (handle-exceptions
+   exn (write (list "error" (describe-exception exn)))
+   (let ((log (make-queue)))
+     (parameterize ((backend-log!
+                     (lambda (type message)
+                       (queue-add! log (cons type message))
+                       (void))))
+                   (let ((result (begin body ...)))
+                     (write (list (queue->list log))))))))
+
+(define (export-storage-error! message)
+  (set-buffering-mode! (current-output-port) #:none)
+
+  ; Write the error header
+  (write *magic-v2*) (newline)
+  (write (list "error" message)))
 
 ;; Given a storage object, provide the storage remote access protocol
 ;; via current-input-port / current-output-port until the storage is closed
 ;; via the protocol.
-(define (export-storage! storage)
+(define (export-storage! storage-thunk)
   (set-buffering-mode! (current-output-port) #:none)
 
   ; Write the header
-  (write *magic*) (newline)
-  (write (list (storage-max-block-size storage)
-               (storage-writable? storage)
-               (storage-unlinkable? storage)))
-
-  ; Engage command loop
-  (let loop ()
-    (newline)
-    (let ((command (read)))
-      (if (eof-object? command)
-          (begin
-            (with-error-reporting
-             ((storage-close! storage))
-             (write "goodbye"))
-            (void))
-          (match
-           command
-
-           (('put! key type length)
-            (let ((data (read-u8vector length)))
-              (with-error-reporting
-               ((storage-put! storage) key data type)
-               (write #t)))
-            (loop))
-
-           (('flush!)
-            (with-error-reporting
-             ((storage-flush! storage))
-             (write #t))
-            (loop))
-
-           (('exists? key)
-            (with-error-reporting
-             (write ((storage-exists? storage) key)))
-            (loop))
-
-           (('get key)
-            (with-error-reporting
-             (let ((data ((storage-get storage) key)))
-               (if data
-                   (begin
-                    (write (list (u8vector-length data)))
-                    (write-u8vector data))
-                   (write #f))))
-            (loop))
-
-           (('link! key)
-            (with-error-reporting
-             ((storage-link! storage) key)
-             (write #t))
-            (loop))
-
-           (('unlink! key)
-            (with-error-reporting
-             (let ((data ((storage-unlink! storage) key)))
-               (if data
-                   (begin
-                     (write (list (u8vector-length data)))
-                     (write-u8vector data))
-                   (write #f))))
-            (loop))
-
-           (('set-tag! name key)
-            (with-error-reporting
-             ((storage-set-tag! storage) name key)
-             (write #t))
-            (loop))
-
-           (('tag name)
-            (with-error-reporting
-             (write ((storage-tag storage) name)))
-            (loop))
-
-           (('all-tags)
-            (with-error-reporting
-             (write ((storage-all-tags storage))))
-            (loop))
-
-           (('remove-tag! name)
-            (with-error-reporting
-             ((storage-remove-tag! storage) name)
-             (write #t))
-            (loop))
-
-           (('lock-tag! name)
-            (with-error-reporting
-             (let  ((result ((storage-lock-tag! storage) name)))
-               (write result)))
-            (loop))
-
-           (('tag-locked? name)
-            (with-error-reporting
-             (write ((storage-tag-locked? storage) name)))
-            (loop))
-
-           (('unlock-tag! name)
-            (with-error-reporting
-             ((storage-unlock-tag! storage) name)
-             (write #t))
-            (loop))
-
-           (('close!)
-            (with-error-reporting
-             ((storage-close! storage))
-             (write "goodbye"))
-            (void))
-
-           (else
-            (write (list "error" (sprintf "Bad command ~s" command)))
-            (loop)))))))
-
-(define (read-response port)
+  (write *magic-v2*) (newline)
+  (let ((storage #f))
+
+    (with-error-reporting-and-result ; Initialise and send the header
+     (let ((storage* (storage-thunk)))
+       (set! storage storage*)        ; This feels hacky
+       (list (storage-max-block-size storage)
+             (storage-writable? storage)
+             (storage-unlinkable? storage))))
+
+                                        ; Engage command loop
+    (if storage
+        (let loop ()
+          (newline)
+          (let ((command (read)))
+            (if (eof-object? command)
+                (begin
+                  (with-error-reporting
+                   ((storage-close! storage)))
+                  (void))
+                (match
+                 command
+
+                 (('put! key type length)
+                  (let ((data (read-u8vector length)))
+                    (with-error-reporting
+                     ((storage-put! storage) key data type)))
+                  (loop))
+
+                 (('flush!)
+                  (with-error-reporting
+                   ((storage-flush! storage)))
+                  (loop))
+
+                 (('exists? key)
+                  (with-error-reporting-and-result
+                   ((storage-exists? storage) key))
+                  (loop))
+
+                 (('get key)
+                  (with-error-reporting-and-block
+                   ((storage-get storage) key))
+                  (loop))
+
+                 (('link! key)
+                  (with-error-reporting
+                   ((storage-link! storage) key))
+                  (loop))
+
+                 (('unlink! key)
+                  (with-error-reporting-and-block
+                   ((storage-unlink! storage) key))
+                  (loop))
+
+                 (('set-tag! name key)
+                  (with-error-reporting
+                   ((storage-set-tag! storage) name key))
+                  (loop))
+
+                 (('tag name)
+                  (with-error-reporting-and-result
+                   ((storage-tag storage) name))
+                  (loop))
+
+                 (('all-tags)
+                  (with-error-reporting-and-result
+                   ((storage-all-tags storage)))
+                  (loop))
+
+                 (('remove-tag! name)
+                  (with-error-reporting
+                   ((storage-remove-tag! storage) name))
+                  (loop))
+
+                 (('lock-tag! name)
+                  (with-error-reporting-and-result
+                   ((storage-lock-tag! storage) name))
+                  (loop))
+
+                 (('tag-locked? name)
+                  (with-error-reporting-and-result
+                   ((storage-tag-locked? storage) name))
+                  (loop))
+
+                 (('unlock-tag! name)
+                  (with-error-reporting
+                   ((storage-unlock-tag! storage) name))
+                  (loop))
+
+                 (('admin! command)
+                  (with-error-reporting-and-result
+                   ((storage-admin! storage) command))
+                  (loop))
+
+                 (('close!)
+                  (with-error-reporting
+                   ((storage-close! storage)))
+                  (void))
+
+                 (else
+                  (write (list "error" (sprintf "Bad command ~s" command)))
+                  (loop)))))))))
+
+(define (read-response-v1 port)
   (let ((response (read port)))
    (match response
@@ -194 +237 @@
           (else response))))
 
-(define (read-response-body port)
-  (let ((response (read-response port)))
+(define (read-response-v1-body port)
+  (let ((response (read-response-v1 port)))
     (if response
         (read-u8vector (car response) port)
         #f)))
+
+(define (import-storage-v1 command-line debug responses commands pid)
+  (let ((header (read responses)))
+    (if debug (print "~a: read header" command-line header))
+    (if (not (list? header))
+        (error "Invalid backend protocol header" header))
+    (if (not (= (length header) 3))
+        (error "Invalid backend protocol header" header))
+    (let ((max-block-size (car header))
+          (writable? (cadr header))
+          (unlinkable? (caddr header)))
+      (make-storage
+       max-block-size
+       writable?
+       unlinkable?
+
+       (lambda (key data type)  ; put!
+         (if debug (printf "~a: put!" command-line))
+         (write `(put! ,key ,type ,(u8vector-length data)) commands)
+         (write-u8vector data commands)
+         (read-response-v1 responses)
+         (void))
+
+       (lambda ()                  ; flush!
+         (if debug (printf "~a: flush!" command-line))
+         (write `(flush!) commands)
+         (read-response-v1 responses)
+         (void))
+
+       (lambda (key)            ; exists?
+         (if debug (printf "~a: exists?" command-line))
+         (write `(exists? ,key) commands)
+         (read-response-v1 responses))
+
+       (lambda (key)            ; get
+         (if debug (printf "~a: get" command-line))
+         (write `(get ,key) commands)
+         (read-response-v1-body responses))
+
+       (lambda (key)            ; link!
+         (if debug (printf "~a: link!" command-line))
+         (write `(link! ,key) commands)
+         (read-response-v1 responses)
+         (void))
+
+       (lambda (key)            ; unlink!
+         (if debug (printf "~a: unlink! ~s" command-line key))
+         (write `(unlink! ,key) commands)
+         (read-response-v1-body responses))
+
+       (lambda (name key)               ; set-tag!
+         (if debug (printf "~a: set-tag!" command-line))
+         (write `(set-tag! ,name ,key) commands)
+         (read-response-v1 responses)
+         (void))
+
+       (lambda (name)           ; tag
+         (if debug (printf "~a: tag" command-line))
+         (write `(tag ,name) commands)
+         (read-response-v1 responses))
+
+       (lambda ()                       ; all-tags
+         (if debug (printf "~a: all-tags" command-line))
+         (write `(all-tags) commands)
+         (read-response-v1 responses))
+
+       (lambda (name)           ; remove-tag!
+         (if debug (printf "~a: remove-tag!" command-line))
+         (write `(remove-tag! ,name) commands)
+         (read-response-v1 responses)
+         (void))
+
+       (lambda (name)           ; lock-tag!
+         (if debug (printf "~a: lock-tag!" command-line))
+         (write `(lock-tag! ,name) commands)
+         (read-response-v1 responses))
+
+       (lambda (name)           ; tag-locked?
+         (if debug (printf "~a: tag-locked?" command-line))
+         (write `(tag-locked? ,name) commands)
+         (read-response-v1 responses))
+
+       (lambda (name)           ; unlock-tag!
+         (if debug (printf "~a: unlock-tag!" command-line))
+         (write `(unlock-tag! ,name) commands)
+         (read-response-v1 responses)
+         (void))
+
+       (lambda ()                       ; close!
+         (if debug (printf "~a: close!!" command-line))
+         (write '(close!) commands)
+         (read-response-v1 responses)
+         (close-input-port responses)
+         (close-output-port commands)
+         (void))))))
+
+(define (read-response-v2 port)
+  (let ((response (read port)))
+   (match response
+          (("error" err) (error (sprintf "Error from backend: ~s" err)))
+          ((log value)
+           (for-each (lambda (logentry)
+                       ((backend-log!) (car logentry) (cdr logentry)))
+                     log)
+           value)
+          ((log)
+           (for-each (lambda (logentry)
+                       ((backend-log!) (car logentry) (cdr logentry)))
+                     log)
+           (void))
+          (else (error "Malformed response from backend" response)))))
+
+(define (read-response-v2-body port)
+  (let ((length (read-response-v2 port)))
+    (if length
+        (read-u8vector length port)
+        #f)))
+
+(define (import-storage-v2 command-line debug responses commands pid)
+  (let ((header (read-response-v2 responses)))
+    (if debug (print "~a: read header" command-line header))
+    (if (not (list? header))
+        (error "Invalid backend protocol header" header))
+    (if (not (= (length header) 3))
+        (error "Invalid backend protocol header" header))
+    (let ((max-block-size (car header))
+          (writable? (cadr header))
+          (unlinkable? (caddr header)))
+      (make-storage
+       max-block-size
+       writable?
+       unlinkable?
+
+       (lambda (key data type)  ; put!
+         (if debug (printf "~a: put!" command-line))
+         (write `(put! ,key ,type ,(u8vector-length data)) commands)
+         (write-u8vector data commands)
+         (read-response-v2 responses)
+         (void))
+
+       (lambda ()                  ; flush!
+         (if debug (printf "~a: flush!" command-line))
+         (write `(flush!) commands)
+         (read-response-v2 responses)
+         (void))
+
+       (lambda (key)            ; exists?
+         (if debug (printf "~a: exists?" command-line))
+         (write `(exists? ,key) commands)
+         (read-response-v2 responses))
+
+       (lambda (key)            ; get
+         (if debug (printf "~a: get" command-line))
+         (write `(get ,key) commands)
+         (read-response-v2-body responses))
+
+       (lambda (key)            ; link!
+         (if debug (printf "~a: link!" command-line))
+         (write `(link! ,key) commands)
+         (read-response-v2 responses)
+         (void))
+
+       (lambda (key)            ; unlink!
+         (if debug (printf "~a: unlink! ~s" command-line key))
+         (write `(unlink! ,key) commands)
+         (read-response-v2-body responses))
+
+       (lambda (name key)               ; set-tag!
+         (if debug (printf "~a: set-tag!" command-line))
+         (write `(set-tag! ,name ,key) commands)
+         (read-response-v2 responses)
+         (void))
+
+       (lambda (name)           ; tag
+         (if debug (printf "~a: tag" command-line))
+         (write `(tag ,name) commands)
+         (read-response-v2 responses))
+
+       (lambda ()                       ; all-tags
+         (if debug (printf "~a: all-tags" command-line))
+         (write `(all-tags) commands)
+         (read-response-v2 responses))
+
+       (lambda (name)           ; remove-tag!
+         (if debug (printf "~a: remove-tag!" command-line))
+         (write `(remove-tag! ,name) commands)
+         (read-response-v2 responses)
+         (void))
+
+       (lambda (name)           ; lock-tag!
+         (if debug (printf "~a: lock-tag!" command-line))
+         (write `(lock-tag! ,name) commands)
+         (read-response-v2 responses))
+
+       (lambda (name)           ; tag-locked?
+         (if debug (printf "~a: tag-locked?" command-line))
+         (write `(tag-locked? ,name) commands)
+         (read-response-v2 responses))
+
+       (lambda (name)           ; unlock-tag!
+         (if debug (printf "~a: unlock-tag!" command-line))
+         (write `(unlock-tag! ,name) commands)
+         (read-response-v2 responses)
+         (void))
+
+       (lambda (command)                ; admin!
+         (if debug (printf "~a: admin!" command-line))
+         (write `(admin! ,command) commands)
+         (read-response-v2 responses))
+
+       (lambda ()                       ; close!
+         (if debug (printf "~a: close!!" command-line))
+         (write '(close!) commands)
+         (read-response-v2 responses)
+         (close-input-port responses)
+         (close-output-port commands)
+         (void))))))
 
 ;; Given the command line to a storage remote access protocol server,
@@ -213 +473 @@
      (let ((magic (read responses)))
        (if debug (print "~a: read magic ~a" command-line magic))
-       (if (not (equal? magic *magic*))
-           (error "Invalid backend protocol header magic" magic))
-
-       (let ((header (read responses)))
-         (if debug (print "~a: read header" command-line header))
-         (if (not (list? header))
-             (error "Invalid backend protocol header" header))
-         (if (not (= (length header) 3))
-             (error "Invalid backend protocol header" header))
-         (let ((max-block-size (car header))
-               (writable? (cadr header))
-               (unlinkable? (caddr header)))
-           (make-storage
-            max-block-size
-            writable?
-            unlinkable?
-
-            (lambda (key data type)     ; put!
-              (if debug (printf "~a: put!" command-line))
-              (write `(put! ,key ,type ,(u8vector-length data)) commands)
-              (write-u8vector data commands)
-              (read-response responses)
-              (void))
-
-            (lambda ()                  ; flush!
-              (if debug (printf "~a: flush!" command-line))
-              (write `(flush!) commands)
-              (read-response responses)
-              (void))
-
-            (lambda (key)               ; exists?
-              (if debug (printf "~a: exists?" command-line))
-              (write `(exists? ,key) commands)
-              (read-response responses))
-
-            (lambda (key)               ; get
-              (if debug (printf "~a: get" command-line))
-              (write `(get ,key) commands)
-              (read-response-body responses))
-
-            (lambda (key)               ; link!
-              (if debug (printf "~a: link!" command-line))
-              (write `(link! ,key) commands)
-              (read-response responses)
-              (void))
-
-            (lambda (key)               ; unlink!
-              (if debug (printf "~a: unlink! ~s" command-line key))
-              (write `(unlink! ,key) commands)
-              (read-response-body responses))
-
-            (lambda (name key)          ; set-tag!
-              (if debug (printf "~a: set-tag!" command-line))
-              (write `(set-tag! ,name ,key) commands)
-              (read-response responses)
-              (void))
-
-            (lambda (name)              ; tag
-              (if debug (printf "~a: tag" command-line))
-              (write `(tag ,name) commands)
-              (read-response responses))
-
-            (lambda ()                  ; all-tags
-              (if debug (printf "~a: all-tags" command-line))
-              (write `(all-tags) commands)
-              (read-response responses))
-
-            (lambda (name)              ; remove-tag!
-              (if debug (printf "~a: remove-tag!" command-line))
-              (write `(remove-tag! ,name) commands)
-              (read-response responses)
-              (void))
-
-            (lambda (name)              ; lock-tag!
-              (if debug (printf "~a: lock-tag!" command-line))
-              (write `(lock-tag! ,name) commands)
-              (read-response responses))
-
-            (lambda (name)              ; tag-locked?
-              (if debug (printf "~a: tag-locked?" command-line))
-              (write `(tag-locked? ,name) commands)
-              (read-response responses))
-
-            (lambda (name)              ; unlock-tag!
-              (if debug (printf "~a: unlock-tag!" command-line))
-              (write `(unlock-tag! ,name) commands)
-              (read-response responses)
-              (void))
-
-            (lambda ()                  ; close!
-              (if debug (printf "~a: close!!" command-line))
-              (write '(close!) commands)
-              (read-response responses)
-              (close-input-port responses)
-              (close-output-port commands)
-              (void)))))))))
+       (cond
+        ((equal? magic *magic-v1*)
+         (import-storage-v1 command-line debug responses commands pid))
+        ((equal? magic *magic-v2*)
+         (import-storage-v2 command-line debug responses commands pid))
+        (else (error "Unrecognised backend protocol header magic" magic)))))))
+
 
 )

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

@@ -12 +12 @@
          archive-writable?
          archive-unlinkable?
+         archive-log!
          archive-exists?
          archive-get
@@ -25 +26 @@
          archive-link!
          archive-unlink!
+         archive-admin!
          archive-close!
 
@@ -111 +113 @@
 (use ugarit-backend)
 (use sql-de-lite)
-
+(use data-structures)
+
+;;
+;; LOG EVENTS
+;;
+
+(define-record event
+  type                                  ; error/warning/note
+  time                                  ; timestamp (current-seconds)
+  path                                  ; where applicable, #f if not
+  message                               ; string
+)
+
+(define (make-event* type path message)
+  (let ((now (current-seconds)))
+    (printf "~A: ~A [~A] ~A\n" type (epochtime->string now) path message)
+    (make-event type now path message)))
 
 ;;
@@ -131 +149 @@
   global-directory-rules ; top-level directory rules
 
+  ; FIXME: Take out all these counters, including file-cache ones, and
+  ; the event log into a separate record and make a parameter to
+  ; contain them, and apply counters if that parameter is non-#f,
+  ; rather than keeping them in the archive 'god object' as multiple
+  ; snapshots could be happening to the same archive, etc; a snapshot
+  ; is a separate object to an archive.
+
   ; Snapshot counters
   (setter snapshot-blocks-stored)              ; Blocks written to storage
@@ -144 +169 @@
   (setter file-cache-hits)              ; count of file cache hits
   (setter file-cache-bytes)                 ; count of file cache bytes saved
+
+  ; Event log
+  event-log    ; a queue (see data-structures unit) of event records
   )
+
+(define (archive-log! archive type path message)
+  (queue-add! (archive-event-log archive)
+              (make-event* type path message))
+  (void))
+
+(define-syntax-rule (with-backend-logging archive body ...)
+  (parameterize ((backend-log! (lambda (type message)
+                                 (archive-log! archive type #f message)
+                                 (void))))
+                body ...))
 
 (define file-cache-commit-interval 1000)
@@ -150 +189 @@
 (define (file-cache-put! archive file-path mtime size key)
   (when (> file-cache-commit-interval (archive-file-cache-updates-uncommitted archive))
-        ((storage-flush! (archive-storage archive))) ; Flush the storage before we commit our cache, for crash safety
+        ((with-backend-logging archive (storage-flush! (archive-storage archive)))) ; Flush the storage before we commit our cache, for crash safety
         (exec (sql (archive-file-cache archive) "commit;"))
         (exec (sql (archive-file-cache archive) "begin;"))
@@ -186 +225 @@
     ((1) (blob->u8vector/shared (string->blob (z3:decode-buffer (blob->string (u8vector->blob/shared (subu8vector block 1 (u8vector-length block)))))))) ; deflate
     ((2) (blob->u8vector/shared (lzma:decompress (u8vector->blob/shared (subu8vector block 1 (u8vector-length block)))))))) ; lzma
+
+#|
+function hmac (key, message)
+    if (length(key) > blocksize) then
+        key = hash(key) // keys longer than blocksize are shortened
+    end if
+    if (length(key) < blocksize) then
+        key = key ∥ [0x00 * (blocksize - length(key))] // keys shorter than blocksize are zero-padded ('∥' is concatenation) 
+    end if
+   
+    o_key_pad = [0x5c * blocksize] ⊕ key // Where blocksize is that of the underlying hash function
+    i_key_pad = [0x36 * blocksize] ⊕ key // Where ⊕ is exclusive or (XOR)
+   
+    return hash(o_key_pad ∥ hash(i_key_pad ∥ message)) // Where '∥' is concatenation
+end function
+|#
 
 (define (choose-hash-function config)
@@ -270 +325 @@
                                         ; Valid flags:
                                         ; double-check - check correctness lots, even if it costs efficiency
+
 (define (open-archive config store-atime? store-ctime?)
   (let ((*storage* #f)
@@ -277 +333 @@
         (*double-check?* #f)
         (*file-cache* #f)
-        (*global-rules* '()))
+        (*global-rules* '())
+        (setup-log (make-queue)))
 
     (for-each (lambda (confentry)
@@ -283 +340 @@
                        ('double-check (set! *double-check?* #t))
                        (('storage command-line)
-                        (set! *storage* (import-storage command-line)))
+                        (set! *storage* 
+                              (parameterize ((backend-log! (lambda (type message)
+                                                             (queue-add! setup-log (make-event* type #f message))
+                                                             (void))))
+                                            (import-storage command-line))))
                        (('hash . conf) (set! *hash* conf))
                        (('compression . conf) (set! *compression* conf))
@@ -322 +383 @@
        (if *file-cache* (sql *file-cache* "SELECT key FROM files WHERE path = ? AND mtime = ? AND size = ?") #f)
        (if *file-cache* (sql *file-cache* "INSERT OR REPLACE INTO files (path,mtime,size,key) VALUES (?,?,?,?)") #f)
-       0 0 0))))
+       0 0 0
+       ; event log
+       setup-log))))
 
                                         ; Take a block, and return a compressed and encrypted block
@@ -355 +418 @@
   (inc! (archive-snapshot-bytes-skipped archive) (u8vector-length data)))
 
+(define (epochtime->string e)
+  (let ((localtime (seconds->local-time e)))
+    (string-append
+     (string-pad (number->string (+ 1900 (vector-ref localtime 5))) 4 #\0)
+     "-"
+     (string-pad (number->string (+ 1 (vector-ref localtime 4))) 2 #\0)
+     "-"
+     (string-pad (number->string (vector-ref localtime 3)) 2 #\0)
+     " "
+     (string-pad (number->string (vector-ref localtime 2)) 2 #\0)
+     ":"
+     (string-pad (number->string (vector-ref localtime 1)) 2 #\0)
+     ":"
+     (string-pad (number->string (vector-ref localtime 0)) 2 #\0))))
+
 (define (archive-put! archive key data type)
-  (when (not (archive-writable? archive))
-      (signal (make-property-condition 'exn 'location 'archive-put! 'message "This isn't a writable archive")))
-  ((storage-put! (archive-storage archive)) key (wrap-block archive data) type)
+  (unless (archive-writable? archive)
+      (error 'archive-put! "This isn't a writable archive"))
+  ((with-backend-logging archive (storage-put! (archive-storage archive))) key (wrap-block archive data) type)
   (inc! (archive-snapshot-blocks-stored archive))
   (inc! (archive-snapshot-bytes-stored archive) (u8vector-length data))
@@ -364 +442 @@
 
 (define (archive-flush! archive)
-  ((storage-flush! (archive-storage archive))) ; Flush the storage first, to ensure crash safety
+  ((with-backend-logging archive (storage-flush! (archive-storage archive)))) ; Flush the storage first, to ensure crash safety
   (when (archive-file-cache archive)
         (exec (sql (archive-file-cache archive) "commit;"))
@@ -371 +449 @@
 
 (define (archive-exists? archive key)
-  ((storage-exists? (archive-storage archive)) key))
-
-(define (archive-get archive key) ;; FIXME: Avoid fetching type. Pass in expected type from caller?
-  (let ((data (unwrap-block archive ((storage-get (archive-storage archive)) key))))
-    (assert (string=? key ((archive-hash archive) data (archive-exists? archive key)))
-            (sprintf "CONSISTENCY CHECK FAILURE: Block ~A comes back with hash ~A\n" key ((archive-hash archive) data (archive-exists? archive key))))
+  ((with-backend-logging archive (storage-exists? (archive-storage archive))) key))
+
+(define (archive-get archive key type)
+  (let* ((raw-data ((with-backend-logging archive (storage-get (archive-storage archive))) key))
+         (data (if raw-data
+                   (unwrap-block archive raw-data)
+                   (error 'archive-get (sprintf "Nonexistant block ~A ~A" key type)))))
+    (unless (string=? key ((archive-hash archive) data type))
+            (error 'archive-get (sprintf "Consistency check failure: asked for ~A, got ~A" key ((archive-hash archive) data type))))
     data))
 
 (define (archive-link! archive key)
-  (if (not (archive-writable? archive))
-      (signal (make-property-condition 'exn 'location 'archive-link! 'message "This isn't a writable archive")))
-  ((storage-link! (archive-storage archive)) key))
+  (unless (archive-writable? archive)
+      (error 'archive-link! "This isn't a writable archive"))
+  ((with-backend-logging archive (storage-link! (archive-storage archive))) key))
 
 (define (archive-unlink! archive key)
-  (if (not (archive-writable? archive))
-      (signal (make-property-condition 'exn 'location 'archive-link! 'message "This isn't an unlinkable archive - it's append-only")))
-  (let ((result ((storage-unlink! (archive-storage archive)) key)))
+  (unless (archive-writable? archive)
+      (error 'archive-unlink! "This isn't a writable archive"))
+  (let ((result ((with-backend-logging archive (storage-unlink! (archive-storage archive))) key)))
     (if result
         (unwrap-block archive result)
         #f)))
 
+(define (archive-admin! archive command)
+  ((with-backend-logging archive (storage-admin! (archive-storage archive))) command))
+
 (define (archive-set-tag! archive tag key)
-  (if (not (archive-writable? archive))
-      (signal (make-property-condition 'exn 'location 'archive-set-tag! 'message "This isn't a writable archive")))
-  ((storage-set-tag! (archive-storage archive)) tag key))
+  (unless (archive-writable? archive)
+      (error 'archive-set-tag! "This isn't a writable archive"))
+  ((with-backend-logging archive (storage-set-tag! (archive-storage archive))) tag key))
 
 (define (archive-tag archive tag)
-  ((storage-tag (archive-storage archive)) tag))
+  ((with-backend-logging archive (storage-tag (archive-storage archive))) tag))
 
 (define (archive-all-tags archive)
-  ((storage-all-tags (archive-storage archive))))
+  ((with-backend-logging archive (storage-all-tags (archive-storage archive)))))
 
 (define (archive-remove-tag! archive tag)
-  (if (not (archive-writable? archive))
-      (signal (make-property-condition 'exn 'location 'archive-remove-tag! 'message "This isn't a writable archive")))
-  ((storage-remove-tag! (archive-storage archive)) tag))
+  (unless (archive-writable? archive)
+      (error 'archive-remove-tag! "This isn't a writable archive"))
+  ((with-backend-logging archive (storage-remove-tag! (archive-storage archive))) tag))
 
 (define (archive-lock-tag! archive tag)
-  (if (not (archive-writable? archive))
-      (signal (make-property-condition 'exn 'location 'archive-lock-tag! 'message "This isn't a writable archive")))
+  (unless (archive-writable? archive)
+      (error 'archive-lock-tag! "This isn't a writable archive"))
   (let loop ((tries-left 10))
     (if (zero? tries-left)
         (signal (make-property-condition 'exn 'location 'archive-lock-tag! 'message (sprintf "We timed out attempting to lock the tag '~A'" tag)))
-        (let ((result ((storage-lock-tag! (archive-storage archive)) tag)))
+        (let ((result ((with-backend-logging archive (storage-lock-tag! (archive-storage archive))) tag)))
           (if result
               result                       ; Lock got!
@@ -422 +506 @@
 
 (define (archive-tag-locked? archive tag)
-  (if (not (archive-writable? archive))
-      #f)
-  ((storage-tag-locked? (archive-storage archive)) tag))
+  (unless (archive-writable? archive)
+      (error 'archive-tag-locked? "This isn't a writable archive"))
+  ((with-backend-logging archive (storage-tag-locked? (archive-storage archive))) tag))
 
 (define (archive-unlock-tag! archive tag)
-  (if (not (archive-writable? archive))
-      (signal (make-property-condition 'exn 'location 'archive-unlock-tag! 'message "This isn't a writable archive")))
-  ((storage-unlock-tag! (archive-storage archive)) tag))
+  (unless (archive-writable? archive)
+      (error 'archive-unlock-tag! "This isn't a writable archive"))
+  ((with-backend-logging archive (storage-unlock-tag! (archive-storage archive))) tag))
 
 (define (archive-close! archive)
-  ((storage-close! (archive-storage archive))) ;; This flushes the backend before we flush the file cache, for crash safety
+  ((with-backend-logging archive (storage-close! (archive-storage archive)))) ;; This flushes the backend before we flush the file cache, for crash safety
   (when (archive-file-cache archive)
         (exec (sql (archive-file-cache archive) "commit;"))
@@ -585 +669 @@
                                         ; Recurse
         (begin
-          (let ((subkeys (deserialise-key-stream (archive-get archive key))))
+          (let ((subkeys (deserialise-key-stream (archive-get archive key type))))
             (fold
              (lambda (subkey acc) (fold-key-stream archive subkey ks-type kons acc))
@@ -660 +744 @@
   (fold-key-stream archive key 'fi
                    (lambda (key type acc)
-                     (kons (archive-get archive key) acc))
+                     (kons (archive-get archive key type) acc))
                    knil))
 
@@ -780 +864 @@
                    (lambda (key found-leaf-type acc)
                      (assert (eq? found-leaf-type leaf-type))
-                     (let ((sexprs (deserialise-sexpr-stream (archive-get archive key))))
+                     (let ((sexprs (deserialise-sexpr-stream (archive-get archive key found-leaf-type))))
                        (fold
                         kons
@@ -852 +936 @@
        (for-each (lambda (filename)
                    (handle-exceptions exn
-                                      (printf "ERROR: Could not store ~a into the archive (~a), skipping it...\n" (make-pathname path filename) ((condition-property-accessor 'exn 'message "Unknown error") exn))
+                                      (archive-log! archive 'error (make-pathname path filename) (sprintf "Unable to store into the archive (~a)" ((condition-property-accessor 'exn 'message "Unknown error") exn)))
                                       (let* ((file-path (make-pathname path filename))
                                              (stats (file-stat file-path #t))
@@ -873 +957 @@
                                             (cond
                                              ((eq? type stat/ifsock)
-                                              (printf "WARNING: ~A is a socket, ignoring...\n" file-path))
+                                              (archive-log! archive 'warning file-path "Ignoring a socket"))
                                              ((eq? type stat/ifreg)
                                               (let-values (((content-key content-reused?) (with-input-from-file file-path (lambda () (store-file! archive file-path stats)))))
@@ -904 +988 @@
                                              (else
                                         ; WTF?
-                                              (printf "ERROR: I can't ascertain the type of ~A. Skipping it...\n" file-path)))))))
+                                              (archive-log! archive 'error file-path "Unable to store object of unknown type")))))))
                  (sort! (directory path #t) string>?))
 
@@ -923 +1007 @@
                               (unlink-directory! archive (cdr (assq 'contents props)))))))))
 
-(define (set-standard-file-metadata! path props)
+(define (set-standard-file-metadata! archive path props)
   (let ((mode (assq 'mode props))
         (uid (assq 'uid props))
@@ -935 +1019 @@
     (if (or uid gid)
         (handle-exceptions exn
-                           (printf "WARNING: It was not possible to set the uid/gid of ~a\n" path)
+                           (archive-log! archive 'warning path "Unable to set the uid/gid")
          (change-file-owner path
                             (if uid (cdr uid) (current-user-id))
@@ -952 +1036 @@
       (lambda ()
         (write-file-contents archive contents-key)))
-    (set-standard-file-metadata! path props)))
+    (set-standard-file-metadata! archive path props)))
 
 (define (extract-subdirectory! archive props path)
@@ -962 +1046 @@
     (extract-directory! archive contents-key path)
 
-    (set-standard-file-metadata! path props)))
+    (set-standard-file-metadata! archive path props)))
 
 (define (extract-symlink! archive props path)
@@ -980 +1064 @@
     (if (or uid gid)
         (handle-exceptions exn
-                           (printf "WARNING: It was not possible to set the uid/gid of ~a\n" path)
+                           (archive-log! archive 'warning path "Unable to set the uid/gid")
          (change-link-owner path
                             (if uid (cdr uid) (current-user-id))
@@ -989 +1073 @@
   (create-fifo path)
 
-  (set-standard-file-metadata! path props))
+  (set-standard-file-metadata! archive path props))
 
 (define (extract-block-device! archive props path)
@@ -995 +1079 @@
 
     (handle-exceptions exn
-                       (printf "WARNING: It was not possible to recreate block device ~a\n" path)
+                       (archive-log! archive 'warning path "Unable to recreate block device")
 
      (create-special-file path stat/ifblk number)
-     (set-standard-file-metadata! path props))))
+     (set-standard-file-metadata! archive path props))))
 
 (define (extract-character-device! archive props path)
@@ -1004 +1088 @@
 
     (handle-exceptions exn
-                       (printf "WARNING: It was not possible to recreate character device ~a\n" path)
+                       (archive-log! archive 'warning path "Unable to recreate character device")
 
      (create-special-file path stat/ifchr number)
-     (set-standard-file-metadata! path props))))
+     (set-standard-file-metadata! archive path props))))
 
 (define (extract-object! archive dirent target-path)
@@ -1027 +1111 @@
       (extract-character-device! archive props (make-pathname target-path name)))
      (else
-      (printf "ERROR: Found an object (~A) of unknown type (~A), skipping...\n" name type)))))
+      (archive-log! archive 'error (make-pathname target-path name) (sprintf "Unable to extract an object of unknown type ~A" type))))))
 
 (define (extract-directory! archive key target-path)
   (fold-sexpr-stream archive key 'd 'di
                      (lambda (dirent acc)
-                       (extract-object! archive dirent target-path)
+                       (handle-exceptions
+                        exn
+                        (archive-log! archive 'error (make-pathname target-path (car dirent)) (sprintf "Unable to extract from the archive (~a)" ((condition-property-accessor 'exn 'message "Unknown error") exn)))
+                        (extract-object! archive dirent target-path))
                        (void))
                      '()))
@@ -1055 +1142 @@
           (values (virgin hash) #f)))))
 
-(define (read-sexpr archive key)
-  (let ((data (archive-get archive key)))
+(define (read-sexpr archive key type)
+  (let ((data (archive-get archive key type)))
     (with-input-from-string
         (blob->string (u8vector->blob/shared data))
@@ -1077 +1164 @@
 ;;         'file-cache-hits
 ;;         'file-cache-bytes
+;; 'log (list of log events, each being a (type timestamp path message) list
 ;; Returns the snapshot's key.
 (define (tag-snapshot! archive tag contents-key contents-reused? snapshot-properties)
@@ -1089 +1177 @@
                  (cons 'file-cache-hits (archive-file-cache-hits archive))
                  (cons 'file-cache-bytes (archive-file-cache-bytes archive))))
+         (log (map (lambda (event)
+                     (list (event-type event)
+                           (event-time event)
+                           (event-path event)
+                           (event-message event)))
+                   (queue->list (archive-event-log archive))))
          (snapshot
           (append
@@ -1094 +1188 @@
             (cons 'mtime (current-seconds))
             (cons 'contents contents-key)
-            (cons 'stats stats))
+            (cons 'stats stats)
+            (cons 'log log))
            snapshot-properties))
          (keys
@@ -1113 +1208 @@
 
 (define (fold-history archive snapshot-key kons knil)
-  (let ((snapshot (read-sexpr archive snapshot-key)))
+  (let ((snapshot (read-sexpr archive snapshot-key 'snapshot)))
     (if (assq 'previous snapshot)
         (kons snapshot-key snapshot
@@ -1134 +1229 @@
                     props))))
 
-(define (epochtime->string e)
-  (let ((localtime (seconds->local-time e)))
-    (string-append
-     (string-pad (number->string (+ 1900 (vector-ref localtime 5))) 4 #\0)
-     "-"
-     (string-pad (number->string (+ 1 (vector-ref localtime 4))) 2 #\0)
-     "-"
-     (string-pad (number->string (vector-ref localtime 3)) 2 #\0)
-     " "
-     (string-pad (number->string (vector-ref localtime 2)) 2 #\0)
-     ":"
-     (string-pad (number->string (vector-ref localtime 1)) 2 #\0)
-     ":"
-     (string-pad (number->string (vector-ref localtime 0)) 2 #\0))))
 
 
@@ -1160 +1241 @@
                                         ; List tags
     (fold (lambda (tag acc)
-            (kons (cons 'tag tag) (list tag 'tag (cons 'current (archive-tag archive tag))) acc))
+            (kons (cons 'tag tag) (list tag 'tag (cons 'current (archive-tag archive tag)) (cons 'locked (archive-tag-locked? archive tag))) acc))
           knil (archive-all-tags archive)))
    ((and (pair? directory-key) (eq? (car directory-key) 'tag))
@@ -1166 +1247 @@
     (let* ((tag (cdr directory-key))
            (current (archive-tag archive tag))
-           (current-contents (read-sexpr archive current)))
+           (current-contents (read-sexpr archive current 'snapshot)))
       (kons
        (cdr (assq 'contents current-contents))

release/4/ugarit/trunk/ugarit.meta

@@ -4 +4 @@
  (category data)
  (needs miscmacros sql-de-lite crypto-tools srfi-37 stty matchable autoload regex tiger-hash posix-extras parley)
- (optional lzma z3 tiger-hash sha2 aes)
+ (optional lzma z3 sha2 aes)
  (author "Alaric Snell-Pym")
  (synopsis "A backup/archival system based on content-addressed storage"))

release/4/ugarit/trunk/ugarit.scm

@@ -105 +105 @@
                                ((condition-property-accessor 'exn 'message "Unknown error") exn)
                                (cons ((condition-property-accessor 'exn 'location (void)) exn)
-                                     ((condition-property-accessor 'exn 'arguments (void)) exn)))
+                                     ((condition-property-accessor 'exn 'arguments '()) exn)))
                        (success-continuation))
    (fold-archive-node archive directory-key
@@ -138 +138 @@
       (if (eq? line #!eof)
          (quit-continuation (void)))
-      
       (let ((result (string-split line)))
-  
          (match result
             (()

release/4/ugarit/trunk/ugarit.setup

@@ -1 @@
-(define *version* "1.0.1")
+(define *version* "1.0.2")
 
 (compile -s -O2 -d1 directory-rules.scm -j directory-rules)
@@ -39 +39 @@
   `((version ,*version*)
   ))
+
+(compile ugarit-archive-admin.scm)
+(install-program 'ugarit-archive-admin "ugarit-archive-admin"
+  `((version ,*version*)
+  ))