234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
|
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
|
-
+
-
+
|
(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 #f) ;; FIXME! (server:choose-server *toppath* 'homehost))
(home-host (get-host-name)) ;; FIXME! (server:choose-server *toppath* 'homehost))
(archive-time (seconds->std-time-str (current-seconds)))
(archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time))
(tmp-db-path (conc (dbfile:make-tmpdir-name *toppath* "") "/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)))
(let-values (((pid-val exit-status exit-code) (run-n-wait rsync-exe params: (list "-v" (conc home-host ":"tmp-db-path) archive-staging-db) print-cmd: print-prefix)))
(if (eq? exit-code 0)
(case archiver
((bup) ;; Archive using bup
(let* ((bup-init-params (list "-d" archive-dir "init"))
(bup-index-params (list "-d" archive-dir "index" archive-staging-db))
(bup-save-params (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)
(conc "-" compress) ;; or (conc "--compress=" compress)
|