Changeset 25570 in project


Ignore:
Timestamp:
11/25/11 20:58:42 (10 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:
1 added
11 edited

Legend:

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

    r25566 r25570  
    538538      $ ugarit fork <ugarit.conf> <existing tag> <new tag>
    539539
     540## Archive administration
     541
     542Each backend offers a number of administrative commands for
     543administering archives. These are accessible via the
     544`ugarit-archive-admin` command line interface.
     545
     546To use it, run it with the following command:
     547
     548      $ ugarit-archive-admin '<archive identifier>'
     549
     550The available commands differ between backends, but all backends
     551support the `info` and `help` commands, which give basic information
     552about the archive, and list all available commands, respectively. Some
     553offer a `stats` command that examines the archive state to give
     554interesting statistics, but which may be a time-consuming operation.
     555
     556### Administering `splitlog` archives
     557
     558The splitlog backend offers a wide selection of administrative
     559commands. See the `help` command on a splitlog archive for
     560details. The following facilities are available:
     561
     562 * Configuring the block size of the archive (this will affect new
     563   blocks written to the archive, and leave existing blocks untouched,
     564   even if they are larger than the new block size)
     565
     566 * Configuring the size at which a log file is finished and a new one
     567   started (likewise, existing log files will be untouched; this will
     568   only affect new log files)
     569
     570 * Configuring the frequency of automatic synching of the archive
     571   state to disk. Lowering this harms performance when writing to the
     572   archive, but decreases the number of in-progress block writes that
     573   can fail in a crash.
     574
     575 * Enable or disable write protection of the archive
     576
     577 * Reindex the archive, rebuilding the block and tag state from the
     578   contents of the log. If the metadata file is damaged or lost,
     579   reindexing can rebuild it (although any configuration changes made
     580   via other admin commands will need manually repeating as they are
     581   not logged).
     582
    540583## `.ugarit` files
    541584
     
    824867* Migrate the source repo to Fossil (when there's a
    825868  kitten-technologies.co.uk migration to Fossil), and update the egg
    826   locations thingy.
     869  locations thingy. Migrate all these Future Directions items to
     870  actual tickets.
    827871
    828872* Profile the system. As of 1.0.1, having done the periodic SQLite
     
    838882## Backends
    839883
    840 * Create ugarit-backend-protocol-2, and extend import-backend to
    841   support it. The differences are:
    842 
    843   * Extend the backend API to have all API calls return a possibly
    844     empty list of log messages before the actual result. When
    845     importing a backend, provide a logging callback which is passed
    846     these lists and feeds them into a logging mechanism which prints
    847     them and stores them in the archive object for later logging into
    848     the snapshot. The same logging interface can then be used for
    849     warnings from within ugarit-core itself as well.
    850 
    851   * Extend the backend API to have an initial list of log messages and
    852     a possible error or success for initialisation, inside the
    853     header. Make the command-line wrappers for backends use this to
    854     indicate startup failure.
    855 
    856884* Carefully document backend API for other backend authors: in
    857885  particular note behaviour in crash situations - we assume that after
     
    874902  not flushed to the metadata) or scan the log onwards from that point
    875903  to find (complete) blocks that did not get flushed to the metadata.
    876 
    877 * Make `lock-tag!` fail if the tag is already locked. Make the archive
    878   block and retry a few times in that case.
    879 
    880 * Extend the backend protocol with a special "admin" command that
    881   allows for arbitrary backend-specific operations, and write an
    882   ugarit-backend-admin CLI tool to administer backends with it. The
    883   input should be a single s-expression as a list, and the result
    884   should be an alist which is displayed to the user in a friendly
    885   manner, as "Key: Value\n" lines.
    886 
    887 * Implement "info" admin commands for all backends, that list any
    888   available stats, and at least the backend type and parameters.
    889 
    890 * Support for recreating the index and tags on a backend-splitlog if
    891   they get corrupted, from the headers left in the log, as a "reindex"
    892   admin command.
    893 
    894 * Support for flushing the cache on a backend-cache, via an admin
    895   command, rather than having to delete the cache file.
    896904
    897905* Support for unlinking in backend-splitlog, by marking byte ranges as
     
    909917  existing archive with no refcounts, default them to NULL, and treat
    910918  a NULL refcount as "infinity".
    911 
    912 * Have read-only and unlinkable and block size config flags in the
    913   backend-split metadata file, settable via admin commands.
    914919
    915920* For people doing remote backups who want to not hog resources, write
     
    975980## Core
    976981
    977 * Add the option to support full HMAC for salted hashing; make this
    978   the recommended setting, with syntax `(hash tiger hmac "SALT")`, and
    979   require `(hash tiger simple "SALT")` to explicitly request legacy
    980   mode. Note this in the upgrade notes for existing users.
    981 
    982 * Add the option to append HMACed signatures to the post-encryption
     982* Add the option to append hash signatures to the post-encryption
    983983  blocks in the archive, to protect against people who tamper with
    984984  blocks in order to try and exploit vulnerabilities in the
     
    988988  that decrypt to giant amounts of RAM).
    989989
    990 * When extracting, wrap each restore operation under
    991   extract-directory! with exception handling that logs the error and
    992   then continues with the next dirent in the directory.
    993 
    994 * Check sensibly-worded conditions are raised when we try and fetch
    995   nonexistant or corrupted blocks from the archive in `archive-get`.
    996 
    997 * Make `fold-archive-node`'s listing of tags at the top level report
    998   the lock status of the tags.
    999 
    1000990* More stats. Log bytes written AFTER compression and encryption in
    1001991  `archive-put!`. Log snapshot start and end times in the snapshot
    1002992  object.
    1003 
    1004 * SIGINFO support. Add a SIGINFO handler that sets a flag, and make
    1005   the `store-file!` and `store-directory!` main loops look for the
    1006   flag and, if set, display what path we're working on, and perhaps a
    1007   quick summary of the bytes/blocks stored/skipped stats.
    1008993
    1009994* Clarify what characters are legal in tag names sent to backends, and
     
    11441129  node tree
    11451130
    1146 * Better error messages
    1147 
    11481131* API mode: Works something like the backend API, except at the
    11491132  archive level. Supports all the important archive operations, plus
     
    12761259  metadata. Switched to the `posix-extras` egg and ditched our own
    12771260  `posixextras.scm` wrappers. Used the `parley` egg in the `ugarit
    1278   explore` CLI for line editing. BUGFIX: Made file cache check the
    1279   file hashes it finds in the cache actually exist in the archive, to
    1280   protect against the case where a crash of some kind has caused
    1281   unflushed changes to be lost; the file cache may well have committed
    1282   changes that the backend hasn't, leading to references to
    1283   nonexistant blocks. Note that we assume that archives are
    1284   sequentially safe, eg if the final indirect block of a large file
    1285   made it, all the partial blocks must have made it too. BUGFIX: Added
    1286   an explicit `flush!` command to the backend protocol, and put
    1287   explicit flushes at critical points in higher layers
    1288   (`backend-cache`, the archive abstraction in the Ugarit core, and
    1289   when tagging a snapshot) so that we ensure the blocks we point at
    1290   are flushed before committing references to them in the
    1291   `backend-cache` or file caches, or into tags, to ensure crash
    1292   safety. BUGFIX: Made the splitlog backend never exceed the file size
    1293   limit (except when passed blocks that, plus a header, are larger
    1294   than it), rather than letting a partial block hang over the
    1295   'end'. BUGFIX: Fixed tag locking, which was broken all over the
    1296   place. Concurrent snapshots to the same tag should now block for one
    1297   another, although why you'd want to *do* that is
    1298   questionable. BUGFIX: Fixed generation of non-keyed hashes, which
    1299   was incorrectly appending the type to the hash without an outer
    1300   hash. This breaks backwards compatability, but nobody was using the
    1301   old algorithm, right? I'll introduce it as an option if required.
     1261  explore` CLI for line editing. Added logging infrastructure,
     1262  recording of snapshot logs in the snapshot. Added recovery from
     1263  extraction errors. Listed lock state of tags in explore
     1264  mode. Backend protocol v2 introduced (retaining v1 for
     1265  compatability) allowing for an error on backend startup, and logging
     1266  nonfatal errors, warnings, and info on startup and all protocol
     1267  calls. Added `ugarit-archive-admin` command line interface to
     1268  backend-specific administrative interfaces. Configuration of the
     1269  splitlog backend (write protection, adjusting block size and logfile
     1270  size limit and commit interval) is now possible via the admin
     1271  interface. The admin interface also permits rebuilding the metadata
     1272  index of a splitlog archive with the `reindex!` admin command.
     1273
     1274  * BUGFIX: Made file cache check the file hashes it finds in the
     1275    cache actually exist in the archive, to protect against the case
     1276    where a crash of some kind has caused unflushed changes to be
     1277    lost; the file cache may well have committed changes that the
     1278    backend hasn't, leading to references to nonexistant blocks. Note
     1279    that we assume that archives are sequentially safe, eg if the
     1280    final indirect block of a large file made it, all the partial
     1281    blocks must have made it too.
     1282
     1283  * BUGFIX: Added an explicit `flush!` command to the backend
     1284    protocol, and put explicit flushes at critical points in higher
     1285    layers (`backend-cache`, the archive abstraction in the Ugarit
     1286    core, and when tagging a snapshot) so that we ensure the blocks we
     1287    point at are flushed before committing references to them in the
     1288    `backend-cache` or file caches, or into tags, to ensure crash
     1289    safety.
     1290
     1291  * BUGFIX: Made the splitlog backend never exceed the file size limit
     1292    (except when passed blocks that, plus a header, are larger than
     1293    it), rather than letting a partial block hang over the 'end'.
     1294
     1295  * BUGFIX: Fixed tag locking, which was broken all over the
     1296    place. Concurrent snapshots to the same tag should now block for
     1297    one another, although why you'd want to *do* that is questionable.
     1298
     1299  * BUGFIX: Fixed generation of non-keyed hashes, which was
     1300    incorrectly appending the type to the hash without an outer
     1301    hash. This breaks backwards compatability, but nobody was using
     1302    the old algorithm, right? I'll introduce it as an option if
     1303    required.
    13021304
    13031305* 1.0.1: Consistency check on read blocks by default. Removed warning
  • release/4/ugarit/trunk/VERSION.txt

    r25521 r25570  
    1 1.0.1
     11.0.2
  • release/4/ugarit/trunk/backend-cache.scm

    r25565 r25570  
    2121   (define cache-delete-query (sql *db* "DELETE FROM cache WHERE key = ?"))
    2222
     23   (define *hits* 0)
     24   (define *misses* 0)
     25   (define *flushes* 0)
     26
    2327   (define commit-interval 1000)
    2428   (define *updates-since-last-commit* 0)
    2529   (define (flush!)
    2630     (when (> *updates-since-last-commit* 0)
     31      (inc! *flushes*)
    2732      (exec (sql *db* "COMMIT;"))
    2833      (exec (sql *db* "BEGIN;"))
     
    5257     (maybe-flush!))
    5358
     59   (define (cache-clear!)
     60     (exec (sql *db* "DELETE FROM cache")))
     61
    5462   (make-storage
    5563      (storage-max-block-size be)
     
    6775          (void)))
    6876      (lambda (key) ; exists?
    69          (or
    70             (cache-get key)
    71             (cache-set! key ((storage-exists? be) key))))
     77        (let ((cached-result (cache-get key)))
     78          (if cached-result
     79              (begin
     80                (inc! *hits*)
     81                cached-result)
     82              (begin
     83                (inc! *misses*)
     84                (cache-set! key ((storage-exists? be) key))))))
    7285      (lambda (key) ; get
    7386         ((storage-get be) key))
     
    104117          ((storage-flush! be))
    105118          (flush!))
     119      (lambda (command) ; admin!
     120        (match command
     121               (('info)
     122                (list (cons 'backend "cache")
     123                      (cons 'block-size (storage-max-block-size be))
     124                      (cons 'writable? (storage-writable? be))
     125                      (cons 'unlinkable? (storage-unlinkable? be))
     126                      (cons 'cache-file cachepath)
     127                      (cons 'commit-interval commit-interval)))
     128               (('help)
     129                (list (cons 'info "Return information about the archive")
     130                      (cons 'help "List available admin commands")
     131                      (cons 'stats "Examine the cache and report back statistics")
     132                      (cons 'clear! "Clear the cache")))
     133               (('stats)
     134                (list (cons 'entries (car (query fetch (sql *db* "SELECT COUNT(*) FROM cache"))))))
     135               (('clear!)
     136                (cache-clear!)
     137                (flush!)
     138                (list (cons 'result "Done")))
     139               (else (error "Unknown admin command"))))
    106140      (lambda () ; close!
    107141        (begin
     142          ((backend-log!) 'info (sprintf "Cache hits: ~A misses: ~A flushes: ~A" *hits* *misses* *flushes*))
    108143          ((storage-close! be))
    109144          (exec (sql *db* "COMMIT;"))
     
    114149  (match (command-line-arguments)
    115150         ((cachepath backend)
    116           (backend-cache cachepath (import-storage backend)))
     151          (lambda () (backend-cache cachepath (import-storage backend))))
    117152
    118153         (else
     154          (export-storage-error! "Invalid arguments to backend-cache")
    119155          (printf "USAGE:\nbackend-cache <path-to-cache-file> \"<backend command line>\"\n")
    120156          #f)))
  • release/4/ugarit/trunk/backend-devtools.scm

    r25565 r25570  
    3030      (lambda (tag) ; unlock-tag!
    3131         ((storage-unlock-tag! be) tag))
     32      (lambda (command) ; admin!
     33         ((storage-admin! be) command))
    3234      (lambda () ; close!
    3335         ((storage-close! be)))))
     
    6466      (lambda (tag) ; unlock-tag!
    6567         ((storage-unlock-tag! be) tag))
     68      (lambda (command) ; admin!
     69         ((storage-admin! be) command))
    6670      (lambda () ; close!
    6771         ((storage-close! be)))))
     
    133137            (printf "~A: (lock-tag! ~A)\n" name tag)
    134138            ((storage-unlock-tag! be) tag)))
     139      (lambda (command) ; admin!
     140         (let ((result ((storage-admin! be) command)))
     141            (begin
     142               (printf "~A: (admin! ~A) = ~A\n" name command result)
     143               result)))
    135144      (lambda () ; close!
    136145         (begin
  • release/4/ugarit/trunk/backend-fs.scm

    r25565 r25570  
    5353
    5454   (if (not (directory? base))
    55       (signal (make-property-condition 'exn 'message "The archive does not exist" 'arguments base)))
     55       (error "The archive directory does not exist" base))
     56
     57   (define block-size (* 1024 1024))
    5658
    5759   (make-storage
    58       (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap
     60    block-size
    5961      #t ; We are writable
    6062      #t ; We support unlink!
     
    162164        (delete-file (make-tag-lock-name tag))
    163165        (void))
     166      (lambda (command) ; admin!
     167        (match command
     168               (('info)
     169                (list (cons 'backend "fs")
     170                      (cons 'path base)
     171                      (cons 'block-size block-size)
     172                      (cons 'writable? #t)
     173                      (cons 'unlinkable? #t)))
     174               (('help)
     175                (list (cons 'info "Return information about the archive")
     176                      (cons 'help "List available admin commands")))
     177               (else (error "Unknown admin command"))))
    164178      (lambda () ; close!
    165179         (void))))
     
    172186   "CREATE TABLE tags (tag TEXT PRIMARY KEY, key TEXT, locked INTEGER DEFAULT 0);"))
    173187
    174 (define (backend-splitlog logdir metapath max-logpart-size)
     188(define file-sync (foreign-lambda int "fsync" int))
     189
     190(define (backend-splitlog logdir metapath)
    175191   (let*
    176192        ((*db*
     
    204220                                 default)
    205221                               (car result)))))
    206          (set-metadata (lambda (key value)
     222         (set-metadata! (lambda (key value)
    207223                         (exec set-metadata-query key value)))
     224
     225         (max-logpart-size (string->number (get-metadata "max-logpart-size" "600000000")))
    208226
    209227         ; Log file management
     
    222240                     fd)))))
    223241
     242         ; Basic configurables
     243         (block-size (string->number (get-metadata "block-size" "1048576")))
     244         (writable? (not (string=? "0" (get-metadata "writable" "1"))))
     245         (check-writable (lambda ()
     246                           (unless writable?
     247                                   (error "This archive is write protected"))))
     248
    224249         ; Periodic commit management
    225250         (commit-interval (string->number (get-metadata "commit-interval" "1000")))
     
    227252         (flush! (lambda ()
    228253                   (when (> *updates-since-last-commit* 0)
    229                     (set-metadata "current-logfile" (number->string *logcount*))
     254                    (file-sync *log*)
     255                    (set-metadata! "current-logfile" (number->string *logcount*))
    230256                    (exec (sql *db* "COMMIT;"))
    231257                    (exec (sql *db* "BEGIN;"))
     
    280306
    281307         (get-tags (lambda ()
    282                      (map car (query fetch-all get-tags-query)))))
     308                     (map car (query fetch-all get-tags-query))))
     309
     310         (reindex! (lambda ()
     311                     (flush!)
     312                     (exec (sql *db* "DELETE FROM tags;"))
     313                     (exec (sql *db* "DELETE FROM blocks;"))
     314
     315                     (let loop-over-logs ((log-number 0))
     316                       (let* ((log-file-name (string-append logdir "/log" (number->string log-number))))
     317                         (if (file-exists? log-file-name)
     318                          (begin
     319                            ((backend-log!) 'info (sprintf "Reading ~a" log-file-name))
     320                            (with-input-from-file log-file-name
     321                              (lambda ()
     322                                (let loop-over-entries ()
     323                                  (let* ((entry (read))
     324                                         (posn (file-position (current-input-port))))
     325                                    (if (eof-object? entry)
     326                                        (loop-over-logs (+ log-number 1))
     327                                        (begin
     328                                          (match entry
     329                                                 (('block key type length)
     330                                                  (set-block-data! key type log-number posn length)
     331                                                  (set-file-position! (current-input-port) length seek/cur))
     332                                                 (('tag tag key)
     333                                                  (set-tag! tag key))
     334                                                 (else
     335                                                  ((backend-log!) 'error "Unknown log entry ~S" entry)))
     336                                          (loop-over-entries)))))))))
     337                         (void)))
     338                     (flush!)
     339                     (void))))
    283340
    284341      (make-storage
    285          (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap, right?
    286          #t ; We are writable
     342         block-size
     343         writable?
    287344         #f ; We DO NOT support unlink!
    288345
    289346         (lambda (key data type) ; put!
     347           (check-writable)
    290348           (when (pair? (get-block-data key))
    291                  (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type))))
     349                 (error "Duplicate block" key type))
    292350
    293351           (set-file-position! *log* 0 seek/end)
     
    332390
    333391         (lambda (key) ; link!
    334             (void))
     392           (check-writable)
     393           (void))
    335394
    336395         (lambda (key) ; unlink!
    337             (signal (make-property-condition 'exn 'message "Log archives do not support deletion")))
     396           (check-writable)
     397           (error "splitlog archives do not support unlinkined"))
    338398
    339399         (lambda (tag key) ; set-tag!
    340             (file-write *log* (sprintf "(tag ~S ~S)" tag key))
    341             (set-tag! tag key)
    342             (void))
     400           (check-writable)
     401           (file-write *log* (sprintf "(tag ~S ~S)" tag key))
     402           (set-tag! tag key)
     403           (void))
    343404         (lambda (tag) ; tag
    344405           (get-tag tag))
     
    346407           (get-tags))
    347408         (lambda (tag) ; remove-tag!
     409           (check-writable)
    348410           (remove-tag! tag)
    349411           (void))
    350412         (lambda (tag) ; lock-tag!
     413           (check-writable)
    351414           (flush!)
    352415           (let ((existing-lock? (not (zero? (get-tag-lock tag)))))
     
    363426               #t))
    364427         (lambda (tag) ; unlock-tag!
     428           (check-writable)
    365429           (set-tag-lock! tag 0)
    366430           (flush!))
     431         (lambda (command) ; admin!
     432           (match command
     433                  (('info)
     434                   (list (cons 'backend "splitlog")
     435                         (cons 'block-size block-size)
     436                         (cons 'writable? writable?)
     437                         (cons 'unlinkable? #f)
     438                         (cons 'path logdir)
     439                         (cons 'metadata-file metapath)
     440                         (cons 'max-logfile-size max-logpart-size)
     441                         (cons 'currently-writing-to *logcount*)
     442                         (cons 'commit-interval commit-interval)))
     443                  (('help)
     444                   (list (cons 'info "Return information about the archive")
     445                         (cons 'help "List available admin commands")
     446                         (cons 'stats "Examine the metadata and report back statistics")
     447                         (cons 'set-block-size! (sprintf "<size in bytes> Sets a new maximum block size (current: ~a)" block-size))
     448                         (cons 'set-max-logfile-size! (sprintf "<size in bytes> Sets a new maximum logfile size (current: ~a)" max-logpart-size))
     449                         (cons 'set-commit-interval! (sprintf "<updates> Sets a new commit interval (current: ~a)" commit-interval))
     450                         (cons 'write-protect! (sprintf "Disable writing to the archive (currently ~a)" (if writable? "enabled" "disabled")))
     451                         (cons 'write-unprotect! (sprintf "Enable writing to the archive (currently ~a)" (if writable? "enabled" "disabled")))
     452                         (cons 'reindex! "Rebuild the index in the metadata from scratch by scanning the log (takes a while)")))
     453                  (('stats)
     454                   (let* ((stats (query fetch (sql *db* "SELECT COUNT(*), SUM(length) FROM blocks"))))
     455                    (list (cons 'blocks (first stats))
     456                          (cons 'bytes (second stats)))))
     457                  (('set-block-size! size)
     458                   (assert (integer? size))
     459                   (set! block-size size)
     460                   (set-metadata! "block-size" (number->string size))
     461                   (list (cons 'result "Done")))
     462                  (('set-max-logfile-size! size)
     463                   (assert (integer? size))
     464                   (set! max-logpart-size size)
     465                   (set-metadata! "max-logpart-size" (number->string size))
     466                   (list (cons 'result "Done")))
     467                  (('set-commit-interval! cis)
     468                   (assert (integer? cis))
     469                   (set! commit-interval cis)
     470                   (set-metadata! "commit-interval" (number->string  cis))
     471                   (list (cons 'result "Done")))
     472                  (('write-protect!)
     473                   (set! writable? #f)
     474                   (set-metadata! "writable" "0")
     475                   (list (cons 'result "Done")))
     476                  (('write-unprotect!)
     477                   (set! writable? #f)
     478                   (set-metadata! "writable" "1")
     479                   (list (cons 'result "Done")))
     480                  (('reindex!)
     481                   (reindex!)
     482                   (list (cons 'result "Done")))
     483                  (else (error "Unknown admin command"))))
    367484         (lambda () ; close!
    368485           (flush!)
     
    377494  (match (command-line-arguments)
    378495         (("fs" base)
    379           (backend-fs base))
    380 
    381          (("splitlog" logdir metadir max-logpart-size)
    382           (backend-splitlog logdir metadir (string->number max-logpart-size)))
     496          (lambda ()  (backend-fs base)))
     497
     498         (("splitlog" logdir metadir)
     499          (lambda ()  (backend-splitlog logdir metadir)))
    383500
    384501         (else
    385           (printf "USAGE:\nbackend-fs fs <basedir-path>\nbackend-fs splitlog <logdir-path> <metadata-file-path> <max-file-size>\n")
     502          (export-storage-error! "Invalid arguments to backend-fs")
     503          (printf "USAGE:\nbackend-fs fs <basedir-path>\nbackend-fs splitlog <logdir-path> <metadata-file-path>\n")
    386504          #f)))
    387505
  • release/4/ugarit/trunk/test/run.scm

    r25566 r25570  
    3939
    4040(define (test-backend w)
    41    (test-assert "Storage writable" (storage-writable? w))
    42    (test-assert "Storage is empty" (not ((storage-exists? w) "TEST")))
    43    (test "Load a block" (void) ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5)) 'test))
    44    (test-assert "Block successfully loaded" ((storage-exists? w) "TEST"))
    45    (test "Block contents reads back" (list 1 2 3 4 5) (u8vector->list ((storage-get w) "TEST")))
    46    (if (storage-unlinkable? w)
    47       (begin
    48          (test "Unlink returns data" (list 1 2 3 4 5) (u8vector->list ((storage-unlink! w) "TEST")))
    49          (test-assert "Unlinked block is gone" (not ((storage-exists? w) "TEST")))))
    50    (test "Set a tag" (void) ((storage-set-tag! w) "TEST" "TEST123"))
    51    (test "Tag is not locked" #f ((storage-tag-locked? w) "TEST"))
    52    (test "Lock a tag" #t ((storage-lock-tag! w) "TEST"))
    53    (test "Tag is now locked" #t ((storage-tag-locked? w) "TEST"))
    54    (test "Lock a tag again" #f ((storage-lock-tag! w) "TEST"))
    55    (test "Tag is still locked" #t ((storage-tag-locked? w) "TEST"))
    56    (test "Unlock a tag" (void) ((storage-unlock-tag! w) "TEST"))
    57    (test "Tag is no longer locked" #f ((storage-tag-locked? w) "TEST"))
    58    (test "Tag reads back" "TEST123" ((storage-tag w) "TEST"))
    59    (test "Tag list works" (list "TEST") ((storage-all-tags w)))
    60    (test "Remove tag" (void)  ((storage-remove-tag! w) "TEST")))
     41(parameterize ((backend-log! (lambda (type message) (void))))
     42 (test-assert "Storage writable" (storage-writable? w))
     43 (test-assert "Storage is empty" (not ((storage-exists? w) "TEST")))
     44 (test "Load a block" (void) ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5)) 'test))
     45 (test-assert "Block successfully loaded" ((storage-exists? w) "TEST"))
     46 (test "Block contents reads back" (list 1 2 3 4 5) (u8vector->list ((storage-get w) "TEST")))
     47 (test "Nonexistant block reacts correctly" #f ((storage-get w) "NONEXISTANT"))
     48 (test-error "Cannot update existing blocks" ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5 6)) 'test))
     49 (if (storage-unlinkable? w)
     50     (begin
     51       (test "Unlink returns data" (list 1 2 3 4 5) (u8vector->list ((storage-unlink! w) "TEST")))
     52       (test-assert "Unlinked block is gone" (not ((storage-exists? w) "TEST")))))
     53
     54 (test "Set a tag" (void) ((storage-set-tag! w) "TEST" "TEST123"))
     55 (test "Tag is not locked" #f ((storage-tag-locked? w) "TEST"))
     56 (test "Lock a tag" #t ((storage-lock-tag! w) "TEST"))
     57 (test "Tag is now locked" #t ((storage-tag-locked? w) "TEST"))
     58 (test "Lock a tag again" #f ((storage-lock-tag! w) "TEST"))
     59 (test "Tag is still locked" #t ((storage-tag-locked? w) "TEST"))
     60 (test "Unlock a tag" (void) ((storage-unlock-tag! w) "TEST"))
     61 (test "Tag is no longer locked" #f ((storage-tag-locked? w) "TEST"))
     62 (test "Tag reads back" "TEST123" ((storage-tag w) "TEST"))
     63 (test "Tag list works" (list "TEST") ((storage-all-tags w)))
     64 (test "Remove tag" (void) ((storage-remove-tag! w) "TEST"))
     65
     66 (test "Nonexistant tag is not locked" #f ((storage-tag-locked? w) "NONEXISTANT"))
     67 (test "Lock a nonexistant tag" #t ((storage-lock-tag! w) "NONEXISTANT"))
     68 (test "Nonexistant tag is now locked" #t ((storage-tag-locked? w) "NONEXISTANT"))
     69 (test "Lock a nonexistant tag again" #f ((storage-lock-tag! w) "NONEXISTANT"))
     70 (test "Nonexistant tag is still locked" #t ((storage-tag-locked? w) "NONEXISTANT"))
     71 (test "Unlock a locked nonexistant tag" (void) ((storage-unlock-tag! w) "NONEXISTANT"))
     72 (test "Nonexistant tag is no longer locked" #f ((storage-tag-locked? w) "NONEXISTANT"))
     73
     74 (test "Close storage" (void) ((storage-close! be)))))
    6175
    6276(define (key-stream-cat a ks-hash ks-type level)
     
    6781            (for-each (lambda (subkey)
    6882               (key-stream-cat a subkey ks-type (+ level 1)))
    69                (deserialise-key-stream (archive-get a ks-hash))))
     83               (deserialise-key-stream (archive-get a ks-hash type))))
    7084      (printf "kleaf(~A): ~A (~A)\n" level ks-hash type)))
    7185
     
    7993               (for-each (lambda (subkey)
    8094                  (sexpr-stream-cat a subkey leaf-type ss-type (+ level 1)))
    81                   (deserialise-key-stream (archive-get a ss-hash)))))
     95                  (deserialise-key-stream (archive-get a ss-hash type)))))
    8296      ((eq? type leaf-type)
    8397         (begin ; leaf node
     
    8599               (for-each (lambda (sexpr)
    86100                  (printf " ~A\n" sexpr))
    87                   (deserialise-sexpr-stream (archive-get a ss-hash)))))))
     101                  (deserialise-sexpr-stream (archive-get a ss-hash type)))))))
    88102
    89103(define (check-dir-is-empty store-path)
     
    135149               (test "Data goes into archive" (void) (archive-put! a test-key test-data 'test))
    136150               (test-assert "Data now exists in archive" (archive-exists? a test-key))
    137                (test "Data reads back" test-list (u8vector->list (archive-get a test-key)))
     151               (test "Data reads back" test-list (u8vector->list (archive-get a test-key 'test)))
    138152
    139153               (if (archive-unlinkable? a)
     
    485499
    486500                 (test-assert "Directory has the same key" (string=? dir-key dir2-key))
     501                 (test "Log a message" (void) (archive-log! a 'info #f "This is a test"))
    487502
    488503                 (test-define-values "Tag it as a snapshot" (sk2)
     
    500515                                        ('mtime . _)
    501516                                        ('contents . dir2-key*)
    502                                         ('stats . _))
     517                                        ('stats . _)
     518                                        ('log . (('info _ #f "This is a test"))))
    503519                                       (('mtime . _)
    504520                                        ('contents . dir-key*)
    505                                         ('stats . _)))
     521                                        ('stats . _)
     522                                        ('log)))
    506523                                      (and (string=? sk1 sk1*)
    507524                                           (string=? dir2-key dir2-key*)
     
    511528                 (test-define-values "Walk the tag list with fold-archive-node" (root)
    512529                                     (fold-archive-node a '() (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
    513                  (test-assert "Root history has expected form"
     530                 (test-assert "Root listing has expected form"
    514531                              (match root
    515532                                     (((('tag . "Test")
    516533                                        "Test"
    517534                                        'tag
    518                                         ('current . sk2*)))
     535                                        ('current . sk2*)
     536                                        ('locked . #f)))
    519537                                      (string=? sk2 sk2*))
    520538                                     (else #f)))
     
    529547                                        ('mtime . _)
    530548                                        ('contents . dir-key*)
    531                                         ('stats . _))
     549                                        ('stats . _)
     550                                        ('log . (('info _ #f "This is a test"))))
    532551                                       (dir-key-c**
    533552                                        _
     
    536555                                        ('mtime . _)
    537556                                        ('contents . dir-key**)
    538                                         ('stats . _))
     557                                        ('stats . _)
     558                                        ('log . (('info _ #f "This is a test"))))
    539559                                       (dir-key-c***
    540560                                        _
     
    542562                                        ('mtime . _)
    543563                                        ('contents . dir-key***)
    544                                         ('stats . _)))
     564                                        ('stats . _)
     565                                        ('log)))
    545566                                      (and
    546567                                       (string=? sk1 sk1*)
     
    555576                 (test-define-values "Walk the root directory with fold-archive-node" (dir)
    556577                                     (fold-archive-node a dir-key (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
    557                  ; FIXME: Write a giant match to match this bad boy...
    558578                 (if (zero? (current-user-id))
    559                      (test-assert "Directory history has the expected form (as root)"
     579                     (test-assert "Directory listing has the expected form (as root)"
    560580                                  (match dir
    561581                                         (((#f "block-special" 'block-device (number . 123) . _)
     
    566586                                           (#f "plain-file2" 'file . _)) #t)
    567587                                         (else #f)))
    568                      (test-assert "Directory history has the expected form (not as root)"
     588                     (test-assert "Directory listing has the expected form (not as root)"
    569589                                  (match dir
    570590                                         (((_ "directory" 'dir . _)
     
    585605 (create-directory "./tmp/be1")
    586606 (test-define "Open storage" be (import-storage "backend-fs fs ./tmp/be1"))
    587  (test-backend be)
    588  (test "Close storage" (void) ((storage-close! be))))
     607 (test-backend be))
    589608
    590609(test-group "Splitlog backend"
    591610 (create-directory "./tmp/be3")
    592  (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be3 ./tmp/be3/metadata 1024"))
    593  (test-backend be)
    594  (test "Close storage" (void) ((storage-close! be))))
     611 (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be3 ./tmp/be3/metadata"))
     612 (test "Set max file size to 1024" '((result . "Done")) ((storage-admin! be) '(set-max-logfile-size! 1024)))
     613 (test-backend be))
    595614
    596615(test-group "Limited cached splitlog backend"
    597616 (create-directory "./tmp/be4")
    598  (test-define "Open storage" be (import-storage "backend-cache ./tmp/be4-cache \"backend-fs splitlog ./tmp/be4 ./tmp/be4/metadata 1024\""))
     617 (test-define "Open storage" be (import-storage "backend-cache ./tmp/be4-cache \"backend-fs splitlog ./tmp/be4 ./tmp/be4/metadata\""))
    599618 (test-define "Wrap in block-limiter" lbe (backend-limit-block-size be 1024))
    600  (test-backend lbe)
    601  (test "Close storage" (void) ((storage-close! lbe))))
     619 (test-backend lbe))
    602620
    603621(test-group "Filesystem backend archive"
     
    615633(test-group "Splitlog backend archive"
    616634 (create-directory "./tmp/be7")
    617  (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be7 ./tmp/be7/metadata 1024")) #f #t))
     635 (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be7 ./tmp/be7/metadata")) #f #t))
     636 (test "Set max file size to 1024" '((result . "Done")) (archive-admin! be '(set-max-logfile-size! 1024)))
    618637 (test-archive be "./tmp/be7")
    619638 (test "Close archive" (void) (archive-close! be)))
     
    621640(test-group "Splitlog backend archive plus file cache"
    622641 (create-directory "./tmp/be8")
    623  (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))
     642 (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be8 ./tmp/be8/metadata") (file-cache "./tmp/be8-file-cache")) #f #t))
     643 (test "Set max file size to 1024" '((result . "Done")) (archive-admin! be '(set-max-logfile-size! 1024)))
    624644 (test-archive be "./tmp/be8")
    625645 (test "Close archive" (void) (archive-close! be)))
  • release/4/ugarit/trunk/ugarit-backend.scm

    r25565 r25570  
    1818         storage-tag-locked?
    1919         storage-unlock-tag!
     20         storage-admin!
    2021         storage-close!
    2122
     23         backend-log!
     24
    2225         export-storage! ; Export a storage via stdin/stdout
     26         export-storage-error!
    2327         import-storage ; Create a storage from a command line
    2428         )
     
    3135(use posix)
    3236(use srfi-4)
    33 
     37(use data-structures)
     38(use miscmacros)
     39
     40; Backends can call the procedure found in this paramter to log
     41; things. type should be 'warning, 'error or 'info. message should
     42; be any string.
     43(define backend-log! (make-parameter
     44                      (lambda (type message)
     45                        (error "No backend log handler has been defined"))))
    3446
    3547(define-record storage
     
    5062  tag-locked? ; Procedure: (tag-locked? name) - returns #t if the tag is locked, #f otherwise
    5163  unlock-tag! ; Procedure: (unlock-tag! name) - unlocks the named tag
     64  admin! ; Procedure: (admin! command) - returns an alist
    5265  close!)  ; Procedure: (close!) - closes the storage engine
    5366
    54 (define *magic* 'ugarit-backend-protocol-1)
     67(define *magic-v1* 'ugarit-backend-protocol-1)
     68(define *magic-v2* 'ugarit-backend-protocol-2)
    5569
    5670(define (describe-exception exn)
    57   (list (##sys#slot exn 1) (##sys#slot exn 2)))
    58 
    59 (define-syntax with-error-reporting
    60   (er-macro-transformer
    61    (lambda (e r c)
    62      (let ((body (cdr e)))
    63        `(,(r 'call-with-current-continuation)
    64          (,(r 'lambda) (,(r 'escape))
    65           (,(r 'with-exception-handler)
    66            (,(r 'lambda) (,(r 'k))
    67             (,(r 'write) (,(r 'list) "error" (,(r 'describe-exception) ,(r 'k))))
    68             (,(r 'escape) #f))
    69            (,(r 'lambda) ()
    70             ,@body))))))))
     71  (sprintf "~a: ~s in ~a"
     72           ((condition-property-accessor 'exn 'message "Unknown error") exn)
     73           ((condition-property-accessor 'exn 'arguments '()) exn)
     74           ((condition-property-accessor 'exn 'location (void)) exn)))
     75
     76; Return the result of the body, and any logs
     77(define-syntax-rule (with-error-reporting-and-result body ...)
     78  (handle-exceptions
     79   exn (write (list "error" (describe-exception exn)))
     80   (let ((log (make-queue)))
     81     (parameterize ((backend-log!
     82                     (lambda (type message)
     83                       (queue-add! log (cons type message))
     84                       (void))))
     85                   (let ((result (begin body ...)))
     86                     (write (list (queue->list log) result)))))))
     87
     88; Return the result of the body as a data block, and any logs
     89(define-syntax-rule (with-error-reporting-and-block body ...)
     90  (handle-exceptions
     91   exn (write (list "error" (describe-exception exn)))
     92   (let ((log (make-queue)))
     93     (parameterize ((backend-log!
     94                     (lambda (type message)
     95                       (queue-add! log (cons type message))
     96                       (void))))
     97                   (let ((result (begin body ...)))
     98                     (if result
     99                         (begin
     100                           (write (list (queue->list log) (u8vector-length result)))
     101                           (write-u8vector result))
     102                         (write (list (queue->list log) #f))))))))
     103
     104; Return any logs
     105(define-syntax-rule (with-error-reporting body ...)
     106  (handle-exceptions
     107   exn (write (list "error" (describe-exception exn)))
     108   (let ((log (make-queue)))
     109     (parameterize ((backend-log!
     110                     (lambda (type message)
     111                       (queue-add! log (cons type message))
     112                       (void))))
     113                   (let ((result (begin body ...)))
     114                     (write (list (queue->list log))))))))
     115
     116(define (export-storage-error! message)
     117  (set-buffering-mode! (current-output-port) #:none)
     118
     119  ; Write the error header
     120  (write *magic-v2*) (newline)
     121  (write (list "error" message)))
    71122
    72123;; Given a storage object, provide the storage remote access protocol
    73124;; via current-input-port / current-output-port until the storage is closed
    74125;; via the protocol.
    75 (define (export-storage! storage)
     126(define (export-storage! storage-thunk)
    76127  (set-buffering-mode! (current-output-port) #:none)
    77128
    78129  ; Write the header
    79   (write *magic*) (newline)
    80   (write (list (storage-max-block-size storage)
    81                (storage-writable? storage)
    82                (storage-unlinkable? storage)))
    83 
    84   ; Engage command loop
    85   (let loop ()
    86     (newline)
    87     (let ((command (read)))
    88       (if (eof-object? command)
    89           (begin
    90             (with-error-reporting
    91              ((storage-close! storage))
    92              (write "goodbye"))
    93             (void))
    94           (match
    95            command
    96 
    97            (('put! key type length)
    98             (let ((data (read-u8vector length)))
    99               (with-error-reporting
    100                ((storage-put! storage) key data type)
    101                (write #t)))
    102             (loop))
    103 
    104            (('flush!)
    105             (with-error-reporting
    106              ((storage-flush! storage))
    107              (write #t))
    108             (loop))
    109 
    110            (('exists? key)
    111             (with-error-reporting
    112              (write ((storage-exists? storage) key)))
    113             (loop))
    114 
    115            (('get key)
    116             (with-error-reporting
    117              (let ((data ((storage-get storage) key)))
    118                (if data
    119                    (begin
    120                     (write (list (u8vector-length data)))
    121                     (write-u8vector data))
    122                    (write #f))))
    123             (loop))
    124 
    125            (('link! key)
    126             (with-error-reporting
    127              ((storage-link! storage) key)
    128              (write #t))
    129             (loop))
    130 
    131            (('unlink! key)
    132             (with-error-reporting
    133              (let ((data ((storage-unlink! storage) key)))
    134                (if data
    135                    (begin
    136                      (write (list (u8vector-length data)))
    137                      (write-u8vector data))
    138                    (write #f))))
    139             (loop))
    140 
    141            (('set-tag! name key)
    142             (with-error-reporting
    143              ((storage-set-tag! storage) name key)
    144              (write #t))
    145             (loop))
    146 
    147            (('tag name)
    148             (with-error-reporting
    149              (write ((storage-tag storage) name)))
    150             (loop))
    151 
    152            (('all-tags)
    153             (with-error-reporting
    154              (write ((storage-all-tags storage))))
    155             (loop))
    156 
    157            (('remove-tag! name)
    158             (with-error-reporting
    159              ((storage-remove-tag! storage) name)
    160              (write #t))
    161             (loop))
    162 
    163            (('lock-tag! name)
    164             (with-error-reporting
    165              (let  ((result ((storage-lock-tag! storage) name)))
    166                (write result)))
    167             (loop))
    168 
    169            (('tag-locked? name)
    170             (with-error-reporting
    171              (write ((storage-tag-locked? storage) name)))
    172             (loop))
    173 
    174            (('unlock-tag! name)
    175             (with-error-reporting
    176              ((storage-unlock-tag! storage) name)
    177              (write #t))
    178             (loop))
    179 
    180            (('close!)
    181             (with-error-reporting
    182              ((storage-close! storage))
    183              (write "goodbye"))
    184             (void))
    185 
    186            (else
    187             (write (list "error" (sprintf "Bad command ~s" command)))
    188             (loop)))))))
    189 
    190 (define (read-response port)
     130  (write *magic-v2*) (newline)
     131  (let ((storage #f))
     132
     133    (with-error-reporting-and-result ; Initialise and send the header
     134     (let ((storage* (storage-thunk)))
     135       (set! storage storage*)        ; This feels hacky
     136       (list (storage-max-block-size storage)
     137             (storage-writable? storage)
     138             (storage-unlinkable? storage))))
     139
     140                                        ; Engage command loop
     141    (if storage
     142        (let loop ()
     143          (newline)
     144          (let ((command (read)))
     145            (if (eof-object? command)
     146                (begin
     147                  (with-error-reporting
     148                   ((storage-close! storage)))
     149                  (void))
     150                (match
     151                 command
     152
     153                 (('put! key type length)
     154                  (let ((data (read-u8vector length)))
     155                    (with-error-reporting
     156                     ((storage-put! storage) key data type)))
     157                  (loop))
     158
     159                 (('flush!)
     160                  (with-error-reporting
     161                   ((storage-flush! storage)))
     162                  (loop))
     163
     164                 (('exists? key)
     165                  (with-error-reporting-and-result
     166                   ((storage-exists? storage) key))
     167                  (loop))
     168
     169                 (('get key)
     170                  (with-error-reporting-and-block
     171                   ((storage-get storage) key))
     172                  (loop))
     173
     174                 (('link! key)
     175                  (with-error-reporting
     176                   ((storage-link! storage) key))
     177                  (loop))
     178
     179                 (('unlink! key)
     180                  (with-error-reporting-and-block
     181                   ((storage-unlink! storage) key))
     182                  (loop))
     183
     184                 (('set-tag! name key)
     185                  (with-error-reporting
     186                   ((storage-set-tag! storage) name key))
     187                  (loop))
     188
     189                 (('tag name)
     190                  (with-error-reporting-and-result
     191                   ((storage-tag storage) name))
     192                  (loop))
     193
     194                 (('all-tags)
     195                  (with-error-reporting-and-result
     196                   ((storage-all-tags storage)))
     197                  (loop))
     198
     199                 (('remove-tag! name)
     200                  (with-error-reporting
     201                   ((storage-remove-tag! storage) name))
     202                  (loop))
     203
     204                 (('lock-tag! name)
     205                  (with-error-reporting-and-result
     206                   ((storage-lock-tag! storage) name))
     207                  (loop))
     208
     209                 (('tag-locked? name)
     210                  (with-error-reporting-and-result
     211                   ((storage-tag-locked? storage) name))
     212                  (loop))
     213
     214                 (('unlock-tag! name)
     215                  (with-error-reporting
     216                   ((storage-unlock-tag! storage) name))
     217                  (loop))
     218
     219                 (('admin! command)
     220                  (with-error-reporting-and-result
     221                   ((storage-admin! storage) command))
     222                  (loop))
     223
     224                 (('close!)
     225                  (with-error-reporting
     226                   ((storage-close! storage)))
     227                  (void))
     228
     229                 (else
     230                  (write (list "error" (sprintf "Bad command ~s" command)))
     231                  (loop)))))))))
     232
     233(define (read-response-v1 port)
    191234  (let ((response (read port)))
    192235   (match response
     
    194237          (else response))))
    195238
    196 (define (read-response-body port)
    197   (let ((response (read-response port)))
     239(define (read-response-v1-body port)
     240  (let ((response (read-response-v1 port)))
    198241    (if response
    199242        (read-u8vector (car response) port)
    200243        #f)))
     244
     245(define (import-storage-v1 command-line debug responses commands pid)
     246  (let ((header (read responses)))
     247    (if debug (print "~a: read header" command-line header))
     248    (if (not (list? header))
     249        (error "Invalid backend protocol header" header))
     250    (if (not (= (length header) 3))
     251        (error "Invalid backend protocol header" header))
     252    (let ((max-block-size (car header))
     253          (writable? (cadr header))
     254          (unlinkable? (caddr header)))
     255      (make-storage
     256       max-block-size
     257       writable?
     258       unlinkable?
     259
     260       (lambda (key data type)  ; put!
     261         (if debug (printf "~a: put!" command-line))
     262         (write `(put! ,key ,type ,(u8vector-length data)) commands)
     263         (write-u8vector data commands)
     264         (read-response-v1 responses)
     265         (void))
     266
     267       (lambda ()                  ; flush!
     268         (if debug (printf "~a: flush!" command-line))
     269         (write `(flush!) commands)
     270         (read-response-v1 responses)
     271         (void))
     272
     273       (lambda (key)            ; exists?
     274         (if debug (printf "~a: exists?" command-line))
     275         (write `(exists? ,key) commands)
     276         (read-response-v1 responses))
     277
     278       (lambda (key)            ; get
     279         (if debug (printf "~a: get" command-line))
     280         (write `(get ,key) commands)
     281         (read-response-v1-body responses))
     282
     283       (lambda (key)            ; link!
     284         (if debug (printf "~a: link!" command-line))
     285         (write `(link! ,key) commands)
     286         (read-response-v1 responses)
     287         (void))
     288
     289       (lambda (key)            ; unlink!
     290         (if debug (printf "~a: unlink! ~s" command-line key))
     291         (write `(unlink! ,key) commands)
     292         (read-response-v1-body responses))
     293
     294       (lambda (name key)               ; set-tag!
     295         (if debug (printf "~a: set-tag!" command-line))
     296         (write `(set-tag! ,name ,key) commands)
     297         (read-response-v1 responses)
     298         (void))
     299
     300       (lambda (name)           ; tag
     301         (if debug (printf "~a: tag" command-line))
     302         (write `(tag ,name) commands)
     303         (read-response-v1 responses))
     304
     305       (lambda ()                       ; all-tags
     306         (if debug (printf "~a: all-tags" command-line))
     307         (write `(all-tags) commands)
     308         (read-response-v1 responses))
     309
     310       (lambda (name)           ; remove-tag!
     311         (if debug (printf "~a: remove-tag!" command-line))
     312         (write `(remove-tag! ,name) commands)
     313         (read-response-v1 responses)
     314         (void))
     315
     316       (lambda (name)           ; lock-tag!
     317         (if debug (printf "~a: lock-tag!" command-line))
     318         (write `(lock-tag! ,name) commands)
     319         (read-response-v1 responses))
     320
     321       (lambda (name)           ; tag-locked?
     322         (if debug (printf "~a: tag-locked?" command-line))
     323         (write `(tag-locked? ,name) commands)
     324         (read-response-v1 responses))
     325
     326       (lambda (name)           ; unlock-tag!
     327         (if debug (printf "~a: unlock-tag!" command-line))
     328         (write `(unlock-tag! ,name) commands)
     329         (read-response-v1 responses)
     330         (void))
     331
     332       (lambda ()                       ; close!
     333         (if debug (printf "~a: close!!" command-line))
     334         (write '(close!) commands)
     335         (read-response-v1 responses)
     336         (close-input-port responses)
     337         (close-output-port commands)
     338         (void))))))
     339
     340(define (read-response-v2 port)
     341  (let ((response (read port)))
     342   (match response
     343          (("error" err) (error (sprintf "Error from backend: ~s" err)))
     344          ((log value)
     345           (for-each (lambda (logentry)
     346                       ((backend-log!) (car logentry) (cdr logentry)))
     347                     log)
     348           value)
     349          ((log)
     350           (for-each (lambda (logentry)
     351                       ((backend-log!) (car logentry) (cdr logentry)))
     352                     log)
     353           (void))
     354          (else (error "Malformed response from backend" response)))))
     355
     356(define (read-response-v2-body port)
     357  (let ((length (read-response-v2 port)))
     358    (if length
     359        (read-u8vector length port)
     360        #f)))
     361
     362(define (import-storage-v2 command-line debug responses commands pid)
     363  (let ((header (read-response-v2 responses)))
     364    (if debug (print "~a: read header" command-line header))
     365    (if (not (list? header))
     366        (error "Invalid backend protocol header" header))
     367    (if (not (= (length header) 3))
     368        (error "Invalid backend protocol header" header))
     369    (let ((max-block-size (car header))
     370          (writable? (cadr header))
     371          (unlinkable? (caddr header)))
     372      (make-storage
     373       max-block-size
     374       writable?
     375       unlinkable?
     376
     377       (lambda (key data type)  ; put!
     378         (if debug (printf "~a: put!" command-line))
     379         (write `(put! ,key ,type ,(u8vector-length data)) commands)
     380         (write-u8vector data commands)
     381         (read-response-v2 responses)
     382         (void))
     383
     384       (lambda ()                  ; flush!
     385         (if debug (printf "~a: flush!" command-line))
     386         (write `(flush!) commands)
     387         (read-response-v2 responses)
     388         (void))
     389
     390       (lambda (key)            ; exists?
     391         (if debug (printf "~a: exists?" command-line))
     392         (write `(exists? ,key) commands)
     393         (read-response-v2 responses))
     394
     395       (lambda (key)            ; get
     396         (if debug (printf "~a: get" command-line))
     397         (write `(get ,key) commands)
     398         (read-response-v2-body responses))
     399
     400       (lambda (key)            ; link!
     401         (if debug (printf "~a: link!" command-line))
     402         (write `(link! ,key) commands)
     403         (read-response-v2 responses)
     404         (void))
     405
     406       (lambda (key)            ; unlink!
     407         (if debug (printf "~a: unlink! ~s" command-line key))
     408         (write `(unlink! ,key) commands)
     409         (read-response-v2-body responses))
     410
     411       (lambda (name key)               ; set-tag!
     412         (if debug (printf "~a: set-tag!" command-line))
     413         (write `(set-tag! ,name ,key) commands)
     414         (read-response-v2 responses)
     415         (void))
     416
     417       (lambda (name)           ; tag
     418         (if debug (printf "~a: tag" command-line))
     419         (write `(tag ,name) commands)
     420         (read-response-v2 responses))
     421
     422       (lambda ()                       ; all-tags
     423         (if debug (printf "~a: all-tags" command-line))
     424         (write `(all-tags) commands)
     425         (read-response-v2 responses))
     426
     427       (lambda (name)           ; remove-tag!
     428         (if debug (printf "~a: remove-tag!" command-line))
     429         (write `(remove-tag! ,name) commands)
     430         (read-response-v2 responses)
     431         (void))
     432
     433       (lambda (name)           ; lock-tag!
     434         (if debug (printf "~a: lock-tag!" command-line))
     435         (write `(lock-tag! ,name) commands)
     436         (read-response-v2 responses))
     437
     438       (lambda (name)           ; tag-locked?
     439         (if debug (printf "~a: tag-locked?" command-line))
     440         (write `(tag-locked? ,name) commands)
     441         (read-response-v2 responses))
     442
     443       (lambda (name)           ; unlock-tag!
     444         (if debug (printf "~a: unlock-tag!" command-line))
     445         (write `(unlock-tag! ,name) commands)
     446         (read-response-v2 responses)
     447         (void))
     448
     449       (lambda (command)                ; admin!
     450         (if debug (printf "~a: admin!" command-line))
     451         (write `(admin! ,command) commands)
     452         (read-response-v2 responses))
     453
     454       (lambda ()                       ; close!
     455         (if debug (printf "~a: close!!" command-line))
     456         (write '(close!) commands)
     457         (read-response-v2 responses)
     458         (close-input-port responses)
     459         (close-output-port commands)
     460         (void))))))
    201461
    202462;; Given the command line to a storage remote access protocol server,
     
    213473     (let ((magic (read responses)))
    214474       (if debug (print "~a: read magic ~a" command-line magic))
    215        (if (not (equal? magic *magic*))
    216            (error "Invalid backend protocol header magic" magic))
    217 
    218        (let ((header (read responses)))
    219          (if debug (print "~a: read header" command-line header))
    220          (if (not (list? header))
    221              (error "Invalid backend protocol header" header))
    222          (if (not (= (length header) 3))
    223              (error "Invalid backend protocol header" header))
    224          (let ((max-block-size (car header))
    225                (writable? (cadr header))
    226                (unlinkable? (caddr header)))
    227            (make-storage
    228             max-block-size
    229             writable?
    230             unlinkable?
    231 
    232             (lambda (key data type)     ; put!
    233               (if debug (printf "~a: put!" command-line))
    234               (write `(put! ,key ,type ,(u8vector-length data)) commands)
    235               (write-u8vector data commands)
    236               (read-response responses)
    237               (void))
    238 
    239             (lambda ()                  ; flush!
    240               (if debug (printf "~a: flush!" command-line))
    241               (write `(flush!) commands)
    242               (read-response responses)
    243               (void))
    244 
    245             (lambda (key)               ; exists?
    246               (if debug (printf "~a: exists?" command-line))
    247               (write `(exists? ,key) commands)
    248               (read-response responses))
    249 
    250             (lambda (key)               ; get
    251               (if debug (printf "~a: get" command-line))
    252               (write `(get ,key) commands)
    253               (read-response-body responses))
    254 
    255             (lambda (key)               ; link!
    256               (if debug (printf "~a: link!" command-line))
    257               (write `(link! ,key) commands)
    258               (read-response responses)
    259               (void))
    260 
    261             (lambda (key)               ; unlink!
    262               (if debug (printf "~a: unlink! ~s" command-line key))
    263               (write `(unlink! ,key) commands)
    264               (read-response-body responses))
    265 
    266             (lambda (name key)          ; set-tag!
    267               (if debug (printf "~a: set-tag!" command-line))
    268               (write `(set-tag! ,name ,key) commands)
    269               (read-response responses)
    270               (void))
    271 
    272             (lambda (name)              ; tag
    273               (if debug (printf "~a: tag" command-line))
    274               (write `(tag ,name) commands)
    275               (read-response responses))
    276 
    277             (lambda ()                  ; all-tags
    278               (if debug (printf "~a: all-tags" command-line))
    279               (write `(all-tags) commands)
    280               (read-response responses))
    281 
    282             (lambda (name)              ; remove-tag!
    283               (if debug (printf "~a: remove-tag!" command-line))
    284               (write `(remove-tag! ,name) commands)
    285               (read-response responses)
    286               (void))
    287 
    288             (lambda (name)              ; lock-tag!
    289               (if debug (printf "~a: lock-tag!" command-line))
    290               (write `(lock-tag! ,name) commands)
    291               (read-response responses))
    292 
    293             (lambda (name)              ; tag-locked?
    294               (if debug (printf "~a: tag-locked?" command-line))
    295               (write `(tag-locked? ,name) commands)
    296               (read-response responses))
    297 
    298             (lambda (name)              ; unlock-tag!
    299               (if debug (printf "~a: unlock-tag!" command-line))
    300               (write `(unlock-tag! ,name) commands)
    301               (read-response responses)
    302               (void))
    303 
    304             (lambda ()                  ; close!
    305               (if debug (printf "~a: close!!" command-line))
    306               (write '(close!) commands)
    307               (read-response responses)
    308               (close-input-port responses)
    309               (close-output-port commands)
    310               (void)))))))))
     475       (cond
     476        ((equal? magic *magic-v1*)
     477         (import-storage-v1 command-line debug responses commands pid))
     478        ((equal? magic *magic-v2*)
     479         (import-storage-v2 command-line debug responses commands pid))
     480        (else (error "Unrecognised backend protocol header magic" magic)))))))
     481
    311482
    312483)
  • release/4/ugarit/trunk/ugarit-core.scm

    r25566 r25570  
    1212         archive-writable?
    1313         archive-unlinkable?
     14         archive-log!
    1415         archive-exists?
    1516         archive-get
     
    2526         archive-link!
    2627         archive-unlink!
     28         archive-admin!
    2729         archive-close!
    2830
     
    111113(use ugarit-backend)
    112114(use sql-de-lite)
    113 
     115(use data-structures)
     116
     117;;
     118;; LOG EVENTS
     119;;
     120
     121(define-record event
     122  type                                  ; error/warning/note
     123  time                                  ; timestamp (current-seconds)
     124  path                                  ; where applicable, #f if not
     125  message                               ; string
     126)
     127
     128(define (make-event* type path message)
     129  (let ((now (current-seconds)))
     130    (printf "~A: ~A [~A] ~A\n" type (epochtime->string now) path message)
     131    (make-event type now path message)))
    114132
    115133;;
     
    131149  global-directory-rules ; top-level directory rules
    132150
     151  ; FIXME: Take out all these counters, including file-cache ones, and
     152  ; the event log into a separate record and make a parameter to
     153  ; contain them, and apply counters if that parameter is non-#f,
     154  ; rather than keeping them in the archive 'god object' as multiple
     155  ; snapshots could be happening to the same archive, etc; a snapshot
     156  ; is a separate object to an archive.
     157
    133158  ; Snapshot counters
    134159  (setter snapshot-blocks-stored)              ; Blocks written to storage
     
    144169  (setter file-cache-hits)              ; count of file cache hits
    145170  (setter file-cache-bytes)                 ; count of file cache bytes saved
     171
     172  ; Event log
     173  event-log    ; a queue (see data-structures unit) of event records
    146174  )
     175
     176(define (archive-log! archive type path message)
     177  (queue-add! (archive-event-log archive)
     178              (make-event* type path message))
     179  (void))
     180
     181(define-syntax-rule (with-backend-logging archive body ...)
     182  (parameterize ((backend-log! (lambda (type message)
     183                                 (archive-log! archive type #f message)
     184                                 (void))))
     185                body ...))
    147186
    148187(define file-cache-commit-interval 1000)
     
    150189(define (file-cache-put! archive file-path mtime size key)
    151190  (when (> file-cache-commit-interval (archive-file-cache-updates-uncommitted archive))
    152         ((storage-flush! (archive-storage archive))) ; Flush the storage before we commit our cache, for crash safety
     191        ((with-backend-logging archive (storage-flush! (archive-storage archive)))) ; Flush the storage before we commit our cache, for crash safety
    153192        (exec (sql (archive-file-cache archive) "commit;"))
    154193        (exec (sql (archive-file-cache archive) "begin;"))
     
    186225    ((1) (blob->u8vector/shared (string->blob (z3:decode-buffer (blob->string (u8vector->blob/shared (subu8vector block 1 (u8vector-length block)))))))) ; deflate
    187226    ((2) (blob->u8vector/shared (lzma:decompress (u8vector->blob/shared (subu8vector block 1 (u8vector-length block)))))))) ; lzma
     227
     228#|
     229function hmac (key, message)
     230    if (length(key) > blocksize) then
     231        key = hash(key) // keys longer than blocksize are shortened
     232    end if
     233    if (length(key) < blocksize) then
     234        key = key ∥ [0x00 * (blocksize - length(key))] // keys shorter than blocksize are zero-padded ('∥' is concatenation)
     235    end if
     236   
     237    o_key_pad = [0x5c * blocksize] ⊕ key // Where blocksize is that of the underlying hash function
     238    i_key_pad = [0x36 * blocksize] ⊕ key // Where ⊕ is exclusive or (XOR)
     239   
     240    return hash(o_key_pad ∥ hash(i_key_pad ∥ message)) // Where '∥' is concatenation
     241end function
     242|#
    188243
    189244(define (choose-hash-function config)
     
    270325                                        ; Valid flags:
    271326                                        ; double-check - check correctness lots, even if it costs efficiency
     327
    272328(define (open-archive config store-atime? store-ctime?)
    273329  (let ((*storage* #f)
     
    277333        (*double-check?* #f)
    278334        (*file-cache* #f)
    279         (*global-rules* '()))
     335        (*global-rules* '())
     336        (setup-log (make-queue)))
    280337
    281338    (for-each (lambda (confentry)
     
    283340                       ('double-check (set! *double-check?* #t))
    284341                       (('storage command-line)
    285                         (set! *storage* (import-storage command-line)))
     342                        (set! *storage*
     343                              (parameterize ((backend-log! (lambda (type message)
     344                                                             (queue-add! setup-log (make-event* type #f message))
     345                                                             (void))))
     346                                            (import-storage command-line))))
    286347                       (('hash . conf) (set! *hash* conf))
    287348                       (('compression . conf) (set! *compression* conf))
     
    322383       (if *file-cache* (sql *file-cache* "SELECT key FROM files WHERE path = ? AND mtime = ? AND size = ?") #f)
    323384       (if *file-cache* (sql *file-cache* "INSERT OR REPLACE INTO files (path,mtime,size,key) VALUES (?,?,?,?)") #f)
    324        0 0 0))))
     385       0 0 0
     386       ; event log
     387       setup-log))))
    325388
    326389                                        ; Take a block, and return a compressed and encrypted block
     
    355418  (inc! (archive-snapshot-bytes-skipped archive) (u8vector-length data)))
    356419
     420(define (epochtime->string e)
     421  (let ((localtime (seconds->local-time e)))
     422    (string-append
     423     (string-pad (number->string (+ 1900 (vector-ref localtime 5))) 4 #\0)
     424     "-"
     425     (string-pad (number->string (+ 1 (vector-ref localtime 4))) 2 #\0)
     426     "-"
     427     (string-pad (number->string (vector-ref localtime 3)) 2 #\0)
     428     " "
     429     (string-pad (number->string (vector-ref localtime 2)) 2 #\0)
     430     ":"
     431     (string-pad (number->string (vector-ref localtime 1)) 2 #\0)
     432     ":"
     433     (string-pad (number->string (vector-ref localtime 0)) 2 #\0))))
     434
    357435(define (archive-put! archive key data type)
    358   (when (not (archive-writable? archive))
    359       (signal (make-property-condition 'exn 'location 'archive-put! 'message "This isn't a writable archive")))
    360   ((storage-put! (archive-storage archive)) key (wrap-block archive data) type)
     436  (unless (archive-writable? archive)
     437      (error 'archive-put! "This isn't a writable archive"))
     438  ((with-backend-logging archive (storage-put! (archive-storage archive))) key (wrap-block archive data) type)
    361439  (inc! (archive-snapshot-blocks-stored archive))
    362440  (inc! (archive-snapshot-bytes-stored archive) (u8vector-length data))
     
    364442
    365443(define (archive-flush! archive)
    366   ((storage-flush! (archive-storage archive))) ; Flush the storage first, to ensure crash safety
     444  ((with-backend-logging archive (storage-flush! (archive-storage archive)))) ; Flush the storage first, to ensure crash safety
    367445  (when (archive-file-cache archive)
    368446        (exec (sql (archive-file-cache archive) "commit;"))
     
    371449
    372450(define (archive-exists? archive key)
    373   ((storage-exists? (archive-storage archive)) key))
    374 
    375 (define (archive-get archive key) ;; FIXME: Avoid fetching type. Pass in expected type from caller?
    376   (let ((data (unwrap-block archive ((storage-get (archive-storage archive)) key))))
    377     (assert (string=? key ((archive-hash archive) data (archive-exists? archive key)))
    378             (sprintf "CONSISTENCY CHECK FAILURE: Block ~A comes back with hash ~A\n" key ((archive-hash archive) data (archive-exists? archive key))))
     451  ((with-backend-logging archive (storage-exists? (archive-storage archive))) key))
     452
     453(define (archive-get archive key type)
     454  (let* ((raw-data ((with-backend-logging archive (storage-get (archive-storage archive))) key))
     455         (data (if raw-data
     456                   (unwrap-block archive raw-data)
     457                   (error 'archive-get (sprintf "Nonexistant block ~A ~A" key type)))))
     458    (unless (string=? key ((archive-hash archive) data type))
     459            (error 'archive-get (sprintf "Consistency check failure: asked for ~A, got ~A" key ((archive-hash archive) data type))))
    379460    data))
    380461
    381462(define (archive-link! archive key)
    382   (if (not (archive-writable? archive))
    383       (signal (make-property-condition 'exn 'location 'archive-link! 'message "This isn't a writable archive")))
    384   ((storage-link! (archive-storage archive)) key))
     463  (unless (archive-writable? archive)
     464      (error 'archive-link! "This isn't a writable archive"))
     465  ((with-backend-logging archive (storage-link! (archive-storage archive))) key))
    385466
    386467(define (archive-unlink! archive key)
    387   (if (not (archive-writable? archive))
    388       (signal (make-property-condition 'exn 'location 'archive-link! 'message "This isn't an unlinkable archive - it's append-only")))
    389   (let ((result ((storage-unlink! (archive-storage archive)) key)))
     468  (unless (archive-writable? archive)
     469      (error 'archive-unlink! "This isn't a writable archive"))
     470  (let ((result ((with-backend-logging archive (storage-unlink! (archive-storage archive))) key)))
    390471    (if result
    391472        (unwrap-block archive result)
    392473        #f)))
    393474
     475(define (archive-admin! archive command)
     476  ((with-backend-logging archive (storage-admin! (archive-storage archive))) command))
     477
    394478(define (archive-set-tag! archive tag key)
    395   (if (not (archive-writable? archive))
    396       (signal (make-property-condition 'exn 'location 'archive-set-tag! 'message "This isn't a writable archive")))
    397   ((storage-set-tag! (archive-storage archive)) tag key))
     479  (unless (archive-writable? archive)
     480      (error 'archive-set-tag! "This isn't a writable archive"))
     481  ((with-backend-logging archive (storage-set-tag! (archive-storage archive))) tag key))
    398482
    399483(define (archive-tag archive tag)
    400   ((storage-tag (archive-storage archive)) tag))
     484  ((with-backend-logging archive (storage-tag (archive-storage archive))) tag))
    401485
    402486(define (archive-all-tags archive)
    403   ((storage-all-tags (archive-storage archive))))
     487  ((with-backend-logging archive (storage-all-tags (archive-storage archive)))))
    404488
    405489(define (archive-remove-tag! archive tag)
    406   (if (not (archive-writable? archive))
    407       (signal (make-property-condition 'exn 'location 'archive-remove-tag! 'message "This isn't a writable archive")))
    408   ((storage-remove-tag! (archive-storage archive)) tag))
     490  (unless (archive-writable? archive)
     491      (error 'archive-remove-tag! "This isn't a writable archive"))
     492  ((with-backend-logging archive (storage-remove-tag! (archive-storage archive))) tag))
    409493
    410494(define (archive-lock-tag! archive tag)
    411   (if (not (archive-writable? archive))
    412       (signal (make-property-condition 'exn 'location 'archive-lock-tag! 'message "This isn't a writable archive")))
     495  (unless (archive-writable? archive)
     496      (error 'archive-lock-tag! "This isn't a writable archive"))
    413497  (let loop ((tries-left 10))
    414498    (if (zero? tries-left)
    415499        (signal (make-property-condition 'exn 'location 'archive-lock-tag! 'message (sprintf "We timed out attempting to lock the tag '~A'" tag)))
    416         (let ((result ((storage-lock-tag! (archive-storage archive)) tag)))
     500        (let ((result ((with-backend-logging archive (storage-lock-tag! (archive-storage archive))) tag)))
    417501          (if result
    418502              result                       ; Lock got!
     
    422506
    423507(define (archive-tag-locked? archive tag)
    424   (if (not (archive-writable? archive))
    425       #f)
    426   ((storage-tag-locked? (archive-storage archive)) tag))
     508  (unless (archive-writable? archive)
     509      (error 'archive-tag-locked? "This isn't a writable archive"))
     510  ((with-backend-logging archive (storage-tag-locked? (archive-storage archive))) tag))
    427511
    428512(define (archive-unlock-tag! archive tag)
    429   (if (not (archive-writable? archive))
    430       (signal (make-property-condition 'exn 'location 'archive-unlock-tag! 'message "This isn't a writable archive")))
    431   ((storage-unlock-tag! (archive-storage archive)) tag))
     513  (unless (archive-writable? archive)
     514      (error 'archive-unlock-tag! "This isn't a writable archive"))
     515  ((with-backend-logging archive (storage-unlock-tag! (archive-storage archive))) tag))
    432516
    433517(define (archive-close! archive)
    434   ((storage-close! (archive-storage archive))) ;; This flushes the backend before we flush the file cache, for crash safety
     518  ((with-backend-logging archive (storage-close! (archive-storage archive)))) ;; This flushes the backend before we flush the file cache, for crash safety
    435519  (when (archive-file-cache archive)
    436520        (exec (sql (archive-file-cache archive) "commit;"))
     
    585669                                        ; Recurse
    586670        (begin
    587           (let ((subkeys (deserialise-key-stream (archive-get archive key))))
     671          (let ((subkeys (deserialise-key-stream (archive-get archive key type))))
    588672            (fold
    589673             (lambda (subkey acc) (fold-key-stream archive subkey ks-type kons acc))
     
    660744  (fold-key-stream archive key 'fi
    661745                   (lambda (key type acc)
    662                      (kons (archive-get archive key) acc))
     746                     (kons (archive-get archive key type) acc))
    663747                   knil))
    664748
     
    780864                   (lambda (key found-leaf-type acc)
    781865                     (assert (eq? found-leaf-type leaf-type))
    782                      (let ((sexprs (deserialise-sexpr-stream (archive-get archive key))))
     866                     (let ((sexprs (deserialise-sexpr-stream (archive-get archive key found-leaf-type))))
    783867                       (fold
    784868                        kons
     
    852936       (for-each (lambda (filename)
    853937                   (handle-exceptions exn
    854                                       (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))
     938                                      (archive-log! archive 'error (make-pathname path filename) (sprintf "Unable to store into the archive (~a)" ((condition-property-accessor 'exn 'message "Unknown error") exn)))
    855939                                      (let* ((file-path (make-pathname path filename))
    856940                                             (stats (file-stat file-path #t))
     
    873957                                            (cond
    874958                                             ((eq? type stat/ifsock)
    875                                               (printf "WARNING: ~A is a socket, ignoring...\n" file-path))
     959                                              (archive-log! archive 'warning file-path "Ignoring a socket"))
    876960                                             ((eq? type stat/ifreg)
    877961                                              (let-values (((content-key content-reused?) (with-input-from-file file-path (lambda () (store-file! archive file-path stats)))))
     
    904988                                             (else
    905989                                        ; WTF?
    906                                               (printf "ERROR: I can't ascertain the type of ~A. Skipping it...\n" file-path)))))))
     990                                              (archive-log! archive 'error file-path "Unable to store object of unknown type")))))))
    907991                 (sort! (directory path #t) string>?))
    908992
     
    9231007                              (unlink-directory! archive (cdr (assq 'contents props)))))))))
    9241008
    925 (define (set-standard-file-metadata! path props)
     1009(define (set-standard-file-metadata! archive path props)
    9261010  (let ((mode (assq 'mode props))
    9271011        (uid (assq 'uid props))
     
    9351019    (if (or uid gid)
    9361020        (handle-exceptions exn
    937                            (printf "WARNING: It was not possible to set the uid/gid of ~a\n" path)
     1021                           (archive-log! archive 'warning path "Unable to set the uid/gid")
    9381022         (change-file-owner path
    9391023                            (if uid (cdr uid) (current-user-id))
     
    9521036      (lambda ()
    9531037        (write-file-contents archive contents-key)))
    954     (set-standard-file-metadata! path props)))
     1038    (set-standard-file-metadata! archive path props)))
    9551039
    9561040(define (extract-subdirectory! archive props path)
     
    9621046    (extract-directory! archive contents-key path)
    9631047
    964     (set-standard-file-metadata! path props)))
     1048    (set-standard-file-metadata! archive path props)))
    9651049
    9661050(define (extract-symlink! archive props path)
     
    9801064    (if (or uid gid)
    9811065        (handle-exceptions exn
    982                            (printf "WARNING: It was not possible to set the uid/gid of ~a\n" path)
     1066                           (archive-log! archive 'warning path "Unable to set the uid/gid")
    9831067         (change-link-owner path
    9841068                            (if uid (cdr uid) (current-user-id))
     
    9891073  (create-fifo path)
    9901074
    991   (set-standard-file-metadata! path props))
     1075  (set-standard-file-metadata! archive path props))
    9921076
    9931077(define (extract-block-device! archive props path)
     
    9951079
    9961080    (handle-exceptions exn
    997                        (printf "WARNING: It was not possible to recreate block device ~a\n" path)
     1081                       (archive-log! archive 'warning path "Unable to recreate block device")
    9981082
    9991083     (create-special-file path stat/ifblk number)
    1000      (set-standard-file-metadata! path props))))
     1084     (set-standard-file-metadata! archive path props))))
    10011085
    10021086(define (extract-character-device! archive props path)
     
    10041088
    10051089    (handle-exceptions exn
    1006                        (printf "WARNING: It was not possible to recreate character device ~a\n" path)
     1090                       (archive-log! archive 'warning path "Unable to recreate character device")
    10071091
    10081092     (create-special-file path stat/ifchr number)
    1009      (set-standard-file-metadata! path props))))
     1093     (set-standard-file-metadata! archive path props))))
    10101094
    10111095(define (extract-object! archive dirent target-path)
     
    10271111      (extract-character-device! archive props (make-pathname target-path name)))
    10281112     (else
    1029       (printf "ERROR: Found an object (~A) of unknown type (~A), skipping...\n" name type)))))
     1113      (archive-log! archive 'error (make-pathname target-path name) (sprintf "Unable to extract an object of unknown type ~A" type))))))
    10301114
    10311115(define (extract-directory! archive key target-path)
    10321116  (fold-sexpr-stream archive key 'd 'di
    10331117                     (lambda (dirent acc)
    1034                        (extract-object! archive dirent target-path)
     1118                       (handle-exceptions
     1119                        exn
     1120                        (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)))
     1121                        (extract-object! archive dirent target-path))
    10351122                       (void))
    10361123                     '()))
     
    10551142          (values (virgin hash) #f)))))
    10561143
    1057 (define (read-sexpr archive key)
    1058   (let ((data (archive-get archive key)))
     1144(define (read-sexpr archive key type)
     1145  (let ((data (archive-get archive key type)))
    10591146    (with-input-from-string
    10601147        (blob->string (u8vector->blob/shared data))
     
    10771164;;         'file-cache-hits
    10781165;;         'file-cache-bytes
     1166;; 'log (list of log events, each being a (type timestamp path message) list
    10791167;; Returns the snapshot's key.
    10801168(define (tag-snapshot! archive tag contents-key contents-reused? snapshot-properties)
     
    10891177                 (cons 'file-cache-hits (archive-file-cache-hits archive))
    10901178                 (cons 'file-cache-bytes (archive-file-cache-bytes archive))))
     1179         (log (map (lambda (event)
     1180                     (list (event-type event)
     1181                           (event-time event)
     1182                           (event-path event)
     1183                           (event-message event)))
     1184                   (queue->list (archive-event-log archive))))
    10911185         (snapshot
    10921186          (append
     
    10941188            (cons 'mtime (current-seconds))
    10951189            (cons 'contents contents-key)
    1096             (cons 'stats stats))
     1190            (cons 'stats stats)
     1191            (cons 'log log))
    10971192           snapshot-properties))
    10981193         (keys
     
    11131208
    11141209(define (fold-history archive snapshot-key kons knil)
    1115   (let ((snapshot (read-sexpr archive snapshot-key)))
     1210  (let ((snapshot (read-sexpr archive snapshot-key 'snapshot)))
    11161211    (if (assq 'previous snapshot)
    11171212        (kons snapshot-key snapshot
     
    11341229                    props))))
    11351230
    1136 (define (epochtime->string e)
    1137   (let ((localtime (seconds->local-time e)))
    1138     (string-append
    1139      (string-pad (number->string (+ 1900 (vector-ref localtime 5))) 4 #\0)
    1140      "-"
    1141      (string-pad (number->string (+ 1 (vector-ref localtime 4))) 2 #\0)
    1142      "-"
    1143      (string-pad (number->string (vector-ref localtime 3)) 2 #\0)
    1144      " "
    1145      (string-pad (number->string (vector-ref localtime 2)) 2 #\0)
    1146      ":"
    1147      (string-pad (number->string (vector-ref localtime 1)) 2 #\0)
    1148      ":"
    1149      (string-pad (number->string (vector-ref localtime 0)) 2 #\0))))
    11501231
    11511232
     
    11601241                                        ; List tags
    11611242    (fold (lambda (tag acc)
    1162             (kons (cons 'tag tag) (list tag 'tag (cons 'current (archive-tag archive tag))) acc))
     1243            (kons (cons 'tag tag) (list tag 'tag (cons 'current (archive-tag archive tag)) (cons 'locked (archive-tag-locked? archive tag))) acc))
    11631244          knil (archive-all-tags archive)))
    11641245   ((and (pair? directory-key) (eq? (car directory-key) 'tag))
     
    11661247    (let* ((tag (cdr directory-key))
    11671248           (current (archive-tag archive tag))
    1168            (current-contents (read-sexpr archive current)))
     1249           (current-contents (read-sexpr archive current 'snapshot)))
    11691250      (kons
    11701251       (cdr (assq 'contents current-contents))
  • release/4/ugarit/trunk/ugarit.meta

    r25528 r25570  
    44 (category data)
    55 (needs miscmacros sql-de-lite crypto-tools srfi-37 stty matchable autoload regex tiger-hash posix-extras parley)
    6  (optional lzma z3 tiger-hash sha2 aes)
     6 (optional lzma z3 sha2 aes)
    77 (author "Alaric Snell-Pym")
    88 (synopsis "A backup/archival system based on content-addressed storage"))
  • release/4/ugarit/trunk/ugarit.scm

    r25528 r25570  
    105105                               ((condition-property-accessor 'exn 'message "Unknown error") exn)
    106106                               (cons ((condition-property-accessor 'exn 'location (void)) exn)
    107                                      ((condition-property-accessor 'exn 'arguments (void)) exn)))
     107                                     ((condition-property-accessor 'exn 'arguments '()) exn)))
    108108                       (success-continuation))
    109109   (fold-archive-node archive directory-key
     
    138138      (if (eq? line #!eof)
    139139         (quit-continuation (void)))
    140      
    141140      (let ((result (string-split line)))
    142  
    143141         (match result
    144142            (()
  • release/4/ugarit/trunk/ugarit.setup

    r25522 r25570  
    1 (define *version* "1.0.1")
     1(define *version* "1.0.2")
    22
    33(compile -s -O2 -d1 directory-rules.scm -j directory-rules)
     
    3939  `((version ,*version*)
    4040  ))
     41
     42(compile ugarit-archive-admin.scm)
     43(install-program 'ugarit-archive-admin "ugarit-archive-admin"
     44  `((version ,*version*)
     45  ))
Note: See TracChangeset for help on using the changeset viewer.