@@ -136,10 +136,11 @@ ;; 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)) @@ -150,13 +151,16 @@ (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 @@ -163,12 +167,11 @@ (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)) - (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/")) - + (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)) @@ -316,12 +319,126 @@ (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* "/logs/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 0 *default-log-port* "Init bup in " archive-dir) + (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix))) + (debug:print-info 0 *default-log-port* "Indexing data to be archived") + (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix) + (debug:print-info 0 *default-log-port* "Archiving data with bup") + (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix))) + (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 0 *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: #f)) + (db:multi-db-sync + (db:setup #f) + 'killservers + ;'dejunk + ;'adj-testids + 'old2new + ) + (debug:print-info 1 *default-log-port* "dropping trigerrs 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 '())) + (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 run-id test-partial-path test-last-update) + (print (seconds->std-time-str test-last-update)) + (let* ((internal-path (conc testsuite-name "-" run-id)) + (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)) 120) + (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"))) @@ -351,21 +468,24 @@ (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-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path)) + (archive-timestamp-dir (if archive-path (archive:get-timestamp-dir bup-exe archive-path (common:get-testsuite-name) run-id test-partial-path test-last-update) #f)) + (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/" 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 - ;; (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)) @@ -378,17 +498,14 @@ (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 @@ -395,15 +512,16 @@ (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)))) + (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