35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
+
+
+
+
+
+
+
-
+
+
|
(declare (uses mtmod))
(declare (uses dbmod))
(declare (uses dbfile))
(use srfi-69)
(module archivemod
(
archive:get-archive-disks
archive:allocate-new-archive-block
archive:get-timestamp-dir
archive:megatest-db
archive:bup-get-data
archive:restore-db
*
|
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
-
-
+
+
|
srfi-13
srfi-18
srfi-69
typed-records
z3
)
(include "common_records.scm")
(include "db_records.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
;;======================================================================
;;
;;======================================================================
;; ;; NOT CURRENTLY USED
;; ;;
|
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
|
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
|
-
+
-
+
|
(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)
|