Changeset 25570 in project
- Timestamp:
- 11/25/11 20:58:42 (9 years ago)
- Location:
- release/4/ugarit/trunk
- Files:
-
- 1 added
- 11 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/ugarit/trunk/README.txt
r25566 r25570 538 538 $ ugarit fork <ugarit.conf> <existing tag> <new tag> 539 539 540 ## Archive administration 541 542 Each backend offers a number of administrative commands for 543 administering archives. These are accessible via the 544 `ugarit-archive-admin` command line interface. 545 546 To use it, run it with the following command: 547 548 $ ugarit-archive-admin '<archive identifier>' 549 550 The available commands differ between backends, but all backends 551 support the `info` and `help` commands, which give basic information 552 about the archive, and list all available commands, respectively. Some 553 offer a `stats` command that examines the archive state to give 554 interesting statistics, but which may be a time-consuming operation. 555 556 ### Administering `splitlog` archives 557 558 The splitlog backend offers a wide selection of administrative 559 commands. See the `help` command on a splitlog archive for 560 details. 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 540 583 ## `.ugarit` files 541 584 … … 824 867 * Migrate the source repo to Fossil (when there's a 825 868 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. 827 871 828 872 * Profile the system. As of 1.0.1, having done the periodic SQLite … … 838 882 ## Backends 839 883 840 * Create ugarit-backend-protocol-2, and extend import-backend to841 support it. The differences are:842 843 * Extend the backend API to have all API calls return a possibly844 empty list of log messages before the actual result. When845 importing a backend, provide a logging callback which is passed846 these lists and feeds them into a logging mechanism which prints847 them and stores them in the archive object for later logging into848 the snapshot. The same logging interface can then be used for849 warnings from within ugarit-core itself as well.850 851 * Extend the backend API to have an initial list of log messages and852 a possible error or success for initialisation, inside the853 header. Make the command-line wrappers for backends use this to854 indicate startup failure.855 856 884 * Carefully document backend API for other backend authors: in 857 885 particular note behaviour in crash situations - we assume that after … … 874 902 not flushed to the metadata) or scan the log onwards from that point 875 903 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 archive878 block and retry a few times in that case.879 880 * Extend the backend protocol with a special "admin" command that881 allows for arbitrary backend-specific operations, and write an882 ugarit-backend-admin CLI tool to administer backends with it. The883 input should be a single s-expression as a list, and the result884 should be an alist which is displayed to the user in a friendly885 manner, as "Key: Value\n" lines.886 887 * Implement "info" admin commands for all backends, that list any888 available stats, and at least the backend type and parameters.889 890 * Support for recreating the index and tags on a backend-splitlog if891 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 admin895 command, rather than having to delete the cache file.896 904 897 905 * Support for unlinking in backend-splitlog, by marking byte ranges as … … 909 917 existing archive with no refcounts, default them to NULL, and treat 910 918 a NULL refcount as "infinity". 911 912 * Have read-only and unlinkable and block size config flags in the913 backend-split metadata file, settable via admin commands.914 919 915 920 * For people doing remote backups who want to not hog resources, write … … 975 980 ## Core 976 981 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 983 983 blocks in the archive, to protect against people who tamper with 984 984 blocks in order to try and exploit vulnerabilities in the … … 988 988 that decrypt to giant amounts of RAM). 989 989 990 * When extracting, wrap each restore operation under991 extract-directory! with exception handling that logs the error and992 then continues with the next dirent in the directory.993 994 * Check sensibly-worded conditions are raised when we try and fetch995 nonexistant or corrupted blocks from the archive in `archive-get`.996 997 * Make `fold-archive-node`'s listing of tags at the top level report998 the lock status of the tags.999 1000 990 * More stats. Log bytes written AFTER compression and encryption in 1001 991 `archive-put!`. Log snapshot start and end times in the snapshot 1002 992 object. 1003 1004 * SIGINFO support. Add a SIGINFO handler that sets a flag, and make1005 the `store-file!` and `store-directory!` main loops look for the1006 flag and, if set, display what path we're working on, and perhaps a1007 quick summary of the bytes/blocks stored/skipped stats.1008 993 1009 994 * Clarify what characters are legal in tag names sent to backends, and … … 1144 1129 node tree 1145 1130 1146 * Better error messages1147 1148 1131 * API mode: Works something like the backend API, except at the 1149 1132 archive level. Supports all the important archive operations, plus … … 1276 1259 metadata. Switched to the `posix-extras` egg and ditched our own 1277 1260 `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. 1302 1304 1303 1305 * 1.0.1: Consistency check on read blocks by default. Removed warning -
release/4/ugarit/trunk/VERSION.txt
r25521 r25570 1 1.0. 11 1.0.2 -
release/4/ugarit/trunk/backend-cache.scm
r25565 r25570 21 21 (define cache-delete-query (sql *db* "DELETE FROM cache WHERE key = ?")) 22 22 23 (define *hits* 0) 24 (define *misses* 0) 25 (define *flushes* 0) 26 23 27 (define commit-interval 1000) 24 28 (define *updates-since-last-commit* 0) 25 29 (define (flush!) 26 30 (when (> *updates-since-last-commit* 0) 31 (inc! *flushes*) 27 32 (exec (sql *db* "COMMIT;")) 28 33 (exec (sql *db* "BEGIN;")) … … 52 57 (maybe-flush!)) 53 58 59 (define (cache-clear!) 60 (exec (sql *db* "DELETE FROM cache"))) 61 54 62 (make-storage 55 63 (storage-max-block-size be) … … 67 75 (void))) 68 76 (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)))))) 72 85 (lambda (key) ; get 73 86 ((storage-get be) key)) … … 104 117 ((storage-flush! be)) 105 118 (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")))) 106 140 (lambda () ; close! 107 141 (begin 142 ((backend-log!) 'info (sprintf "Cache hits: ~A misses: ~A flushes: ~A" *hits* *misses* *flushes*)) 108 143 ((storage-close! be)) 109 144 (exec (sql *db* "COMMIT;")) … … 114 149 (match (command-line-arguments) 115 150 ((cachepath backend) 116 ( backend-cache cachepath (import-storage backend)))151 (lambda () (backend-cache cachepath (import-storage backend)))) 117 152 118 153 (else 154 (export-storage-error! "Invalid arguments to backend-cache") 119 155 (printf "USAGE:\nbackend-cache <path-to-cache-file> \"<backend command line>\"\n") 120 156 #f))) -
release/4/ugarit/trunk/backend-devtools.scm
r25565 r25570 30 30 (lambda (tag) ; unlock-tag! 31 31 ((storage-unlock-tag! be) tag)) 32 (lambda (command) ; admin! 33 ((storage-admin! be) command)) 32 34 (lambda () ; close! 33 35 ((storage-close! be))))) … … 64 66 (lambda (tag) ; unlock-tag! 65 67 ((storage-unlock-tag! be) tag)) 68 (lambda (command) ; admin! 69 ((storage-admin! be) command)) 66 70 (lambda () ; close! 67 71 ((storage-close! be))))) … … 133 137 (printf "~A: (lock-tag! ~A)\n" name tag) 134 138 ((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))) 135 144 (lambda () ; close! 136 145 (begin -
release/4/ugarit/trunk/backend-fs.scm
r25565 r25570 53 53 54 54 (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)) 56 58 57 59 (make-storage 58 (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap60 block-size 59 61 #t ; We are writable 60 62 #t ; We support unlink! … … 162 164 (delete-file (make-tag-lock-name tag)) 163 165 (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")))) 164 178 (lambda () ; close! 165 179 (void)))) … … 172 186 "CREATE TABLE tags (tag TEXT PRIMARY KEY, key TEXT, locked INTEGER DEFAULT 0);")) 173 187 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) 175 191 (let* 176 192 ((*db* … … 204 220 default) 205 221 (car result))))) 206 (set-metadata (lambda (key value)222 (set-metadata! (lambda (key value) 207 223 (exec set-metadata-query key value))) 224 225 (max-logpart-size (string->number (get-metadata "max-logpart-size" "600000000"))) 208 226 209 227 ; Log file management … … 222 240 fd))))) 223 241 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 224 249 ; Periodic commit management 225 250 (commit-interval (string->number (get-metadata "commit-interval" "1000"))) … … 227 252 (flush! (lambda () 228 253 (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*)) 230 256 (exec (sql *db* "COMMIT;")) 231 257 (exec (sql *db* "BEGIN;")) … … 280 306 281 307 (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)))) 283 340 284 341 (make-storage 285 (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap, right?286 #t ; We are writable342 block-size 343 writable? 287 344 #f ; We DO NOT support unlink! 288 345 289 346 (lambda (key data type) ; put! 347 (check-writable) 290 348 (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)) 292 350 293 351 (set-file-position! *log* 0 seek/end) … … 332 390 333 391 (lambda (key) ; link! 334 (void)) 392 (check-writable) 393 (void)) 335 394 336 395 (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")) 338 398 339 399 (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)) 343 404 (lambda (tag) ; tag 344 405 (get-tag tag)) … … 346 407 (get-tags)) 347 408 (lambda (tag) ; remove-tag! 409 (check-writable) 348 410 (remove-tag! tag) 349 411 (void)) 350 412 (lambda (tag) ; lock-tag! 413 (check-writable) 351 414 (flush!) 352 415 (let ((existing-lock? (not (zero? (get-tag-lock tag))))) … … 363 426 #t)) 364 427 (lambda (tag) ; unlock-tag! 428 (check-writable) 365 429 (set-tag-lock! tag 0) 366 430 (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")))) 367 484 (lambda () ; close! 368 485 (flush!) … … 377 494 (match (command-line-arguments) 378 495 (("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))) 383 500 384 501 (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") 386 504 #f))) 387 505 -
release/4/ugarit/trunk/test/run.scm
r25566 r25570 39 39 40 40 (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))))) 61 75 62 76 (define (key-stream-cat a ks-hash ks-type level) … … 67 81 (for-each (lambda (subkey) 68 82 (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)))) 70 84 (printf "kleaf(~A): ~A (~A)\n" level ks-hash type))) 71 85 … … 79 93 (for-each (lambda (subkey) 80 94 (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))))) 82 96 ((eq? type leaf-type) 83 97 (begin ; leaf node … … 85 99 (for-each (lambda (sexpr) 86 100 (printf " ~A\n" sexpr)) 87 (deserialise-sexpr-stream (archive-get a ss-hash )))))))101 (deserialise-sexpr-stream (archive-get a ss-hash type))))))) 88 102 89 103 (define (check-dir-is-empty store-path) … … 135 149 (test "Data goes into archive" (void) (archive-put! a test-key test-data 'test)) 136 150 (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))) 138 152 139 153 (if (archive-unlinkable? a) … … 485 499 486 500 (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")) 487 502 488 503 (test-define-values "Tag it as a snapshot" (sk2) … … 500 515 ('mtime . _) 501 516 ('contents . dir2-key*) 502 ('stats . _)) 517 ('stats . _) 518 ('log . (('info _ #f "This is a test")))) 503 519 (('mtime . _) 504 520 ('contents . dir-key*) 505 ('stats . _))) 521 ('stats . _) 522 ('log))) 506 523 (and (string=? sk1 sk1*) 507 524 (string=? dir2-key dir2-key*) … … 511 528 (test-define-values "Walk the tag list with fold-archive-node" (root) 512 529 (fold-archive-node a '() (lambda (name dirent acc) (cons (cons name dirent) acc)) '())) 513 (test-assert "Root historyhas expected form"530 (test-assert "Root listing has expected form" 514 531 (match root 515 532 (((('tag . "Test") 516 533 "Test" 517 534 'tag 518 ('current . sk2*))) 535 ('current . sk2*) 536 ('locked . #f))) 519 537 (string=? sk2 sk2*)) 520 538 (else #f))) … … 529 547 ('mtime . _) 530 548 ('contents . dir-key*) 531 ('stats . _)) 549 ('stats . _) 550 ('log . (('info _ #f "This is a test")))) 532 551 (dir-key-c** 533 552 _ … … 536 555 ('mtime . _) 537 556 ('contents . dir-key**) 538 ('stats . _)) 557 ('stats . _) 558 ('log . (('info _ #f "This is a test")))) 539 559 (dir-key-c*** 540 560 _ … … 542 562 ('mtime . _) 543 563 ('contents . dir-key***) 544 ('stats . _))) 564 ('stats . _) 565 ('log))) 545 566 (and 546 567 (string=? sk1 sk1*) … … 555 576 (test-define-values "Walk the root directory with fold-archive-node" (dir) 556 577 (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...558 578 (if (zero? (current-user-id)) 559 (test-assert "Directory historyhas the expected form (as root)"579 (test-assert "Directory listing has the expected form (as root)" 560 580 (match dir 561 581 (((#f "block-special" 'block-device (number . 123) . _) … … 566 586 (#f "plain-file2" 'file . _)) #t) 567 587 (else #f))) 568 (test-assert "Directory historyhas the expected form (not as root)"588 (test-assert "Directory listing has the expected form (not as root)" 569 589 (match dir 570 590 (((_ "directory" 'dir . _) … … 585 605 (create-directory "./tmp/be1") 586 606 (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)) 589 608 590 609 (test-group "Splitlog backend" 591 610 (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)) 595 614 596 615 (test-group "Limited cached splitlog backend" 597 616 (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\"")) 599 618 (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)) 602 620 603 621 (test-group "Filesystem backend archive" … … 615 633 (test-group "Splitlog backend archive" 616 634 (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))) 618 637 (test-archive be "./tmp/be7") 619 638 (test "Close archive" (void) (archive-close! be))) … … 621 640 (test-group "Splitlog backend archive plus file cache" 622 641 (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))) 624 644 (test-archive be "./tmp/be8") 625 645 (test "Close archive" (void) (archive-close! be))) -
release/4/ugarit/trunk/ugarit-backend.scm
r25565 r25570 18 18 storage-tag-locked? 19 19 storage-unlock-tag! 20 storage-admin! 20 21 storage-close! 21 22 23 backend-log! 24 22 25 export-storage! ; Export a storage via stdin/stdout 26 export-storage-error! 23 27 import-storage ; Create a storage from a command line 24 28 ) … … 31 35 (use posix) 32 36 (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")))) 34 46 35 47 (define-record storage … … 50 62 tag-locked? ; Procedure: (tag-locked? name) - returns #t if the tag is locked, #f otherwise 51 63 unlock-tag! ; Procedure: (unlock-tag! name) - unlocks the named tag 64 admin! ; Procedure: (admin! command) - returns an alist 52 65 close!) ; Procedure: (close!) - closes the storage engine 53 66 54 (define *magic* 'ugarit-backend-protocol-1) 67 (define *magic-v1* 'ugarit-backend-protocol-1) 68 (define *magic-v2* 'ugarit-backend-protocol-2) 55 69 56 70 (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))) 71 122 72 123 ;; Given a storage object, provide the storage remote access protocol 73 124 ;; via current-input-port / current-output-port until the storage is closed 74 125 ;; via the protocol. 75 (define (export-storage! storage )126 (define (export-storage! storage-thunk) 76 127 (set-buffering-mode! (current-output-port) #:none) 77 128 78 129 ; 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) 191 234 (let ((response (read port))) 192 235 (match response … … 194 237 (else response)))) 195 238 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))) 198 241 (if response 199 242 (read-u8vector (car response) port) 200 243 #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)))))) 201 461 202 462 ;; Given the command line to a storage remote access protocol server, … … 213 473 (let ((magic (read responses))) 214 474 (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 311 482 312 483 ) -
release/4/ugarit/trunk/ugarit-core.scm
r25566 r25570 12 12 archive-writable? 13 13 archive-unlinkable? 14 archive-log! 14 15 archive-exists? 15 16 archive-get … … 25 26 archive-link! 26 27 archive-unlink! 28 archive-admin! 27 29 archive-close! 28 30 … … 111 113 (use ugarit-backend) 112 114 (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))) 114 132 115 133 ;; … … 131 149 global-directory-rules ; top-level directory rules 132 150 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 133 158 ; Snapshot counters 134 159 (setter snapshot-blocks-stored) ; Blocks written to storage … … 144 169 (setter file-cache-hits) ; count of file cache hits 145 170 (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 146 174 ) 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 ...)) 147 186 148 187 (define file-cache-commit-interval 1000) … … 150 189 (define (file-cache-put! archive file-path mtime size key) 151 190 (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 safety191 ((with-backend-logging archive (storage-flush! (archive-storage archive)))) ; Flush the storage before we commit our cache, for crash safety 153 192 (exec (sql (archive-file-cache archive) "commit;")) 154 193 (exec (sql (archive-file-cache archive) "begin;")) … … 186 225 ((1) (blob->u8vector/shared (string->blob (z3:decode-buffer (blob->string (u8vector->blob/shared (subu8vector block 1 (u8vector-length block)))))))) ; deflate 187 226 ((2) (blob->u8vector/shared (lzma:decompress (u8vector->blob/shared (subu8vector block 1 (u8vector-length block)))))))) ; lzma 227 228 #| 229 function 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 241 end function 242 |# 188 243 189 244 (define (choose-hash-function config) … … 270 325 ; Valid flags: 271 326 ; double-check - check correctness lots, even if it costs efficiency 327 272 328 (define (open-archive config store-atime? store-ctime?) 273 329 (let ((*storage* #f) … … 277 333 (*double-check?* #f) 278 334 (*file-cache* #f) 279 (*global-rules* '())) 335 (*global-rules* '()) 336 (setup-log (make-queue))) 280 337 281 338 (for-each (lambda (confentry) … … 283 340 ('double-check (set! *double-check?* #t)) 284 341 (('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)))) 286 347 (('hash . conf) (set! *hash* conf)) 287 348 (('compression . conf) (set! *compression* conf)) … … 322 383 (if *file-cache* (sql *file-cache* "SELECT key FROM files WHERE path = ? AND mtime = ? AND size = ?") #f) 323 384 (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)))) 325 388 326 389 ; Take a block, and return a compressed and encrypted block … … 355 418 (inc! (archive-snapshot-bytes-skipped archive) (u8vector-length data))) 356 419 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 357 435 (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) 361 439 (inc! (archive-snapshot-blocks-stored archive)) 362 440 (inc! (archive-snapshot-bytes-stored archive) (u8vector-length data)) … … 364 442 365 443 (define (archive-flush! archive) 366 (( storage-flush! (archive-storage archive))) ; Flush the storage first, to ensure crash safety444 ((with-backend-logging archive (storage-flush! (archive-storage archive)))) ; Flush the storage first, to ensure crash safety 367 445 (when (archive-file-cache archive) 368 446 (exec (sql (archive-file-cache archive) "commit;")) … … 371 449 372 450 (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)))) 379 460 data)) 380 461 381 462 (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)) 385 466 386 467 (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))) 390 471 (if result 391 472 (unwrap-block archive result) 392 473 #f))) 393 474 475 (define (archive-admin! archive command) 476 ((with-backend-logging archive (storage-admin! (archive-storage archive))) command)) 477 394 478 (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)) 398 482 399 483 (define (archive-tag archive tag) 400 (( storage-tag (archive-storage archive)) tag))484 ((with-backend-logging archive (storage-tag (archive-storage archive))) tag)) 401 485 402 486 (define (archive-all-tags archive) 403 (( storage-all-tags (archive-storage archive))))487 ((with-backend-logging archive (storage-all-tags (archive-storage archive))))) 404 488 405 489 (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)) 409 493 410 494 (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")) 413 497 (let loop ((tries-left 10)) 414 498 (if (zero? tries-left) 415 499 (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))) 417 501 (if result 418 502 result ; Lock got! … … 422 506 423 507 (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)) 427 511 428 512 (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)) 432 516 433 517 (define (archive-close! archive) 434 (( storage-close! (archive-storage archive))) ;; This flushes the backend before we flush the file cache, for crash safety518 ((with-backend-logging archive (storage-close! (archive-storage archive)))) ;; This flushes the backend before we flush the file cache, for crash safety 435 519 (when (archive-file-cache archive) 436 520 (exec (sql (archive-file-cache archive) "commit;")) … … 585 669 ; Recurse 586 670 (begin 587 (let ((subkeys (deserialise-key-stream (archive-get archive key ))))671 (let ((subkeys (deserialise-key-stream (archive-get archive key type)))) 588 672 (fold 589 673 (lambda (subkey acc) (fold-key-stream archive subkey ks-type kons acc)) … … 660 744 (fold-key-stream archive key 'fi 661 745 (lambda (key type acc) 662 (kons (archive-get archive key ) acc))746 (kons (archive-get archive key type) acc)) 663 747 knil)) 664 748 … … 780 864 (lambda (key found-leaf-type acc) 781 865 (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)))) 783 867 (fold 784 868 kons … … 852 936 (for-each (lambda (filename) 853 937 (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))) 855 939 (let* ((file-path (make-pathname path filename)) 856 940 (stats (file-stat file-path #t)) … … 873 957 (cond 874 958 ((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")) 876 960 ((eq? type stat/ifreg) 877 961 (let-values (((content-key content-reused?) (with-input-from-file file-path (lambda () (store-file! archive file-path stats))))) … … 904 988 (else 905 989 ; 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"))))))) 907 991 (sort! (directory path #t) string>?)) 908 992 … … 923 1007 (unlink-directory! archive (cdr (assq 'contents props))))))))) 924 1008 925 (define (set-standard-file-metadata! path props)1009 (define (set-standard-file-metadata! archive path props) 926 1010 (let ((mode (assq 'mode props)) 927 1011 (uid (assq 'uid props)) … … 935 1019 (if (or uid gid) 936 1020 (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") 938 1022 (change-file-owner path 939 1023 (if uid (cdr uid) (current-user-id)) … … 952 1036 (lambda () 953 1037 (write-file-contents archive contents-key))) 954 (set-standard-file-metadata! path props)))1038 (set-standard-file-metadata! archive path props))) 955 1039 956 1040 (define (extract-subdirectory! archive props path) … … 962 1046 (extract-directory! archive contents-key path) 963 1047 964 (set-standard-file-metadata! path props)))1048 (set-standard-file-metadata! archive path props))) 965 1049 966 1050 (define (extract-symlink! archive props path) … … 980 1064 (if (or uid gid) 981 1065 (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") 983 1067 (change-link-owner path 984 1068 (if uid (cdr uid) (current-user-id)) … … 989 1073 (create-fifo path) 990 1074 991 (set-standard-file-metadata! path props))1075 (set-standard-file-metadata! archive path props)) 992 1076 993 1077 (define (extract-block-device! archive props path) … … 995 1079 996 1080 (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") 998 1082 999 1083 (create-special-file path stat/ifblk number) 1000 (set-standard-file-metadata! path props))))1084 (set-standard-file-metadata! archive path props)))) 1001 1085 1002 1086 (define (extract-character-device! archive props path) … … 1004 1088 1005 1089 (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") 1007 1091 1008 1092 (create-special-file path stat/ifchr number) 1009 (set-standard-file-metadata! path props))))1093 (set-standard-file-metadata! archive path props)))) 1010 1094 1011 1095 (define (extract-object! archive dirent target-path) … … 1027 1111 (extract-character-device! archive props (make-pathname target-path name))) 1028 1112 (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)))))) 1030 1114 1031 1115 (define (extract-directory! archive key target-path) 1032 1116 (fold-sexpr-stream archive key 'd 'di 1033 1117 (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)) 1035 1122 (void)) 1036 1123 '())) … … 1055 1142 (values (virgin hash) #f))))) 1056 1143 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))) 1059 1146 (with-input-from-string 1060 1147 (blob->string (u8vector->blob/shared data)) … … 1077 1164 ;; 'file-cache-hits 1078 1165 ;; 'file-cache-bytes 1166 ;; 'log (list of log events, each being a (type timestamp path message) list 1079 1167 ;; Returns the snapshot's key. 1080 1168 (define (tag-snapshot! archive tag contents-key contents-reused? snapshot-properties) … … 1089 1177 (cons 'file-cache-hits (archive-file-cache-hits archive)) 1090 1178 (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)))) 1091 1185 (snapshot 1092 1186 (append … … 1094 1188 (cons 'mtime (current-seconds)) 1095 1189 (cons 'contents contents-key) 1096 (cons 'stats stats)) 1190 (cons 'stats stats) 1191 (cons 'log log)) 1097 1192 snapshot-properties)) 1098 1193 (keys … … 1113 1208 1114 1209 (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))) 1116 1211 (if (assq 'previous snapshot) 1117 1212 (kons snapshot-key snapshot … … 1134 1229 props)))) 1135 1230 1136 (define (epochtime->string e)1137 (let ((localtime (seconds->local-time e)))1138 (string-append1139 (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))))1150 1231 1151 1232 … … 1160 1241 ; List tags 1161 1242 (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)) 1163 1244 knil (archive-all-tags archive))) 1164 1245 ((and (pair? directory-key) (eq? (car directory-key) 'tag)) … … 1166 1247 (let* ((tag (cdr directory-key)) 1167 1248 (current (archive-tag archive tag)) 1168 (current-contents (read-sexpr archive current )))1249 (current-contents (read-sexpr archive current 'snapshot))) 1169 1250 (kons 1170 1251 (cdr (assq 'contents current-contents)) -
release/4/ugarit/trunk/ugarit.meta
r25528 r25570 4 4 (category data) 5 5 (needs miscmacros sql-de-lite crypto-tools srfi-37 stty matchable autoload regex tiger-hash posix-extras parley) 6 (optional lzma z3 tiger-hashsha2 aes)6 (optional lzma z3 sha2 aes) 7 7 (author "Alaric Snell-Pym") 8 8 (synopsis "A backup/archival system based on content-addressed storage")) -
release/4/ugarit/trunk/ugarit.scm
r25528 r25570 105 105 ((condition-property-accessor 'exn 'message "Unknown error") exn) 106 106 (cons ((condition-property-accessor 'exn 'location (void)) exn) 107 ((condition-property-accessor 'exn 'arguments (void)) exn)))107 ((condition-property-accessor 'exn 'arguments '()) exn))) 108 108 (success-continuation)) 109 109 (fold-archive-node archive directory-key … … 138 138 (if (eq? line #!eof) 139 139 (quit-continuation (void))) 140 141 140 (let ((result (string-split line))) 142 143 141 (match result 144 142 (() -
release/4/ugarit/trunk/ugarit.setup
r25522 r25570 1 (define *version* "1.0. 1")1 (define *version* "1.0.2") 2 2 3 3 (compile -s -O2 -d1 directory-rules.scm -j directory-rules) … … 39 39 `((version ,*version*) 40 40 )) 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.