@@ -14,622 +14,5 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-;;
-;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
-;;
-;; (declare (unit archive))
-;; (declare (uses db))
-;; (declare (uses common))
-;;
-;; (include "common_records.scm")
-;; (include "db_records.scm")
-;;
-;;======================================================================
-;;
-;;======================================================================
-
-;; NOT CURRENTLY USED
-;;
-;; (define (archive:main linktree target runname testname itempath options)
-;; (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempath))
-;; (flavor 'plain) ;; type of machine to run jobs on
-;; (maxload 1.5) ;; max allowed load for this work
-;; (adisks (archive:get-archive-disks)))
-;; ;; get testdir size
-;; ;; - hand off du to job mgr
-;; (if (and (common:file-exists? testdir)
-;; (file-writable? testdir))
-;; (let* ((dused (jobrunner:run-job
-;; flavor ;; machine type
-;; maxload ;; max allowed load
-;; '() ;; prevars - environment vars to set for the job
-;; common:get-disk-space-used ;; if a proc call it, if a string it is a unix command
-;; (list testdir)))
-;; (apath (archive:get-archive testname itempath dused)))
-;; (jobrunner:run-job
-;; flavor
-;; maxload
-;; '()
-;; archive:run-bup
-;; (list testdir apath))))))
-
-;; Get archive disks from megatest.config
-;;
-(define (archive:get-archive-disks)
- (let ((section (configf:get-section *configdat* "archive-disks")))
- (if section
- section
- '())))
-
-;; look for the best candidate archive area, else create new
-;; area
-;;
-(define (archive:get-archive testname itempath dused)
- ;; look up in archive_allocations if there is a pre-used archive
- ;; with adequate diskspace
- ;;
- (let* ((existing-blocks (rmt:archive-get-allocations testname itempath dused))
- (candidate-disks (map (lambda (block)
- (list
- (vector-ref block 1) ;; archive-area-name
- (vector-ref block 2))) ;; disk-path
- existing-blocks)))
- (or (common:get-disk-with-most-free-space candidate-disks dused)
- (archive:allocate-new-archive-block #f #f #f)))) ;; BROKEN. testname itempath))))
-
-;; allocate a new archive area
-;;
-(define (archive:allocate-new-archive-block blockid-cache run-area-home testsuite-name dneeded target run-name test-name)
- (let ((key (conc testsuite-name "/" target "/" run-name "/" test-name)))
- (if (hash-table-exists? blockid-cache key)
- (hash-table-ref blockid-cache key)
- (let* ((pscript (configf:lookup *configdat* "archive" "pathscript"))
- (pscript-cmd (conc pscript " " testsuite-name " " target " " run-name " " test-name))
- (apath (if pscript
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "ERROR: script \"" pscript-cmd "\" failed to run properly. exn=" exn)
- (exit 1))
- (with-input-from-pipe
- pscript-cmd
- read-line))
- #f)) ;; this is the user-calculated archive path
- (adisks (archive:get-archive-disks))
- (best-disk (common:get-disk-with-most-free-space adisks dneeded)))
- (if best-disk
- (let* ((bdisk-name (car best-disk))
- (bdisk-path (cdr best-disk))
- (area-key (substring (message-digest-string (md5-primitive) run-area-home) 0 5))
- (bdisk-id (rmt:archive-register-disk bdisk-name bdisk-path (get-df bdisk-path)))
- (archive-name (if apath
- apath
- (let ((sec (current-seconds)))
- (conc (time->string (seconds->local-time sec) "%Y")
- "_q" (seconds->quarter sec) "/"
- testsuite-name "_" area-key))))
- (archive-path (conc bdisk-path "/" archive-name))
- (block-id (rmt:archive-register-block-name bdisk-id archive-path)))
- ;; (allocation-id (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name area-key)))
- (if block-id ;; (and block-id allocation-id)
- (let ((res (cons block-id archive-path)))
- (hash-table-set! blockid-cache key res)
- res)
- (begin
- (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", archive-path=" archive-path)
- #f)))
- (begin
- (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name )
- #f)))))) ;; no best disk found
-
-;; archive - run bup
-;;
-;; 1. create the bup dir if not exists
-;; 2. start the du of each directory
-;; 3. gen index
-;; 4. save
-;;
-(define (archive:run-bup archive-command run-id run-name tests rp-mutex bup-mutex)
- ;; move the getting of archive space down into the below block so that a single run can
- ;; allocate as needed should a disk fill up
- ;;
- (let* ((blockid-cache (make-hash-table))
- (tsname (common:get-testsuite-name))
- (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
- (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
- (arch-groups (make-hash-table)) ;; archive groups, each corrosponds to a bup area
- (disk-groups (make-hash-table)) ;;
- (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely
- (test-dirs (make-hash-table))
- (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
- (compress (or (configf:lookup *configdat* "archive" "compress") "9"))
- (linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
- (archiver (let ((s (configf:lookup *configdat* "archive" "archiver")))
- (if s (string->symbol s) 'bup)))
- (archiver-cmd (case archiver
- ((tar) "tar cfj ARCHIVE_NAME.tar.bz2 ")
- ((7z) " 7z u -t7z -m0=lzma -mx=9 -mfb=64 -md=32m -ms=on ARCHIVE_NAME.7z ")
- (else #f)))
- (src-archive-linktree (rmt:get-var "src-archive-linktree"))
- (print-prefix "Running: ") ;; change to #f to turn off printing
- (preclean-spec (configf:get-section *configdat* "archive-preclean")))
-
- (if (or (not src-archive-linktree) (not (equal? src-archive-linktree linktree)))
- (rmt:set-var "src-archive-linktree" linktree))
- ;; (tests:match patt testname itempath)
-
- ;; from the test info bin the path to the test by stem
- ;;
- (for-each
- (lambda (test-dat)
- (let* ((item-path (db:test-get-item-path test-dat))
- (test-name (db:test-get-testname test-dat))
- (test-id (db:test-get-id test-dat))
- (run-id (db:test-get-run_id test-dat))
-
- (toplevel/children (and (db:test-get-is-toplevel test-dat)
- (> (rmt:test-toplevel-num-items run-id test-name) 0)))
- (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path)))
- ;; note the trailing slash to get the dir inspite of it being a link
- (test-path (conc linktree "/" test-partial-path))
- (mutex-lock! rp-mutex)
- (test-physical-path (if (common:file-exists? test-path)
- (common:real-path test-path)
- #f))
- (mutex-unlock! rp-mutex)
- (partial-path-index (if test-physical-path (substring-index test-partial-path test-physical-path) #f))
- (test-base (if (and partial-path-index
- test-physical-path )
- (substring test-physical-path
- 0
- partial-path-index)
- #f))
- ;; we need our archive dir checked for every test to enable folks who want to store other ways.
- (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target run-name test-name))
- (archive-dir (if archive-info (cdr archive-info) #f))
- (archive-id (if archive-info (car archive-info) -1)))
-
- (if (not archive-dir) ;; no archive disk found, this is fatal
- (begin
- (debug:print 0 *default-log-port* "FATAL: No archive disks found. Please add disks with at least "
- min-space " MB space to the [archive-disks] section of megatest.config")
- (debug:print 0 *default-log-port* " use [archive] minspace to specify minimum available space")
- (debug:print 0 *default-log-port* " disks: "
- (string-intersperse (map cadr (archive:get-archive-disks)) "\n "))
- (exit 1))
- (debug:print-info 0 *default-log-port* "Using path " archive-dir " for archiving test " test-path))
-
- ;; preclean the test directory per the spec if provided
- (if (not (null? preclean-spec)) ;; we've been asked to preclean before archiving
- (let loop ((spec (car preclean-spec))
- (tail (cdr preclean-spec)))
- (if (> (length spec) 1)
- (let ((testspec (car spec))
- (rules (cadr spec)))
- (if (tests:match testspec test-name item-path)
- (begin
- (debug:print 0 *default-log-port* "INFO: cleanup requested for " test-physical-path)
- (common:dir-clean-up test-physical-path rules remove-empty: #t))
- (if (not (null? tail))
- (loop (car tail)(cdr tail)))))
- (begin
- (debug:print 0 *default-log-port* "ERROR: bad spec line in [archive-preclean] section. \"" spec "\"")
- (if (not (null? tail))(loop (car tail)(cdr tail)))))))
- (cond
- (toplevel/children
- (debug:print 0 *default-log-port* "WARNING: cannot archive " test-name " with id " test-id
- " as it is a toplevel test with children"))
- ((not (common:file-exists? test-path))
- (debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path
- " as path " test-path " does not exist"))
- (else
- (debug:print 2 *default-log-port*
- "From test-dat=" test-dat " derived the following:\n"
- "test-partial-path = " test-partial-path "\n"
- "test-path = " test-path "\n"
- "test-physical-path = " test-physical-path "\n"
- "partial-path-index = " partial-path-index "\n"
- "test-base = " test-base)
- (hash-table-set! disk-groups test-base
- (cons test-physical-path (hash-table-ref/default disk-groups test-base '())))
- (hash-table-set! test-groups test-base
- (cons test-dat (hash-table-ref/default test-groups test-base '())))
- (hash-table-set! arch-groups test-base
- (cons archive-info (hash-table-ref/default arch-groups test-base '())))
- (hash-table-set! test-dirs test-id test-path)))))
- ;; test-path))))
- tests)
- (debug:print 0 *default-log-port* "INFO: DISK GROUPS=" (hash-table->alist disk-groups))
- ;; for each disk-group, initialize the bup area if needed
- (for-each
- (lambda (test-base)
- (let* ((disk-group (hash-table-ref disk-groups test-base))
- (arch-group (hash-table-ref arch-groups test-base))
- (arch-info (car arch-group)) ;; don't know yet how this will work, can I get more than one possibility?
- (archive-id (car arch-info))
- (archive-dir (cdr arch-info)))
- (debug:print 0 *default-log-port* "Processing disk-group " test-base)
- (let* ((test-paths-in (hash-table-ref disk-groups test-base))
- (test-paths (if (args:get-arg "-include")
- (let ((subpaths (string-split (args:get-arg "-include") ",")))
- (apply append
- (map (lambda (p)
- (map (lambda (subp)
- (conc p "/" subp))
- subpaths))
- test-paths-in)))
- test-paths-in)))
- (if (not (common:file-exists? archive-dir))
- (create-directory archive-dir #t))
- (case archiver
- ((bup) ;; Archive using bup
- (let* ((bup-init-params (list "-d" archive-dir "init"))
- (bup-index-params (append (list "-d" archive-dir "index") test-paths))
- (bup-save-params (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)
- (conc "-" compress) ;; or (conc "--compress=" compress)
- "-n" (conc (common:get-testsuite-name) "-"(string-substitute "/" "-" target " "))
- (conc "--strip-path=" (conc test-base target "/" )) ;; if we push to the directory do we need this?
- )
- test-paths)))
- (if (not (common:file-exists? (conc archive-dir "/HEAD")))
- (begin
- ;; replace this with jobrunner stuff enventually
- (debug:print-info 2 *default-log-port* "Init bup in " archive-dir)
- ;; (mutex-lock! bup-mutex)
- (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)))
- (if (not (eq? exit-code 0))
- (begin
- (debug:print-error 0 *default-log-port* "There was an error initializing bup. Archive failed.")
- (exit 1))))
- ;; (mutex-unlock! bup-mutex)
- ))
- (debug:print-info 2 *default-log-port* "Indexing data to be archived")
- ;; (mutex-lock! bup-mutex)
- (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)))
- (if (not (eq? exit-code 0))
- (begin
- (debug:print-error 0 *default-log-port* "There was an error Indexing bup. Archive failed.")
- (exit 1))))
- (debug:print-info 2 *default-log-port* "Archiving data with bup")
- (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
- (if (not (eq? exit-code 0))
- (begin
- (debug:print-error 0 *default-log-port* "There was an archiving data with bup. Archive failed.")
- (exit 1))))))
- ((7z tar)
- (for-each
- (lambda (test-dat)
- (let* ((test-id (db:test-get-id test-dat))
- (test-name (db:test-get-testname test-dat))
- (item-path (db:test-get-item-path test-dat))
- (test-full-name (db:test-make-full-name test-name item-path))
- (run-id (db:test-get-run_id test-dat))
- (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
- (run-name (rmt:get-run-name-from-id run-id))
- (source-dir (hash-table-ref test-dirs test-id)) ;; (conc test-base "/" test-name "/" item-path))
- (target-dir (string-substitute "/$" "" (conc archive-dir "/" target "/" run-name "/" test-full-name))))
- ;; create the test and item-path levels under archive-dir
- (create-directory (pathname-directory target-dir) #t)
- (run-n-wait
- (conc
- (string-substitute "ARCHIVE_NAME" target-dir archiver-cmd) " "
- "."
- )
- print-cmd: print-prefix
- run-dir: source-dir)))
- (hash-table-ref test-groups test-base))))
- ;; (mutex-unlock! bup-mutex)
- (for-each
- (lambda (test-dat)
- (let ((test-id (db:test-get-id test-dat))
- (run-id (db:test-get-run_id test-dat)))
- (rmt:test-set-archive-block-id run-id test-id archive-id)
- (if (member (symbol->string archive-command) '("save-remove"))
- (begin
- (debug:print-info 0 *default-log-port* "remove testdat")
- (runs:remove-test-directory test-dat 'archive-remove)))))
- (hash-table-ref test-groups test-base)))))
- (hash-table-keys disk-groups))
- #t))
-
-(define (archive:megatest-db target-patt run-patt)
- (let* ((blockid-cache (make-hash-table))
- (tsname (common:get-testsuite-name))
- (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
- (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
- (compress (or (configf:lookup *configdat* "archive" "compress") "9"))
- (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))
- (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)
- (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)
- "-n" (conc tsname "-megatest-db" )
- (conc "--strip-path=" archive-staging-db ) ;; if we push to the directory do we need this?
- dbfile)))
- (if (not (common:file-exists? (conc archive-dir "/HEAD")))
- (begin
- ;; replace this with jobrunner stuff enventually
- (debug:print-info 2 *default-log-port* "Init bup in " archive-dir)
- (let-values (((pid-val exit-status exit-code)(run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)))
- (if (not (eq? exit-code 0))
- (begin
- (debug:print-error 0 *default-log-port* "There was an error initializing bup. Archive failed.")
- (exit 1))))))
- (debug:print-info 2 *default-log-port* "Indexing data to be archived")
- (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)))
- (if (not (eq? exit-code 0))
- (begin
- (debug:print-error 0 *default-log-port* "There was an error Indexing bup. Archive failed.")
- (exit 1))))
- (debug:print-info 2 *default-log-port* "Archiving data with bup")
- (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
- (if (not (eq? exit-code 0))
- (begin
- (debug:print-error 0 *default-log-port* "There was an error archiving data with bup. Archive failed.")
- (exit 1))
- (debug:print-info 0 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp . Current timestamp: " (seconds->std-time-str (current-seconds)))))))
- (else
- (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver)))
- (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database")))))
-
-(define (archive:restore-db archive-path ts)
- (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
- (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" ))
- (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
- (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
- (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:"))
- (sleep 2)
- (db:multi-db-sync
- (db:setup #f)
- 'killservers
- ;'dejunk
- ;'adj-testids
- 'old2new
- )
- (debug:print-info 1 *default-log-port* "dropping triggers to update linktree")
- (rmt:drop-all-triggers)
- (let* ((linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
- (src-archive-linktree (rmt:get-var "src-archive-linktree")))
- (if (not (equal? src-archive-linktree linktree))
- (rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree))
- (debug:print-info 1 *default-log-port* "creating triggers after updating linktree")
- (rmt:create-all-triggers)
-))
-
-(define (archive:ls->list bup-exe archive-dir internal-path)
- (let ((cmd (conc bup-exe " -d " archive-dir " ls -l " internal-path "| awk '{print $6}' | sort"))
- (res '()))
- (debug:print-info 0 *default-log-port* cmd)
- (handle-exceptions
- exn
- #f ;; anything goes wrong - assume the process in NOT running.
- (with-input-from-pipe
- cmd
- (lambda ()
- (let* ((inl (read-lines)))
- (reverse inl)))))))
-
-(define (time-string->seconds tstr ds-flag)
- (let* ((atime (string->time tstr "%Y-%m-%d-%H%M%S")))
- (vector-set! atime 8 ds-flag)
- (local-time->seconds atime)))
-
-(define (seconds->std-time-str sec)
- (time->string
- (seconds->local-time sec)
- "%Y-%m-%d-%H%M%S"))
-
-
-(define (archive:get-timestamp-dir bup-exe archive-dir testsuite-name target test-partial-path test-last-update)
- (debug:print-info 0 *default-log-port* "Test last update time:" (seconds->std-time-str test-last-update))
- (let* ((internal-path (conc testsuite-name "-" target))
- (archive-update-delay (string->number (or (configf:lookup *configdat* "archive" "test-update-delay") "900" )))
- (ts-list (archive:ls->list bup-exe archive-dir internal-path))
- (ds-flag (vector-ref (seconds->local-time) 8)))
- (let loop ((hed (car ts-list))
- (tail (cdr ts-list)))
- (if (and (null? tail) (equal? hed "latest"))
- #f
- (if (and (not (null? tail)) (equal? hed "latest"))
- (loop (car tail) (cdr tail))
- (let* ((archive-seconds (time-string->seconds hed ds-flag)))
- (if (< (abs (- archive-seconds test-last-update)) archive-update-delay)
- (let* ((test-list (archive:ls->list bup-exe archive-dir (conc internal-path "/" hed "/" test-partial-path))))
- (if (> (length test-list) 0)
- hed
- (if (not (null? tail))
- (loop (car tail) (cdr tail))
- #f)))
- (if (null? tail)
- #f
- (loop (car tail) (cdr tail))))))))))
-
-(define (archive:bup-restore archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can
- ;; allocate as needed should a disk fill up
- ;;
- (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
- (linktree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
-
- ;; from the test info bin the path to the test by stem
- ;;
- (for-each
- (lambda (test-dat)
- ;; When restoring test-dat will initially contain an old and invalid path to the test
- (let* ((best-disk (get-best-disk *configdat* #f)) ;; BUG: get the testconfig and use it here. Otherwise data pulled out of archive could end up on the wrong kind of disk.
- (item-path (db:test-get-item-path test-dat))
- (test-name (db:test-get-testname test-dat))
- (test-id (db:test-get-id test-dat))
- (run-id (db:test-get-run_id test-dat))
- (keyvals (rmt:get-key-val-pairs run-id))
- (target (string-intersperse (map cadr keyvals) "/"))
-
- (toplevel/children (and (db:test-get-is-toplevel test-dat)
- (> (rmt:test-toplevel-num-items run-id test-name) 0)))
- (test-partial-path (conc run-name "/" (db:test-make-full-name test-name item-path)))
- ;; note the trailing slash to get the dir inspite of it being a link
- (test-path (conc linktree "/" test-partial-path))
- ;; if the old path was not deleted then prev-test-physical-path will end up pointing to a real directory
- (mutex-lock! rp-mutex)
- (prev-test-physical-path (if (common:file-exists? test-path)
- ;; (read-symbolic-link test-path #t)
- (common:real-path test-path)
- #f))
- (mutex-unlock! rp-mutex)
- (new-test-physical-path (conc best-disk "/" test-partial-path))
- (archive-block-id (db:test-get-archived test-dat))
- (test-last-update (db:test-get-last_update test-dat))
- (archive-block-info (rmt:test-get-archive-block-info archive-block-id))
- (archive-path (if (vector? archive-block-info)
- (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info
- #f)) ;; no archive found?
- (archive-timestamp-dir (if archive-path (archive:get-timestamp-dir bup-exe archive-path (common:get-testsuite-name) (string-substitute "/" "-" target " ") test-partial-path test-last-update) #f))
- (archive-internal-path (conc (common:get-testsuite-name) "-" (string-substitute "/" "-" target " ") "/" archive-timestamp-dir "/" test-partial-path))
- (include-paths (args:get-arg "-include"))
- (exclude-pattern (args:get-arg "-exclude-rx"))
- (exclude-file (args:get-arg "-exclude-rx-from")))
- (if (not archive-timestamp-dir)
- (debug:print-error 0 *default-log-port* "Archive not found for testsuite" (common:get-testsuite-name) " run/test/itempath" test-partial-path)
- (begin
- ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children
- (debug:print-info 0 *default-log-port* "Archive time: " archive-timestamp-dir)
- (if (and (not toplevel/children) ;; special handling needed for toplevel with children
- prev-test-physical-path
- (common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in?
- (let* ((base (pathname-directory prev-test-physical-path))
- (dirn (pathname-file prev-test-physical-path))
- (newn (conc base "/." dirn)))
- (debug:print-error 0 *default-log-port* "the old directory " prev-test-physical-path ", still exists! Moving it to " newn)
- (rename-file prev-test-physical-path newn)))
-
- (if (and archive-path ;; no point in proceeding if there is no actual archive
- (not toplevel/children))
- (begin
- ;; CREATE WORK AREA
- ;; test-src-path == #f ==> don't copy in data from tests directory
- ;; itemdat == string ==> use directly
- (create-work-area run-id run-name keyvals test-id #f best-disk test-name item-path) ;; #!key (remtries 2))
- ;; 1. Get the block id from the test info
- ;; 2. Get the block data given the block id
- ;; 3. Construct the paths etc. for the following command:
- ;; bup -d /tmp/matt/adisk1/2015_q1/fullrun_e1a40/ restore -C /tmp/seeme fullrun-30/latest/ubuntu/nfs/none/w02.1.20.54_b/
- ;; DO BUP RESTORE
- (let* ((new-test-dat (rmt:get-test-info-by-id run-id test-id))
- (new-test-path (if (vector? new-test-dat )
- (db:test-get-rundir new-test-dat)
- (begin
- (debug:print-error 0 *default-log-port* "unable to get data for run-id=" run-id ", test-id=" test-id)
- (exit 1))))
- ;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /..
- (bup-restore-params (list "-d" archive-path "restore" "-C" (conc new-test-path "/..") archive-internal-path)))
- (debug:print-info 0 *default-log-port* "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path)
- (debug:print-info 0 *default-log-port* bup-exe " " (string-join bup-restore-params " "))
- ;; (mutex-lock! bup-mutex)
- (run-n-wait bup-exe params: bup-restore-params print-cmd: #f)
- ;; (mutex-unlock! bup-mutex)
- (mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f)))
- (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id))))))
- (filter vector? tests))))
-
-(define (common:get-youngest-test tests)
- (if (null? tests)
- #f
- (let ((res #f))
- (for-each
- (lambda (test-dat)
- (let ((event-time (db:test-get-event_time test-dat)))
- (if (or (not res)
- (> event-time (db:test-get-event_time res)))
- (set! res test-dat))))
- tests)
- res)))
-
-;; from an archive get a specific path - works ONLY with bup for now
-;;
-(define (archive:bup-get-data archive-command run-id-in run-name-in tests rp-mutex bup-mutex)
- (if (null? tests)
- (debug:print-info 0 *default-log-port* "get-data called with no matching tests to operate on.")
-
- (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
- (linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
- ;; (test-dat (common:get-youngest-test tests))
- (destpath (args:get-arg "-dest")))
- (cond
- ((null? tests)
- (debug:print-error 0 *default-log-port*
- "No test matching provided target, runname pattern and test pattern found."))
- ((file-exists? destpath)
- (debug:print-error 0 *default-log-port*
- "Destination path alread exists! Please remove it before running get."))
- (else
- (let loop ((rem-tests tests))
- (let* ((test-dat (common:get-youngest-test rem-tests))
- (item-path (db:test-get-item-path test-dat))
- (test-name (db:test-get-testname test-dat))
- (test-id (db:test-get-id test-dat))
- (run-id (db:test-get-run_id test-dat))
- (run-name (rmt:get-run-name-from-id run-id))
- (keyvals (rmt:get-key-val-pairs run-id))
- (target (string-intersperse (map cadr keyvals) "/"))
-
- (toplevel/children (and (db:test-get-is-toplevel test-dat)
- (> (rmt:test-toplevel-num-items run-id test-name) 0)))
- (test-partial-path (conc target "/" run-name "/"
- (db:test-make-full-name test-name item-path)))
- ;; note the trailing slash to get the dir inspite of it being a link
- (test-path (conc linktree "/" test-partial-path))
- (archive-block-id (db:test-get-archived test-dat))
- (archive-block-info (rmt:test-get-archive-block-info archive-block-id))
- (archive-path (if (vector? archive-block-info)
- (vector-ref archive-block-info 2)
- #f))
- (archive-internal-path (conc (common:get-testsuite-name) "-" run-id
- "/latest/" test-partial-path))
- (include-paths (args:get-arg "-include"))
- (exclude-pattern (args:get-arg "-exclude-rx"))
- (exclude-file (args:get-arg "-exclude-rx-from")))
-
- (if (and archive-path ;; no point in proceeding if there is no actual archive
- (not toplevel/children))
- (begin
- (let* ((bup-restore-params (append (list "-d" archive-path "restore" "-C" (or destpath "data"))
- ;; " " ;; What is the empty string for?
- (if include-paths
- (map (lambda (p)
- (conc archive-internal-path "/" p))
- (string-split include-paths ","))
- (list archive-internal-path)))))
- (debug:print-info 0 *default-log-port* "Restoring archived data to " (or destpath "data")
- " from archive in " archive-path " ... " archive-internal-path)
- (run-n-wait bup-exe params: bup-restore-params print-cmd: #t)))
- (let ((new-rem-tests (filter (lambda (tdat)
- (or (not (eq? (db:test-get-id tdat) test-id))
- (not (eq? (db:test-get-run_id tdat) run-id))))
- rem-tests) ))
- (debug:print-info 0 *default-log-port*
- "No archive path in the record for run-id=" run-id
- " test-id=" test-id ", skipping.")
- (if (null? new-rem-tests)
- (begin
- (debug:print-info 0 *default-log-port* "No archives found for " target "/" run-name "...")
- #f)
- (loop new-rem-tests)))))))))))
-