Ugarit
Check-in [80b324f3af]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Archival mode command-line interface to search an archive tag for matching objects, available properties, and available values; and to extract or stream files from a vault. [dae5e21ffc]
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | alaricsp
Files: files | file ages | folders
SHA1:80b324f3af995e2fbb790938454d67eda4e21708
User & Date: alaric 2014-10-25 19:19:36
Context
2014-10-25
22:04
Archive mode [dae5e21ffc]: support for ($import <prop>) searches, and unit tests for advanced archive search expressions. check-in: 7152d37509 user: alaric tags: alaricsp
19:19
Archival mode command-line interface to search an archive tag for matching objects, available properties, and available values; and to extract or stream files from a vault. [dae5e21ffc] check-in: 80b324f3af user: alaric tags: alaricsp
13:54
Basic command-line interface to vault searching for archive mode [dae5e21ffc]. check-in: 40472e20fd user: alaric tags: alaricsp
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ugarit-api.scm.

1
2
3
4
5
6
7

8
9
10
11
12
13
14
..
61
62
63
64
65
66
67

68
69
70
71
72

73
74
75
76
77
78
79
(module
 ugarit-api
 (open-vault ;; Note: Mutates job configuration from the conf file
  vault-close!

  ;; Re-exports from ugarit-core
  vault?

  vault-global-directory-rules

  make-job
  job?
  job-blocks-stored
  job-bytes-stored
  job-blocks-skipped
................................................................................
  tag-archive-import!
  merge-archive-tags!

  cache-import!
  search-archive
  list-archive-properties
  list-archive-property-values


  ;; Re-exports from ugarit-vfs.scm
  fold-vault-node
  traverse-vault-node
  traverse-vault-path)


 (import scheme)
 (import chicken)

 (use ugarit-backend)
 (use ugarit-core)
 (use ugarit-streams)







>







 







>




|
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
..
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
(module
 ugarit-api
 (open-vault ;; Note: Mutates job configuration from the conf file
  vault-close!

  ;; Re-exports from ugarit-core
  vault?
  vault-exists?
  vault-global-directory-rules

  make-job
  job?
  job-blocks-stored
  job-bytes-stored
  job-blocks-skipped
................................................................................
  tag-archive-import!
  merge-archive-tags!

  cache-import!
  search-archive
  list-archive-properties
  list-archive-property-values
  archive-get-entry

  ;; Re-exports from ugarit-vfs.scm
  fold-vault-node
  traverse-vault-node
  traverse-vault-path
  archive-entry->dirent)

 (import scheme)
 (import chicken)

 (use ugarit-backend)
 (use ugarit-core)
 (use ugarit-streams)

Changes to ugarit-archive.scm.

19
20
21
22
23
24
25
26

27
28
29
30
31
32
33
...
361
362
363
364
365
366
367






























368
369
370
371
372
373
374

  tag-archive-import!
  merge-archive-tags!

  cache-import!
  search-archive
  list-archive-properties
  list-archive-property-values)


(import scheme)
(import chicken)
(import extras)
(import ports)
(use ugarit-core)
(use ugarit-streams)
................................................................................
(define (make-object-ssql tag-name filter-ssql)
  `(select
    (distinct (columns archive_objects.key archive_objects.object_id archive_objects.import_id))
    (from (join inner
                archive_imports archive_objects
                (on (= archive_imports.import_id archive_objects.import_id))))
    (where (and (= archive_imports.tag ,tag-name) ,filter-ssql))))































; Returns a list of archive entry objects
(define (search-archive vault tag-name filter-expr)
  (update-cache-for-tag! vault tag-name)

                                        ; Now construct and run the query against the cache
  (let* ((db (vault-cache vault))







|
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
...
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405

  tag-archive-import!
  merge-archive-tags!

  cache-import!
  search-archive
  list-archive-properties
  list-archive-property-values
  archive-get-entry)

(import scheme)
(import chicken)
(import extras)
(import ports)
(use ugarit-core)
(use ugarit-streams)
................................................................................
(define (make-object-ssql tag-name filter-ssql)
  `(select
    (distinct (columns archive_objects.key archive_objects.object_id archive_objects.import_id))
    (from (join inner
                archive_imports archive_objects
                (on (= archive_imports.import_id archive_objects.import_id))))
    (where (and (= archive_imports.tag ,tag-name) ,filter-ssql))))

; Returns one archive entry object, or #f
(define (archive-get-entry vault tag-name key)
    (let* ((db (vault-cache vault))
           (final-ssql `(select (columns prop value)
                                (from (join inner
                                            (join inner
                                                  archive_imports
                                                  archive_objects
                                                  (on (= archive_imports.import_id
                                                         archive_objects.import_id)))
                                            archive_entries
                                            (on (= archive_objects.object_id
                                                   archive_entries.object_id))))
                                (where (and
                                        (= archive_imports.tag ,tag-name)
                                        (= archive_objects.key ,key)))
                                (order (desc prop) value)))
           (final-sql (ssql->sql #f final-ssql))
           (results (query fetch-all (sql db final-sql))))
      (if (pair? results)
          (let ((alist (map
                        (lambda (row)
                          (let ((key (first row))
                                (prop (second row)))
                            (cons key prop)))
                        results)))
            (make-archive-entry key #t alist))
          ; else case, nothing found
          #f)))

; Returns a list of archive entry objects
(define (search-archive vault tag-name filter-expr)
  (update-cache-for-tag! vault tag-name)

                                        ; Now construct and run the query against the cache
  (let* ((db (vault-cache vault))

Changes to ugarit-files.scm.

501
502
503
504
505
506
507
508

509
510
511
512
513
514
515
516
517
518
519
520
521
522
523




524
525
526
527
528
529
530
531
532
533
534
535
...
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
                      (lambda (dirent-sexpr acc)
                        (let ((dirent (make-dirent-from-sexpr dirent-sexpr)))
                         (condition-case
                          (begin
                            (extract-object!
                             vault
                             dirent
                             target-path))

                          (exn (exn i/o file)
                               (job-log!
                                'error
                                (make-pathname target-path (dirent-name dirent))
                                (sprintf "Unable to extract from the vault (~a)"
                                         ((condition-property-accessor 'exn 'message "Unknown error") exn))))))
                        (void))
                      (void))
   (job-progress! 'dir-end #f #f #f)
   (void))

 (define (extract-object! vault dirent target-path)
   (let ((type (dirent-type dirent))
         (name (dirent-name dirent))
         (props (dirent-props dirent)))




     (cond
      ((eq? type 'file)
       (extract-file! vault props (make-pathname target-path name)))
      ((eq? type 'inline)
       (extract-inline! vault props (make-pathname target-path name)))
      ((eq? type 'tag)
       (signal (make-property-condition
                'exn
                'location 'extract-object!
                'dirent dirent
                'message "You can't extract an entire tag.")))
      ((eq? type 'root)
................................................................................
       (let ((output-path (make-pathname target-path name)))
         (if (not (directory? output-path))
             (create-directory output-path))
         (extract-directory! vault
                             (cdr (assq 'contents props))
                             output-path)))
      ((eq? type 'dir)
       (extract-subdirectory! vault props (make-pathname target-path name)))
      ((eq? type 'symlink)
       (extract-symlink! vault props (make-pathname target-path name)))
      ((eq? type 'fifo)
       (extract-fifo! vault props (make-pathname target-path name)))
      ((eq? type 'block-device)
       (extract-block-device! vault props (make-pathname target-path name)))
      ((eq? type 'character-device)
       (extract-character-device! vault props (make-pathname target-path name)))
      (else
       (job-log! 'error (make-pathname target-path name) (sprintf "Unable to extract an object of unknown type ~A" type))))))

 (define (fold-leaf-object vault dirent kons knil)
   (let ((type (dirent-type dirent))
         (name (dirent-name dirent))
         (props (dirent-props dirent)))







|
>











|
|
|
|
>
>
>
>


|

|







 







|

|

|

|

|







501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
...
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
                      (lambda (dirent-sexpr acc)
                        (let ((dirent (make-dirent-from-sexpr dirent-sexpr)))
                         (condition-case
                          (begin
                            (extract-object!
                             vault
                             dirent
                             target-path
                             #t))
                          (exn (exn i/o file)
                               (job-log!
                                'error
                                (make-pathname target-path (dirent-name dirent))
                                (sprintf "Unable to extract from the vault (~a)"
                                         ((condition-property-accessor 'exn 'message "Unknown error") exn))))))
                        (void))
                      (void))
   (job-progress! 'dir-end #f #f #f)
   (void))

 (define (extract-object! vault dirent target-path use-object-name?)
   (let* ((type (dirent-type dirent))
          (name (dirent-name dirent))
          (props (dirent-props dirent))
          (target-name
           (if use-object-name?
               (make-pathname target-path name)
               target-path)))
     (cond
      ((eq? type 'file)
       (extract-file! vault props target-name))
      ((eq? type 'inline)
       (extract-inline! vault props target-name))
      ((eq? type 'tag)
       (signal (make-property-condition
                'exn
                'location 'extract-object!
                'dirent dirent
                'message "You can't extract an entire tag.")))
      ((eq? type 'root)
................................................................................
       (let ((output-path (make-pathname target-path name)))
         (if (not (directory? output-path))
             (create-directory output-path))
         (extract-directory! vault
                             (cdr (assq 'contents props))
                             output-path)))
      ((eq? type 'dir)
       (extract-subdirectory! vault props target-name))
      ((eq? type 'symlink)
       (extract-symlink! vault props target-name))
      ((eq? type 'fifo)
       (extract-fifo! vault props target-name))
      ((eq? type 'block-device)
       (extract-block-device! vault props target-name))
      ((eq? type 'character-device)
       (extract-character-device! vault props target-name))
      (else
       (job-log! 'error (make-pathname target-path name) (sprintf "Unable to extract an object of unknown type ~A" type))))))

 (define (fold-leaf-object vault dirent kons knil)
   (let ((type (dirent-type dirent))
         (name (dirent-name dirent))
         (props (dirent-props dirent)))

Changes to ugarit-vfs.scm.

2
3
4
5
6
7
8
9


10
11
12
13
14
15
16
..
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
..
43
44
45
46
47
48
49






















50
51
52
53
54
55
56
...
107
108
109
110
111
112
113
114
115

116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
 ugarit-vfs
 (                                      ; FIXME: These two will be useful in future
                                        ;verify-directory!
                                        ;verify-object!
  fold-history
  fold-vault-node
  traverse-vault-node
  traverse-vault-path)



 (import scheme)
 (import chicken)
 (use ugarit-core)
 (use ugarit-streams)
 (use ugarit-files)
 (use ugarit-snapshot)
................................................................................
     (if (assq 'previous entry)
         (kons key entry
               (fold-history vault (cdr (assq 'previous entry)) type kons knil))
         (kons key entry knil))))

 ;; BRING IT ALL TOGETHER

(define (make-vault-object-name object-key object-props)
  (string-append
   object-key
   ":"
   (let* ((ae (make-archive-entry object-key #t object-props))
          (filenames (archive-entry-property ae 'filename))
          (names (archive-entry-property ae 'name)))
     (cond
................................................................................
      ((not (null? filenames))
       (car filenames))
      ((not (null? names))
       (string-append (car names) (archive-entry-guessed-extension ae)))
      (else
       (archive-entry-guessed-extension ae))))))























(define (make-inline-dirent name sexpr)
      (make-dirent
       #f
       name
       'inline
       `((text . ,(with-output-to-string
                    (lambda () (pp sexpr))))
................................................................................

      ((a ai)
       (fold-sexpr-stream vault directory-key 'a 'ai
                          (lambda (entry-sexpr acc)
                            (let* ((object-key (car entry-sexpr))
                                   (object-props (cdr entry-sexpr))
                                   (block-type (vault-exists? vault object-key)))
                              (kons (make-dirent
                                     #f

                                     (make-vault-object-name object-key object-props)
                                     (case block-type
                                       ((d di) 'dir)
                                       ((f fi) 'file)
                                       (else 'unknown))
                                     (cons
                                      (cons 'contents object-key)
                                      (cons
                                       (cons 'mode
                                             (case block-type
                                               ((d di) (+ perm/irusr perm/ixusr))
                                               (else perm/irusr)))
                                       object-props))) acc)))
                          knil)
       )
      ((d di)                              ; List directory contents
       (fold-sexpr-stream vault directory-key 'd 'di
                          (lambda (dirent-sexpr acc)
                            (kons (make-dirent-from-sexpr dirent-sexpr) acc))
                          knil))







|
>
>







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|
<
>
|
<
<
<
<
<
<
<
<
<
<
<
|







2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
..
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
...
131
132
133
134
135
136
137
138

139
140











141
142
143
144
145
146
147
148
 ugarit-vfs
 (                                      ; FIXME: These two will be useful in future
                                        ;verify-directory!
                                        ;verify-object!
  fold-history
  fold-vault-node
  traverse-vault-node
  traverse-vault-path

  archive-entry->dirent)

 (import scheme)
 (import chicken)
 (use ugarit-core)
 (use ugarit-streams)
 (use ugarit-files)
 (use ugarit-snapshot)
................................................................................
     (if (assq 'previous entry)
         (kons key entry
               (fold-history vault (cdr (assq 'previous entry)) type kons knil))
         (kons key entry knil))))

 ;; BRING IT ALL TOGETHER

(define (make-archive-object-name object-key object-props)
  (string-append
   object-key
   ":"
   (let* ((ae (make-archive-entry object-key #t object-props))
          (filenames (archive-entry-property ae 'filename))
          (names (archive-entry-property ae 'name)))
     (cond
................................................................................
      ((not (null? filenames))
       (car filenames))
      ((not (null? names))
       (string-append (car names) (archive-entry-guessed-extension ae)))
      (else
       (archive-entry-guessed-extension ae))))))

 (define (archive-entry->dirent type key props)
   (case type
     ((f fi) (make-dirent #f
                          (make-archive-object-name
                           key props)
                          'file
                          (cons
                           (cons 'contents key)
                           (cons
                            (cons 'mode
                                  perm/irusr)
                            props))))
     ((d di) (make-dirent key
                          (make-archive-object-name
                           key props)
                          'dir
                          (cons
                           (cons 'mode (+ perm/irusr perm/ixusr))
                           props)))
     (else (error 'archive-entry->dirent
                  "Unknown object type ~a" type))))

(define (make-inline-dirent name sexpr)
      (make-dirent
       #f
       name
       'inline
       `((text . ,(with-output-to-string
                    (lambda () (pp sexpr))))
................................................................................

      ((a ai)
       (fold-sexpr-stream vault directory-key 'a 'ai
                          (lambda (entry-sexpr acc)
                            (let* ((object-key (car entry-sexpr))
                                   (object-props (cdr entry-sexpr))
                                   (block-type (vault-exists? vault object-key)))
                              (kons

                               (archive-entry->dirent
                                block-type object-key object-props)











                               acc)))
                          knil)
       )
      ((d di)                              ; List directory contents
       (fold-sexpr-stream vault directory-key 'd 'di
                          (lambda (dirent-sexpr acc)
                            (kons (make-dirent-from-sexpr dirent-sexpr) acc))
                          knil))

Changes to ugarit.scm.

108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
...
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
...
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
...
439
440
441
442
443
444
445
446




447
448



























































449
450
451
452
453
454
455
...
769
770
771
772
773
774
775



776
777
778





779
780
781
782
783






784
785
786
787
788
789
790
            (set! dir-depth
                  (+ dir-depth 1)))
           ((dir-end)
            (set! dir-depth
                  (- dir-depth 1)))))))))

(define (log-event! event)
  (printf "~A\n" event))

(define (bit? i b)
   (not (zero? (bitwise-and i b))))

(define (print-posix-mode mode)
   (if (bit? mode perm/irusr) (printf "r") (printf "-"))
   (if (bit? mode perm/iwusr) (printf "w") (printf "-"))
................................................................................
                                          props)))))
                           (if (not long-format)
                              (printf "~A <~A>\n" name type))))

                        (void))))
                     (void)))))

(define (extract-file-from-dirent! vault dirent target)
  (let* ((props (dirent-props dirent))
         (files (assq 'files props))
         (bytes (assq 'size props)))
   (parameterize
    ((progress-total-files (if files (cdr files) #f))
     (progress-total-bytes (if bytes (cdr bytes) #f)))
    (extract-object! vault dirent target)))
  (printf "Extracted ~A into ~A\n" (dirent-name dirent) target))

(define (extract-file-from-node! vault directory-key name path success-continuation)
  (handle-exceptions exn
                     (begin
                       (printf "ERROR: Could not extract ~a: ~a in ~a\n"
                               name
................................................................................
                       (success-continuation))
                     (let* ((dirent (traverse-vault-node vault
                                                         directory-key
                                                         name)))
                      (if (string=? (dirent-name dirent) name)
                          (begin
                            (extract-file-from-dirent! vault dirent
                                                       ".")
                            (success-continuation))
                          acc))
                      #f))

(define (cat-file-from-node! vault directory-key name path success-continuation)
  (handle-exceptions exn
                     (begin
................................................................................
              (let ((dirent (traverse-vault-path
                             vault
                             path)))
                (if dirent
                    (extract-file-from-dirent! vault dirent
                                               (if target
                                                   target
                                                   (dirent-name dirent)))




                    (printf "Cannot find ~A\n" vaultpath)))))




























































         (vault-close! vault)))))

(define (provide-default prop value alist)
  (if (assq prop alist)
      alist
      (cons (cons prop value) alist)))

................................................................................
               #f))

   (("search" confpath archive-tag filter format)
    (do-search confpath archive-tag
               (with-input-from-string filter read)
               (string->symbol format)))




   (("search-props" confpath archive-tag filter)
    (do-search-props confpath archive-tag
                     (with-input-from-string filter read)))






   (("search-values" confpath archive-tag filter prop-name)
    (do-search-values confpath archive-tag
                      (with-input-from-string filter read)
                      (string->symbol prop-name)))







   ; FIXME: Make this use traverse-vault-path
   ; and give traverse-vault-path a syntax for raw keys.
   (("cat" confpath key)
    (let ((cat-job (make-job log-event! #f progress-callback)))
      (parameterize ((current-job cat-job))
      (let ((vault (open-vault







|







 







|






|







 







|







 







<
>
>
>
>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>



>
>
>
>
>





>
>
>
>
>
>







108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
...
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
...
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
...
439
440
441
442
443
444
445

446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
...
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
            (set! dir-depth
                  (+ dir-depth 1)))
           ((dir-end)
            (set! dir-depth
                  (- dir-depth 1)))))))))

(define (log-event! event)
  (fprintf (current-error-port) "~A\n" event))

(define (bit? i b)
   (not (zero? (bitwise-and i b))))

(define (print-posix-mode mode)
   (if (bit? mode perm/irusr) (printf "r") (printf "-"))
   (if (bit? mode perm/iwusr) (printf "w") (printf "-"))
................................................................................
                                          props)))))
                           (if (not long-format)
                              (printf "~A <~A>\n" name type))))

                        (void))))
                     (void)))))

(define (extract-file-from-dirent! vault dirent target use-object-name?)
  (let* ((props (dirent-props dirent))
         (files (assq 'files props))
         (bytes (assq 'size props)))
   (parameterize
    ((progress-total-files (if files (cdr files) #f))
     (progress-total-bytes (if bytes (cdr bytes) #f)))
    (extract-object! vault dirent target use-object-name?)))
  (printf "Extracted ~A into ~A\n" (dirent-name dirent) target))

(define (extract-file-from-node! vault directory-key name path success-continuation)
  (handle-exceptions exn
                     (begin
                       (printf "ERROR: Could not extract ~a: ~a in ~a\n"
                               name
................................................................................
                       (success-continuation))
                     (let* ((dirent (traverse-vault-node vault
                                                         directory-key
                                                         name)))
                      (if (string=? (dirent-name dirent) name)
                          (begin
                            (extract-file-from-dirent! vault dirent
                                                       "." #t)
                            (success-continuation))
                          acc))
                      #f))

(define (cat-file-from-node! vault directory-key name path success-continuation)
  (handle-exceptions exn
                     (begin
................................................................................
              (let ((dirent (traverse-vault-path
                             vault
                             path)))
                (if dirent
                    (extract-file-from-dirent! vault dirent
                                               (if target
                                                   target

                                                   ".")
                                               (if target
                                                   #t
                                                   #f))
                    (printf "Cannot find ~A\n" vaultpath)))))

         (vault-close! vault)))))

(define (do-archive-extract! confpath archive-tag hash target)
    (let ((extract-job (make-job log-event! #f progress-callback)))
      (parameterize ((current-job extract-job))
       (let ((vault (open-vault
                     (with-input-from-file confpath read-file))))
         (override-job-options! extract-job)

         (handle-exceptions exn
            (begin
              (printf "ERROR: Could not extract ~a/~a: ~a in ~a\n"
                      archive-tag hash
                      ((condition-property-accessor 'exn 'message "Unknown error") exn)
                      (cons ((condition-property-accessor 'exn 'location (void)) exn)
                            ((condition-property-accessor 'exn 'arguments '()) exn))))

            (let ((ae (archive-get-entry vault archive-tag hash)))
              (if ae
                  (let ((dirent (archive-entry->dirent
                                 (vault-exists? vault (archive-entry-key ae))
                                 (archive-entry-key ae)
                                 (archive-entry-alist ae))))
                   (extract-file-from-dirent! vault dirent
                                              target #f))
                  (printf "Cannot find ~A in ~A\n" hash archive-tag))))

         (vault-close! vault)))))

(define (do-archive-stream! confpath archive-tag hash)
    (let ((extract-job (make-job log-event! #f progress-callback)))
      (parameterize ((current-job extract-job))
       (let ((vault (open-vault
                     (with-input-from-file confpath read-file))))
         (override-job-options! extract-job)

         (handle-exceptions exn
            (begin
              (printf "ERROR: Could not extract ~a/~a: ~a in ~a\n"
                      archive-tag hash
                      ((condition-property-accessor 'exn 'message "Unknown error") exn)
                      (cons ((condition-property-accessor 'exn 'location (void)) exn)
                            ((condition-property-accessor 'exn 'arguments '()) exn))))

            (let ((ae (archive-get-entry vault archive-tag hash)))
              (if ae
                  (let ((dirent (archive-entry->dirent
                                 (vault-exists? vault (archive-entry-key ae))
                                 (archive-entry-key ae)
                                 (archive-entry-alist ae))))
                    (fold-leaf-object
                     vault dirent
                     (lambda (block acc)
                       (write-u8vector block)
                       acc)
                     #f))
                  (fprintf (current-error-port)
                           "Cannot find ~A in ~A\n" hash archive-tag))))

         (vault-close! vault)))))

(define (provide-default prop value alist)
  (if (assq prop alist)
      alist
      (cons (cons prop value) alist)))

................................................................................
               #f))

   (("search" confpath archive-tag filter format)
    (do-search confpath archive-tag
               (with-input-from-string filter read)
               (string->symbol format)))

   (("search-props" confpath archive-tag)
    (do-search-props confpath archive-tag #t))

   (("search-props" confpath archive-tag filter)
    (do-search-props confpath archive-tag
                     (with-input-from-string filter read)))

   (("search-values" confpath archive-tag prop-name)
    (do-search-values confpath archive-tag
                      #t
                      (string->symbol prop-name)))

   (("search-values" confpath archive-tag filter prop-name)
    (do-search-values confpath archive-tag
                      (with-input-from-string filter read)
                      (string->symbol prop-name)))

   (("archive-extract" confpath archive-tag hash target)
    (do-archive-extract! confpath archive-tag hash target))

   (("archive-stream" confpath archive-tag hash)
    (do-archive-stream! confpath archive-tag hash))

   ; FIXME: Make this use traverse-vault-path
   ; and give traverse-vault-path a syntax for raw keys.
   (("cat" confpath key)
    (let ((cat-job (make-job log-event! #f progress-callback)))
      (parameterize ((current-job cat-job))
      (let ((vault (open-vault