Index: TODO
==================================================================
--- TODO
+++ TODO
@@ -16,10 +16,17 @@
# along with Megatest. If not, see <http://www.gnu.org/licenses/>.
TODO
====
+WW38
+. Add test_rundat to no-sync ==> correction, put in <testdir>/.meta/test-run.dat
+. Add STATE/STATUS transitions to .meta/test-run.dat or similar
+. Swizzle update-test-rundat to operate on no-sync
+. Swizzle update-run-duration, -uname-host and cpuload-diskfree to no-sync
+. On state/status change update tests table with duration
+
WW15
. fill newview matrix with data, filter pipeline gui elements
. improve [script], especially indent handling
WW16
@@ -35,11 +42,10 @@
. break command line into sections; all, run control, queries, utilities etc.
. pull in ftfplan (not integrated, just code pulled in)
WW20
. ./configure => ubuntu, sles11, sles12, rh7
-. Jenkins junit XML support
. Add output flushing in teamcity support
. Switch to using simple runs query everywhere
. Add end_time to runs and add a rollup call that sets state, status and end_time
Future
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -120,11 +120,11 @@
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 ", block-id=" block-id)
+ (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
@@ -224,11 +224,11 @@
" 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 0 *default-log-port*
+ (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"
@@ -268,27 +268,39 @@
((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) "-" run-id)
- (conc "--strip-path=" test-base) ;; if we push to the directory do we need this?
+ "-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 0 *default-log-port* "Init bup in " archive-dir)
+ (debug:print-info 2 *default-log-port* "Init bup in " archive-dir)
;; (mutex-lock! bup-mutex)
- (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)
+ (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 0 *default-log-port* "Indexing data to be archived")
+ (debug:print-info 2 *default-log-port* "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 *default-log-port* "Archiving data with bup")
- (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
+ (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))
@@ -336,11 +348,11 @@
(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))
+ (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)
@@ -354,16 +366,29 @@
(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)))
+ (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 2 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp <ts>. 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)
@@ -411,13 +436,13 @@
(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)
+(define (archive:get-timestamp-dir bup-exe archive-dir testsuite-name target test-partial-path test-last-update)
(print (seconds->std-time-str test-last-update))
- (let* ((internal-path (conc testsuite-name "-" run-id))
+ (let* ((internal-path (conc testsuite-name "-" target))
(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"))
@@ -455,11 +480,11 @@
(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)))
+ (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)
@@ -472,12 +497,12 @@
(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) 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))
+ (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)
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -1534,11 +1534,10 @@
state TEXT DEFAULT 'new',
status TEXT DEFAULT 'n/a',
archive_type TEXT DEFAULT 'bup',
du INTEGER,
archive_path TEXT);")))
- ;; (print "creating trigges from init")
(db:create-triggers db)
db)) ;; )
;;======================================================================
;; A R C H I V E S
@@ -3467,11 +3466,11 @@
(lambda (run-id)
(let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
(db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs)))
run-ids)))
-;; Get test data using test_id, run-id is not used
+;; Get test data using test_id, run-id is not used - but it will be!
;;
(define (db:get-test-info-by-id dbstruct run-id test-id)
(db:with-db
dbstruct
#f ;; run-id
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -205,17 +205,19 @@
(current-seconds)
start-seconds)))))
(kill-tries 0))
;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area)
;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area)
- (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10)
+ (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10 update-db: #t)
(let loop ((minutes (calc-minutes))
(cpu-load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
(disk-free (get-df (current-directory)))
(last-sync (current-seconds)))
- (common:telemetry-log "zombie" (conc "launch:monitor-job - top of loop encountered at "(current-seconds)" with last-sync="last-sync))
+ ;; (common:telemetry-log "zombie" (conc "launch:monitor-job -
+ ;; top of loop encountered at "(current-seconds)" with
+ ;; last-sync="last-sync))
(let* ((over-time (> (current-seconds) (+ last-sync update-period)))
(new-cpu-load (let* ((load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
(delta (abs (- load cpu-load))))
(if (> delta 0.1) ;; don't bother updating with small changes
load
@@ -233,33 +235,28 @@
(test-info (rmt:get-test-info-by-id run-id test-id))
(state (db:test-get-state test-info))
(status (db:test-get-status test-info))
(kill-reason "no kill reason specified")
(kill-job? #f))
- (common:telemetry-log "zombie" (conc "launch:monitor-job - decision time encountered at "(current-seconds)" with last-sync="last-sync" do-sync="do-sync" over-time="over-time" update-period="update-period))
+ #;(common:telemetry-log "zombie" (conc "launch:monitor-job - decision time encountered at "(current-seconds)" with last-sync="last-sync" do-sync="do-sync" over-time="over-time" update-period="update-period))
(cond
((test-get-kill-request run-id test-id)
(set! kill-reason "KILLING TEST since received kill request (KILLREQ)")
(set! kill-job? #t))
((and runtlim (> (- (current-seconds) start-seconds) runtlim))
(set! kill-reason (conc "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" (- (current-seconds) start-seconds) " seconds, limit=" runtlim))
(set! kill-job? #t))
((equal? status "DEAD")
- (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
+ (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f update-db: #t)
(rmt:set-state-status-and-roll-up-items run-id test-id 'foo "RUNNING" "n/a" "was marked dead; really still running.")
;;(set! kill-reason "KILLING TEST because it was marked as DEAD by launch:handle-zombie-tests (might indicate really overloaded server or else overzealous setup.deadtime)") ;; MARK RUNNING
(set! kill-job? #f)))
(debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync)
(launch:handle-zombie-tests run-id)
- (when do-sync
- ;;(with-output-to-file (conc (getenv "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append)
- ;; (lambda () (pp (list (current-seconds) new-cpu-load new-disk-free (calc-minutes)))))
- (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync started at "(current-seconds)))
- (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
- (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync finished at "(current-seconds))))
-
+ (if do-sync ;; save meta data about the running of this test
+ (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f))
(if kill-job?
(begin
(debug:print-info 0 *default-log-port* "proceeding to kill test: "kill-reason)
(mutex-lock! m)
;; NOTE: The pid can change as different steps are run. Do we need handshaking between this
@@ -312,11 +309,11 @@
(if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
(loop (calc-minutes)
(or new-cpu-load cpu-load)
(or new-disk-free disk-free)
(if do-sync (current-seconds) last-sync)))))))
- (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional
+ (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f update-db: #t))) ;; NOTE: Checking twice for keep-going is intentional
(define (launch:execute encoded-cmd)
(let* ((cmdinfo (common:read-encoded-string encoded-cmd))
(tconfigreg #f))
@@ -465,11 +462,13 @@
(debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.")
(exit))))
(test-pid (db:test-get-process_id test-info)))
(cond
;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag.
- ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
+ ((or (member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
+ (and (equal? (db:test-get-state test-info) "COMPLETED") ;; completed/abort => rerun if asked
+ (member (db:test-get-status test-info) '("ABORT"))))
(debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
(rmt:general-call 'set-test-start-time #f test-id)
(rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -1970,15 +1970,17 @@
;;======================================================================
;; Archive tests
;;======================================================================
;; Archive tests matching target, runname, and testpatt
-(if (equal? (args:get-arg "-archive") "replicacte-db")
+(if (equal? (args:get-arg "-archive") "replicate-db")
(begin
;; check if source
- ;; check if megatest.db exist
- (launch:setup)
+ ;; check if megatest.db exist
+ (print "launch")
+ (launch:setup)
+ (print "launce done")
(if (not (args:get-arg "-source"))
(begin
(debug:print-info 1 *default-log-port* "Missing required argument -source <archive path>")
(exit 1)))
(if (common:file-exists? (conc *toppath* "/megatest.db"))
@@ -2001,11 +2003,11 @@
(set! *didsomething* #t))
(begin
(debug:print-error 1 *default-log-port* "Path " source " not found")
(exit 1))))))
;; else do a general-run-call
- (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicacte-db")))
+ (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db")))
(begin
;; for the archive get we need to preserve the starting dir as part of the target path
(if (and (args:get-arg "-dest")
(not (equal? (substring (args:get-arg "-dest") 0 1) "/")))
(let ((newpath (conc (current-directory) "/" (args:get-arg "-dest"))))
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -22,10 +22,12 @@
(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(include "common_records.scm")
+(include "db_records.scm")
+
;; (declare (uses rmtmod))
;; (import rmtmod)
;;
@@ -546,15 +548,24 @@
(rmt:general-call 'register-test run-id run-id test-name item-path))
(define (rmt:get-test-id run-id testname item-path)
(rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))
-;; run-id is NOT used
+;; run-id is NOT used - but it will be!
;;
(define (rmt:get-test-info-by-id run-id test-id)
(if (number? test-id)
- (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))
+ (let* ((testdat (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)))
+ (trundatf (conc (db:test-get-rundir testdat) "/.mt_data/test-run.dat")))
+ ;; now we can update a couple fields from the filesystem
+ (if (and (db:test-get-rundir testdat)
+ (file-exists? trundatf))
+ (let* ((duration (db:test-get-run_duration testdat))
+ (event-time (db:test-get-event_time testdat))
+ (last-touch (file-modification-time trundatf)))
+ (db:test-set-run_duration! testdat (max duration (- last-touch event-time)))))
+ testdat)
(begin
(debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
(print-call-chain (current-error-port))
#f)))
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -2241,52 +2241,76 @@
;;
(define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep #!key (actions '(print)))
(let* ((runs-ht (runs:get-hash-by-target target-patts runpatt))
(age (if (args:get-arg "-age")(common:hms-string->seconds (args:get-arg "-age")) #f))
(age-mark (if age (- (current-seconds) age) (+ (current-seconds) 86400)))
- (precmd (or (args:get-arg "-precmd") "")))
- (print "Actions: " actions)
- (for-each
- (lambda (target)
- (let* ((runs (hash-table-ref runs-ht target))
- (sorted (sort runs (lambda (a b)(< (simple-run-event_time a)(simple-run-event_time b)))))
- (to-remove (let* ((len (length sorted))
- (trim-amt (- len num-to-keep)))
- (if (> trim-amt 0)
- (take sorted trim-amt)
- '()))))
- (hash-table-set! runs-ht target to-remove)
- (print target ":")
- (for-each
- (lambda (run)
- (let ((remove (member run to-remove (lambda (a b)
- (eq? (simple-run-id a)
- (simple-run-id b))))))
- (if (and age (> (simple-run-event_time run) age-mark))
- (print "Skipping handling of " target "/" (simple-run-runname run) " as it is younger than " (args:get-arg "-age"))
- (for-each
- (lambda (action)
+ (precmd (or (args:get-arg "-precmd") ""))
+ (action-chk (member (string->symbol "remove-runs") actions)))
+ ;; check the sequence of actions archive must comme before remove-runs
+ (if (and action-chk (member (string->symbol "archive") action-chk))
+ (begin
+ (debug:print-error 0 *default-log-port* "action remove-runs must come after archive")
+ (exit 1)))
+ (print "Actions: " actions " age: " age)
+ (for-each
+ (lambda (target)
+ (let* ((runs (hash-table-ref runs-ht target))
+ (sorted (sort runs (lambda (a b)(< (simple-run-event_time a)(simple-run-event_time b)))))
+ (to-remove (let* ((len (length sorted))
+ (trim-amt (- len num-to-keep)))
+ (if (> trim-amt 0)
+ (take sorted trim-amt)
+ '()))))
+ (hash-table-set! runs-ht target to-remove)))
+ (hash-table-keys runs-ht))
+
+ (for-each
+ (lambda (action)
+ (for-each
+ (lambda (target)
+ (let* ((runs (hash-table-ref runs-ht target))
+ (sorted (sort runs (lambda (a b)(< (simple-run-event_time a)(simple-run-event_time b)))))
+ (to-remove (let* ((len (length sorted))
+ (trim-amt (- len num-to-keep)))
+ (if (> trim-amt 0)
+ (take sorted trim-amt)
+ '()))))
+ ;(hash-table-set! runs-ht target to-remove)
+ (print action " " target ":")
+ (for-each
+ (lambda (run)
+ (let ((remove #t ));(member run to-remove (lambda (a b)
+ ; (eq? (simple-run-id a)
+ ; (simple-run-id b))))))
+ (if (and age (> (simple-run-event_time run) age-mark))
+ (print "Skipping handling of " target "/" (simple-run-runname run) " as it is younger than " (args:get-arg "-age"))
(case action
((print)
(print " " (simple-run-runname run)
" " (time->string (seconds->local-time (simple-run-event_time run)) "WW%V.%u %H:%M:%S")
" " (if remove "REMOVE" "")))
((remove-runs)
- (if remove (system (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"
+ (print "in remove-runs")
+ (if remove
+ (let ((cmd (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"
(if (member 'kill-runs actions) ;; if kill-runs is specified then set -kill-wait to 0
" -kill-wait 0"
- "")))))
+ ""))))
+ (print cmd)
+ (system cmd))))
((archive)
- (if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %"))))
+ (if remove
+ (let ((cmd (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %")))
+ (print cmd)
+ (system cmd))))
((kill-runs)
(if remove (system (conc precmd " megatest -kill-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"))))
- ))
- actions))))
- sorted)))
- ;; (print "Sorted: " (map simple-run-event_time sorted))
- ;; (print "Remove: " (map simple-run-event_time to-remove))))
- (hash-table-keys runs-ht))
+ (else
+ (print "unrecognised cmd " action))))))
+ sorted)))
+ (hash-table-keys runs-ht)))
+ actions)
runs-ht))
(define (remove-last-path-directory path-in)
(let* ((dparts (string-split path-in "/"))
(path-out (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))
Index: sauth-common.scm
==================================================================
--- sauth-common.scm
+++ sauth-common.scm
@@ -240,11 +240,20 @@
(set! obj data-row))))
;(print obj)
obj))
+(define (sauth-common:src-size path)
+ (let ((output (with-input-from-pipe (conc "/usr/bin/du -s " path " | awk '{print $1}'")
+ (lambda()
+ (read-line)))))
+ (string->number output)))
+(define (sauth-common:space-left-at-dest path)
+ (let* ((output (run/string (pipe (df ,path ) (tail -1))))
+ (size (caddr (cdr (string-split output " ")))))
+ (string->number size)))
;; function to validate the users input for target path and resolve the path
;; TODO: Check for restriction in subpath
(define (sauth-common:resolve-path new current allowed-sheets)
(let* ((target-path (append current (string-split new "/")))
@@ -279,11 +288,11 @@
(if (and (not (equal? restricted-areas "" ))
(string-match (regexp restrictions) target-path))
(begin
- (sauth:print-error "Access denied to " (string-join resolved-path "/"))
+ (sauth:print-error (conc "Access denied to " (string-join resolved-path "/")))
;(exit 1)
#f)
target-path)
))
Index: spublish.scm
==================================================================
--- spublish.scm
+++ spublish.scm
@@ -391,10 +391,14 @@
((not (file-exists? target-path))
(sauth:print-error (conc " target Directory " target-path " does not exist!!")))
((not (file-exists? src-path))
(sauth:print-error (conc "Source path " src-path " does not exist!!" )))
(else
+ (if (< (sauth-common:space-left-at-dest target-path) (sauth-common:src-size src-path))
+ (begin
+ (sauth:print-error "Destination does not have enough disk space.")
+ (exit 1)))
(if (is_directory src-path)
(begin
(let* ((parent-dir src-path)
(start-dir target-path))
(run (pipe
Index: sretrieve.scm
==================================================================
--- sretrieve.scm
+++ sretrieve.scm
@@ -638,10 +638,11 @@
(pathname-file target-path)))
(curr-dir (current-directory))
(start-dir (conc (current-directory) "/" last-dir-name))
(execlude (make-exclude-pattern (string-split restrictions ",")))
(tmpfile (conc "/tmp/" (current-user-name) "/my-pipe-" (current-process-id))))
+ (sauth:print-error start-dir)
(if (file-exists? start-dir)
(begin
(sauth:print-error (conclast-dir-name " already exist in your work dir."))
(sauth:print-error "Nothing has been retrieved!! "))
(begin
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -1972,52 +1972,45 @@
tdb
"SELECT count(id) FROM test_rundat;")
res))
0)
-(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)
- (rmt:general-call 'update-test-rundat run-id test-id (current-seconds) (or cpuload -1)(or diskfree -1) -1 (or minutes -1))
- (if (and cpuload diskfree)
- (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id))
- (if minutes
- (rmt:general-call 'update-run-duration run-id minutes test-id))
- (if (and uname hostname)
- (rmt:general-call 'update-uname-host run-id uname hostname test-id)))
+;;
+(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname #!key (update-db #f))
+ (if (get-environment-variable "MT_TEST_RUN_DIR")
+ (let* ((dest-dir (conc (get-environment-variable "MT_TEST_RUN_DIR") "/.mt_data"))
+ (or-dash (lambda (instr)(if instr instr "-"))))
+ (if (not (directory-exists? dest-dir))(create-directory dest-dir #t))
+ (let* ((outp (open-output-file (conc dest-dir "/test-run.dat") #:append)))
+ (with-output-to-port outp
+ (lambda ()
+ (print (current-seconds) " " (or-dash run-id) " " (or-dash test-id) " "
+ (or-dash cpuload) " " (or-dash diskfree) " "
+ (or-dash minutes) " " (or-dash hostname) " "
+ (or-dash uname)))) ;; put uname last as it has spaces in it
+ (close-output-port outp)))
+ (begin
+ (rmt:general-call 'update-test-rundat run-id test-id (current-seconds) (or cpuload -1)(or diskfree -1) -1 (or minutes -1))))
+ (if update-db
+ (begin
+ (if (and cpuload diskfree)
+ (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id))
+ (if minutes
+ (rmt:general-call 'update-run-duration run-id minutes test-id))
+ (if (and uname hostname)
+ (rmt:general-call 'update-uname-host run-id uname hostname test-id)))))
;; This one is for running with no db access (i.e. via rmt: internally)
-(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries)
+(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries #!key (update-db #f))
;; (define (tests:set-full-meta-info test-id run-id minutes work-area)
;; (let ((remtries 10))
(let* ((cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(uname (get-uname "-srvpio"))
(hostname (get-host-name)))
- (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)))
-
-;; (define (tests:set-partial-meta-info test-id run-id minutes work-area)
-#;(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries)
- (let* ((cpuload (get-cpu-load))
- (diskfree (get-df (current-directory)))
- (remtries 10))
- (handle-exceptions
- exn
- (if (> remtries 0)
- (begin
- (print-call-chain (current-error-port))
- (debug:print-info 0 *default-log-port* "WARNING: failed to set meta info. Will try " remtries " more times")
- (set! remtries (- remtries 1))
- (thread-sleep! 10)
- (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1)))
- (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
- (debug:print-error 0 *default-log-port* "tried for over a minute to update meta info and failed. Giving up")
- (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 5 *default-log-port* "exn=" (condition->list exn))
- (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
- (print-call-chain (current-error-port))))
- (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
- )))
+ (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname update-db: update-db)))
+
;;======================================================================
;; A R C H I V I N G
;;======================================================================