51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
chicken.time.posix
(prefix base64 base64:)
;; csv-xml
directory-utils
matchable
regex
s11n
srfi-1
|
>
|
|
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
chicken.time.posix
system-information
(prefix base64 base64:)
;; csv-xml
directory-utils
matchable
regex
s11n
srfi-1
|
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
|
(archiver (let ((s (configf:lookup *configdat* "archive" "archiver")))
(if s (string->symbol s) 'bup)))
(rsync-exe (or (configf:lookup *configdat* "archive" "rsync") "rsync"))
(print-prefix "Running: ")
(archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target-patt run-patt "megatest-db"))
(archive-dir (if archive-info (cdr archive-info) #f))
(archive-id (if archive-info (car archive-info) -1))
(home-host (common:get-homehost))
|
|
|
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
|
(archiver (let ((s (configf:lookup *configdat* "archive" "archiver")))
(if s (string->symbol s) 'bup)))
(rsync-exe (or (configf:lookup *configdat* "archive" "rsync") "rsync"))
(print-prefix "Running: ")
(archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target-patt run-patt "megatest-db"))
(archive-dir (if archive-info (cdr archive-info) #f))
(archive-id (if archive-info (car archive-info) -1))
(home-host (get-host-name)) ;; common:get-homehost)) ;; TODO: Fix this.
(archive-time (seconds->std-time-str (current-seconds)))
(archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time))
(tmp-db-path (conc (common:get-db-tmp-area) "/megatest.db"))
(dbfile (conc archive-staging-db "/megatest.db")))
(create-directory archive-staging-db #t)
(let-values (((pid-val exit-status exit-code) (run-n-wait rsync-exe params: (list "-v" (conc (car home-host) ":"tmp-db-path) archive-staging-db) print-cmd: print-prefix)))
(if (eq? exit-code 0)
|