Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -7,11 +7,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format md5 message-digest) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format md5 message-digest srfi-18) (import (prefix sqlite3 sqlite3:)) (declare (unit archive)) (declare (uses db)) (declare (uses common)) @@ -99,11 +99,11 @@ ;; 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) +(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* ((min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000"))) (archive-info (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space)) @@ -136,11 +136,15 @@ (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)) - (test-physical-path (if (file-exists? test-path) (read-symbolic-link test-path #t) #f)) + (mutex-lock! rp-mutex) + (test-physical-path (if (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 @@ -182,15 +186,20 @@ (create-directory archive-dir #t)) (if (not (file-exists? (conc archive-dir "/HEAD"))) (begin ;; replace this with jobrunner stuff enventually (debug:print-info 0 "Init bup in " archive-dir) - (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix))) + ;; (mutex-lock! bup-mutex) + (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix) + ;; (mutex-unlock! bup-mutex) + )) (debug:print-info 0 "Indexing data to be archived") + ;; (mutex-lock! bup-mutex) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix) (debug:print-info 0 "Archiving data with bup") (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix) + ;; (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) @@ -198,11 +207,11 @@ (runs:remove-test-directory test-dat 'archive-remove)))) (hash-table-ref test-groups disk-group)))) (hash-table-keys disk-groups)) #t)) -(define (archive:bup-restore archive-command run-id run-name tests) ;; move the getting of archive space down into the below block so that a single run can +(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 (configf:lookup *configdat* "setup" "linktree"))) @@ -223,15 +232,16 @@ (> (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)) ;; 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 (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)) (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 @@ -271,10 +281,12 @@ (debug:print 0 "ERROR: 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 "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path) + ;; (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 0 "ERROR: No archive path in the record for run-id=" run-id " test-id=" test-id)))) (filter vector? tests)))) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -588,11 +588,28 @@ (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) +;; for reasons I don't understand multiple calls to real-path in parallel threads +;; must be protected by mutexes +;; (define (common:real-path inpath) + ;; (cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params) + ;; (let-values + ;; (((inp oup pid) (process "readlink" (list "-f" inpath)))) + ;; (with-input-from-port inp + ;; (let loop ((inl (read-line)) + ;; (res #f)) + ;; (print "inl=" inl) + ;; (if (eof-object? inl) + ;; (begin + ;; (close-input-port inp) + ;; (close-output-port oup) + ;; ;; (process-wait pid) + ;; res) + ;; (loop (read-line) inl)))))) (with-input-from-pipe (conc "readlink -f " inpath) read-line)) ;;====================================================================== ;; D I S K S P A C E ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1523,11 +1523,13 @@ (rundat (mt:get-runs-by-patt keys runnamepatt target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1)) (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)))) + (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))) + (rp-mutex (make-mutex)) + (bup-mutex (make-mutex))) (debug:print-info 4 "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) (if (> 2 (length state-status)) (begin (debug:print 0 "ERROR: the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL") (exit))) @@ -1572,12 +1574,12 @@ (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete")) ((archive) (debug:print 1 "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname")) (set! worker-thread (make-thread (lambda () (case (string->symbol (args:get-arg "-archive")) - ((save save-remove keep-html)(archive:run-bup (args:get-arg "-archive") run-id run-name tests)) - ((restore)(archive:bup-restore (args:get-arg "-archive") run-id run-name tests)) + ((save save-remove keep-html)(archive:run-bup (args:get-arg "-archive") run-id run-name tests rp-mutex bup-mutex)) + ((restore)(archive:bup-restore (args:get-arg "-archive") run-id run-name tests rp-mutex bup-mutex)) (else (debug:print 0 "ERROR: unrecognised sub command to -archive. Run \"megatest\" to see help") (exit)))) "archive-bup-thread")) (thread-start! worker-thread))