Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -387,50 +387,82 @@ ;; (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 run-name tests rp-mutex bup-mutex) +(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 (car tests)) + ;; (test-dat (common:get-youngest-test tests)) (destpath (args:get-arg "-dest"))) - - ;; When restoring test-dat will initially contain an old and invalid path to the test - (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)) - (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)) - (mutex-lock! rp-mutex) - (mutex-unlock! rp-mutex) - (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) ;; look in db.scm for test-get-archive-block-info for the vector record info - #f)) ;; no archive found? - (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path))) - - (if (and archive-path ;; no point in proceeding if there is no actual archive - (not toplevel/children)) - (begin - ;; 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-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" (or destpath "data") " " 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) - ;; (mutex-lock! bup-mutex) - (run-n-wait bup-exe params: bup-restore-params print-cmd: #f))) - (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id)))))) - + (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))) + + (if (and archive-path ;; no point in proceeding if there is no actual archive + (not toplevel/children)) + (begin + (let* ((bup-restore-params (list "-d" archive-path "restore" "-C" (or destpath "data") + " " ;; What is the empty string for? + 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))))))))))) + Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -2105,11 +2105,12 @@ (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))) (rp-mutex (make-mutex)) (bup-mutex (make-mutex)) - (keep-records (args:get-arg "-keep-records"))) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". + (keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". + (test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs)) (dbfile (conc *toppath* "/megatest.db")) (readonly-mode (not (file-write-access? dbfile)))) (when (and readonly-mode @@ -2139,11 +2140,11 @@ (run-name (db:get-value-by-header run header "runname")) (tests (if (not (equal? run-state "locked")) (proc-get-tests run-id) '())) (lasttpath "/does/not/exist/I/hope") - (lastrealpath "/does/not/exist/I/hope") + (lastrealpath "/does/not/exist/I/hope") (worker-thread #f)) (debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin (case action @@ -2166,26 +2167,29 @@ action) ((run-wait) (debug:print 1 *default-log-port* "Waiting for run " runkey ", run=" runnamepatt " to complete")) ((archive) (debug:print 1 *default-log-port* "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname")) - (set! worker-thread - (make-thread - (lambda () - (let ((op (string->symbol (args:get-arg "-archive")))) + (let ((op (string->symbol (args:get-arg "-archive")))) + (set! worker-thread + (make-thread + (lambda () (case op - ((save save-remove keep-html) - (archive:run-bup op run-id run-name tests rp-mutex bup-mutex)) - ((restore) - (archive:bup-restore op run-id run-name tests rp-mutex bup-mutex)) - ((get) - (archive:bup-get-data op run-id run-name tests rp-mutex bup-mutex)) - (else - (debug:print-error 0 *default-log-port* "unrecognised sub command " op " for -archive. Run \"megatest\" to see help") - (exit))))) - "archive-bup-thread")) - (thread-start! worker-thread)) + ((save save-remove keep-html) + (archive:run-bup op run-id run-name tests rp-mutex bup-mutex)) + ((restore) + (archive:bup-restore op run-id run-name tests rp-mutex bup-mutex)) + ((get) ;;; NOTE: This is a special case. We wish to operate on ALL tests in one go + (set! test-records (append tests test-records))) + (else + (debug:print-error 0 *default-log-port* "unrecognised sub command " op " for -archive. Run \"megatest\" to see help") + (exit)))) + "archive-bup-thread")) + (thread-start! worker-thread) + (if (eq? op 'get) + (thread-join! worker-thread)) ;; we need the test-records set to not overlap + )) (else (debug:print-info 0 *default-log-port* "action not recognised " action))) ;; actions that operate on one test at a time can be handled below ;; @@ -2397,10 +2401,11 @@ (loop (car tal)(cdr tal)))) ))) ) (if worker-thread (thread-join! worker-thread))) (common:join-backgrounded-threads)))) + ;; remove the run if zero tests remain (if (eq? action 'remove-runs) (let* ((run-id (db:get-value-by-header run header "id")) ;; NB// masks run-id from above? (remtests (mt:get-tests-for-run run-id #f '("DELETED") '("n/a") not-in: #t))) (if (null? remtests) ;; no more tests remaining @@ -2426,14 +2431,16 @@ (runs:recursive-delete-with-error-msg realpath) ))))) )) runs) - ;; (sqlite3:finalize! (db:delay-if-busy tdbdat)) + ;; special case - archive get + (if (equal? (args:get-arg "-archive") "get") + (archive:bup-get-data "get" #f #f test-records rp-mutex bup-mutex)) + ) + #t ) -#t -) (define (runs:remove-test-directory test mode) ;; remove-data-only) (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree (real-dir (if (common:file-exists? run-dir) ;; (resolve-pathname run-dir)