Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -40,12 +40,14 @@ # module source files MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \ tcp-transportmod.scm rmtmod.scm portlogger.scm apimod.scm \ configfmod.scm processmod.scm servermod.scm megatestmod.scm \ - stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.scm tasksmod.scm \ - pkts.scm testsmod.scm pgdb.scm cookie.scm + stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.scm \ + pkts.scm testsmod.scm pgdb.scm cookie.scm launchmod.scm \ + subrunmod.scm runsmod.scm tasksmod.scm archivemod.scm \ + ezstepsmod.scm transport-mode.scm : transport-mode.scm.template cp transport-mode.scm.template transport-mode.scm dashboard-transport-mode.scm : dashboard-transport-mode.scm.template @@ -61,12 +63,16 @@ mofiles/processmod.o : mofiles/commonmod.o mofiles/servermod.o : mofiles/commonmod.o mofiles/rmtmod.o : mofiles/mtmod.o mofiles/apimod.o mofiles/dbmod.o : mofiles/mtmod.o # mofiles/mtmod.o : mofiles/tcp-transportmod.o -mofiles/megatestmod.o : mofiles/pkts.o mofiles/servermod.o +mofiles/megatestmod.o : mofiles/pkts.o mofiles/servermod.o mofiles/fsmod.o mofiles/mtmod.o : mofiles/testsmod.o +mofiles/subrunmod.o : mofiles/tasksmod.o +mofiles/launchmod.o : mofiles/subrunmod.o mofiles/runsmod.o +mofiles/launchmod.o : mofiles/ezstepsmod.o +mofiles/runsmod.o : mofiles/archivemod.o mofiles/dbfile.o : \ mofiles/debugprint.o mofiles/commonmod.o mofiles/configfmod.o mofiles/apimod.o : mofiles/commonmod.o mofiles/tcp-transportmod.o mofiles/configfmod.o mofiles/megatestmod.o mofiles/dbmod.o : mofiles/dbfile.o Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -34,614 +34,5 @@ configfmod debugprint rmtmod (prefix mtargs args:)) -(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 "/" itempatt)) - (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-is-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 (server:choose-server *toppath* 'homehost)) - (archive-time (seconds->std-time-str (current-seconds))) - (archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time)) - (tmp-db-path (conc (dbfile:make-tmpdir-name *toppath* "") "/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) ;; (db:setup-db *dbstruct-dbs* *toppath* #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))))))))))) - ADDED archivemod.scm Index: archivemod.scm ================================================================== --- /dev/null +++ archivemod.scm @@ -0,0 +1,441 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +;;====================================================================== +;; Cpumod: +;; +;; Put things here don't fit anywhere else +;;====================================================================== + +(declare (unit archivemod)) + +(declare (uses debugprint)) +(declare (uses mtargs)) +(declare (uses commonmod)) +(declare (uses configfmod)) +(declare (uses fsmod)) +(declare (uses processmod)) +(declare (uses mtmod)) +(declare (uses dbmod)) +(declare (uses dbfile)) + +(use srfi-69) + +(module archivemod + * + +(import scheme) +(cond-expand + (chicken-4 + + (import chicken + ports + (prefix base64 base64:) + + (prefix sqlite3 sqlite3:) + data-structures + extras + files + matchable + md5 + message-digest + pathname-expand + posix + posix-extras + + debugprint + (prefix mtargs args:) + ) + (use srfi-69)) + (chicken-5 + (import (prefix sqlite3 sqlite3:) + ;; data-structures + ;; extras + ;; files + ;; posix + ;; posix-extras + chicken.base + chicken.condition + chicken.file + chicken.file.posix + chicken.io + chicken.pathname + chicken.port + chicken.process + chicken.process-context + chicken.process-context.posix + chicken.sort + chicken.string + chicken.time + chicken.time.posix + + matchable + md5 + message-digest + pathname-expand + regex + regex-case + srfi-1 + srfi-18 + srfi-69 + typed-records + system-information + + debugprint + + ))) +(import debugprint + commonmod + configfmod + fsmod + rmtmod + processmod + mtmod + dbmod + dbfile + (prefix mtargs args:) + + regex + regex-case + sparse-vectors + srfi-1 + srfi-13 + srfi-18 + srfi-69 + typed-records + z3 + ) + +(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 "/" itempatt)) +;; (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-is-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 + + +(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 #f) ;; FIXME! (server:choose-server *toppath* 'homehost)) + (archive-time (seconds->std-time-str (current-seconds))) + (archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time)) + (tmp-db-path (conc (dbfile:make-tmpdir-name *toppath* "") "/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) ;; (db:setup-db *dbstruct-dbs* *toppath* #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 (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))))))))))) + +) Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -2729,8 +2729,12 @@ (conc megatest-version "-" megatest-fossil-hash)) (define (common:version-signature) (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) +(define (common:get-fields cfgdat) + (let ((fields (hash-table-ref/default cfgdat "fields" '()))) + (map car fields))) +(define keys:config-get-fields common:get-fields) ) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -55,28 +55,10 @@ (include "common_records.scm") (define configf:imports "(import commonmod configfmod processmod (prefix mtargs args:))") -;; pathenvvar will set the named var to the path of the config -(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) - (let* ((curr-dir (current-directory)) - (configinfo (find-config fname toppath: given-toppath)) - (toppath (car configinfo)) - (configfile (cadr configinfo)) - (set-fields (lambda (curr-section next-section ht path) - (let ((field-names (if ht (common:get-fields ht) '())) - (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target")))) - (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht) - (if (not (null? field-names))(keys:target-set-args field-names target #f)))))) - (if toppath (change-directory toppath)) - (if (and toppath pathenvvar)(setenv pathenvvar toppath)) - (let ((configdat (if configfile - (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f)))) - (if toppath (change-directory curr-dir)) - (list configdat toppath configfile fname)))) - (define (configf:process-line l ht allow-system #!key (linenum #f)) (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) (if matchdat Index: configfmod.scm ================================================================== --- configfmod.scm +++ configfmod.scm @@ -20,10 +20,11 @@ (declare (unit configfmod)) (declare (uses debugprint)) (declare (uses commonmod)) (declare (uses processmod)) +(declare (uses mtargs)) (use regex regex-case) (module configfmod * @@ -46,11 +47,13 @@ ) (import debugprint commonmod - processmod) + processmod + (prefix mtargs args:) + ) ;; Run a shell command and return the output as a string (define (shell cmd) (let* ((output (process:cmd-run->list cmd)) (res (car output)) @@ -430,11 +433,15 @@ (debug:print 0 *default-log-port* "read of alist " fname " failed. exn=" exn) #f) (configf:alist->config (with-input-from-file fname read)))) - +(define read-config (lambda ()(assert #f "FATAL: read-config proc not set!"))) + +(define (read-config-set! proc) + (set! read-config proc)) + ;; convert hierarchial list to ini format ;; (define (configf:config->ini data) (map (lambda (section) @@ -447,9 +454,27 @@ (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f))) (if fname (print "# " var "=>" fname)) (print var " " val))) section-dat))) ;; (print "section-dat: " section-dat)) (hash-table->alist data))) + +;; pathenvvar will set the named var to the path of the config +(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) + (let* ((curr-dir (current-directory)) + (configinfo (find-config fname toppath: given-toppath)) + (toppath (car configinfo)) + (configfile (cadr configinfo)) + (set-fields (lambda (curr-section next-section ht path) + (let ((field-names (if ht (common:get-fields ht) '())) + (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target")))) + (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht) + (if (not (null? field-names))(keys:target-set-args field-names target #f)))))) + (if toppath (change-directory toppath)) + (if (and toppath pathenvvar)(setenv pathenvvar toppath)) + (let ((configdat (if configfile + (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f)))) + (if toppath (change-directory curr-dir)) + (list configdat toppath configfile fname)))) ) Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -40,368 +40,5 @@ rmtmod (prefix mtargs args:) tasksmod ) -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") - - -;;(rmt:get-test-info-by-id run-id test-id) -> testdat - -;; TODO: deprecate me in favor of ezsteps.scm -;; -(define (ezsteps:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat) - (let* ((stepname (car ezstep)) ;; do stuff to run the step - (stepinfo (cadr ezstep)) - ;; (let ((info (cadr ezstep))) - ;; (if (proc? info) "" info))) - ;; (stepproc (let ((info (cadr ezstep))) - ;; (if (proc? info) info #f))) - (stepparts (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo)) - (stepparams (if (and (list? stepparts) - (> (length stepparts) 1)) - (list-ref stepparts 2) - #f)) ;; for future use, {VAR=1,2,3}, run step for each - (paramparts (if (string? stepparams) - (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams)) - '())) - (subrun (alist-ref "subrun" paramparts equal?)) - (stepcmd (if (and (list? stepparts) - (> (length stepparts) 2)) - (list-ref stepparts 3) - (conc "# error, no command for step "stepname))) - (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\ - (logpro-file (conc stepname ".logpro")) - (html-file (conc stepname ".html")) - (dat-file (conc stepname ".dat")) - (tconfig-logpro (configf:lookup testconfig "logpro" stepname)) - (logpro-used (common:file-exists? logpro-file)) - (mtexepath (common:get-megatest-exe-path))) - (setenv "MT_STEP_NAME" stepname) - (hash-table-set! all-steps-dat stepname `((params . ,paramparts))) - (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams - ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd) - - (if (and tconfig-logpro - (not logpro-used)) ;; no logpro file found but have a defn in the testconfig - (begin - (with-output-to-file logpro-file - (lambda () - (print ";; logpro file extracted from testconfig\n" - ";;") - (print tconfig-logpro))) - (set! logpro-used #t))) - - ;; NB// can safely assume we are in test-area directory - (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts - " stepparams: " stepparams " stepcmd: " stepcmd) - - ;; ;; first source the previous environment - ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") - ;; (get-environment-variable "SHELL")) ".csh" ".sh")))) - ;; (if (and prevstep (common:file-exists? prev-env)) - ;; (set! script (conc script "source " prev-env)))) - - ;; call the command using mt_ezstep - ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd)) - - (debug:print 4 *default-log-port* "script: " script) - (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) - ;; now launch the actual process - (call-with-environment-variables - (list (cons "PATH" mtexepath)) - (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1") - (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 - (pid #f)) - (let ((proc (lambda () - (set! pid (process-run "/bin/bash" (list "-c" cmd)))))) - (if subrun - (begin - (debug:print-info 0 *default-log-port* "Running "cmd" without MT_.* environment variables.") - (common:without-vars proc "^MT_.*")) - (proc))) - - (with-output-to-file "Makefile.ezsteps" - (lambda () - (print stepname ".log :") - (print "\t" cmd) - (if (common:file-exists? (conc stepname ".logpro")) - (print "\tlogpro " stepname ".logpro " stepname ".html < " stepname ".log")) - (print) - (print stepname " : " stepname ".log") - (print)) - #:append) - - (rmt:test-set-top-process-pid run-id test-id pid) - (let processloop ((i 0)) - (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) - (mutex-lock! m) - (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) - (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) - (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code) - (mutex-unlock! m) - (if (eq? pid-val 0) - (begin - (thread-sleep! 2) - (processloop (+ i 1)))) - ))))) - (debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) - ;; now run logpro if needed - (if logpro-used - (let* ((logpro-exe (or (getenv "LOGPRO_EXE") "logpro")) - (pid (process-run (conc "/bin/sh -c '"logpro-exe" "logpro-file " " (conc stepname ".html") " < " stepname ".log > /dev/null'")))) - (let processloop ((i 0)) - (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) - (mutex-lock! m) - ;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code) - (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) - (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) - (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code) - (mutex-unlock! m) - (if (eq? pid-val 0) - (begin - (thread-sleep! 2) - (processloop (+ i 1))))) - (debug:print-info 0 *default-log-port* "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2))))) - - (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) - (logfna (if logpro-used (conc stepname ".html") "")) - (comment #f)) - (if logpro-used - (let ((datfile (conc stepname ".dat"))) - ;; load the .dat file into the test_data table if it exists - (if (common:file-exists? datfile) - (set! comment (launch:load-logpro-dat run-id test-id stepname))) - (rmt:test-set-log! run-id test-id (conc stepname ".html")))) - (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna)) - ;; set the test final status - (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) - (this-step-status (cond - ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings - ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check - ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = waived - ((and (eq? process-exit-status 5) logpro-used) 'abort) ;; logpro 5 = abort - ((and (eq? process-exit-status 6) logpro-used) 'skip) ;; logpro 6 = skip - ((eq? process-exit-status 0) 'pass) ;; logpro 0 = pass - (else 'fail))) - (overall-status - (cond - ((eq? (launch:einf-rollup-status exit-info) 2) 'warn) ;; rollup-status (vector-ref exit-info 3) - ((eq? (launch:einf-rollup-status exit-info) 3) 'check) - ((eq? (launch:einf-rollup-status exit-info) 4) 'waived) - ((eq? (launch:einf-rollup-status exit-info) 5) 'abort) - ((eq? (launch:einf-rollup-status exit-info) 6) 'skip) - ((eq? (launch:einf-rollup-status exit-info) 0) 'pass) - (else 'fail))) - (next-status (common:worse-status-sym this-step-status overall-status)) - - (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ?? - (cond - ((null? tal) ;; more to run? - "COMPLETED") - (else "RUNNING")))) - (debug:print 4 *default-log-port* "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used - " this-step-status: " this-step-status " overall-status: " overall-status - " next-status: " next-status " rollup-status: " (launch:einf-rollup-status exit-info)) ;; (vector-ref exit-info 3)) - (case next-status - ((warn) - (launch:einf-rollup-status-set! exit-info 2) ;; (vector-set! exit-info 3 2) ;; rollup-status - ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! run-id test-id next-state "WARN" - (if (eq? this-step-status 'warn) "Logpro warning found" #f) - #f)) - ((check) - (launch:einf-rollup-status-set! exit-info 3) ;; (vector-set! exit-info 3 3) ;; rollup-status - ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! run-id test-id next-state "CHECK" - (if (eq? this-step-status 'check) "Logpro check found" #f) - #f)) - ((waived) - (launch:einf-rollup-status-set! exit-info 4) ;; (vector-set! exit-info 3 3) ;; rollup-status - ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! run-id test-id next-state "WAIVED" - (if (eq? this-step-status 'check) "Logpro waived found" #f) - #f)) - ((abort) - (launch:einf-rollup-status-set! exit-info 5) ;; (vector-set! exit-info 3 4) ;; rollup-status - ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! run-id test-id next-state "ABORT" - (if (eq? this-step-status 'abort) "Logpro abort found" #f) - #f)) - ((skip) - (launch:einf-rollup-status-set! exit-info 6) ;; (vector-set! exit-info 3 4) ;; rollup-status - ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! run-id test-id next-state "SKIP" - (if (eq? this-step-status 'skip) "Logpro skip found" #f) - #f)) - ((pass) - (tests:test-set-status! run-id test-id next-state "PASS" #f #f)) - (else ;; 'fail - (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" - (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) - ))) - logpro-used)) - -(define (ezsteps:run-from testdat start-step-name run-one) - ;;# TODO - recapture item variables, debug repeated step eval; regen logpro from test - (let* ((do-update-test-state-status #f) - (test-run-dir ;; (filedb:get-path *fdb* - (db:test-get-rundir testdat)) ;; ) - (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) - (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) - (run-mutex (make-mutex)) - (rollup-status 0) - (rollup-status-string #f) - (rollup-status-sym #f) - (exit-info (vector #t #t #t)) - (test-id (db:test-get-id testdat)) - (run-id (db:test-get-run_id testdat)) - (test-name (db:test-get-testname testdat)) - (orig-test-state (db:test-get-state testdat)) - (orig-test-status (db:test-get-status testdat)) - (kill-job #f) ;; for future use (on re-factoring with launch.scm code - (the-step-params '())) ;; not exactly "functional" - - ;; keep trying till NFS deigns to populate test run dir on this host - (let loop ((count 5)) - (if (not (common:file-exists? test-run-dir)) - ;;(push-directory test-run-dir) - (if (> count 0) - (begin - (debug:print 0 *default-log-port* "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times") - (sleep 3) - (loop (- count 1)))))) - - (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir) - (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps")) - ;; if ezsteps was defined then we are sure to have at least one step but check anyway - - (if (not (> (length ezstepslst) 0)) - (message-window "ERROR: You can only re-run steps defined via ezsteps") - (begin - (let loop ((ezstep (car ezstepslst)) - (tal (cdr ezstepslst)) - (status-sym-so-far 'pass) - ;;(runflag #f) - (saw-start-step-name #f)) ;; flag used to skip steps when not starting at the beginning - (if (or (vector-ref exit-info 1) - (equal? (alist-ref 'keep-going prev-step-params) 'yes)) - (let* ((prev-step-params the-step-params) ;; need to snag this now - (stepname (car ezstep)) ;; do stuff to run the step - (logpro-used (common:file-exists? (conc test-run-dir "/" stepname ".logpro"))) - (stepinfo (cadr ezstep)) - (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) - (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each - (stepcmd (list-ref stepparts 3)) - (script (conc "mt_ezstep '"test-run-dir"' '"stepname"' '"stepcmd"'")) ;; call the command using mt_ezstep - (saw-start-step-name-next (or saw-start-step-name (equal? stepname start-step-name))) - (proceed-with-this-step - (or (not start-step-name) - (equal? stepname start-step-name) - (and saw-start-step-name (not run-one)) - saw-start-step-name-next - (and start-step-name (equal? stepname start-step-name)))) - ) - (debug:print 0 *default-log-port* "NOTE: stepparms=" stepparms) - (set! prev-step-params stepparms) - (set! do-update-test-state-status (and proceed-with-this-step (null? tal))) - ;;(BB> "stepname="stepname" proceed-with-this-step="proceed-with-this-step " do-update-test-state-status="do-update-test-state-status " orig-test-state="orig-test-state" orig-test-status="orig-test-status) - (cond - ((and (not proceed-with-this-step) (null? tal)) - 'done) - ((not proceed-with-this-step) - (loop (car tal) - (cdr tal) - status-sym-so-far - saw-start-step-name-next)) - (else - (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts - " stepparms: " stepparms " stepcmd: " stepcmd) - (debug:print 4 *default-log-port* "script: " script) - (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) - - ;; now launch the script - (let ((pid (process-run script))) - (let processloop ((i 0)) - (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) - (mutex-lock! run-mutex) - (vector-set! exit-info 0 pid) - (vector-set! exit-info 1 exit-status) - (vector-set! exit-info 2 exit-code) - (mutex-unlock! run-mutex) - (if (eq? pid-val 0) - (begin - (thread-sleep! 1) - (processloop (+ i 1)))) - )) - (let ((exinfo (vector-ref exit-info 2)) - (logfna (if logpro-used (conc stepname ".html") ""))) - (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) - - (if logpro-used - (rmt:test-set-log! run-id test-id (conc stepname ".html"))) - - ;; set the test final status - (let* ((this-step-status (cond - (logpro-used - (common:logpro-exit-code->status-sym (vector-ref exit-info 2))) - ((eq? (vector-ref exit-info 2) 0) - 'pass) - (else - 'fail))) - (overall-status-sym (common:worse-status-sym this-step-status status-sym-so-far)) - (overall-status-string (status-sym->string overall-status-sym))) - (debug:print 4 *default-log-port* "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used - " this-step-status: " this-step-status " overall-status: " overall-status-sym) - ;;" next-status: " next-status " rollup-status: " rollup-status) - (set! rollup-status-string overall-status-string) - (set! rollup-status-sym overall-status-sym) - (tests:test-set-status! run-id test-id "RUNNING" overall-status-string #f #f))) - - (if (and - (not run-one) - (common:steps-can-proceed-given-status-sym rollup-status-sym) - (not (null? tal))) - (loop (car tal) - (cdr tal) - rollup-status-sym - saw-start-step-name-next))))) - (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))) - - ;; Once done with step/steps update the test record - ;; - (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) - (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr - ;; Am I completed? - (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) - (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status - ;; "COMPLETED" - ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test - ) - (new-status rollup-status-string) - ) ;; (db:test-get-status testinfo))) - (debug:print-info 2 *default-log-port* "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) - (tests:test-set-status! run-id test-id - (if do-update-test-state-status new-state orig-test-state) - (if do-update-test-state-status new-status orig-test-status) - (args:get-arg "-m") #f) - ;; need to update the top test record if PASS or FAIL and this is a subtest - (if (and (not (equal? item-path "")) do-update-test-state-status) - (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status #f)))) - ;; for automated creation of the rollup html file this is a good place... - (if (not (equal? item-path "")) - (tests:summarize-items run-id test-id test-name #f)) ;; don't force - just update if no - ))) - ;;(pop-directory) - rollup-status-string)) - -(define (ezsteps:spawn-run-from testdat start-step-name run-one) - (thread-start! - (make-thread - (lambda () - (ezsteps:run-from testdat start-step-name run-one)) - (conc "ezstep run single step " start-step-name " run-one="run-one))) - ) - ADDED ezstepsmod.scm Index: ezstepsmod.scm ================================================================== --- /dev/null +++ ezstepsmod.scm @@ -0,0 +1,496 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +;;====================================================================== +;; Cpumod: +;; +;; Put things here don't fit anywhere else +;;====================================================================== + +(declare (unit ezstepsmod)) + +(declare (uses debugprint)) +(declare (uses mtargs)) +(declare (uses commonmod)) +(declare (uses configfmod)) +(declare (uses dbfile)) +(declare (uses dbmod)) +(declare (uses rmtmod)) +(declare (uses servermod)) +(declare (uses processmod)) +(declare (uses pgdb)) +(declare (uses mtmod)) +(declare (uses megatestmod)) +(declare (uses tasksmod)) +(declare (uses subrunmod)) +(declare (uses testsmod)) +(declare (uses runsmod)) +(declare (uses fsmod)) + +(use srfi-69) + +(module ezstepsmod + * + +(import scheme) +(cond-expand + (chicken-4 + + (import chicken + ports + data-structures + extras + files + matchable + pathname-expand + posix + posix-extras + regex + regex-case + sparse-vectors + + ) + (use srfi-69)) + (chicken-5 + (import (prefix sqlite3 sqlite3:) + chicken.base + chicken.condition + chicken.file + chicken.file.posix + chicken.io + chicken.pathname + chicken.port + chicken.process + chicken.process-context + chicken.process-context.posix + chicken.sort + chicken.string + chicken.time + chicken.time.posix + + matchable + md5 + message-digest + pathname-expand + regex + regex-case + system-information + + ))) + +;; imports common to ck4 and ck5 +(import srfi-1 + srfi-13 + srfi-18 + srfi-69 + typed-records + (prefix base64 base64:) + (prefix sqlite3 sqlite3:) + md5 + message-digest + z3 + csv + directory-utils + + debugprint + commonmod + configfmod + (prefix mtargs args:) + dbmod + dbfile + rmtmod + servermod + processmod + pgdb + mtmod + megatestmod + tasksmod + subrunmod + testsmod + runsmod + fsmod + ) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") + + +;;(rmt:get-test-info-by-id run-id test-id) -> testdat + +;; TODO: deprecate me in favor of ezsteps.scm +;; +(define (ezsteps:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat) + (let* ((stepname (car ezstep)) ;; do stuff to run the step + (stepinfo (cadr ezstep)) + ;; (let ((info (cadr ezstep))) + ;; (if (proc? info) "" info))) + ;; (stepproc (let ((info (cadr ezstep))) + ;; (if (proc? info) info #f))) + (stepparts (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo)) + (stepparams (if (and (list? stepparts) + (> (length stepparts) 1)) + (list-ref stepparts 2) + #f)) ;; for future use, {VAR=1,2,3}, run step for each + (paramparts (if (string? stepparams) + (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams)) + '())) + (subrun (alist-ref "subrun" paramparts equal?)) + (stepcmd (if (and (list? stepparts) + (> (length stepparts) 2)) + (list-ref stepparts 3) + (conc "# error, no command for step "stepname))) + (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\ + (logpro-file (conc stepname ".logpro")) + (html-file (conc stepname ".html")) + (dat-file (conc stepname ".dat")) + (tconfig-logpro (configf:lookup testconfig "logpro" stepname)) + (logpro-used (common:file-exists? logpro-file)) + (mtexepath (common:get-megatest-exe-path))) + (setenv "MT_STEP_NAME" stepname) + (hash-table-set! all-steps-dat stepname `((params . ,paramparts))) + (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams + ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd) + + (if (and tconfig-logpro + (not logpro-used)) ;; no logpro file found but have a defn in the testconfig + (begin + (with-output-to-file logpro-file + (lambda () + (print ";; logpro file extracted from testconfig\n" + ";;") + (print tconfig-logpro))) + (set! logpro-used #t))) + + ;; NB// can safely assume we are in test-area directory + (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts + " stepparams: " stepparams " stepcmd: " stepcmd) + + ;; ;; first source the previous environment + ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") + ;; (get-environment-variable "SHELL")) ".csh" ".sh")))) + ;; (if (and prevstep (common:file-exists? prev-env)) + ;; (set! script (conc script "source " prev-env)))) + + ;; call the command using mt_ezstep + ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd)) + + (debug:print 4 *default-log-port* "script: " script) + (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) + ;; now launch the actual process + (call-with-environment-variables + (list (cons "PATH" mtexepath)) + (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1") + (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 + (pid #f)) + (let ((proc (lambda () + (set! pid (process-run "/bin/bash" (list "-c" cmd)))))) + (if subrun + (begin + (debug:print-info 0 *default-log-port* "Running "cmd" without MT_.* environment variables.") + (common:without-vars proc "^MT_.*")) + (proc))) + + (with-output-to-file "Makefile.ezsteps" + (lambda () + (print stepname ".log :") + (print "\t" cmd) + (if (common:file-exists? (conc stepname ".logpro")) + (print "\tlogpro " stepname ".logpro " stepname ".html < " stepname ".log")) + (print) + (print stepname " : " stepname ".log") + (print)) + #:append) + + (rmt:test-set-top-process-pid run-id test-id pid) + (let processloop ((i 0)) + (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) + (mutex-lock! m) + (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) + (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) + (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code) + (mutex-unlock! m) + (if (eq? pid-val 0) + (begin + (thread-sleep! 2) + (processloop (+ i 1)))) + ))))) + (debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) + ;; now run logpro if needed + (if logpro-used + (let* ((logpro-exe (or (getenv "LOGPRO_EXE") "logpro")) + (pid (process-run (conc "/bin/sh -c '"logpro-exe" "logpro-file " " (conc stepname ".html") " < " stepname ".log > /dev/null'")))) + (let processloop ((i 0)) + (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) + (mutex-lock! m) + ;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code) + (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) + (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) + (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code) + (mutex-unlock! m) + (if (eq? pid-val 0) + (begin + (thread-sleep! 2) + (processloop (+ i 1))))) + (debug:print-info 0 *default-log-port* "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2))))) + + (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) + (logfna (if logpro-used (conc stepname ".html") "")) + (comment #f)) + (if logpro-used + (let ((datfile (conc stepname ".dat"))) + ;; load the .dat file into the test_data table if it exists + (if (common:file-exists? datfile) + (set! comment (launch:load-logpro-dat run-id test-id stepname))) + (rmt:test-set-log! run-id test-id (conc stepname ".html")))) + (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna)) + ;; set the test final status + (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) + (this-step-status (cond + ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings + ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check + ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = waived + ((and (eq? process-exit-status 5) logpro-used) 'abort) ;; logpro 5 = abort + ((and (eq? process-exit-status 6) logpro-used) 'skip) ;; logpro 6 = skip + ((eq? process-exit-status 0) 'pass) ;; logpro 0 = pass + (else 'fail))) + (overall-status + (cond + ((eq? (launch:einf-rollup-status exit-info) 2) 'warn) ;; rollup-status (vector-ref exit-info 3) + ((eq? (launch:einf-rollup-status exit-info) 3) 'check) + ((eq? (launch:einf-rollup-status exit-info) 4) 'waived) + ((eq? (launch:einf-rollup-status exit-info) 5) 'abort) + ((eq? (launch:einf-rollup-status exit-info) 6) 'skip) + ((eq? (launch:einf-rollup-status exit-info) 0) 'pass) + (else 'fail))) + (next-status (common:worse-status-sym this-step-status overall-status)) + + (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ?? + (cond + ((null? tal) ;; more to run? + "COMPLETED") + (else "RUNNING")))) + (debug:print 4 *default-log-port* "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used + " this-step-status: " this-step-status " overall-status: " overall-status + " next-status: " next-status " rollup-status: " (launch:einf-rollup-status exit-info)) ;; (vector-ref exit-info 3)) + (case next-status + ((warn) + (launch:einf-rollup-status-set! exit-info 2) ;; (vector-set! exit-info 3 2) ;; rollup-status + ;; NB// test-set-status! does rdb calls under the hood + (tests:test-set-status! run-id test-id next-state "WARN" + (if (eq? this-step-status 'warn) "Logpro warning found" #f) + #f)) + ((check) + (launch:einf-rollup-status-set! exit-info 3) ;; (vector-set! exit-info 3 3) ;; rollup-status + ;; NB// test-set-status! does rdb calls under the hood + (tests:test-set-status! run-id test-id next-state "CHECK" + (if (eq? this-step-status 'check) "Logpro check found" #f) + #f)) + ((waived) + (launch:einf-rollup-status-set! exit-info 4) ;; (vector-set! exit-info 3 3) ;; rollup-status + ;; NB// test-set-status! does rdb calls under the hood + (tests:test-set-status! run-id test-id next-state "WAIVED" + (if (eq? this-step-status 'check) "Logpro waived found" #f) + #f)) + ((abort) + (launch:einf-rollup-status-set! exit-info 5) ;; (vector-set! exit-info 3 4) ;; rollup-status + ;; NB// test-set-status! does rdb calls under the hood + (tests:test-set-status! run-id test-id next-state "ABORT" + (if (eq? this-step-status 'abort) "Logpro abort found" #f) + #f)) + ((skip) + (launch:einf-rollup-status-set! exit-info 6) ;; (vector-set! exit-info 3 4) ;; rollup-status + ;; NB// test-set-status! does rdb calls under the hood + (tests:test-set-status! run-id test-id next-state "SKIP" + (if (eq? this-step-status 'skip) "Logpro skip found" #f) + #f)) + ((pass) + (tests:test-set-status! run-id test-id next-state "PASS" #f #f)) + (else ;; 'fail + (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" + (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) + ))) + logpro-used)) + +(define (ezsteps:run-from testdat start-step-name run-one) + ;;# TODO - recapture item variables, debug repeated step eval; regen logpro from test + (let* ((do-update-test-state-status #f) + (test-run-dir ;; (filedb:get-path *fdb* + (db:test-get-rundir testdat)) ;; ) + (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) + (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) + (run-mutex (make-mutex)) + (rollup-status 0) + (rollup-status-string #f) + (rollup-status-sym #f) + (exit-info (vector #t #t #t)) + (test-id (db:test-get-id testdat)) + (run-id (db:test-get-run_id testdat)) + (test-name (db:test-get-testname testdat)) + (orig-test-state (db:test-get-state testdat)) + (orig-test-status (db:test-get-status testdat)) + (kill-job #f) ;; for future use (on re-factoring with launch.scm code + (the-step-params '())) ;; not exactly "functional" + + ;; keep trying till NFS deigns to populate test run dir on this host + (let loop ((count 5)) + (if (not (common:file-exists? test-run-dir)) + ;;(push-directory test-run-dir) + (if (> count 0) + (begin + (debug:print 0 *default-log-port* "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times") + (sleep 3) + (loop (- count 1)))))) + + (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir) + (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps")) + ;; if ezsteps was defined then we are sure to have at least one step but check anyway + + (if (not (> (length ezstepslst) 0)) + (message-window "ERROR: You can only re-run steps defined via ezsteps") + (begin + (let loop ((ezstep (car ezstepslst)) + (tal (cdr ezstepslst)) + (status-sym-so-far 'pass) + ;;(runflag #f) + (saw-start-step-name #f)) ;; flag used to skip steps when not starting at the beginning + (if (or (vector-ref exit-info 1) + (equal? (alist-ref 'keep-going prev-step-params) 'yes)) + (let* ((prev-step-params the-step-params) ;; need to snag this now + (stepname (car ezstep)) ;; do stuff to run the step + (logpro-used (common:file-exists? (conc test-run-dir "/" stepname ".logpro"))) + (stepinfo (cadr ezstep)) + (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) + (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each + (stepcmd (list-ref stepparts 3)) + (script (conc "mt_ezstep '"test-run-dir"' '"stepname"' '"stepcmd"'")) ;; call the command using mt_ezstep + (saw-start-step-name-next (or saw-start-step-name (equal? stepname start-step-name))) + (proceed-with-this-step + (or (not start-step-name) + (equal? stepname start-step-name) + (and saw-start-step-name (not run-one)) + saw-start-step-name-next + (and start-step-name (equal? stepname start-step-name)))) + ) + (debug:print 0 *default-log-port* "NOTE: stepparms=" stepparms) + (set! prev-step-params stepparms) + (set! do-update-test-state-status (and proceed-with-this-step (null? tal))) + ;;(BB> "stepname="stepname" proceed-with-this-step="proceed-with-this-step " do-update-test-state-status="do-update-test-state-status " orig-test-state="orig-test-state" orig-test-status="orig-test-status) + (cond + ((and (not proceed-with-this-step) (null? tal)) + 'done) + ((not proceed-with-this-step) + (loop (car tal) + (cdr tal) + status-sym-so-far + saw-start-step-name-next)) + (else + (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts + " stepparms: " stepparms " stepcmd: " stepcmd) + (debug:print 4 *default-log-port* "script: " script) + (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) + + ;; now launch the script + (let ((pid (process-run script))) + (let processloop ((i 0)) + (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) + (mutex-lock! run-mutex) + (vector-set! exit-info 0 pid) + (vector-set! exit-info 1 exit-status) + (vector-set! exit-info 2 exit-code) + (mutex-unlock! run-mutex) + (if (eq? pid-val 0) + (begin + (thread-sleep! 1) + (processloop (+ i 1)))) + )) + (let ((exinfo (vector-ref exit-info 2)) + (logfna (if logpro-used (conc stepname ".html") ""))) + (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) + + (if logpro-used + (rmt:test-set-log! run-id test-id (conc stepname ".html"))) + + ;; set the test final status + (let* ((this-step-status (cond + (logpro-used + (common:logpro-exit-code->status-sym (vector-ref exit-info 2))) + ((eq? (vector-ref exit-info 2) 0) + 'pass) + (else + 'fail))) + (overall-status-sym (common:worse-status-sym this-step-status status-sym-so-far)) + (overall-status-string (status-sym->string overall-status-sym))) + (debug:print 4 *default-log-port* "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used + " this-step-status: " this-step-status " overall-status: " overall-status-sym) + ;;" next-status: " next-status " rollup-status: " rollup-status) + (set! rollup-status-string overall-status-string) + (set! rollup-status-sym overall-status-sym) + (tests:test-set-status! run-id test-id "RUNNING" overall-status-string #f #f))) + + (if (and + (not run-one) + (common:steps-can-proceed-given-status-sym rollup-status-sym) + (not (null? tal))) + (loop (car tal) + (cdr tal) + rollup-status-sym + saw-start-step-name-next))))) + (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))) + + ;; Once done with step/steps update the test record + ;; + (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) + (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr + ;; Am I completed? + (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) + (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status + ;; "COMPLETED" + ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test + ) + (new-status rollup-status-string) + ) ;; (db:test-get-status testinfo))) + (debug:print-info 2 *default-log-port* "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) + (tests:test-set-status! run-id test-id + (if do-update-test-state-status new-state orig-test-state) + (if do-update-test-state-status new-status orig-test-status) + (args:get-arg "-m") #f) + ;; need to update the top test record if PASS or FAIL and this is a subtest + (if (and (not (equal? item-path "")) do-update-test-state-status) + (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status #f)))) + ;; for automated creation of the rollup html file this is a good place... + (if (not (equal? item-path "")) + (tests:summarize-items run-id test-id test-name #f)) ;; don't force - just update if no + ))) + ;;(pop-directory) + rollup-status-string)) + +(define (ezsteps:spawn-run-from testdat start-step-name run-one) + (thread-start! + (make-thread + (lambda () + (ezsteps:run-from testdat start-step-name run-one)) + (conc "ezstep run single step " start-step-name " run-one="run-one))) + ) + + + +) Index: fsmod.scm ================================================================== --- fsmod.scm +++ fsmod.scm @@ -23,12 +23,16 @@ ;; ;; Put things here don't fit anywhere else ;;====================================================================== (declare (unit fsmod)) + (declare (uses debugprint)) (declare (uses mtargs)) +(declare (uses configfmod)) +(declare (uses commonmod)) +(declare (uses processmod)) (use srfi-69) (module fsmod * @@ -58,11 +62,10 @@ srfi-18 srfi-69 typed-records z3 - debugprint (prefix mtargs args:) ) (use srfi-69)) (chicken-5 (import (prefix sqlite3 sqlite3:) @@ -96,10 +99,176 @@ srfi-18 srfi-69 typed-records system-information - debugprint - ))) + ))) + +(import configfmod + commonmod + debugprint + processmod + ) + +;;====================================================================== +;; given path get free space, allows override in [setup] +;; with free-space-script /path/to/some/script.sh +;; +(define (get-df path) + (if (configf:lookup *configdat* "setup" "free-space-script") + (with-input-from-pipe + (conc (configf:lookup *configdat* "setup" "free-space-script") " " path) + (lambda () + (let ((res (read-line))) + (if (string? res) + (string->number res))))) + (get-unix-df path))) + +(define (get-free-inodes path) + (if (configf:lookup *configdat* "setup" "free-inodes-script") + (with-input-from-pipe + (conc (configf:lookup *configdat* "setup" "free-inodes-script") " " path) + (lambda () + (let ((res (read-line))) + (if (string? res) + (string->number res))))) + (get-unix-inodes path))) + +;;====================================================================== +;; D I S K S P A C E +;;====================================================================== + +(define (common:get-disk-space-used fpath) + (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read)) + +(define (get-unix-df path) + (let* ((df-results (process:cmd-run->list (conc "df " path))) + (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) + (freespc #f)) + ;; (write df-results) + (for-each (lambda (l) + (let ((match (string-search space-rx l))) + (if match + (let ((newval (string->number (cadr match)))) + (if (number? newval) + (set! freespc newval)))))) + (car df-results)) + freespc)) + +(define (get-unix-inodes path) + (let* ((df-results (process:cmd-run->list (conc "df -i " path))) + (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) + (freenodes 0)) ;; 0 is a better failsafe than #f here. + ;; (write df-results) + (for-each (lambda (l) + (let ((match (string-search space-rx l))) + (if match + (let ((newval (string->number (cadr match)))) + (if (number? newval) + (set! freenodes newval)))))) + (car df-results)) + freenodes)) + +(define (common:check-space-in-dir dirpath required) + (let* ((dbspace (if (directory? dirpath) + (get-df dirpath) + 0))) + (list (> dbspace required) + dbspace + required + dirpath))) + +(define (get-uname . params) + (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) + (uname #f)) + (if (null? (car uname-res)) + "unknown" + (caar uname-res)))) + +;;====================================================================== +;; check space in dbdir and in megatest dir +;; returns: ok/not dbspace required-space +;; +(define (common:check-db-dir-space) + (let* ((required (string->number + ;; default is 1GB (or actually a billion bytes) This is the number of 1 kB blocks. + (or (configf:lookup *configdat* "setup" "dbdir-space-required") + "1000000"))) + (dbdir (common:make-tmpdir-name *toppath* "")) ;; (db:get-dbdir)) + (tdbspace (common:check-space-in-dir dbdir required)) + (mdbspace (common:check-space-in-dir *toppath* required))) + (sort (list tdbspace mdbspace) (lambda (a b) + (< (cadr a)(cadr b)))))) + +;;====================================================================== +;; check available space in dbdir, exit if insufficient +;; +(define (common:check-db-dir-and-exit-if-insufficient) + (let* ((spacedat (car (common:check-db-dir-space))) ;; look only at worst for now + (is-ok (car spacedat)) + (dbspace (cadr spacedat)) + (required (caddr spacedat)) + (dbdir (cadddr spacedat))) + (if (not is-ok) + (begin + (debug:print-error 0 *default-log-port* "Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.") + (exit 1))))) + +;;====================================================================== +;; paths is list of lists ((name path) ... ) +;; +(define (common:get-disk-with-most-free-space disks minsize) + (let* ((best #f) + (bestsize 0) + (default-min-inodes-string "1000000") + (default-min-inodes (string->number default-min-inodes-string)) + (min-inodes (or (string->number (if (configf:lookup *configdat* "setup" "min_inodes") (configf:lookup *configdat* "setup" "min_inodes") default-min-inodes-string)) default-min-inodes))) + + (for-each + (lambda (disk-num) + (let* ((dirpath (cadr (assoc disk-num disks))) + (freespc (cond + ((not (directory? dirpath)) + (if (common:low-noise-print 300 "disks not a dir " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) + -1) + ((not (file-write-access? dirpath)) + (if (common:low-noise-print 300 "disks not writeable " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) + -1) + ((not (eq? (string-ref dirpath 0) #\/)) + (if (common:low-noise-print 300 "disks not a proper path " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) + -1) + (else + (get-df dirpath)))) + (free-inodes (cond + ((not (directory? dirpath)) + (if (common:low-noise-print 300 "disks not a dir " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) + -1) + ((not (file-write-access? dirpath)) + (if (common:low-noise-print 300 "disks not writeable " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) + -1) + ((not (eq? (string-ref dirpath 0) #\/)) + (if (common:low-noise-print 300 "disks not a proper path " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) + -1) + (else + (get-free-inodes dirpath)))) + ;;(free-inodes (get-free-inodes dirpath)) + ) + (debug:print 2 *default-log-port* "INFO: disk " disk-num " path " dirpath " free space " freespc " free inodes " free-inodes) + (if (and (> freespc bestsize)(> free-inodes min-inodes )) + (begin + (set! best (cons disk-num dirpath)) + (set! bestsize freespc))) + ;;(print "Processing: " disk-num " bestsize: " bestsize " best: " best " freespc: " freespc " min-inodes: " min-inodes " free-inodes: " free-inodes) + )) + (map car disks)) + (if (and best (> bestsize minsize)) + best + #f))) ;; #f means no disk candidate found ) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -64,1809 +64,5 @@ mtmod megatestmod tasksmod ) -;;====================================================================== -;; ezsteps -;;====================================================================== - -;; ezsteps were going to be coded as -;; stepname[,predstep1,predstep2 ...] [{VAR1=first,second,third}] command to execute -;; BUT -;; now are -;; stepname {VAR=first,second,third ...} command ... -;; where the {VAR=first,second,third ...} is optional. - -;; given an exit code and whether or not logpro was used calculate OK/BAD -;; return #t if we are ok, #f otherwise -(define (steprun-good? logpro exitcode stepparms) - (or (eq? exitcode 0) - (and logpro (member exitcode '( 2 4 6))) - (let* ((params (alist-ref 'params stepparms)) ;; get the params section - (keep-going (if params - (alist-ref "keep-going" params equal?) - #f))) - (debug:print 0 *default-log-port* "keep-going=" keep-going) - (and keep-going (equal? (car keep-going) "yes"))))) - -;; if handed a string, process it, else look for MT_CMDINFO -(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f)) - (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO")))) - (if enccmd - (common:read-encoded-string enccmd) - '()))) - -;; 0 1 2 3 -(defstruct launch:einf (pid #t)(exit-status #t)(exit-code #t)(rollup-status 0)) - -;; return (conc status ": " comment) from the final section so that -;; the comment can be set in the step record in launch.scm -;; -(define (launch:load-logpro-dat run-id test-id stepname) - (let ((cname (conc stepname ".dat"))) - (if (common:file-exists? cname) - (let* ((dat (read-config cname #f #f)) - (csvr (db:logpro-dat->csv dat stepname)) - (csvt (let-values (((fmt-cell fmt-record fmt-csv) (make-format ","))) - (fmt-csv (map list->csv-record csvr)))) - (status (configf:lookup dat "final" "exit-status")) - (msg (configf:lookup dat "final" "message"))) - (if csvt ;; this if blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro - (rmt:csv->test-data run-id test-id csvt) - (debug:print 0 *default-log-port* "ERROR: no csvdat exists for run-id: " run-id " test-id: " test-id " stepname: " stepname ", check that logpro version is 1.15 or newer")) - ;; (debug:print-info 13 *default-log-port* "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr) - ;; ) - (cond - ((equal? status "PASS") "PASS") ;; skip the message part if status is pass - (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message"))) - (else #f))) - #f))) - -(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m) - ;; (let-values - ;; (((pid exit-status exit-code) - ;; (run-n-wait fullrunscript))) - ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) - ;; Since we should have a clean slate at this time there is no need to do - ;; any of the other stuff that tests:test-set-status! does. Let's just - ;; force RUNNING/n/a - - ;; (thread-sleep! 0.3) - ;; (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") - (rmt:set-state-status-and-roll-up-items run-id test-name item-path "RUNNING" #f #f) - ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here - - ;; if there is a runscript do it first - (if fullrunscript - (let ((pid (process-run fullrunscript))) - (rmt:test-set-top-process-pid run-id test-id pid) - (let loop ((i 0)) - (let-values - (((pid-val exit-status exit-code) (process-wait pid #t))) - (mutex-lock! m) - (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) - (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) - (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code) - (launch:einf-rollup-status-set! exit-info exit-code) ;; (vector-set! exit-info 3 exit-code) ;; rollup status - (mutex-unlock! m) - (if (eq? pid-val 0) - (begin - (thread-sleep! 2) - (loop (+ i 1))) - ))))) - ;; then, if runscript ran ok (or did not get called) - ;; do all the ezsteps (if any) - (if (or ezsteps subrun) - (let* ((test-run-dir (tests:get-test-path-from-environment)) - (testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? - ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic - ;; ezstep names need a full re-eval here. - (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) - (ezstepslst (if (hash-table? testconfig) - (hash-table-ref/default testconfig "ezsteps" '()) - #f))) - (if testconfig - (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... - (begin - (launch:setup) - (debug:print 0 *default-log-port* "WARNING: no testconfig found for " test-name " in search path:\n " - (string-intersperse (tests:get-tests-search-path *configdat*) "\n ")))) - ;; after all that, still no testconfig? Time to abort - (if (not testconfig) - (begin - (debug:print-error 0 *default-log-port* "Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") - (exit 1))) - - ;; create a proc for the subrun if requested, save that proc in the ezsteps table as the last entry - ;; 1. get section [runarun] - ;; 2. unset MT_* vars - ;; 3. fix target - ;; 4. fix runname - ;; 5. fix testpatt or calculate it from contour - ;; 6. launch the run - ;; 7. roll up the run result and or roll up the logpro processed result - (when (configf:lookup testconfig "subrun" "runwait") ;; we use runwait as the flag that a subrun is requested - (subrun:initialize-toprun-test testconfig test-run-dir) - (let* ((mt-cmd (subrun:launch-cmd test-run-dir (configf:lookup testconfig "subrun" "runwait")))) - (debug:print-info 0 *default-log-port* "Subrun command is \"" mt-cmd "\"") - (set! ezsteps #t) ;; set the needed flag - (set! ezstepslst - (append (or ezstepslst '()) - (list (list "subrun" (conc "{subrun=true} " mt-cmd))))))) - - ;; process the ezsteps - (if ezsteps - (let* ((all-steps-dat (make-hash-table))) ;; keep all the info around as stepname ==> alist; where 'params is the params list (add other stuff as needed) - (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps")) - ;; if ezsteps was defined then we are sure to have at least one step but check anyway - (if (not (> (length ezstepslst) 0)) - (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length") - (let ((all-step-names (map car ezstepslst)) - (status-file (file-open "ezsteps.status" (+ open/append open/wronly open/creat))) - ) - (setenv "MT_STEP_NAMES" (string-intersperse all-step-names " ")) - (let loop ((ezstep (car ezstepslst)) - (tal (cdr ezstepslst)) - (prevstep #f)) - (debug:print-info 0 *default-log-port* "Processing ezstep \"" (string-intersperse ezstep " ") "\"") - ;; check exit-info (vector-ref exit-info 1) - (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) - (let* ((logpro-used (ezsteps:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)) - (stepname (car ezstep)) - (stepparms (hash-table-ref all-steps-dat stepname))) - (setenv "MT_STEP_NAME" stepname) - (pp (hash-table->alist all-steps-dat)) - ;; if logpro-used read in the stepname.dat file - (if (and logpro-used (common:file-exists? (conc stepname ".dat"))) - (launch:load-logpro-dat run-id test-id stepname)) - - (file-write status-file (conc stepname " " (launch:einf-exit-code exit-info) "\n")) - - (if (steprun-good? logpro-used (launch:einf-exit-code exit-info) stepparms) - (if (not (null? tal)) - (loop (car tal) (cdr tal) stepname)) - (debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping"))) - (debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))) - (file-close status-file) - ) - - )))))) - -(define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags) - (let* ((update-period (string->number (or (configf:lookup *configdat* "setup" "test-stats-update-period") "60"))) - (start-seconds (current-seconds)) - (calc-minutes (lambda () - (inexact->exact - (round - (- - (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) - - (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))) - (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 - #f))) - (new-disk-free (let* ((df (if over-time ;; only get df every 30 seconds - (get-df (current-directory)) - disk-free)) - (delta (abs (- df disk-free)))) - (if (and (> df 0) - (> (/ delta df) 0.1)) ;; (> delta 200) ;; ignore changes under 200 Meg - df - #f))) - (do-sync (or new-cpu-load new-disk-free over-time)) - - (test-info (rmt:get-test-state-status-by-id run-id test-id)) - (state (car test-info));; (db:test-get-state test-info)) - (status (cdr test-info));; (db:test-get-status test-info)) - (killreq (equal? state "KILLREQ")) - (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)) - (cond - (killreq - (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) - (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) - (if (common:low-noise-print 600 "run zombie") ;; every five minutes is plenty - (launch:handle-zombie-tests run-id)) - (when do-sync - (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 - ;; section and the runit section? Or add a loop that tries three times with a 1/4 second - ;; between tries? - (let* ((pid1 (launch:einf-pid exit-info)) ;; (vector-ref exit-info 0)) - (pid2 (rmt:test-get-top-process-pid run-id test-id)) - (pids (delete-duplicates (filter number? (list pid1 pid2))))) - (if (not (null? pids)) - (begin - (for-each - (lambda (pid) - (handle-exceptions - exn - (begin - (debug:print-info 0 *default-log-port* "Unable to kill process with pid " pid ", possibly already killed.") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) - (debug:print 0 *default-log-port* "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")") - (debug:print-info 0 *default-log-port* "Signal mask=" (signal-mask)) - ;; (if (process:alive? pid) - ;; (begin - (map (lambda (pid-num) - (process-signal pid-num signal/term)) - (process:get-sub-pids pid)) - (thread-sleep! 5) - ;; (if (process:process-alive? pid) - (map (lambda (pid-num) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* " .... had trouble sending kill to " pid-num ", exn=" exn) - #f) - (process-signal pid-num signal/kill))) - (process:get-sub-pids pid)))) - ;; (debug:print-info 0 *default-log-port* "not killing process " pid " as it is not alive")))) - pids) - ;; BB: question to Matt -- does the tests:test-state-status! encompass rollup to toplevel? If not, should it? - (tests:test-set-status! run-id test-id "KILLED" "KILLED" (conc (args:get-arg "-m")" "kill-reason) #f)) ;; BB ADDED kill-reason -- confirm OK with Matt - (begin - (debug:print-error 0 *default-log-port* "Nothing to kill, pid1=" pid1 ", pid2=" pid2) - (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (conc (args:get-arg "-m")" "kill-reason) #f) ;; BB ADDED kill-reason -- confirm OK with Matt - ))) - (mutex-unlock! m) - ;; no point in sticking around. Exit now. But run end of run before exiting? - (launch:end-of-run-check run-id) - (exit))) - (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 - (begin - (thread-sleep! 6) ;; was 3 - (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 (commonmod:get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional - - -;; read testconfig and create .logpro and script files -;; - use #f for tconfigreg to re-read the testconfigs from disk -;; -(define (launch:extract-scripts-logpro test-dir test-name item-path tconfigreg-in) - (let* ((tconfigreg (or tconfigreg-in - (tests:get-all))) - (tconfig-fname (conc test-dir "/.testconfig")) - (tconfig-tmpfile (conc tconfig-fname ".tmp")) - (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) - (scripts (configf:get-section tconfig "scripts")) - (logpros (configf:get-section tconfig "logpro"))) - ;; create .testconfig file - (configf:write-alist tconfig tconfig-tmpfile) - (file-move tconfig-tmpfile tconfig-fname #t) - (delete-file* ".final-status") - - ;; extract scripts from testconfig and write them to files in test run dir - (for-each - (lambda (scriptdat) - (match scriptdat - ((name content) - (debug:print-info 2 *default-log-port* "Creating script "(current-directory)"/"name) - (with-output-to-file name - (lambda () - (print content))) - (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu))) - (else - (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\"")))) - scripts) - - ;; extract logpro from testconfig and write them to files in test run dir - (for-each - (lambda (logprodat) - (match logprodat - ((name content) - (debug:print-info 2 *default-log-port* "Creating logpro file "(current-directory)"/"name".logpro") - (with-output-to-file (conc name".logpro") - (lambda () - (print content) - ;; (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)) - ))) - (else - (debug:print-info 0 "Invalid logpro definiton found in [logpro] section of testconfig. \"" logprodat "\"")))) - logpros))) - -(define (launch:execute encoded-cmd) - (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) - (tconfigreg #f)) - (setenv "MT_CMDINFO" encoded-cmd) - ;;(bb-check-path msg: "launch:execute incoming") - (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) - ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) - (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area - (top-path (assoc/default 'toppath cmdinfo)) - (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area - (test-name (assoc/default 'test-name cmdinfo)) - (runscript (assoc/default 'runscript cmdinfo)) - (ezsteps (assoc/default 'ezsteps cmdinfo)) - (subrun (assoc/default 'subrun cmdinfo)) - ;; (runremote (assoc/default 'runremote cmdinfo)) - ;; (transport (assoc/default 'transport cmdinfo)) ;; not used - ;; (serverinf (assoc/default 'serverinf cmdinfo)) - ;; (port (assoc/default 'port cmdinfo)) - (serverurl (assoc/default 'serverurl cmdinfo)) - (homehost (assoc/default 'homehost cmdinfo)) - (run-id (assoc/default 'run-id cmdinfo)) - (test-id (assoc/default 'test-id cmdinfo)) - (target (assoc/default 'target cmdinfo)) - (areaname (assoc/default 'areaname cmdinfo)) - (itemdat (assoc/default 'itemdat cmdinfo)) - (env-ovrd (assoc/default 'env-ovrd cmdinfo)) - (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar - (runname (assoc/default 'runname cmdinfo)) - (megatest (assoc/default 'megatest cmdinfo)) - (runtlim (assoc/default 'runtlim cmdinfo)) - (contour (assoc/default 'contour cmdinfo)) - (item-path (item-list->path itemdat)) - (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) - (keys #f) - (keyvals #f) - (fullrunscript (if (not runscript) - #f - (if (substring-index "/" runscript) - runscript ;; use unadultered if contains slashes - (let ((fulln (conc work-area "/" runscript))) - (if (and (common:file-exists? fulln) - (file-execute-access? fulln)) - fulln - runscript))))) ;; assume it is on the path - (check-work-area (lambda () - ;; NFS might not have propagated the directory meta data to the run host - give it time if needed - (let loop ((count 0)) - (if (or (common:directory-exists? work-area) - (> count 10)) - (change-directory work-area) - (begin - (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") - (thread-sleep! 10) - (loop (+ count 1))))) - - (if (not (string=? (common:real-path work-area)(common:real-path (current-directory)))) - (begin - (debug:print 0 *default-log-port* - "INFO: we are expecting to be in directory " work-area "\n" - " but we are actually in the directory " (current-directory) "\n" - " doing another change dir.") - (change-directory work-area))) - - ;; spot check that the files in testpath are available. Too often NFS delays cause problems here. - (let ((files (glob (conc testpath "/*"))) - (bad-files '())) - (for-each - (lambda (fullname) - (let* ((fname (pathname-strip-directory fullname)) - (targn (conc work-area "/" fname))) - (if (not (file-exists? targn)) - (set! bad-files (cons fname bad-files))))) - files) - (if (not (null? bad-files)) - (begin - (debug:print 0 *default-log-port* "INFO: test data from " testpath " not copied properly or filesystem problems causing data to not be found. Re-running the copy command.") - (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", ")) - (launch:test-copy testpath work-area)))) - ;; one more time, change to the work-area directory - (change-directory work-area))) - ) ;; let* - - (if contour (setenv "MT_CONTOUR" contour)) - - ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ... - ;; - (setenv "MT_TESTSUITENAME" areaname) - (setenv "MT_RUN_AREA_HOME" top-path) - (set! *toppath* top-path) - (change-directory *toppath*) ;; temporarily switch to the run area home - (setenv "MT_TEST_RUN_DIR" work-area) - - (launch:setup) ;; should be properly in the run area home now - - (if contour (setenv "MT_CONTOUR" contour)) - - ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ... - ;; - (setenv "MT_TESTSUITENAME" areaname) - (setenv "MT_RUN_AREA_HOME" top-path) - (set! *toppath* top-path) - (change-directory *toppath*) ;; temporarily switch to the run area home - (setenv "MT_TEST_RUN_DIR" work-area) - - (launch:setup) ;; should be properly in the run area home now - - (set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path - (let ((sighand (lambda (signum) - ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting - (if (eq? signum signal/stop) - (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting.")) - (set! *time-to-exit* #t) - (debug:print 0 *default-log-port* "Received signal " signum ", cleaning up before exit (set this test to COMPLETED/ABORT) . Please wait...") - (let ((th1 (make-thread (lambda () - (debug:print 0 *default-log-port* "set test to COMPLETED/ABORT begin.") - (rmt:test-set-state-status run-id test-id "COMPLETED" "ABORT" "received kill signal") - (debug:print 0 *default-log-port* "set test to COMPLETED/ABORT complete.") - (debug:print 0 *default-log-port* "Killed by signal " signum ". Exiting") - (exit 1)))) - (th2 (make-thread (lambda () - (thread-sleep! 20) - (debug:print 0 *default-log-port* "Done") - (exit 4))))) - (thread-start! th2) - (thread-start! th1) - (thread-join! th2))))) - (set-signal-handler! signal/int sighand) - (set-signal-handler! signal/term sighand) - ) ;; (set-signal-handler! signal/stop sighand) - - ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, - ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* - ;; - (let* ((test-info (let loop ((tries 0)) - (let ((tinfo (rmt:get-test-info-by-id run-id test-id))) - (if tinfo - tinfo - (if (> tries 5) - #f - (begin - (thread-sleep! (+ 1 (* tries 10))) - (loop (+ tries 1)))))))) - (test-host (if test-info - (db:test-get-host test-info) - (begin - (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 - (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 run-id test-id) - (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) - ) ;; prime it for running - ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART")) - (if (process:alive-on-host? test-host test-pid) - (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed") - (exit 1))) - ((member (db:test-get-state test-info) '("COMPLETED")) ;; we do NOT want to re-run COMPLETED jobs. Mark as NOT_STARTED to run! - (debug:print 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed") - (debug:print 0 *default-log-port* "exiting with status 1") - (exit 1)) - ((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) - ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") - (rmt:general-call 'set-test-start-time run-id test-id) - (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)) - (else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")) - (debug:print 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed") - (debug:print 0 *default-log-port* "exiting with status 1") - (exit 1)))) - - ;; cleanup prior execution's steps - (rmt:delete-steps-for-test! run-id test-id) - - (debug:print 2 *default-log-port* "Executing " test-name " (id: " test-id ") on " (get-host-name)) - (set! keys (rmt:get-keys)) - ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process - ;; one of these is defunct/redundant ... - (if (not (launch:setup force-reread: #t)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - ;; (sqlite3:finalize! db) - ;; (sqlite3:finalize! tdb) - (exit 1))) - ;; validate that the test run area is available - (check-work-area) - - ;; still need to go back to run area home for next couple steps - (change-directory *toppath*) - - ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This - ;; seems non-ideal but could well break stuff - ;; BUG? BUG? BUG? - - (let ((rconfig (full-runconfigs-read)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))) - (wconfig (read-config "waivers.config" #f #t sections: `( "default" ,target )))) ;; read the waivers config if it exists - ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target) - ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) - ;; Now have runconfigs data loaded, set environment vars - (for-each - (lambda (section) - (for-each - (lambda (varval) - (let ((var (car varval)) - (val (cadr varval))) - (if (and (string? var)(string? val)) - (begin - (safe-setenv var (configf:eval-string-in-environment val))) ;; val) - (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val)))) - (configf:get-section rconfig section))) - (list "default" target))) - ;;(bb-check-path msg: "launch:execute post block 1") - - ;; NFS might not have propagated the directory meta data to the run host - give it time if needed - (let loop ((count 0)) - (if (or (common:file-exists? work-area) - (> count 10)) - (change-directory work-area) - (begin - (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") - (thread-sleep! 10) - (loop (+ count 1))))) - - ;; now we can switch to the work-area? - (change-directory work-area) - ;;(bb-check-path msg: "launch:execute post block 1.5") - ;; (change-directory work-area) - (set! keyvals (keys:target->keyval keys target)) - ;; apply pre-overrides before other variables. The pre-override vars must not - ;; clobbers things from the official sources such as megatest.config and runconfigs.config - (if (string? set-vars) - (let ((varpairs (string-split set-vars ","))) - (debug:print 4 *default-log-port* "varpairs: " varpairs) - (map (lambda (varpair) - (let ((varval (string-split varpair "="))) - (if (eq? (length varval) 2) - (let ((var (car varval)) - (val (cadr varval))) - (debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment") - (setenv var val))))) - varpairs))) - ;;(bb-check-path msg: "launch:execute post block 2") - (for-each - (lambda (varval) - (let ((var (car varval)) - (val (cadr varval))) - (if val - (setenv var val) - (begin - (debug:print-error 0 *default-log-port* "required variable " var " does not have a valid value. Exiting") - (exit))))) - (list - (list "MT_TEST_RUN_DIR" work-area) - (list "MT_TEST_NAME" test-name) - (list "MT_ITEM_INFO" (conc itemdat)) - (list "MT_ITEMPATH" item-path) - (list "MT_RUNNAME" runname) - (list "MT_MEGATEST" megatest) - (list "MT_TARGET" target) - (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) - (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) - ;;(bb-check-path msg: "launch:execute post block 3") - - (let ((tmppath (getenv "PATH"))) - (if (string-search tmppath " ") - (debug:print 0 *default-log-port* "WARNING: spaces in PATH are not supported.")) - (if mt-bindir-path (setenv "PATH" (conc tmppath":"mt-bindir-path)))) - ;;(bb-check-path msg: "launch:execute post block 4") - ;; (change-directory top-path) - ;; Can setup as client for server mode now - ;; (client:setup) - - ;; environment overrides are done *before* the remaining critical envars. - (alist->env-vars env-ovrd) - ;;(bb-check-path msg: "launch:execute post block 41") - (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) - ;;(bb-check-path msg: "launch:execute post block 42") - (set-item-env-vars itemdat) - ;;(bb-check-path msg: "launch:execute post block 43") - (let ((blacklist (configf:lookup *configdat* "setup" "blacklistvars"))) - (if blacklist - (let ((vars (string-split blacklist))) - (save-environment-as-files "megatest" ignorevars: vars) - (for-each (lambda (var) - (unsetenv var)) - vars)) - (save-environment-as-files "megatest"))) - ;;(bb-check-path msg: "launch:execute post block 44") - ;; open-run-close not needed for test-set-meta-info - ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) - ;; (tests:set-full-meta-info test-id run-id 0 work-area) - (tests:set-full-meta-info #f test-id run-id 0 work-area 10) - - ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here - - (if (args:get-arg "-xterm") - (set! fullrunscript "xterm") - (if (and fullrunscript - (common:file-exists? fullrunscript) - (not (file-execute-access? fullrunscript))) - (system (conc "chmod ug+x " fullrunscript)))) - (launch:extract-scripts-logpro work-area test-name item-path tconfigreg) - -;;;;; ;; We are about to actually kick off the test -;;;;; ;; so this is a good place to remove the records for -;;;;; ;; any previous runs -;;;;; ;; (db:test-remove-steps db run-id testname itemdat) -;;;;; ;; now is also a good time to write the .testconfig file -;;;;; (let* ((tconfig-fname (conc work-area "/.testconfig")) -;;;;; (tconfig-tmpfile (conc tconfig-fname ".tmp")) -;;;;; (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) -;;;;; (scripts (configf:get-section tconfig "scripts")) -;;;;; (precmd (configf:lookup tconfig ) -;;;;; ;; create .testconfig file -;;;;; (configf:write-alist tconfig tconfig-tmpfile) -;;;;; (file-move tconfig-tmpfile tconfig-fname #t) -;;;;; (delete-file* ".final-status") -;;;;; -;;;;; ;; extract scripts from testconfig and write them to files in test run dir -;;;;; (for-each -;;;;; (lambda (scriptdat) -;;;;; (match scriptdat -;;;;; ((name content) -;;;;; (with-output-to-file name -;;;;; (lambda () -;;;;; (print content) -;;;;; (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu))))) -;;;;; (else -;;;;; (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\"")))) -;;;;; scripts)) - ;; - - (let* ((m (make-mutex)) - (kill-job? #f) - (exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status - (job-thread #f) - ;; (keep-going #t) - (misc-flags (let ((ht (make-hash-table))) - (hash-table-set! ht 'keep-going #t) - ht)) - (runit (lambda () - (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m))) - (monitorjob (lambda () - (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags))) - (th1 (make-thread monitorjob "monitor job")) - (th2 (make-thread runit "run job")) - (tconfig (tests:get-testconfig test-name item-path tconfigreg #t)) - (propagate-exit-code (configf:lookup *configdat* "setup" "propagate-exit-code")) - (propagate-status-list '("FAIL" "KILLED" "ABORT" "DEAD" "CHECK" "SKIP" "WAIVED")) - (test-status "not set") - (precmd (configf:lookup tconfig "setup" "precmd")) - (postcmd (configf:lookup tconfig "setup" "postcmd"))) - ;; first, if set, run the precmd - (if precmd ;; (file-exists? precmd)(file-execute-access? precmd)) - (system precmd)) ;; up to test author to put nbfake if desired. - (set! job-thread th2) - (thread-start! th1) - (thread-start! th2) - (thread-join! th2) - (debug:print-info 0 *default-log-port* "Megatest execute of test " test-name ", item path " item-path " complete. Notifying the db ...") - (debug:print-info 2 *default-log-port* "exit-info = " exit-info) - (hash-table-set! misc-flags 'keep-going #f) - (thread-join! th1) - (thread-sleep! 1) ;; givbe thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. - (mutex-lock! m) - (let* ((item-path (item-list->path itemdat)) - ;; only state and status needed - use lazy routine - (testinfo (rmt:get-testinfo-state-status run-id test-id))) - ;; Am I completed? - (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) - (let ((new-state (if kill-job? "KILLED" "COMPLETED")) - (new-status (cond - ((not (launch:einf-exit-status exit-info)) "FAIL") ;; job failed to run ... (vector-ref exit-info 1) - ((eq? (launch:einf-rollup-status exit-info) 0) ;; (vector-ref exit-info 3) - ;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO) - (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) - ((eq? (launch:einf-rollup-status exit-info) 1) "FAIL") ;; (vector-ref exit-info 3) - ((eq? (launch:einf-rollup-status exit-info) 2) ;; (vector-ref exit-info 3) - ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) - (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) - ((eq? (launch:einf-rollup-status exit-info) 3) "CHECK") - ((eq? (launch:einf-rollup-status exit-info) 4) "WAIVED") - ((eq? (launch:einf-rollup-status exit-info) 5) "ABORT") - ((eq? (launch:einf-rollup-status exit-info) 6) "SKIP") - (else "FAIL"))) - ) ;; (db:test-get-status testinfo))) - (debug:print-info 0 *default-log-port* "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info)) - - ;; Leave a .final-status file for each sub-test - (tests:save-final-status run-id test-id) - - (tests:test-set-status! run-id - test-id - new-state - new-status - (args:get-arg "-m") #f) - ;; need to update the top test record if PASS or FAIL and this is a subtest - ;; NO NEED TO CALL set-state-status-and-roll-up-items HERE, THIS IS DONE IN set-state-status-and-roll-up-items called by tests:test-set-status! - ) - ) - - - ;; for automated creation of the rollup html file this is a good place... - (if (not (equal? item-path "")) - (tests:summarize-items run-id test-id test-name #f)) - ;; BUG was this meant to be the antecnt of the if above? - ;; BUG was this meant to be the antecnt of the if above? - (tests:summarize-test run-id test-id) ;; don't force - just update if no - ;; Leave a .final-status file for the top level test - (tests:save-final-status run-id test-id) - (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) ;; end of let* - - (mutex-unlock! m) - (launch:end-of-run-check run-id ) - (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " - work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n") - - - (set! test-status (db:test-get-status (rmt:get-testinfo-state-status run-id test-id))) - - ;; If the propagate-exit-code option has been set in the megatest config, and the test status matches the list, set the exit code to 1. - - (if postcmd - (system postcmd)) - - (if (and propagate-exit-code (string=? propagate-exit-code "yes") (member test-status propagate-status-list)) - (begin - (debug:print 1 *default-log-port* "Setting exit status to 1 because of test status of " test-status) - (set! *globalexitstatus* 1) - ) - ) - - (if (not (launch:einf-exit-status exit-info)) - (exit 4)))) - ))) - -;; Spec for End of test -;; At end of each test call, after marking self as COMPLETED do run-state-status-rollup -;; At transition to run COMPLETED/X do hooks -;; Definition: test_dead if event_time + duration + 1 minute? < current_time AND -;; we can prove the process is not alive (ssh host pstree -A pid) -;; if dead safe to mark the test as killed in the db -;; State/status table -;; new -;; 100% COMPLETED/ (PASS,FAIL,ABORT etc.) ==> COMPLETED / X where X is same as itemized rollup -;; > 3 RUNNING with not test_dead do nothing (run should already be RUNNING/ na -;; > 0 RUNNING and test_dead then send KILLREQ ==> COMPLETED -;; 0 RUNNING ==> this is actually the first condition, should not get here -(define *last-rollup* 0) -(define (launch:end-of-run-check run-id ) - (let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id)) - (running-cnt (rmt:get-count-tests-running-for-run-id run-id)) - (all-test-launched (rmt:get-var (conc "lunch-complete-" run-id))) - (current-state-status (rmt:get-run-state-status run-id)) - (current-state (car current-state-status)) ;; (rmt:get-run-state run-id)) - (current-status (cdr current-state-status))) ;; (rmt:get-run-status run-id))) - ;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing - (debug:print 0 *default-log-port* "Running test cnt :" running-cnt) - ;; - ;; TODO: add a final rollup when run is done (if there isn't one already) - ;; - (if (or (< running-cnt 3) ;; have only few running - (> (- (current-seconds) *last-rollup*) 10)) ;; or haven't rolled up in past ten seconds - (begin - (rmt:set-state-status-and-roll-up-run run-id current-state current-status) - (set! *last-rollup* (current-seconds)))) - (runs:update-junit-test-reporter-xml run-id) - (cond - ((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" )) - (if (and (equal? (rmt:get-var (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id))) - (begin - (debug:print 4 *default-log-port* "look for post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var (conc "end-of-run-" run-id))) - (debug:print 0 *default-log-port* "End of Run Detected.") - (rmt:set-var (conc "end-of-run-" run-id) "yes") - ;(thread-sleep! 10) - (runs:run-post-hook run-id) - (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var (conc "end-of-run-" run-id))) - (common:simple-unlock (conc "endOfRun" run-id))) - (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var (conc "end-of-run-" run-id))))) - ((> running-cnt 3) - (debug:print 0 *default-log-port* "There are " running-cnt " tests running." )) - ((> running-cnt 0) - (debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" ) - (let ((kill-cnt (launch:kill-tests-if-dead run-id))) - (if (and all-test-launched (equal? all-test-launched "yes") (eq? kill-cnt running-cnt)) - (launch:end-of-run-check run-id)))) ;;todo - (else (debug:print 0 *default-log-port* "Should it get here?? May be everything is not launched yet. Running test cnt:" running-cnt " Not completed test cnt:" not-completed-cnt) - (let* ((not-completed-tests (rmt:get-tests-for-run run-id "%" `("NOT_STARTED" "RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f))) - (if (> (length not-completed-tests) 0) - (let loop ((running-test (car not-completed-tests)) - (tal (cdr not-completed-tests))) - (let* ((test-name (vector-ref running-test 2)) - (item-path (vector-ref running-test 11))) - (debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed") - (if (not (null? tal)) - (loop (car tal) (cdr tal))))))))))) - -(define (launch:kill-tests-if-dead run-id) - (let* ((running-tests (rmt:get-tests-for-run run-id "%" `("RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f))) - (let loop ((running-test (car running-tests)) - (tal (cdr running-tests)) - (kill-cnt 0)) - (let* ((test-name (vector-ref running-test 2)) - (item-path (vector-ref running-test 11)) - (test-id (vector-ref running-test 0)) - (host (vector-ref running-test 6)) - (pid (rmt:test-get-top-process-pid run-id test-id)) - (event-time (vector-ref running-test 5)) - (duration (vector-ref running-test 12)) - (flag 0) - (curr-time (current-seconds))) - (if (and (< (+ event-time duration 600) curr-time) (not (commonmod:is-test-alive host pid))) ;;test has not updated duration in last 10 min then likely its not running but confirm before marking it as killed - (begin - (debug:print 0 *default-log-port* "test " test-name "/" item-path " needs to be killed") - (set! flag 1) - (rmt:set-state-status-and-roll-up-items run-id test-name item-path "KILLREQ" "n/a" #f))) - (if (not (null? tal)) - (loop (car tal) (cdr tal) (+ kill-cnt flag)) - (+ kill-cnt flag)))))) - -;; DO NOT USE - caching of configs is handled in launch:setup now. -;; -(define (launch:cache-config) - ;; if we have a linktree and -runtests and -target and the directory exists dump the config - ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg - (if (and *configdat* - (or (args:get-arg "-run") - (args:get-arg "-runtests") - (args:get-arg "-execute"))) - (let* ((linktree (common:get-linktree)) ;; (get-environment-variable "MT_LINKTREE")) - (target (common:args-get-target exit-if-bad: #t)) - (runname (or (args:get-arg "-runname") - (args:get-arg ":runname") - (getenv "MT_RUNNAME"))) - (fulldir (conc linktree "/" - target "/" - runname))) - (if (and linktree (common:file-exists? linktree)) ;; can't proceed without linktree - (begin - (debug:print-info 0 *default-log-port* "Have -run with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) - (if (not (common:file-exists? fulldir)) - (create-directory fulldir #t)) ;; need to protect with exception handler - (if (and target - runname - (common:file-exists? fulldir)) - (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) - (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) - (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) - (if (common:file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached - (begin - (debug:print-info 0 *default-log-port* "Caching megatest.config in " tmpfile) - (if (not (common:in-running-test?)) - (configf:write-alist *configdat* tmpfile)) - (system (conc "ln -sf " tmpfile " " targfile)))) - ))) - (debug:print-info 1 *default-log-port* "No linktree yet, no caching configs."))))) - - -;; gather available information, if legit read configs in this order: -;; -;; if have cache; -;; read it a return it -;; else -;; megatest.config (do not cache) -;; runconfigs.config (cache if all vars avail) -;; megatest.config (cache if all vars avail) -;; returns: -;; *toppath* -;; side effects: -;; sets; *configdat* (megatest.config info) -;; *runconfigdat* (runconfigs.config info) -;; *configstatus* (status of the read data) -;; -(define (launch:setup #!key (force-reread #f) (areapath #f)) - (mutex-lock! *launch-setup-mutex*) - ;; this stops the train quickly for new processes - (if (and *toppath* - (file-exists? (conc *toppath*"/stop-the-train"))) - (begin - (debug:print 0 *default-log-port* "ERROR: found file "*toppath*"/stop-the-train, exiting immediately") - (exit 1))) - (if (and *toppath* - (eq? *configstatus* 'fulldata) (not force-reread)) ;; got it all - (begin - (debug:print 2 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata") - (mutex-unlock! *launch-setup-mutex*) - *toppath*) - (let ((res (launch:setup-body force-reread: force-reread areapath: areapath))) - (mutex-unlock! *launch-setup-mutex*) - res))) - -;; return paths depending on what info is available. -;; -(define (launch:get-cache-file-paths areapath toppath target mtconfig) - (let* ((use-cache (common:use-cache?)) - (runname (common:args-get-runname)) - (linktree (common:get-linktree)) - (testname (common:get-full-test-name)) - (rundir (if (and runname target linktree) - (common:directory-writable? (conc linktree "/" target "/" runname)) - #f)) - (testdir (if (and rundir testname) - (common:directory-writable? (conc rundir "/" testname)) - #f)) - (cachedir (or testdir rundir)) - (mtcachef (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) - (rccachef (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))) - (debug:print-info 6 *default-log-port* - "runname=" runname - "\n linktree=" linktree - "\n testname=" testname - "\n rundir=" rundir - "\n testdir=" testdir - "\n cachedir=" cachedir - "\n mtcachef=" mtcachef - "\n rccachef=" rccachef) - (cons mtcachef rccachef))) - -(define (launch:setup-body #!key (force-reread #f) (areapath #f)) - (if (and (eq? *configstatus* 'fulldata) - *toppath* - (not force-reread)) ;; no need to reprocess - *toppath* ;; return toppath - (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting. We do not have *configdat*. Bootstrapping problem here. - (toppath (common:get-toppath areapath)) - (target (common:args-get-target)) - (sections (if target (list "default" target) #f)) ;; for runconfigs - (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config - (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) - ;; checking for null cachefiles should not be necessary, I was seeing error car of '(), might be a chicken bug or a red herring ... - (mtcachef (if (null? cachefiles) - #f - (car cachefiles))) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) - (rccachef (if (null? cachefiles) - #f - (cdr cachefiles)))) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) - ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?))))) - (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource - ;;(BB> "launch:setup-body -- cachefiles="cachefiles) - (cond - ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME - ((and (not force-reread) - mtcachef rccachef - use-cache - (get-environment-variable "MT_RUN_AREA_HOME") - (common:file-exists? mtcachef) - (common:file-exists? rccachef)) - ;;(BB> "launch:setup-body -- cond branch 1 - use-cache") - (set! *configdat* (configf:read-alist mtcachef)) - ;;(BB> "launch:setup-body -- 1 set! *configdat*="*configdat*) - (set! *runconfigdat* (configf:read-alist rccachef)) - (set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME"))) - (set! *configstatus* 'fulldata) - (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) - *toppath*) - ;; there are no existing cached configs, do full reads of the configs and cache them - ;; we have all the info needed to fully process runconfigs and megatest.config - ((and ;; (not force-reread) ;; force-reread is irrelevant in the AND, could however OR it? - mtcachef - rccachef) ;; BB- why are we doing this without asking if caching is desired? - ;;(BB> "launch:setup-body -- cond branch 2") - (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect - mtconfig - environ-patt: "env-override" - given-toppath: toppath - pathenvvar: "MT_RUN_AREA_HOME")) - (first-rundat (let ((toppath (if toppath - toppath - (car first-pass)))) - (read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now. - (conc (if (string? toppath) - toppath - (get-environment-variable "MT_RUN_AREA_HOME")) - "/runconfigs.config") - *runconfigdat* #t - sections: sections)))) - (set! *runconfigdat* first-rundat) - (if first-pass ;; - (begin - ;;(BB> "launch:setup-body -- \"first-pass\"=first-pass") - (set! *configdat* (car first-pass)) - ;;(BB> "launch:setup-body -- 2 set! *configdat*="*configdat*) - (set! *configinfo* first-pass) - (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it - (set! toppath *toppath*) - (if (not *toppath*) - (begin - (debug:print-error 0 *default-log-port* "you are not in a megatest area!") - (exit 1))) - (setenv "MT_RUN_AREA_HOME" *toppath*) - ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it - (let* ((keys (common:list-or-null (rmt:get-keys) - message: "Failed to retrieve keys in launch.scm. Please report this to the developers.")) - (key-vals (keys:target->keyval keys target)) - (linktree (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) - ; (if *configdat* - ; (configf:lookup *configdat* "setup" "linktree") - ; (conc *toppath* "/lt")))) - (second-pass (find-and-read-config - mtconfig - environ-patt: "env-override" - given-toppath: toppath - pathenvvar: "MT_RUN_AREA_HOME")) - (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config - (for-each (lambda (kt) - (setenv (car kt) (cadr kt))) - key-vals) - (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ... - sections: sections))) - (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) - (mtcachef (car cachefiles)) - (rccachef (cdr cachefiles))) - ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "/p/fdk/gwa/lefkowit/mtTesting/qa/primbeqa/links/p1222/11/PDK_r1.1.1/prim/clean/pcell_testgen/.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342 - ;; TODO - consider 1) using simple-lock to bracket cache write - ;; 2) cache in hash on server, since need to do rmt: anyway to lock. - - (if rccachef - (common:fail-safe - (lambda () - (configf:write-alist runconfigdat rccachef)) - (conc "Could not write cache file - "rccachef))) - (if mtcachef - (common:fail-safe - (lambda () - (configf:write-alist *configdat* mtcachef)) - (conc "Could not write cache file - "mtcachef))) - (set! *runconfigdat* runconfigdat) - (if (and rccachef mtcachef) (set! *configstatus* 'fulldata)))) - ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table - (set! *configdat* (make-hash-table)) - ))) - - ;; else read what you can and set the flag accordingly - ;; here we don't have either mtconfig or rccachef - (else - ;;(BB> "launch:setup-body -- cond branch 3 - else") - (let* ((cfgdat (find-and-read-config - (or (args:get-arg "-config") "megatest.config") - environ-patt: "env-override" - given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") - pathenvvar: "MT_RUN_AREA_HOME"))) - - (if (and cfgdat (list? cfgdat) (> (length cfgdat) 0) (hash-table? (car cfgdat))) - (let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat))) - (rdat (read-config (conc toppath ;; convert this to use runconfig:read! - "/runconfigs.config") *runconfigdat* #t sections: sections))) - (set! *configinfo* cfgdat) - (set! *configdat* (car cfgdat)) - (set! *runconfigdat* rdat) - (set! *toppath* toppath) - (set! *configstatus* 'partial)) - (begin - (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.") - (exit 2)))))) - ;; COND ends here. - - ;; additional house keeping - (let* ((linktree (or (common:get-linktree) - (conc *toppath* "/lt")))) - (if linktree - (begin - (if (not (common:file-exists? linktree)) - (begin - (handle-exceptions - exn - (begin - (debug:print-error 0 *default-log-port* "Something went wrong when trying to create linktree dir at " linktree) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - (exit 1)) - (create-directory linktree #t)))) - (handle-exceptions - exn - (begin - (debug:print-error 0 *default-log-port* "Something went wrong when trying to create link to linktree at " *toppath*) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) - (let ((tlink (conc *toppath* "/lt"))) - (if (not (common:file-exists? tlink)) - (create-symbolic-link linktree tlink))))) - (begin - (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config") - ))) - (if (and *toppath* - (directory-exists? *toppath*)) - (begin - (setenv "MT_RUN_AREA_HOME" *toppath*) - (setenv "MT_TESTSUITENAME" (common:get-testsuite-name))) - (begin - (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") - (set! *toppath* #f) ;; force it to be false so we return #f - #f)) - - ;; needed by various transport and db modules - (dbfile:testsuite-name (common:get-testsuite-name)) ;; (get-testsuite-name *toppath* *configdat*)) - - ;; one more attempt to cache the configs for future reading - (let* ((cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) - (mtcachef (car cachefiles)) - (rccachef (cdr cachefiles))) - - ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "...somepath.../.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342 - ;; TODO - consider 1) using simple-lock to bracket cache write - ;; 2) cache in hash on server, since need to do rmt: anyway to lock. - (if (and rccachef *runconfigdat* (not (common:file-exists? rccachef))) - (common:fail-safe - (lambda () - (configf:write-alist *runconfigdat* rccachef)) - (conc "Could not write cache file - "rccachef)) - ) - (if (and mtcachef *configdat* (not (common:file-exists? mtcachef))) - (common:fail-safe - (lambda () - (configf:write-alist *configdat* mtcachef)) - (conc "Could not write cache file - "mtcachef)) - ) - (if (and rccachef mtcachef *runconfigdat* *configdat*) - (set! *configstatus* 'fulldata))) - - ;; if have -append-config then read and append here - (let ((cfname (args:get-arg "-append-config"))) - (if (and cfname - (file-read-access? cfname)) - (read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special. - - ;; have config at this time, this is a good place to set params based on config file settings - (let* ((dbmode (configf:lookup *configdat* "setup" "dbcache-mode")) - (syncmode (configf:lookup *configdat* "setup" "sync-mode")) - (srvdebug (configf:lookup *configdat* "server" "debug-parameter"))) - (if dbmode - (begin - (debug:print-info 0 *default-log-port* "Overriding dbmode to "dbmode) - (dbcache-mode (string->symbol dbmode)))) - (if syncmode - (begin - (debug:print-info 0 *default-log-port* "Overriding syncmode to "syncmode) - (dbfile:sync-method (string->symbol syncmode)))) - (if srvdebug - (begin - (debug:print-info 0 *default-log-port* "Overriding server debug parameter to "srvdebug) - (tt-server-profile-string srvdebug))) - ) - - *toppath*))) - - -(define (get-best-disk confdat testconfig) - (let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f)) - (hash-table-ref/default confdat "disks" #f))) - (minspace (let ((m (configf:lookup confdat "setup" "minspace"))) - (string->number (or m "10000"))))) - (if disks - (let ((res (common:get-disk-with-most-free-space disks minspace))) - (if res - (cdr res) - ;; else if no valid disks... - (begin - (debug:print 0 *default-log-port* "WARNING: No valid disks or no disk with enough space found from " disks) - (if (null? disks) - (cons 1 (conc *toppath* "/runs")) - - ;; else try to create the directories anyway. - (let ((paths (sort disks (lambda (x y) (> (string-length (cadr x)) (string-length (cadr y))))))) - (let loop ((head (car paths)) (tail (cdr paths))) - (let ((result (handle-exceptions exn - (begin - (debug:print 0 *default-log-port* "failed to create dir " (cadr head) ", exn=" exn) - #f) - (create-directory (cadr head) #t)))) - (if result - result - (if (null? tail) - (begin - (debug:print 0 *default-log-port* "Using toppath/runs") - (conc *toppath* "/runs") - ) - (loop (car tail) (cdr tail)))))) - ) - ) ;; if null? disks - ) ;; if not res - ) - ) - ;; no disks definition - use toppath/runs, fall back to currdir/runs - (let* ((toppath (or *toppath* - (common:get-toppath *toppath*) - (begin - (debug:print-error 0 *default-log-port* "Creating runs dir in current directory, this is probably not what you wanted. Please check your setup.") - (current-directory)))) - (runsdir (conc toppath "/runs"))) - (if (not (file-exists? runsdir))(create-directory runsdir)) - runsdir) - ))) ;; the code creates the necessary directories if it does not exist and returns the path. - - - -(define (launch:test-copy test-src-path test-path) - (let* ((ovrcmd (let ((cmd (configf:lookup *configdat* "setup" "testcopycmd"))) - (if cmd - ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH - (string-substitute "TEST_TARG_PATH" test-path - (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t) - #f))) - (cmd (if ovrcmd - ovrcmd - (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/" - " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log"))) - (status (system cmd))) - (if (not (eq? status 0)) - (debug:print 2 *default-log-port* "ERROR: problem with running \"" cmd "\"")))) - - -;; Desired directory structure: -;; -;; - - -. -;; | -;; v -;; - - -|- -;; -;; dir stored in test is: -;; -;; - - [ - ] -;; -;; All log file links should be stored relative to the top of link path -;; -;; - [ - ] -;; -(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat #!key (remtries 2)) - (let* ((item-path (if (string? itemdat) itemdat (item-list->path itemdat))) ;; if pass in string - just use it - (runname (if (string? run-info) ;; if we pass in a string as run-info use it as run-name. - run-info - (db:get-value-by-header (db:get-rows run-info) - (db:get-header run-info) - "runname"))) - (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour")) - ;; convert back to db: from rdb: - this is always run at server end - (target (string-intersperse (map cadr keyvals) "/")) - - (not-iterated (equal? "" item-path)) - - ;; all tests are found at /test-base or /test-base - (testtop-base (conc target "/" runname "/" testname)) - (test-base (conc testtop-base (if not-iterated "" "/") item-path)) - - ;; nb// if itempath is not "" then it is prefixed with "/" - (toptest-path (conc disk-path (if contour (conc "/" contour) "") "/" testtop-base)) - (test-path (conc disk-path (if contour (conc "/" contour) "") "/" test-base)) - - ;; ensure this exists first as links to subtests must be created there - (linktree (common:get-linktree)) - ;; WAS: (let ((rd (configf:lookup *configdat* "setup" "linktree"))) - ;; (if rd rd (conc *toppath* "/runs")))) - ;; which seems wrong ... - - (lnkbase (conc linktree (if contour (conc "/" contour) "") "/" target "/" runname)) - (lnkpath (conc lnkbase "/" testname)) - (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)) - (lnktarget (conc lnkpath "/" item-path))) - - ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical - ;; rundir shortdir - (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path run-id) - - (debug:print 2 *default-log-port* "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) - (if (not (common:file-exists? linktree)) - (begin - (debug:print 0 *default-log-port* "WARNING: linktree did not exist! Creating it now at " linktree) - (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree)))) - ;; create the directory for the tests dir links, this is needed no matter what... try up to three times - (let loop ((done 3)) - (let ((success (if (and (not (common:directory-exists? lnkbase)) - (not (common:file-exists? lnkbase))) - (handle-exceptions - exn - (begin - (debug:print-error 0 *default-log-port* "Problem creating linktree base at " lnkbase ", exn=" exn) - (print-error-message exn (current-error-port)) - #t) - (create-directory lnkbase #t) - #f)))) - (if (and (not success)(> done 0)) - (loop (- done 1))))) - - ;; update the toptest record with its location rundir, cache the path - ;; This wass highly inefficient, one db write for every subtest, potentially - ;; thousands of unnecessary updates, cache the fact it was set and don't set it - ;; again. - - ;; Now create the link from the test path to the link tree, however - ;; if the test is iterated it is necessary to create the parent path - ;; to the iteration. use pathname-directory to trim the path by one - ;; level - (if (not not-iterated) ;; i.e. iterated - (let ((iterated-parent (pathname-directory (conc lnkpath "/" item-path)))) - (debug:print-info 2 *default-log-port* "Creating iterated parent " iterated-parent) - (handle-exceptions - exn - (begin - (debug:print-error 0 *default-log-port* " Failed to create directory " iterated-parent ((condition-property-accessor 'exn 'message) exn) - ", continuing but link tree may be corrupted, exn=" exn) - #;(exit 1)) - (create-directory iterated-parent #t)))) - - (if (symbolic-link? lnkpath) - (handle-exceptions - exn - (begin - (debug:print-error 0 *default-log-port* " Failed to remove symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) - ", continuing but link tree may be corrupted. exn=" exn) - #;(exit 1)) - (delete-file lnkpath))) - - (if (not (or (common:file-exists? lnkpath) - (symbolic-link? lnkpath))) - (handle-exceptions - exn - (begin - (debug:print-error 0 *default-log-port* " Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) - ", continuing but link tree may be corrupted. exn=" exn) - #;(exit 1)) - (create-symbolic-link toptest-path lnkpath))) - - ;; NB - This was not working right - some top tests are not getting the path set!!! - ;; - ;; Do the setting of this record after the paths are created so that the shortdir can - ;; be set to the real directory location. This is safer for future clean up if the link - ;; tree is damaged or lost. - ;; - (if (not (hash-table-ref/default *toptest-paths* testname #f)) - (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path)) - (curr-test-path (if testinfo ;; (filedb:get-path *fdb* - ;; (db:get-path dbstruct - ;; (rmt:sdb-qry 'getstr - (db:test-get-rundir testinfo) ;; ) ;; ) - #f))) - (hash-table-set! *toptest-paths* testname curr-test-path) - ;; NB// Was this for the test or for the parent in an iterated test? - (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath - (if (common:file-exists? lnkpath) - ;; (resolve-pathname lnkpath) - (common:nice-path lnkpath) - lnkpath) - testname "" run-id) - ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) - (if (or (not curr-test-path) - (not (directory-exists? toptest-path))) - (begin - (debug:print-info 2 *default-log-port* "Creating " toptest-path " and link " lnkpath) - (handle-exceptions - exn - (if (directory-exists? toptest-path) ;; it was likely created in parallel - #t - (begin - (debug:print-info 0 *default-log-port* "failed to create directory " toptest-path ", exn=" exn) - #f)) - (create-directory toptest-path #t)) - (hash-table-set! *toptest-paths* testname toptest-path))))) - - ;; The toptest path has been created, the link to the test in the linktree has - ;; been created. Now, if this is an iterated test the real test dir must be created - (if (not not-iterated) ;; this is an iterated test - (begin ;; (let ((lnktarget (conc lnkpath "/" item-path))) - (debug:print 2 *default-log-port* "Setting up sub test run area") - (debug:print 2 *default-log-port* " - creating run area in " test-path) - (handle-exceptions - exn - (if (directory-exists? test-path) - #t - (begin - (debug:print-error 0 *default-log-port* " Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) - ", exiting, exn=" exn) - (exit 1))) - (create-directory test-path #t)) - (debug:print 2 *default-log-port* - " - creating link from: " test-path "\n" - " to: " lnktarget) - - ;; If there is already a symlink delete it and recreate it. - (handle-exceptions - exn - (begin - (debug:print-error 0 *default-log-port* " Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting, exn=" exn) - (exit)) - (if (symbolic-link? lnktarget) (delete-file lnktarget)) - (if (not (common:file-exists? lnktarget)) (create-symbolic-link test-path lnktarget))))) - - (if (not (directory? test-path)) - (create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes - - (if (and test-src-path (directory? test-path)) - (begin - (launch:test-copy test-src-path test-path) - (list lnkpathf lnkpath )) - (if (and test-src-path (> remtries 0)) - (begin - (debug:print-error 0 *default-log-port* "Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) - ;; - (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat remtries: (- remtries 1))) - (list #f #f))))) - - -(define (launch:handle-zombie-tests run-id) - (let* ((key (conc "zombiescan-runid-"run-id)) - (now (current-seconds)) - (threshold (- (current-seconds) (* 2 (or (configf:lookup-number *configdat* "setup" "deadtime") 120)))) - (val (rmt:get-var key)) - (do-scan? - (cond - ((not val) - #t) - ((< val threshold) - #t) - (else #f)))) - (when do-scan? - (debug:print 1 *default-log-port* "INFO: search and mark zombie tests") - (rmt:set-var key (current-seconds)) - (rmt:find-and-mark-incomplete run-id #f)))) - - - - - -;; 1. look though disks list for disk with most space -;; 2. create run dir on disk, path name is meaningful -;; 3. create link from run dir to megatest runs area -;; 4. remotely run the test on allocated host -;; - could be ssh to host from hosts table (update regularly with load) -;; - could be netbatch -;; (launch-test db (cadr status) test-conf)) -(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) - (assert runname "FATAL: launch-test called with no runname") - (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex - (let* ( ;; (lock-key (conc "test-" test-id)) - ;; (got-lock (let loop ((lock (rmt:no-sync-get-lock lock-key)) - ;; (expire-time (+ (current-seconds) 15))) ;; give up on getting the lock and steal it after 15 seconds - ;; (if (car lock) - ;; #t - ;; (if (> (current-seconds) expire-time) - ;; (begin - ;; (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to launch test " keyvals " " runname " " test-name " " test-path) - ;; (rmt:no-sync-del! lock-key) ;; destroy the lock - ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;; - ;; (begin - ;; (thread-sleep! 1) - ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)))))) - (item-path (item-list->path itemdat)) - (contour #f)) ;; NOT READY FOR THIS (args:get-arg "-contour"))) - (let loop ((delta (- (current-seconds) *last-launch*)) - (launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 0))) - (if (> launch-delay delta) - (begin - ;; (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay. - ;; (debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds")) - (thread-sleep! (- launch-delay delta)) - (loop (- (current-seconds) *last-launch*) launch-delay)))) - (change-directory *toppath*) - (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute", *maybe* - the longer they are set the longer each launch takes (must be non-overlapping with the vars) - (append - (list - (list "MT_RUN_AREA_HOME" *toppath*) - (list "MT_TEST_NAME" test-name) - (list "MT_RUNNAME" runname) - (list "MT_ITEMPATH" item-path) - (list "MT_CONTOUR" contour) - ) - itemdat)) - (let* ((tregistry (tests:get-all)) ;; third param (below) is system-allowed - ;; for tconfig, why do we allow fallback to test-conf? - (tconfig (or (tests:get-testconfig test-name item-path tregistry #t force-create: #t) - (begin - (debug:print 0 *default-log-port* "WARNING: falling back to pre-calculated testconfig. This is likely not desired.") - test-conf))) ;; force re-read now that all vars are set - (useshell (let ((ush (configf:lookup *configdat* "jobtools" "useshell"))) - (if ush - (if (equal? ush "no") ;; must use "no" to NOT use shell - #f - ush) - #t))) ;; default is yes - (runscript (configf:lookup tconfig "setup" "runscript")) - (ezsteps (> (length (hash-table-ref/default tconfig "ezsteps" '())) 0)) ;; don't send all the steps, could be big, just send a flag - (subrun (> (length (hash-table-ref/default tconfig "subrun" '())) 0)) ;; send a flag to process a subrun - ;; (diskspace (configf:lookup tconfig "requirements" "diskspace")) - ;; (memory (configf:lookup tconfig "requirements" "memory")) - ;; (hosts (configf:lookup *configdat* "jobtools" "workhosts")) ;; I'm pretty sure this was never completed - (remote-megatest (configf:lookup *configdat* "setup" "executable")) - (run-time-limit (or (configf:lookup tconfig "requirements" "runtimelim") - (configf:lookup *configdat* "setup" "runtimelim"))) - ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to - ;; allow running from dashboard. Extract the path - ;; from the called megatest and convert dashboard - ;; or dboard to megatest - (local-megatest (common:find-local-megatest)) - #;(local-megatest (let* ((lm (car (argv))) - (dir (pathname-directory lm)) - (exe (pathname-strip-directory lm))) - (conc (if dir (conc dir "/") "") - (case (string->symbol exe) - ((dboard) "../megatest") - ((mtest) "../megatest") - ((dashboard) "megatest") - (else exe))))) - (launcher (common:get-launcher *configdat* test-name item-path)) ;; (configf:lookup *configdat* "jobtools" "launcher")) - (test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path - (work-area #f) - (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all - (diskpath #f) - (cmdparms #f) - (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) - (mt-bindir-path #f) - (testinfo (rmt:get-test-info-by-id run-id test-id)) - (mt_target (string-intersperse (map cadr keyvals) "/")) - (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) - (if (args:get-arg "-logging")(list "-logging") '()) - (if (configf:lookup *configdat* "misc" "profilesw") - (list (configf:lookup *configdat* "misc" "profilesw")) - '())))) - ;; (if hosts (set! hosts (string-split hosts))) - ;; set the megatest to be called on the remote host - (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) - (set! mt-bindir-path (pathname-directory remote-megatest)) - (if launcher (set! launcher (string-split launcher))) - ;; set up the run work area for this test - (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run - (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir - (begin - (debug:print-info 0 *default-log-port* "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path) - (runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record - - ;; prevent overlapping actions - set to LAUNCHED as early as possible - ;; - ;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail - (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) - (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "LAUNCHED" #f) - ;; (pp (hash-table->alist tconfig)) - (set! diskpath (get-best-disk *configdat* tconfig)) - (debug:print 2 *default-log-port* "best disk path = " diskpath) - (if diskpath - (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) - (set! work-area (car dat)) - (set! toptest-work-area (cadr dat)) - (debug:print-info 2 *default-log-port* "Using work area " work-area)) - (begin - (set! work-area (conc test-path "/tmp_run")) - (create-directory work-area #t) - (debug:print 0 *default-log-port* "WARNING: No disk work area specified - running in the test directory under tmp_run"))) - (set! cmdparms (base64:base64-encode - (z3:encode-buffer - (with-output-to-string - (lambda () ;; (list 'hosts hosts) - (write (list (list 'testpath test-path) - ;; (list 'transport (conc *transport-type*)) - ;; (list 'serverinf *server-info*) - #;(list 'homehost (let* ((hhdat (server:get-homehost))) - (if hhdat - (car hhdat) - #f))) - #;(list 'serverurl (if *runremote* ;; would like to add this back ... WORK NEEDED - (remote-server-url *runremote*) - #f)) ;; - (list 'areaname (common:get-testsuite-name)) - (list 'toppath *toppath*) - (list 'work-area work-area) - (list 'test-name test-name) - (list 'runscript runscript) - (list 'run-id run-id ) - (list 'test-id test-id ) - ;; (list 'item-path item-path ) - (list 'itemdat itemdat ) - (list 'megatest remote-megatest) - (list 'ezsteps ezsteps) - (list 'subrun subrun) - (list 'target mt_target) - (list 'contour contour) - (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) - (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) - (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) - (list 'runname runname) - (list 'mt-bindir-path mt-bindir-path)))))))) - - (setenv "MT_CMDINFO" cmdparms) ;; setting this for use in nblauncher - - ;; clean out step records from previous run if they exist - ;; (rmt:delete-test-step-records run-id test-id) - ;; if the dir does not exist we may have a itempath where individual variables are a path, launch anyway - (if (common:file-exists? work-area) - (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir - (cond - ;; ((and launcher hosts) ;; must be using ssh hostname - ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param))) - ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) - (launcher - (set! fullcmd (append launcher (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param))) - ;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms)))) - (else - (if (not useshell)(debug:print 0 *default-log-port* "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section")) - (set! fullcmd (append (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param (list (if useshell "&" "")))))) - ;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" ""))))) - (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) - (debug:print 1 *default-log-port* "Launching " work-area) - ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done - (debug:print 4 *default-log-port* "fullcmd: " fullcmd) - (set! *last-launch* (current-seconds)) ;; all that junk above takes time, set this as late as possible. - (let* ((commonprevvals (alist->env-vars - (hash-table-ref/default *configdat* "env-override" '()))) - (miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" - (append (list (list "MT_TEST_RUN_DIR" work-area) - (list "MT_TEST_NAME" test-name) - (list "MT_ITEM_INFO" (conc itemdat)) - (list "MT_RUNNAME" runname) - (list "MT_TARGET" mt_target) - (list "MT_ITEMPATH" item-path) - ) - itemdat))) - (testprevvals (alist->env-vars - (hash-table-ref/default tconfig "pre-launch-env-overrides" '()))) - ;; Launchwait defaults to true, must override it to turn off wait - (launchwait (if (equal? (configf:lookup *configdat* "setup" "launchwait") "no") #f #t)) - (launch-results-prev (apply (if launchwait ;; BB: TODO: refactor this to examine return code of launcher, if nonzero, set state to launch failed. - process:cmd-run-with-stderr-and-exitcode->list - process-run) - (if useshell - (let ((cmdstr (string-intersperse fullcmd " "))) - (if launchwait - cmdstr - (conc cmdstr " >> mt_launch.log 2>&1 &"))) - (car fullcmd)) - (if useshell - '() - (cdr fullcmd)))) - (success (if launchwait (equal? 0 (cadr launch-results-prev)) #t)) - (launch-results (if launchwait (car launch-results-prev) launch-results-prev))) - (if (not success) - (tests:test-set-status! run-id test-id "COMPLETED" "DEAD" "launcher failed; exited non-zero; check mt_launch.log" #f)) ;; (if launch-results launch-results "FAILED")) - (mutex-unlock! *launch-setup-mutex*) ;; yes, really should mutex all the way to here. Need to put this entire process into a fork. - ;; (rmt:no-sync-del! lock-key) ;; release the lock for starting this test - (if (not launchwait) ;; give the OS a little time to allow the process to start - (thread-sleep! 0.01)) - (with-output-to-file "mt_launch.log" - (lambda () - (print "LAUNCHCMD: " (string-intersperse fullcmd " ")) - (if (list? launch-results) - (apply print launch-results) - (print "NOTE: launched \"" fullcmd "\"\n but did not wait for it to proceed. Add the following to megatest.config \n[setup]\nlaunchwait yes\n if you have problems with this")) - #:append)) - (debug:print 2 *default-log-port* "Launching completed, updating db") - (debug:print 2 *default-log-port* "Launch results: " launch-results) - (if (not launch-results) - (begin - (debug:print 0 *default-log-port* "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") - ;; (sqlite3:finalize! db) - ;; good ole "exit" seems not to work - ;; (_exit 9) - ;; but this hack will work! Thanks go to Alan Post of the Chicken email list - ;; NB// Is this still needed? Should be safe to go back to "exit" now? - (process-signal (current-process-id) signal/kill) - )) - (alist->env-vars miscprevvals) - (alist->env-vars testprevvals) - (alist->env-vars commonprevvals) - launch-results)) - (change-directory *toppath*) - (thread-sleep! (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.0)))) - -;; recover a test where the top controlling mtest may have died -;; -(define (launch:recover-test run-id test-id) - ;; this function is called on the test run host via ssh - ;; - ;; 1. look at the process from pid - ;; - is it owned by calling user - ;; - it it's run directory correct for the test - ;; - is there a controlling mtest (maybe stuck) - ;; 2. if recovery is needed watch pid - ;; - when it exits take the exit code and do the needful - ;; - (let* ((pid (rmt:test-get-top-process-pid run-id test-id)) - (psres (with-input-from-pipe - (conc "ps -F -u " (current-user-name) " | grep -E '" pid " ' | grep -v 'grep -E " pid "'") - (lambda () - (read-line)))) - (rundir (if (string? psres) ;; real process owned by user - (read-symbolic-link (conc "/proc/" pid "/cwd")) - #f))) - ;; now wait on that process if all is correct - ;; periodically update the db with runtime - ;; when the process exits look at the db, if still RUNNING after 10 seconds set - ;; state/status appropriately - (process-wait pid))) - -;;====================================================================== -;; Maintenance -;;====================================================================== - -(define (rmt:find-and-mark-incomplete run-id ovr-deadtime) - (let* ((cfg-deadtime (configf:lookup-number *configdat* "setup" "deadtime")) - (test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period"))) - (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period) - ;;call end of eud of run detection for posthook - (launch:end-of-run-check run-id))) - -;; select end_time-now from -;; (select testname,item_path,event_time+run_duration as -;; end_time,strftime('%s','now') as now from tests where state in -;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED')); -;; -;; NOT EASY TO MIGRATE TO db{file,mod} -;; -(define (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period) - (let* ((incompleted '()) - (oldlaunched '()) - (toplevels '()) - ;; The default running-deadtime is 720 seconds = 12 minutes. - ;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30)) - (deadtime-trim (or ovr-deadtime cfg-deadtime)) - (server-start-allowance 200) - (server-overloaded-budget 200) - (launch-monitor-off-time (or test-stats-update-period 30)) - (launch-monitor-on-time-budget 30) - (launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget)) - (remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30)) - (remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default)) - (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period))) - (running-deadtime (or deadtime-trim running-deadtime-default))) ;; two minutes (30 seconds between updates, this leaves 3x grace period) - - (debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime) - (debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim) - - (let* ((dat (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime))) - (set! oldlaunched (list-ref dat 1)) - (set! toplevels (list-ref dat 2)) - (set! incompleted (list-ref dat 0))) - - (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " - (length toplevels) " old LAUNCHED toplevel tests and " - (length incompleted) " tests marked RUNNING but apparently dead.") - - ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. - ;; - ;; (db:delay-if-busy dbdat) - (let* ((min-incompleted-ids (map car incompleted)) ;; do 'em all - (all-ids (append min-incompleted-ids (map car oldlaunched)))) - (if (> (length all-ids) 0) - (begin - ;; (launch:is-test-alive "localhost" 435) - (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") - " as DEAD") - (for-each - (lambda (test-id) - (let* ((tinfo (rmt:get-test-info-by-id run-id test-id)) - (run-dir (db:test-get-rundir tinfo)) - (host (db:test-get-host tinfo)) - (pid (db:test-get-process_id tinfo)) - (result (rmt:get-status-from-final-status-file run-dir))) - (if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result))) - (begin - (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD") - (rmt:set-state-status-and-roll-up-items - run-id test-id 'foo "COMPLETED" "PASS" - "Test stopped responding but it has PASSED; marking it PASS in the DB.")) - (let ((is-alive (and (not (eq? pid 0)) ;; 0 is default in re-used field "attemptnum" where pid stored. - (commonmod:is-test-alive host pid)))) - (if is-alive - (debug:print 0 *default-log-port* "INFO: test " test-id " on host " host - " has a process on pid " pid ", NOT setting to DEAD.") - (begin - (debug:print 0 *default-log-port* "INFO: test " test-id - " final state/status is not COMPLETED/PASS. It is " result) - (rmt:set-state-status-and-roll-up-items - run-id test-id 'foo "COMPLETED" "DEAD" - "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead."))))))) - ;; call end of eud of run detection for posthook - from merge, is it needed? - ;; (launch:end-of-run-check run-id) - all-ids) - ))))) - ADDED launchmod.scm Index: launchmod.scm ================================================================== --- /dev/null +++ launchmod.scm @@ -0,0 +1,1165 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +;;====================================================================== +;; Cpumod: +;; +;; Put things here don't fit anywhere else +;;====================================================================== + +(declare (unit launchmod)) +(declare (uses debugprint)) +(declare (uses mtargs)) +(declare (uses commonmod)) +(declare (uses configfmod)) +(declare (uses dbfile)) +(declare (uses dbmod)) +(declare (uses rmtmod)) +(declare (uses servermod)) +(declare (uses processmod)) +(declare (uses pgdb)) +(declare (uses mtmod)) +(declare (uses megatestmod)) +(declare (uses tasksmod)) +(declare (uses subrunmod)) +(declare (uses testsmod)) +(declare (uses runsmod)) +(declare (uses fsmod)) + +(use srfi-69) + +(module launchmod + * + +(import scheme) +(cond-expand + (chicken-4 + + (import chicken + ports + data-structures + extras + files + matchable + pathname-expand + posix + posix-extras + regex + regex-case + sparse-vectors + + ) + (use srfi-69)) + (chicken-5 + (import (prefix sqlite3 sqlite3:) + chicken.base + chicken.condition + chicken.file + chicken.file.posix + chicken.io + chicken.pathname + chicken.port + chicken.process + chicken.process-context + chicken.process-context.posix + chicken.sort + chicken.string + chicken.time + chicken.time.posix + + matchable + md5 + message-digest + pathname-expand + regex + regex-case + system-information + + ))) + +;; imports common to ck4 and ck5 +(import srfi-1 + srfi-13 + srfi-18 + srfi-69 + typed-records + (prefix base64 base64:) + (prefix sqlite3 sqlite3:) + md5 + message-digest + z3 + csv + directory-utils + + debugprint + commonmod + configfmod + (prefix mtargs args:) + dbmod + dbfile + rmtmod + servermod + processmod + pgdb + mtmod + megatestmod + tasksmod + subrunmod + testsmod + runsmod + fsmod + ) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "megatest-fossil-hash.scm") + +;;====================================================================== +;; ezsteps +;;====================================================================== + +;; ezsteps were going to be coded as +;; stepname[,predstep1,predstep2 ...] [{VAR1=first,second,third}] command to execute +;; BUT +;; now are +;; stepname {VAR=first,second,third ...} command ... +;; where the {VAR=first,second,third ...} is optional. + +;; given an exit code and whether or not logpro was used calculate OK/BAD +;; return #t if we are ok, #f otherwise +(define (steprun-good? logpro exitcode stepparms) + (or (eq? exitcode 0) + (and logpro (member exitcode '( 2 4 6))) + (let* ((params (alist-ref 'params stepparms)) ;; get the params section + (keep-going (if params + (alist-ref "keep-going" params equal?) + #f))) + (debug:print 0 *default-log-port* "keep-going=" keep-going) + (and keep-going (equal? (car keep-going) "yes"))))) + +;; if handed a string, process it, else look for MT_CMDINFO +(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f)) + (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO")))) + (if enccmd + (common:read-encoded-string enccmd) + '()))) + +;; 0 1 2 3 +(defstruct launch:einf (pid #t)(exit-status #t)(exit-code #t)(rollup-status 0)) + +;; return (conc status ": " comment) from the final section so that +;; the comment can be set in the step record in launch.scm +;; +(define (launch:load-logpro-dat run-id test-id stepname) + (let ((cname (conc stepname ".dat"))) + (if (common:file-exists? cname) + (let* ((dat (read-config cname #f #f)) + (csvr (db:logpro-dat->csv dat stepname)) + (csvt (let-values (((fmt-cell fmt-record fmt-csv) (make-format ","))) + (fmt-csv (map list->csv-record csvr)))) + (status (configf:lookup dat "final" "exit-status")) + (msg (configf:lookup dat "final" "message"))) + (if csvt ;; this if blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro + (rmt:csv->test-data run-id test-id csvt) + (debug:print 0 *default-log-port* "ERROR: no csvdat exists for run-id: " run-id " test-id: " test-id " stepname: " stepname ", check that logpro version is 1.15 or newer")) + ;; (debug:print-info 13 *default-log-port* "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr) + ;; ) + (cond + ((equal? status "PASS") "PASS") ;; skip the message part if status is pass + (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message"))) + (else #f))) + #f))) + +(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m) + ;; (let-values + ;; (((pid exit-status exit-code) + ;; (run-n-wait fullrunscript))) + ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) + ;; Since we should have a clean slate at this time there is no need to do + ;; any of the other stuff that tests:test-set-status! does. Let's just + ;; force RUNNING/n/a + + ;; (thread-sleep! 0.3) + ;; (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") + (rmt:set-state-status-and-roll-up-items run-id test-name item-path "RUNNING" #f #f) + ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here + + ;; if there is a runscript do it first + (if fullrunscript + (let ((pid (process-run fullrunscript))) + (rmt:test-set-top-process-pid run-id test-id pid) + (let loop ((i 0)) + (let-values + (((pid-val exit-status exit-code) (process-wait pid #t))) + (mutex-lock! m) + (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) + (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) + (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code) + (launch:einf-rollup-status-set! exit-info exit-code) ;; (vector-set! exit-info 3 exit-code) ;; rollup status + (mutex-unlock! m) + (if (eq? pid-val 0) + (begin + (thread-sleep! 2) + (loop (+ i 1))) + ))))) + ;; then, if runscript ran ok (or did not get called) + ;; do all the ezsteps (if any) + (if (or ezsteps subrun) + (let* ((test-run-dir (tests:get-test-path-from-environment)) + (testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? + ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic + ;; ezstep names need a full re-eval here. + (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) + (ezstepslst (if (hash-table? testconfig) + (hash-table-ref/default testconfig "ezsteps" '()) + #f))) + (if testconfig + (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... + (begin + (launch:setup) + (debug:print 0 *default-log-port* "WARNING: no testconfig found for " test-name " in search path:\n " + (string-intersperse (tests:get-tests-search-path *configdat*) "\n ")))) + ;; after all that, still no testconfig? Time to abort + (if (not testconfig) + (begin + (debug:print-error 0 *default-log-port* "Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") + (exit 1))) + + ;; create a proc for the subrun if requested, save that proc in the ezsteps table as the last entry + ;; 1. get section [runarun] + ;; 2. unset MT_* vars + ;; 3. fix target + ;; 4. fix runname + ;; 5. fix testpatt or calculate it from contour + ;; 6. launch the run + ;; 7. roll up the run result and or roll up the logpro processed result + (when (configf:lookup testconfig "subrun" "runwait") ;; we use runwait as the flag that a subrun is requested + (subrun:initialize-toprun-test testconfig test-run-dir) + (let* ((mt-cmd (subrun:launch-cmd test-run-dir (configf:lookup testconfig "subrun" "runwait")))) + (debug:print-info 0 *default-log-port* "Subrun command is \"" mt-cmd "\"") + (set! ezsteps #t) ;; set the needed flag + (set! ezstepslst + (append (or ezstepslst '()) + (list (list "subrun" (conc "{subrun=true} " mt-cmd))))))) + + ;; process the ezsteps + (if ezsteps + (let* ((all-steps-dat (make-hash-table))) ;; keep all the info around as stepname ==> alist; where 'params is the params list (add other stuff as needed) + (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps")) + ;; if ezsteps was defined then we are sure to have at least one step but check anyway + (if (not (> (length ezstepslst) 0)) + (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length") + (let ((all-step-names (map car ezstepslst)) + (status-file (file-open "ezsteps.status" (+ open/append open/wronly open/creat))) + ) + (setenv "MT_STEP_NAMES" (string-intersperse all-step-names " ")) + (let loop ((ezstep (car ezstepslst)) + (tal (cdr ezstepslst)) + (prevstep #f)) + (debug:print-info 0 *default-log-port* "Processing ezstep \"" (string-intersperse ezstep " ") "\"") + ;; check exit-info (vector-ref exit-info 1) + (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) + (let* ((logpro-used (ezsteps:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)) + (stepname (car ezstep)) + (stepparms (hash-table-ref all-steps-dat stepname))) + (setenv "MT_STEP_NAME" stepname) + (pp (hash-table->alist all-steps-dat)) + ;; if logpro-used read in the stepname.dat file + (if (and logpro-used (common:file-exists? (conc stepname ".dat"))) + (launch:load-logpro-dat run-id test-id stepname)) + + (file-write status-file (conc stepname " " (launch:einf-exit-code exit-info) "\n")) + + (if (steprun-good? logpro-used (launch:einf-exit-code exit-info) stepparms) + (if (not (null? tal)) + (loop (car tal) (cdr tal) stepname)) + (debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping"))) + (debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))) + (file-close status-file) + ) + + )))))) + +(define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags) + (let* ((update-period (string->number (or (configf:lookup *configdat* "setup" "test-stats-update-period") "60"))) + (start-seconds (current-seconds)) + (calc-minutes (lambda () + (inexact->exact + (round + (- + (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) + + (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))) + (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 + #f))) + (new-disk-free (let* ((df (if over-time ;; only get df every 30 seconds + (get-df (current-directory)) + disk-free)) + (delta (abs (- df disk-free)))) + (if (and (> df 0) + (> (/ delta df) 0.1)) ;; (> delta 200) ;; ignore changes under 200 Meg + df + #f))) + (do-sync (or new-cpu-load new-disk-free over-time)) + + (test-info (rmt:get-test-state-status-by-id run-id test-id)) + (state (car test-info));; (db:test-get-state test-info)) + (status (cdr test-info));; (db:test-get-status test-info)) + (killreq (equal? state "KILLREQ")) + (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)) + (cond + (killreq + (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) + (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) + (if (common:low-noise-print 600 "run zombie") ;; every five minutes is plenty + (launch:handle-zombie-tests run-id)) + (when do-sync + (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 + ;; section and the runit section? Or add a loop that tries three times with a 1/4 second + ;; between tries? + (let* ((pid1 (launch:einf-pid exit-info)) ;; (vector-ref exit-info 0)) + (pid2 (rmt:test-get-top-process-pid run-id test-id)) + (pids (delete-duplicates (filter number? (list pid1 pid2))))) + (if (not (null? pids)) + (begin + (for-each + (lambda (pid) + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "Unable to kill process with pid " pid ", possibly already killed.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) + (debug:print 0 *default-log-port* "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")") + (debug:print-info 0 *default-log-port* "Signal mask=" (signal-mask)) + ;; (if (process:alive? pid) + ;; (begin + (map (lambda (pid-num) + (process-signal pid-num signal/term)) + (process:get-sub-pids pid)) + (thread-sleep! 5) + ;; (if (process:process-alive? pid) + (map (lambda (pid-num) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* " .... had trouble sending kill to " pid-num ", exn=" exn) + #f) + (process-signal pid-num signal/kill))) + (process:get-sub-pids pid)))) + ;; (debug:print-info 0 *default-log-port* "not killing process " pid " as it is not alive")))) + pids) + ;; BB: question to Matt -- does the tests:test-state-status! encompass rollup to toplevel? If not, should it? + (tests:test-set-status! run-id test-id "KILLED" "KILLED" (conc (args:get-arg "-m")" "kill-reason) #f)) ;; BB ADDED kill-reason -- confirm OK with Matt + (begin + (debug:print-error 0 *default-log-port* "Nothing to kill, pid1=" pid1 ", pid2=" pid2) + (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (conc (args:get-arg "-m")" "kill-reason) #f) ;; BB ADDED kill-reason -- confirm OK with Matt + ))) + (mutex-unlock! m) + ;; no point in sticking around. Exit now. But run end of run before exiting? + (launch:end-of-run-check run-id) + (exit))) + (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 + (begin + (thread-sleep! 6) ;; was 3 + (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 (commonmod:get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional + + +;; read testconfig and create .logpro and script files +;; - use #f for tconfigreg to re-read the testconfigs from disk +;; +(define (launch:extract-scripts-logpro test-dir test-name item-path tconfigreg-in) + (let* ((tconfigreg (or tconfigreg-in + (tests:get-all))) + (tconfig-fname (conc test-dir "/.testconfig")) + (tconfig-tmpfile (conc tconfig-fname ".tmp")) + (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) + (scripts (configf:get-section tconfig "scripts")) + (logpros (configf:get-section tconfig "logpro"))) + ;; create .testconfig file + (configf:write-alist tconfig tconfig-tmpfile) + (file-move tconfig-tmpfile tconfig-fname #t) + (delete-file* ".final-status") + + ;; extract scripts from testconfig and write them to files in test run dir + (for-each + (lambda (scriptdat) + (match scriptdat + ((name content) + (debug:print-info 2 *default-log-port* "Creating script "(current-directory)"/"name) + (with-output-to-file name + (lambda () + (print content))) + (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu))) + (else + (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\"")))) + scripts) + + ;; extract logpro from testconfig and write them to files in test run dir + (for-each + (lambda (logprodat) + (match logprodat + ((name content) + (debug:print-info 2 *default-log-port* "Creating logpro file "(current-directory)"/"name".logpro") + (with-output-to-file (conc name".logpro") + (lambda () + (print content) + ;; (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)) + ))) + (else + (debug:print-info 0 "Invalid logpro definiton found in [logpro] section of testconfig. \"" logprodat "\"")))) + logpros))) + +(define (launch:execute encoded-cmd) + (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) + (tconfigreg #f)) + (setenv "MT_CMDINFO" encoded-cmd) + ;;(bb-check-path msg: "launch:execute incoming") + (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) + ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) + (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area + (top-path (assoc/default 'toppath cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area + (test-name (assoc/default 'test-name cmdinfo)) + (runscript (assoc/default 'runscript cmdinfo)) + (ezsteps (assoc/default 'ezsteps cmdinfo)) + (subrun (assoc/default 'subrun cmdinfo)) + ;; (runremote (assoc/default 'runremote cmdinfo)) + ;; (transport (assoc/default 'transport cmdinfo)) ;; not used + ;; (serverinf (assoc/default 'serverinf cmdinfo)) + ;; (port (assoc/default 'port cmdinfo)) + (serverurl (assoc/default 'serverurl cmdinfo)) + (homehost (assoc/default 'homehost cmdinfo)) + (run-id (assoc/default 'run-id cmdinfo)) + (test-id (assoc/default 'test-id cmdinfo)) + (target (assoc/default 'target cmdinfo)) + (areaname (assoc/default 'areaname cmdinfo)) + (itemdat (assoc/default 'itemdat cmdinfo)) + (env-ovrd (assoc/default 'env-ovrd cmdinfo)) + (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar + (runname (assoc/default 'runname cmdinfo)) + (megatest (assoc/default 'megatest cmdinfo)) + (runtlim (assoc/default 'runtlim cmdinfo)) + (contour (assoc/default 'contour cmdinfo)) + (item-path (item-list->path itemdat)) + (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) + (keys #f) + (keyvals #f) + (fullrunscript (if (not runscript) + #f + (if (substring-index "/" runscript) + runscript ;; use unadultered if contains slashes + (let ((fulln (conc work-area "/" runscript))) + (if (and (common:file-exists? fulln) + (file-execute-access? fulln)) + fulln + runscript))))) ;; assume it is on the path + (check-work-area (lambda () + ;; NFS might not have propagated the directory meta data to the run host - give it time if needed + (let loop ((count 0)) + (if (or (common:directory-exists? work-area) + (> count 10)) + (change-directory work-area) + (begin + (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") + (thread-sleep! 10) + (loop (+ count 1))))) + + (if (not (string=? (common:real-path work-area)(common:real-path (current-directory)))) + (begin + (debug:print 0 *default-log-port* + "INFO: we are expecting to be in directory " work-area "\n" + " but we are actually in the directory " (current-directory) "\n" + " doing another change dir.") + (change-directory work-area))) + + ;; spot check that the files in testpath are available. Too often NFS delays cause problems here. + (let ((files (glob (conc testpath "/*"))) + (bad-files '())) + (for-each + (lambda (fullname) + (let* ((fname (pathname-strip-directory fullname)) + (targn (conc work-area "/" fname))) + (if (not (file-exists? targn)) + (set! bad-files (cons fname bad-files))))) + files) + (if (not (null? bad-files)) + (begin + (debug:print 0 *default-log-port* "INFO: test data from " testpath " not copied properly or filesystem problems causing data to not be found. Re-running the copy command.") + (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", ")) + (launch:test-copy testpath work-area)))) + ;; one more time, change to the work-area directory + (change-directory work-area))) + ) ;; let* + + (if contour (setenv "MT_CONTOUR" contour)) + + ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ... + ;; + (setenv "MT_TESTSUITENAME" areaname) + (setenv "MT_RUN_AREA_HOME" top-path) + (set! *toppath* top-path) + (change-directory *toppath*) ;; temporarily switch to the run area home + (setenv "MT_TEST_RUN_DIR" work-area) + + (launch:setup) ;; should be properly in the run area home now + + (if contour (setenv "MT_CONTOUR" contour)) + + ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ... + ;; + (setenv "MT_TESTSUITENAME" areaname) + (setenv "MT_RUN_AREA_HOME" top-path) + (set! *toppath* top-path) + (change-directory *toppath*) ;; temporarily switch to the run area home + (setenv "MT_TEST_RUN_DIR" work-area) + + (launch:setup) ;; should be properly in the run area home now + + (set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path + (let ((sighand (lambda (signum) + ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting + (if (eq? signum signal/stop) + (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting.")) + (set! *time-to-exit* #t) + (debug:print 0 *default-log-port* "Received signal " signum ", cleaning up before exit (set this test to COMPLETED/ABORT) . Please wait...") + (let ((th1 (make-thread (lambda () + (debug:print 0 *default-log-port* "set test to COMPLETED/ABORT begin.") + (rmt:test-set-state-status run-id test-id "COMPLETED" "ABORT" "received kill signal") + (debug:print 0 *default-log-port* "set test to COMPLETED/ABORT complete.") + (debug:print 0 *default-log-port* "Killed by signal " signum ". Exiting") + (exit 1)))) + (th2 (make-thread (lambda () + (thread-sleep! 20) + (debug:print 0 *default-log-port* "Done") + (exit 4))))) + (thread-start! th2) + (thread-start! th1) + (thread-join! th2))))) + (set-signal-handler! signal/int sighand) + (set-signal-handler! signal/term sighand) + ) ;; (set-signal-handler! signal/stop sighand) + + ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, + ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* + ;; + (let* ((test-info (let loop ((tries 0)) + (let ((tinfo (rmt:get-test-info-by-id run-id test-id))) + (if tinfo + tinfo + (if (> tries 5) + #f + (begin + (thread-sleep! (+ 1 (* tries 10))) + (loop (+ tries 1)))))))) + (test-host (if test-info + (db:test-get-host test-info) + (begin + (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 + (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 run-id test-id) + (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) + ) ;; prime it for running + ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART")) + (if (process:alive-on-host? test-host test-pid) + (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed") + (exit 1))) + ((member (db:test-get-state test-info) '("COMPLETED")) ;; we do NOT want to re-run COMPLETED jobs. Mark as NOT_STARTED to run! + (debug:print 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed") + (debug:print 0 *default-log-port* "exiting with status 1") + (exit 1)) + ((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) + ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") + (rmt:general-call 'set-test-start-time run-id test-id) + (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)) + (else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")) + (debug:print 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed") + (debug:print 0 *default-log-port* "exiting with status 1") + (exit 1)))) + + ;; cleanup prior execution's steps + (rmt:delete-steps-for-test! run-id test-id) + + (debug:print 2 *default-log-port* "Executing " test-name " (id: " test-id ") on " (get-host-name)) + (set! keys (rmt:get-keys)) + ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process + ;; one of these is defunct/redundant ... + (if (not (launch:setup force-reread: #t)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + ;; (sqlite3:finalize! db) + ;; (sqlite3:finalize! tdb) + (exit 1))) + ;; validate that the test run area is available + (check-work-area) + + ;; still need to go back to run area home for next couple steps + (change-directory *toppath*) + + ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This + ;; seems non-ideal but could well break stuff + ;; BUG? BUG? BUG? + + (let ((rconfig (full-runconfigs-read)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))) + (wconfig (read-config "waivers.config" #f #t sections: `( "default" ,target )))) ;; read the waivers config if it exists + ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target) + ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) + ;; Now have runconfigs data loaded, set environment vars + (for-each + (lambda (section) + (for-each + (lambda (varval) + (let ((var (car varval)) + (val (cadr varval))) + (if (and (string? var)(string? val)) + (begin + (safe-setenv var (configf:eval-string-in-environment val))) ;; val) + (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val)))) + (configf:get-section rconfig section))) + (list "default" target))) + ;;(bb-check-path msg: "launch:execute post block 1") + + ;; NFS might not have propagated the directory meta data to the run host - give it time if needed + (let loop ((count 0)) + (if (or (common:file-exists? work-area) + (> count 10)) + (change-directory work-area) + (begin + (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") + (thread-sleep! 10) + (loop (+ count 1))))) + + ;; now we can switch to the work-area? + (change-directory work-area) + ;;(bb-check-path msg: "launch:execute post block 1.5") + ;; (change-directory work-area) + (set! keyvals (keys:target->keyval keys target)) + ;; apply pre-overrides before other variables. The pre-override vars must not + ;; clobbers things from the official sources such as megatest.config and runconfigs.config + (if (string? set-vars) + (let ((varpairs (string-split set-vars ","))) + (debug:print 4 *default-log-port* "varpairs: " varpairs) + (map (lambda (varpair) + (let ((varval (string-split varpair "="))) + (if (eq? (length varval) 2) + (let ((var (car varval)) + (val (cadr varval))) + (debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment") + (setenv var val))))) + varpairs))) + ;;(bb-check-path msg: "launch:execute post block 2") + (for-each + (lambda (varval) + (let ((var (car varval)) + (val (cadr varval))) + (if val + (setenv var val) + (begin + (debug:print-error 0 *default-log-port* "required variable " var " does not have a valid value. Exiting") + (exit))))) + (list + (list "MT_TEST_RUN_DIR" work-area) + (list "MT_TEST_NAME" test-name) + (list "MT_ITEM_INFO" (conc itemdat)) + (list "MT_ITEMPATH" item-path) + (list "MT_RUNNAME" runname) + (list "MT_MEGATEST" megatest) + (list "MT_TARGET" target) + (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) + (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) + ;;(bb-check-path msg: "launch:execute post block 3") + + (let ((tmppath (getenv "PATH"))) + (if (string-search tmppath " ") + (debug:print 0 *default-log-port* "WARNING: spaces in PATH are not supported.")) + (if mt-bindir-path (setenv "PATH" (conc tmppath":"mt-bindir-path)))) + ;;(bb-check-path msg: "launch:execute post block 4") + ;; (change-directory top-path) + ;; Can setup as client for server mode now + ;; (client:setup) + + ;; environment overrides are done *before* the remaining critical envars. + (alist->env-vars env-ovrd) + ;;(bb-check-path msg: "launch:execute post block 41") + (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) + ;;(bb-check-path msg: "launch:execute post block 42") + (set-item-env-vars itemdat) + ;;(bb-check-path msg: "launch:execute post block 43") + (let ((blacklist (configf:lookup *configdat* "setup" "blacklistvars"))) + (if blacklist + (let ((vars (string-split blacklist))) + (save-environment-as-files "megatest" ignorevars: vars) + (for-each (lambda (var) + (unsetenv var)) + vars)) + (save-environment-as-files "megatest"))) + ;;(bb-check-path msg: "launch:execute post block 44") + ;; open-run-close not needed for test-set-meta-info + ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) + ;; (tests:set-full-meta-info test-id run-id 0 work-area) + (tests:set-full-meta-info #f test-id run-id 0 work-area 10) + + ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here + + (if (args:get-arg "-xterm") + (set! fullrunscript "xterm") + (if (and fullrunscript + (common:file-exists? fullrunscript) + (not (file-execute-access? fullrunscript))) + (system (conc "chmod ug+x " fullrunscript)))) + (launch:extract-scripts-logpro work-area test-name item-path tconfigreg) + +;;;;; ;; We are about to actually kick off the test +;;;;; ;; so this is a good place to remove the records for +;;;;; ;; any previous runs +;;;;; ;; (db:test-remove-steps db run-id testname itemdat) +;;;;; ;; now is also a good time to write the .testconfig file +;;;;; (let* ((tconfig-fname (conc work-area "/.testconfig")) +;;;;; (tconfig-tmpfile (conc tconfig-fname ".tmp")) +;;;;; (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) +;;;;; (scripts (configf:get-section tconfig "scripts")) +;;;;; (precmd (configf:lookup tconfig ) +;;;;; ;; create .testconfig file +;;;;; (configf:write-alist tconfig tconfig-tmpfile) +;;;;; (file-move tconfig-tmpfile tconfig-fname #t) +;;;;; (delete-file* ".final-status") +;;;;; +;;;;; ;; extract scripts from testconfig and write them to files in test run dir +;;;;; (for-each +;;;;; (lambda (scriptdat) +;;;;; (match scriptdat +;;;;; ((name content) +;;;;; (with-output-to-file name +;;;;; (lambda () +;;;;; (print content) +;;;;; (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu))))) +;;;;; (else +;;;;; (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\"")))) +;;;;; scripts)) + ;; + + (let* ((m (make-mutex)) + (kill-job? #f) + (exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status + (job-thread #f) + ;; (keep-going #t) + (misc-flags (let ((ht (make-hash-table))) + (hash-table-set! ht 'keep-going #t) + ht)) + (runit (lambda () + (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m))) + (monitorjob (lambda () + (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags))) + (th1 (make-thread monitorjob "monitor job")) + (th2 (make-thread runit "run job")) + (tconfig (tests:get-testconfig test-name item-path tconfigreg #t)) + (propagate-exit-code (configf:lookup *configdat* "setup" "propagate-exit-code")) + (propagate-status-list '("FAIL" "KILLED" "ABORT" "DEAD" "CHECK" "SKIP" "WAIVED")) + (test-status "not set") + (precmd (configf:lookup tconfig "setup" "precmd")) + (postcmd (configf:lookup tconfig "setup" "postcmd"))) + ;; first, if set, run the precmd + (if precmd ;; (file-exists? precmd)(file-execute-access? precmd)) + (system precmd)) ;; up to test author to put nbfake if desired. + (set! job-thread th2) + (thread-start! th1) + (thread-start! th2) + (thread-join! th2) + (debug:print-info 0 *default-log-port* "Megatest execute of test " test-name ", item path " item-path " complete. Notifying the db ...") + (debug:print-info 2 *default-log-port* "exit-info = " exit-info) + (hash-table-set! misc-flags 'keep-going #f) + (thread-join! th1) + (thread-sleep! 1) ;; givbe thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. + (mutex-lock! m) + (let* ((item-path (item-list->path itemdat)) + ;; only state and status needed - use lazy routine + (testinfo (rmt:get-testinfo-state-status run-id test-id))) + ;; Am I completed? + (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) + (let ((new-state (if kill-job? "KILLED" "COMPLETED")) + (new-status (cond + ((not (launch:einf-exit-status exit-info)) "FAIL") ;; job failed to run ... (vector-ref exit-info 1) + ((eq? (launch:einf-rollup-status exit-info) 0) ;; (vector-ref exit-info 3) + ;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO) + (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) + ((eq? (launch:einf-rollup-status exit-info) 1) "FAIL") ;; (vector-ref exit-info 3) + ((eq? (launch:einf-rollup-status exit-info) 2) ;; (vector-ref exit-info 3) + ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) + (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) + ((eq? (launch:einf-rollup-status exit-info) 3) "CHECK") + ((eq? (launch:einf-rollup-status exit-info) 4) "WAIVED") + ((eq? (launch:einf-rollup-status exit-info) 5) "ABORT") + ((eq? (launch:einf-rollup-status exit-info) 6) "SKIP") + (else "FAIL"))) + ) ;; (db:test-get-status testinfo))) + (debug:print-info 0 *default-log-port* "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info)) + + ;; Leave a .final-status file for each sub-test + (tests:save-final-status run-id test-id) + + (tests:test-set-status! run-id + test-id + new-state + new-status + (args:get-arg "-m") #f) + ;; need to update the top test record if PASS or FAIL and this is a subtest + ;; NO NEED TO CALL set-state-status-and-roll-up-items HERE, THIS IS DONE IN set-state-status-and-roll-up-items called by tests:test-set-status! + ) + ) + + + ;; for automated creation of the rollup html file this is a good place... + (if (not (equal? item-path "")) + (tests:summarize-items run-id test-id test-name #f)) + ;; BUG was this meant to be the antecnt of the if above? + ;; BUG was this meant to be the antecnt of the if above? + (tests:summarize-test run-id test-id) ;; don't force - just update if no + ;; Leave a .final-status file for the top level test + (tests:save-final-status run-id test-id) + (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) ;; end of let* + + (mutex-unlock! m) + (launch:end-of-run-check run-id ) + (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " + work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n") + + + (set! test-status (db:test-get-status (rmt:get-testinfo-state-status run-id test-id))) + + ;; If the propagate-exit-code option has been set in the megatest config, and the test status matches the list, set the exit code to 1. + + (if postcmd + (system postcmd)) + + (if (and propagate-exit-code (string=? propagate-exit-code "yes") (member test-status propagate-status-list)) + (begin + (debug:print 1 *default-log-port* "Setting exit status to 1 because of test status of " test-status) + (set! *globalexitstatus* 1) + ) + ) + + (if (not (launch:einf-exit-status exit-info)) + (exit 4)))) + ))) + +;; DO NOT USE - caching of configs is handled in launch:setup now. +;; +(define (launch:cache-config) + ;; if we have a linktree and -runtests and -target and the directory exists dump the config + ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg + (if (and *configdat* + (or (args:get-arg "-run") + (args:get-arg "-runtests") + (args:get-arg "-execute"))) + (let* ((linktree (common:get-linktree)) ;; (get-environment-variable "MT_LINKTREE")) + (target (common:args-get-target exit-if-bad: #t)) + (runname (or (args:get-arg "-runname") + (args:get-arg ":runname") + (getenv "MT_RUNNAME"))) + (fulldir (conc linktree "/" + target "/" + runname))) + (if (and linktree (common:file-exists? linktree)) ;; can't proceed without linktree + (begin + (debug:print-info 0 *default-log-port* "Have -run with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) + (if (not (common:file-exists? fulldir)) + (create-directory fulldir #t)) ;; need to protect with exception handler + (if (and target + runname + (common:file-exists? fulldir)) + (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) + (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) + (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) + (if (common:file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached + (begin + (debug:print-info 0 *default-log-port* "Caching megatest.config in " tmpfile) + (if (not (common:in-running-test?)) + (configf:write-alist *configdat* tmpfile)) + (system (conc "ln -sf " tmpfile " " targfile)))) + ))) + (debug:print-info 1 *default-log-port* "No linktree yet, no caching configs."))))) + +(define (launch:handle-zombie-tests run-id) + (let* ((key (conc "zombiescan-runid-"run-id)) + (now (current-seconds)) + (threshold (- (current-seconds) (* 2 (or (configf:lookup-number *configdat* "setup" "deadtime") 120)))) + (val (rmt:get-var key)) + (do-scan? + (cond + ((not val) + #t) + ((< val threshold) + #t) + (else #f)))) + (when do-scan? + (debug:print 1 *default-log-port* "INFO: search and mark zombie tests") + (rmt:set-var key (current-seconds)) + (rmt:find-and-mark-incomplete run-id #f)))) + +;; recover a test where the top controlling mtest may have died +;; +(define (launch:recover-test run-id test-id) + ;; this function is called on the test run host via ssh + ;; + ;; 1. look at the process from pid + ;; - is it owned by calling user + ;; - it it's run directory correct for the test + ;; - is there a controlling mtest (maybe stuck) + ;; 2. if recovery is needed watch pid + ;; - when it exits take the exit code and do the needful + ;; + (let* ((pid (rmt:test-get-top-process-pid run-id test-id)) + (psres (with-input-from-pipe + (conc "ps -F -u " (current-user-name) " | grep -E '" pid " ' | grep -v 'grep -E " pid "'") + (lambda () + (read-line)))) + (rundir (if (string? psres) ;; real process owned by user + (read-symbolic-link (conc "/proc/" pid "/cwd")) + #f))) + ;; now wait on that process if all is correct + ;; periodically update the db with runtime + ;; when the process exits look at the db, if still RUNNING after 10 seconds set + ;; state/status appropriately + (process-wait pid))) + +;;====================================================================== +;; Maintenance +;;====================================================================== + +(define (rmt:find-and-mark-incomplete run-id ovr-deadtime) + (let* ((cfg-deadtime (configf:lookup-number *configdat* "setup" "deadtime")) + (test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period"))) + (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period) + ;;call end of eud of run detection for posthook + (launch:end-of-run-check run-id))) + +;; select end_time-now from +;; (select testname,item_path,event_time+run_duration as +;; end_time,strftime('%s','now') as now from tests where state in +;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED')); +;; +;; NOT EASY TO MIGRATE TO db{file,mod} +;; +(define (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period) + (let* ((incompleted '()) + (oldlaunched '()) + (toplevels '()) + ;; The default running-deadtime is 720 seconds = 12 minutes. + ;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30)) + (deadtime-trim (or ovr-deadtime cfg-deadtime)) + (server-start-allowance 200) + (server-overloaded-budget 200) + (launch-monitor-off-time (or test-stats-update-period 30)) + (launch-monitor-on-time-budget 30) + (launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget)) + (remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30)) + (remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default)) + (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period))) + (running-deadtime (or deadtime-trim running-deadtime-default))) ;; two minutes (30 seconds between updates, this leaves 3x grace period) + + (debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime) + (debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim) + + (let* ((dat (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime))) + (set! oldlaunched (list-ref dat 1)) + (set! toplevels (list-ref dat 2)) + (set! incompleted (list-ref dat 0))) + + (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " + (length toplevels) " old LAUNCHED toplevel tests and " + (length incompleted) " tests marked RUNNING but apparently dead.") + + ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. + ;; + ;; (db:delay-if-busy dbdat) + (let* ((min-incompleted-ids (map car incompleted)) ;; do 'em all + (all-ids (append min-incompleted-ids (map car oldlaunched)))) + (if (> (length all-ids) 0) + (begin + ;; (launch:is-test-alive "localhost" 435) + (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") + " as DEAD") + (for-each + (lambda (test-id) + (let* ((tinfo (rmt:get-test-info-by-id run-id test-id)) + (run-dir (db:test-get-rundir tinfo)) + (host (db:test-get-host tinfo)) + (pid (db:test-get-process_id tinfo)) + (result (rmt:get-status-from-final-status-file run-dir))) + (if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result))) + (begin + (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD") + (rmt:set-state-status-and-roll-up-items + run-id test-id 'foo "COMPLETED" "PASS" + "Test stopped responding but it has PASSED; marking it PASS in the DB.")) + (let ((is-alive (and (not (eq? pid 0)) ;; 0 is default in re-used field "attemptnum" where pid stored. + (commonmod:is-test-alive host pid)))) + (if is-alive + (debug:print 0 *default-log-port* "INFO: test " test-id " on host " host + " has a process on pid " pid ", NOT setting to DEAD.") + (begin + (debug:print 0 *default-log-port* "INFO: test " test-id + " final state/status is not COMPLETED/PASS. It is " result) + (rmt:set-state-status-and-roll-up-items + run-id test-id 'foo "COMPLETED" "DEAD" + "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead."))))))) + ;; call end of eud of run detection for posthook - from merge, is it needed? + ;; (launch:end-of-run-check run-id) + all-ids) + ))))) + +;; set up needed environment variables given a run-id and optionally a target, itempath etc. +;; +(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) + ;;(bb-check-path msg: "runs:set-megatest-env-vars entry") + (let* ((target (or intarget + (common:args-get-target) + (get-environment-variable "MT_TARGET"))) + (keys (if inkeys inkeys (rmt:get-keys))) + (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) + (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) + (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) + (if testname (setenv "MT_TEST_NAME" testname)) + (if itempath (setenv "MT_ITEMPATH" itempath)) + + ;; get the info from the db and put it in the cache + (if link-tree + (setenv "MT_LINKTREE" link-tree) + (debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section.")) + (if (not vals) + (let ((ht (make-hash-table))) + (hash-table-set! *env-vars-by-run-id* run-id ht) + (set! vals ht) + (for-each + (lambda (key) + (hash-table-set! vals (car key) (cadr key))) + keyvals))) + ;; from the cached data set the vars + + (hash-table-for-each + vals + (lambda (key val) + (debug:print 2 *default-log-port* "setenv " key " " val) + (safe-setenv key val))) + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1") + ;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals)) + + (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) + ;; we had a case where there was an exception generated by the hash-table-ref + ;; due to *configdat* being #f Adding a handle and exit + (let fatal-loop ((count 0)) + (handle-exceptions + exn + (let ((call-chain (get-call-chain)) + (msg ((condition-property-accessor 'exn 'message) exn))) + (if (< count 5) + (begin ;; this call is colliding, do some crude stuff to fix it. + (debug:print 0 *default-log-port* "ERROR: *configdat* was inaccessible! This should never happen. Retry #" count + ", exn=" exn) + (launch:setup force-reread: #t) + (fatal-loop (+ count 1))) + (begin + (debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count + " times. Message: " msg) + (debug:print 0 *default-log-port* "Call chain:") + (with-output-to-port *default-log-port* + (lambda () + (print "*configdat* is >>"*configdat*"<<") + (pp *configdat*) + (pp call-chain))) + + (exit 1)))) + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5") + (when (or (not *configdat*) (not (hash-table? *configdat*))) + (debug:print 0 *default-log-port* "WARNING: *configdat* was inaccessible! This should never happen. Brute force reread.") + ;;(BB> "ERROR: *configdat* was inaccessible! This should never happen. Brute force reread.") + (thread-sleep! 2) ;; assuming nfs lag. + (launch:setup force-reread: #t)) + (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block. + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 2") + ;; Lets use this as an opportunity to put MT_RUNNAME in the environment + (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) + (if runname + (setenv "MT_RUNNAME" runname) + (debug:print-error 0 *default-log-port* "no value for runname for id " run-id))) + (setenv "MT_RUN_AREA_HOME" *toppath*) + ;; if a testname and itempath are available set the remaining appropriate variables + (if testname (setenv "MT_TEST_NAME" testname)) + (if itempath (setenv "MT_ITEMPATH" itempath)) + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 3") + (if (and testname link-tree) + (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/" + (getenv "MT_TARGET") "/" + (getenv "MT_RUNNAME") "/" + (getenv "MT_TEST_NAME") + (if (and itempath + (not (equal? itempath ""))) + (conc "/" itempath) + "")))))) +(define (set-item-env-vars itemdat) + (for-each (lambda (item) + (debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item)) + (setenv (car item) (cadr item))) + itemdat)) + + + +) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -1161,53 +1161,10 @@ (json-write targets)) (else (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) (set! *didsomething* #t)))) -;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig -;; -(define (full-runconfigs-read) -;; in the envprocessing branch the below code replaces the further below code -;; (if (eq? *configstatus* 'fulldata) -;; *runconfigdat* -;; (begin -;; (launch:setup) -;; *runconfigdat*))) - - (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME")) - (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")) - #f)) - (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f))) - (if (and cfgf - (common:file-exists? cfgf) - (file-write-access? cfgf) - (common:use-cache?)) - (configf:read-alist cfgf) - (let* ((keys (rmt:get-keys)) - (target (common:args-get-target)) - (key-vals (if target (keys:target->keyval keys target) #f)) - (sections (if target (list "default" target) #f)) - (data (begin - (setenv "MT_RUN_AREA_HOME" *toppath*) - (if key-vals - (for-each (lambda (kt) - (setenv (car kt) (cadr kt))) - key-vals)) - ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) - (runconfig:read (conc *toppath* "/runconfigs.config") target #f)))) - (if (and rundir ;; have all needed variabless - (directory-exists? rundir) - (file-write-access? rundir)) - (begin - (if (not (common:in-running-test?)) - (configf:write-alist data cfgf)) - ;; force re-read of megatest.config - this resolves circular references between megatest.config - (launch:setup force-reread: #t) - ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW. - )) ;; we can safely cache megatest.config since we have a valid runconfig - data)))) - (if (args:get-arg "-show-runconfig") (let ((tl (launch:setup))) (push-directory *toppath*) (let ((data (full-runconfigs-read))) ;; keep this one local Index: megatestmod.scm ================================================================== --- megatestmod.scm +++ megatestmod.scm @@ -33,10 +33,11 @@ (declare (uses configfmod)) (declare (uses processmod)) (declare (uses mtmod)) (declare (uses pkts)) (declare (uses servermod)) +(declare (uses fsmod)) (use srfi-69) (module megatestmod * @@ -113,17 +114,13 @@ debugprint mtmod pkts processmod servermod + fsmod ) -(define read-config (lambda ()(assert #f "FATAL: read-config proc not set!"))) - -(define (read-config-set! proc) - (set! read-config proc)) - ;;====================================================================== ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks #!key (configf #f)) (hash-table-ref/default (or configf (read-config "megatest.config" #f #t)) @@ -193,23 +190,10 @@ (else (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt) args-testpatt)))) -(define (common:get-linktree) - (or (getenv "MT_LINKTREE") - (if *configdat* - (configf:lookup *configdat* "setup" "linktree") - #f) - (if (or *toppath* (getenv "MT_RUN_AREA_HOME")) - (conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt") - #f) - (let* ((tp (common:get-toppath #f)) - (lt (conc tp "/lt"))) - (if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt)) - lt))) - (define (common:args-get-runname) (let ((res (or (args:get-arg "-runname") (args:get-arg ":runname") (getenv "MT_RUNNAME")))) ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ... @@ -335,120 +319,10 @@ ;; (if (number? newval) ;; (set! cpu-load newval)))))) ;; (car load-res)) ;; cpu-load)) -;;====================================================================== -;; given path get free space, allows override in [setup] -;; with free-space-script /path/to/some/script.sh -;; -(define (get-df path) - (if (configf:lookup *configdat* "setup" "free-space-script") - (with-input-from-pipe - (conc (configf:lookup *configdat* "setup" "free-space-script") " " path) - (lambda () - (let ((res (read-line))) - (if (string? res) - (string->number res))))) - (get-unix-df path))) - -(define (get-free-inodes path) - (if (configf:lookup *configdat* "setup" "free-inodes-script") - (with-input-from-pipe - (conc (configf:lookup *configdat* "setup" "free-inodes-script") " " path) - (lambda () - (let ((res (read-line))) - (if (string? res) - (string->number res))))) - (get-unix-inodes path))) - -;;====================================================================== -;; check space in dbdir and in megatest dir -;; returns: ok/not dbspace required-space -;; -(define (common:check-db-dir-space) - (let* ((required (string->number - ;; default is 1GB (or actually a billion bytes) This is the number of 1 kB blocks. - (or (configf:lookup *configdat* "setup" "dbdir-space-required") - "1000000"))) - (dbdir (common:make-tmpdir-name *toppath* "")) ;; (db:get-dbdir)) - (tdbspace (common:check-space-in-dir dbdir required)) - (mdbspace (common:check-space-in-dir *toppath* required))) - (sort (list tdbspace mdbspace) (lambda (a b) - (< (cadr a)(cadr b)))))) - -;;====================================================================== -;; check available space in dbdir, exit if insufficient -;; -(define (common:check-db-dir-and-exit-if-insufficient) - (let* ((spacedat (car (common:check-db-dir-space))) ;; look only at worst for now - (is-ok (car spacedat)) - (dbspace (cadr spacedat)) - (required (caddr spacedat)) - (dbdir (cadddr spacedat))) - (if (not is-ok) - (begin - (debug:print-error 0 *default-log-port* "Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.") - (exit 1))))) - -;;====================================================================== -;; paths is list of lists ((name path) ... ) -;; -(define (common:get-disk-with-most-free-space disks minsize) - (let* ((best #f) - (bestsize 0) - (default-min-inodes-string "1000000") - (default-min-inodes (string->number default-min-inodes-string)) - (min-inodes (or (string->number (if (configf:lookup *configdat* "setup" "min_inodes") (configf:lookup *configdat* "setup" "min_inodes") default-min-inodes-string)) default-min-inodes))) - - (for-each - (lambda (disk-num) - (let* ((dirpath (cadr (assoc disk-num disks))) - (freespc (cond - ((not (directory? dirpath)) - (if (common:low-noise-print 300 "disks not a dir " disk-num) - (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) - -1) - ((not (file-write-access? dirpath)) - (if (common:low-noise-print 300 "disks not writeable " disk-num) - (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) - -1) - ((not (eq? (string-ref dirpath 0) #\/)) - (if (common:low-noise-print 300 "disks not a proper path " disk-num) - (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) - -1) - (else - (get-df dirpath)))) - (free-inodes (cond - ((not (directory? dirpath)) - (if (common:low-noise-print 300 "disks not a dir " disk-num) - (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) - -1) - ((not (file-write-access? dirpath)) - (if (common:low-noise-print 300 "disks not writeable " disk-num) - (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) - -1) - ((not (eq? (string-ref dirpath 0) #\/)) - (if (common:low-noise-print 300 "disks not a proper path " disk-num) - (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) - -1) - (else - (get-free-inodes dirpath)))) - ;;(free-inodes (get-free-inodes dirpath)) - ) - (debug:print 2 *default-log-port* "INFO: disk " disk-num " path " dirpath " free space " freespc " free inodes " free-inodes) - (if (and (> freespc bestsize)(> free-inodes min-inodes )) - (begin - (set! best (cons disk-num dirpath)) - (set! bestsize freespc))) - ;;(print "Processing: " disk-num " bestsize: " bestsize " best: " best " freespc: " freespc " min-inodes: " min-inodes " free-inodes: " free-inodes) - )) - (map car disks)) - (if (and best (> bestsize minsize)) - best - #f))) ;; #f means no disk candidate found - (define (common:get-pkts-dirs mtconf use-lt) (let* ((pktsdirs-str (or (configf:lookup mtconf "setup" "pktsdirs") (and use-lt (conc (or *toppath* (current-directory)) @@ -516,61 +390,10 @@ ))) pkts))))))) pktsdirs)) use-lt: use-lt)) -;;====================================================================== -;; D I S K S P A C E -;;====================================================================== - -(define (common:get-disk-space-used fpath) - (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read)) - -(define (get-unix-df path) - (let* ((df-results (process:cmd-run->list (conc "df " path))) - (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) - (freespc #f)) - ;; (write df-results) - (for-each (lambda (l) - (let ((match (string-search space-rx l))) - (if match - (let ((newval (string->number (cadr match)))) - (if (number? newval) - (set! freespc newval)))))) - (car df-results)) - freespc)) - -(define (get-unix-inodes path) - (let* ((df-results (process:cmd-run->list (conc "df -i " path))) - (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) - (freenodes 0)) ;; 0 is a better failsafe than #f here. - ;; (write df-results) - (for-each (lambda (l) - (let ((match (string-search space-rx l))) - (if match - (let ((newval (string->number (cadr match)))) - (if (number? newval) - (set! freenodes newval)))))) - (car df-results)) - freenodes)) - -(define (common:check-space-in-dir dirpath required) - (let* ((dbspace (if (directory? dirpath) - (get-df dirpath) - 0))) - (list (> dbspace required) - dbspace - required - dirpath))) - -(define (get-uname . params) - (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) - (uname #f)) - (if (null? (car uname-res)) - "unknown" - (caar uname-res)))) - ;;====================================================================== ;; use-lt is use linktree "lt" link to find pkts dir (define (common:save-pkt pktalist-in mtconf use-lt #!key (add-only #f)) ;; add-only saves the pkt only if there is a parent already (if (or (not add-only) Index: mtmod.scm ================================================================== --- mtmod.scm +++ mtmod.scm @@ -111,14 +111,10 @@ ;; imports common to chk5 and ck4 (import srfi-13) (include "db_records.scm") -(define (common:get-fields cfgdat) - (let ((fields (hash-table-ref/default cfgdat "fields" '()))) - (map car fields))) - ;;====================================================================== ;; stuff from keys that can't be in commonmod. Maybe move all from commonmod to here? ;;====================================================================== (define (keys:make-key/field-string confdat) @@ -126,15 +122,26 @@ (string-join (map (lambda (field)(conc (car field) " " (cadr field))) fields) ","))) -(define keys:config-get-fields common:get-fields) - ;;====================================================================== ;; testsuite and area utilites ;;====================================================================== + +(define (common:get-linktree) + (or (getenv "MT_LINKTREE") + (if *configdat* + (configf:lookup *configdat* "setup" "linktree") + #f) + (if (or *toppath* (getenv "MT_RUN_AREA_HOME")) + (conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt") + #f) + (let* ((tp (common:get-toppath #f)) + (lt (conc tp "/lt"))) + (if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt)) + lt))) (define (get-testsuite-name toppath configdat) (or (lookup configdat "setup" "area-name") (lookup configdat "setup" "testsuite") (get-environment-variable "MT_TESTSUITE_NAME") Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -30,141 +30,5 @@ (import commonmod debugprint) (include "common_records.scm") -(define (runconfig:read fname target environ-patt) - (let ((ht (make-hash-table))) - (if target (hash-table-set! ht target '())) - (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f)))) - -;; NB// to process a runconfig ensure to use environ-patt with target! -;; -(define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t)) - (let* ((keys (map car keyvals)) - (thekey (if keyvals - (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/") - (or (common:args-get-target) - (get-environment-variable "MT_TARGET") - (begin - (debug:print-error 0 *default-log-port* "setup-env-defaults called with no run-id or -target or -reqtarg") - "nothing matches this I hope")))) - ;; Why was system disallowed in the reading of the runconfigs file? - ;; NOTE: Should be setting env vars based on (target|default) - (confdat (runconfig:read fname thekey environ-patt)) - (whatfound (make-hash-table)) - (finaldat (make-hash-table)) - (sections (list "default" thekey))) - (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code - (debug:print 4 *default-log-port* "Using key=\"" thekey "\"") - - (if change-env - (for-each ;; NB// This can be simplified with new content of keyvals having all that is needed. - (lambda (keyval) - (safe-setenv (car keyval)(cadr keyval))) - keyvals)) - - (for-each - (lambda (section) - (let ((section-dat (hash-table-ref/default confdat section #f))) - (if section-dat - (for-each - (lambda (envvar) - (let ((val (cadr (assoc envvar section-dat)))) - (hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1)) - (if (and (string? envvar) - (string? val) - change-env) - (safe-setenv envvar val)) - (hash-table-set! finaldat envvar val))) - (map car section-dat))))) - sections) - (if already-seen - (begin - (debug:print 2 *default-log-port* "Key settings found in runconfigs.config:") - (for-each (lambda (fullkey) - (debug:print 2 *default-log-port* (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0)))) - sections) - (debug:print 2 *default-log-port* "---") - (set! *already-seen-runconfig-info* #t))) - ;; finaldat ;; was returning this "finaldat" which would be good but conflicts with other uses - confdat - )) - -(define (set-run-config-vars run-id keyvals targ-from-db) - (push-directory *toppath*) ;; the push/pop doesn't appear to do anything ... - (let ((runconfigf (conc *toppath* "/runconfigs.config")) - (targ (or (common:args-get-target) - targ-from-db - (get-environment-variable "MT_TARGET")))) - (pop-directory) - (if (common:file-exists? runconfigf) - (setup-env-defaults runconfigf run-id #t keyvals - environ-patt: (conc "(default" - (if targ - (conc "|" targ ")") - ")"))) - (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf)))) - -;; given (a (b c) d) return ((a b d)(a c d)) -;; NOTE: this feels like it has been done before - perhaps with items handling? -;; -(define (runconfig:combinations inlst) - (let loop ((hed (car inlst)) - (tal (cdr inlst)) - (res '())) - ;; (print "res: " res " hed: " hed) - (if (list? hed) - (let ((newres (if (null? res) ;; first time through convert incoming items to list of items - (map list hed) - (apply append - (map (lambda (r) ;; iterate over items in res - (map (lambda (h) ;; iterate over items in hed - (append r (list h))) - hed)) - res))))) - ;; (print "newres1: " newres) - (if (null? tal) - newres - (loop (car tal)(cdr tal) newres))) - (let ((newres (if (null? res) - (list (list hed)) - (map (lambda (r) - (append r (list hed))) - res)))) - ;; (print "newres2: " newres) - (if (null? tal) - newres - (loop (car tal)(cdr tal) newres)))))) - -;; multi-part expand -;; Given a/b,c,d/e,f return a/b/e a/b/f a/c/e a/c/f a/d/e a/d/f -;; -(define (runconfig:expand target) - (let* ((parts (map (lambda (x) - (string-split x ",")) - (string-split target "/")))) - (map (lambda (x) - (string-intersperse x "/")) - (runconfig:combinations parts)))) - -;; multi-target expansion -;; a/b/c/x,y,z a/b/d/x,y => a/b/c/x a/b/c/y a/b/c/z a/b/d/x a/b/d/y -;; -(define (runconfig:expand-target target-strs) - (delete-duplicates - (apply append (map runconfig:expand (string-split target-strs " "))))) - -#| - (if (null? target-strs) - '() - (let loop ((hed (car target-strs)) - (tal (cdr target-strs)) - (res '())) - ;; first break all parts into individual target patterns - (if (string-index hed " ") ;; this is a multi-target target - (let ((newres (append (string-split hed " ") res))) - (runconfig:expand-target newres)) - (if (string-index hed ",") ;; this is a multi-target where one or more parts are comma separated - -|# - Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -66,3075 +66,5 @@ mtmod tasksmod servermod ) -;; use this struct to facilitate refactoring -;; - -(defstruct runs:dat - reglen regfull - runname max-concurrent-jobs run-id - test-patts required-tests test-registry - registry-mutex flags keyvals run-info all-tests-registry - ;; stores results from last runs:can-run-more-tests - (can-run-more-tests #f) ;; (list can-run-more-flag num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit) - ((can-run-more-tests-count 0) : fixnum) - (last-fuel-check 0) ;; time when we last checked fuel - (beginning-of-time (current-seconds)) - (load-mgmt-function #f) - (wait-for-jobs-function #f) - (last-load-check-time 0) - (last-jobs-check-time 0) - ) - -(defstruct runs:testdat - hed tal reg reruns test-record - test-name item-path jobgroup - waitons testmode newtal itemmaps prereqs-not-met) - -;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files -;; - remove any that are over 3600 seconds old -;; - if there are any that are younger than 10 seconds -;; * sleep 10 seconds -;; * touch my key-host-pid.softlock file -;; * return -;; - if there are no files younger than 10 seconds -;; * touch my key-host-pid.softlock file -;; * return -;; -(define (runs:wait-on-softlock rdat key) - (if (not (and *toppath* (file-exists? *toppath*))) ;; don't seem to have toppath yet - (debug:print-info 0 *default-log-port* "Can't create softlocks - don't see MTRAH yet.") - (let* ((softlocks-dir (conc *toppath* "/.softlocks"))) - (if (not (file-exists? softlocks-dir)) - (create-directory softlocks-dir #t)) - (let* ((my-lock-file (conc softlocks-dir "/" key "-" (get-host-name) "-" (current-process-id) ".softlock")) - (lock-files (filter (lambda (x) - (not (equal? x my-lock-file))) - (glob (conc softlocks-dir "/" key "*.softlock")))) - (fresh-locks (any (lambda (x) ;; do we have any locks younger than 10 seconds - (let* ((mod-time (file-modification-time x)) - (age (- (current-seconds) mod-time))) - (cond - ((> age 3600) ;; too old to keep, remove it - (delete-file* x) #f) - ((< age 10) #t) - (else #f)))) - lock-files))) - (if fresh-locks - (begin - (if (runs:lownoise "runners-softlock-wait" 360) - (debug:print-info 0 *default-log-port* "Other runners in flight, giving up some time...")) - (thread-sleep! 2)) - (begin - (if (runs:lownoise "runners-softlock-nowait" 360) - (debug:print-info 0 *default-log-port* "No runners in flight, updating softlock")) - (let* ((ouf (open-output-file my-lock-file))) - (with-output-to-port ouf (lambda ()(print (current-seconds)))) - (close-output-port ouf)))) - (runs:dat-last-fuel-check-set! rdat (current-seconds)))))) - -;; Fourth try, do accounting through time.... -;; -(define (runs:parallel-runners-mgmt rdat) - (let ((time-to-check (configf:lookup-number *configdat* "runners" "time-to-check" default: 10)) ;; 28 - (time-to-wait (configf:lookup-number *configdat* "runners" "time-to-wait" default: 30)) - (now-time (current-seconds))) - (if (> (- now-time (runs:dat-last-fuel-check rdat)) time-to-check) ;; time to check - (runs:wait-on-softlock rdat "runners")))) - -;; To test parallel-runners management start a repl: -;; megatest -repl -;; then run: -;; (runs:test-parallel-runners 60) -;; -(define (runs:test-parallel-runners duration #!optional (proc #f)) - (let* ((rdat (make-runs:dat)) - (rtime 0) - (startt (current-seconds)) - (endt (+ startt duration))) - ((or proc runs:parallel-runners-mgmt) rdat) - (let loop () - (let* ((wstart (current-seconds))) - (if (< wstart endt) - (let* ((work-time (random 10))) - #;(debug:print-info 0 *default-log-port* "working for " work-time - " seconds. Total work: " rtime ", elapsed time: " (- wstart startt)) - (thread-sleep! work-time) - (set! rtime (+ rtime work-time)) - ((or proc runs:parallel-runners-mgmt) rdat) - (loop))))) - (let* ((done-time (current-seconds))) - (debug:print-info 0 *default-log-port* "DONE: rtime=" rtime ", elapsed time=" (- done-time startt) - ", ratio=" (/ rtime (- done-time startt)))))) - -(define (runs:get-mt-env-alist run-id runname target testname itempath) - ;;(bb-check-path msg: "runs:set-megatest-env-vars entry") - `(("MT_TEST_NAME" . ,testname) - - ("MT_ITEMPATH" . ,itempath) - - ("MT_TARGET" . ,target) - - ("MT_RUNNAME" . ,runname) - - ("MT_RUN_AREA_HOME" . ,*toppath*) - - ,@(let* ((link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) - (if link-tree - (list (cons "MT_LINKTREE" link-tree) - - (cons "MT_TEST_RUN_DIR" - (conc link-tree "/" target "/" runname "/" testname - (if (and (string? itempath) (not (equal? itempath ""))) - (conc "/" itempath) - ""))) - ) - '())) - - ,@(map - (lambda (key) - (cons (car key) (cadr key))) - (keys:target->keyval (rmt:get-keys) target)) - - ,@(map (lambda (var) - (let ((val (configf:lookup *configdat* "env-override" var))) - (cons var val))) - (configf:section-vars *configdat* "env-override")))) - -;; set up needed environment variables given a run-id and optionally a target, itempath etc. -;; -(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) - ;;(bb-check-path msg: "runs:set-megatest-env-vars entry") - (let* ((target (or intarget - (common:args-get-target) - (get-environment-variable "MT_TARGET"))) - (keys (if inkeys inkeys (rmt:get-keys))) - (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) - (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) - (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) - (if testname (setenv "MT_TEST_NAME" testname)) - (if itempath (setenv "MT_ITEMPATH" itempath)) - - ;; get the info from the db and put it in the cache - (if link-tree - (setenv "MT_LINKTREE" link-tree) - (debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section.")) - (if (not vals) - (let ((ht (make-hash-table))) - (hash-table-set! *env-vars-by-run-id* run-id ht) - (set! vals ht) - (for-each - (lambda (key) - (hash-table-set! vals (car key) (cadr key))) - keyvals))) - ;; from the cached data set the vars - - (hash-table-for-each - vals - (lambda (key val) - (debug:print 2 *default-log-port* "setenv " key " " val) - (safe-setenv key val))) - ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1") - ;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals)) - - (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) - ;; we had a case where there was an exception generated by the hash-table-ref - ;; due to *configdat* being #f Adding a handle and exit - (let fatal-loop ((count 0)) - (handle-exceptions - exn - (let ((call-chain (get-call-chain)) - (msg ((condition-property-accessor 'exn 'message) exn))) - (if (< count 5) - (begin ;; this call is colliding, do some crude stuff to fix it. - (debug:print 0 *default-log-port* "ERROR: *configdat* was inaccessible! This should never happen. Retry #" count - ", exn=" exn) - (launch:setup force-reread: #t) - (fatal-loop (+ count 1))) - (begin - (debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count - " times. Message: " msg) - (debug:print 0 *default-log-port* "Call chain:") - (with-output-to-port *default-log-port* - (lambda () - (print "*configdat* is >>"*configdat*"<<") - (pp *configdat*) - (pp call-chain))) - - (exit 1)))) - ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5") - (when (or (not *configdat*) (not (hash-table? *configdat*))) - (debug:print 0 *default-log-port* "WARNING: *configdat* was inaccessible! This should never happen. Brute force reread.") - ;;(BB> "ERROR: *configdat* was inaccessible! This should never happen. Brute force reread.") - (thread-sleep! 2) ;; assuming nfs lag. - (launch:setup force-reread: #t)) - (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block. - ;;(bb-check-path msg: "runs:set-megatest-env-vars block 2") - ;; Lets use this as an opportunity to put MT_RUNNAME in the environment - (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) - (if runname - (setenv "MT_RUNNAME" runname) - (debug:print-error 0 *default-log-port* "no value for runname for id " run-id))) - (setenv "MT_RUN_AREA_HOME" *toppath*) - ;; if a testname and itempath are available set the remaining appropriate variables - (if testname (setenv "MT_TEST_NAME" testname)) - (if itempath (setenv "MT_ITEMPATH" itempath)) - ;;(bb-check-path msg: "runs:set-megatest-env-vars block 3") - (if (and testname link-tree) - (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/" - (getenv "MT_TARGET") "/" - (getenv "MT_RUNNAME") "/" - (getenv "MT_TEST_NAME") - (if (and itempath - (not (equal? itempath ""))) - (conc "/" itempath) - "")))))) - -(define (set-item-env-vars itemdat) - (for-each (lambda (item) - (debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item)) - (setenv (car item) (cadr item))) - itemdat)) - -;; Every time can-run-more-tests is called increment the delay -;; -;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine -;; -(define *last-num-running-tests* 0) -;; (define *runs:can-run-more-tests-count* 0) -(define (runs:shrink-can-run-more-tests-count runsdat) - (runs:dat-can-run-more-tests-count-set! runsdat 0)) - -(define (runs:inc-can-run-more-tests-count runsdat) - (runs:dat-can-run-more-tests-count-set! - runsdat - (+ (runs:dat-can-run-more-tests-count runsdat) 1))) - -;; (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2))) - -;; Temporary globals. Move these into the logic or into common -;; -(define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run -(define (runs:inc-cant-run-tests testname) - (hash-table-set! *seen-cant-run-tests* testname - (+ (hash-table-ref/default *seen-cant-run-tests* testname 0) 1))) - -(define (runs:can-keep-running? testname n) - (< (hash-table-ref/default *seen-cant-run-tests* testname 0) n)) - -(define *runs:denoise* (make-hash-table)) ;; key => last-time-ran - -;; mechanism to limit printing info to the screen that is repetitive. -;; -;; Example: -;; (if (runs:lownoise "waiting on tasks" 60) -;; (debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ...")) -;; -(define (runs:lownoise key waitval) - (let ((lasttime (hash-table-ref/default *runs:denoise* key 0)) - (currtime (current-seconds))) - (if (> (- currtime lasttime) waitval) - (begin - (hash-table-set! *runs:denoise* key currtime) - #t) - #f))) - -(define *last-test-launch* 0) -(define *too-soon-delays* (make-hash-table)) - -;; to-soon delay, when matching event happened in less than dseconds delay wseconds -;; -(define (runs:too-soon-delay key dseconds wseconds) - (let* ((last-time (hash-table-ref/default *too-soon-delays* key #f))) - (if (and last-time - (< (- (current-seconds) last-time) dseconds)) - (begin - (if (runs:lownoise (conc "too-soon-delay"key) 60) - (debug:print-info 2 *default-log-port* "Polling throttle for "key)) - (thread-sleep! wseconds))) - (hash-table-set! *too-soon-delays* key (current-seconds)))) - -(define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) - - ;; Take advantage of a good place to exit if running the one-pass methodology - (if (and (> (runs:dat-can-run-more-tests-count runsdat) 20) - (args:get-arg "-one-pass")) - (exit 0)) - - (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) - - (let* ((num-running (rmt:get-count-tests-running-for-run-id run-id)) - (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) - (job-group-limit (let ((jobg-count (configf:lookup *configdat* "jobgroups" jobgroup))) - (if (string? jobg-count) - (string->number jobg-count) - jobg-count)))) - (if (> (+ num-running num-running-in-jobgroup) 0) - (runs:inc-can-run-more-tests-count runsdat)) ;; (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) - (if (not (eq? *last-num-running-tests* num-running)) - (begin - (debug:print 2 *default-log-port* "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) - (set! *last-num-running-tests* num-running))) - (if (not (eq? 0 *globalexitstatus*)) - (list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit) - (let* ((can-not-run-more (cond - ;; if max-concurrent-jobs is set and the number running is greater - ;; than it then cannot run more jobs - ((and max-concurrent-jobs (>= num-running max-concurrent-jobs)) - (if (runs:lownoise "mcj msg" 60) - (debug:print 0 *default-log-port* "WARNING: Max running jobs exceeded, current number running: " num-running - ", max_concurrent_jobs: " max-concurrent-jobs)) - #t) - ;; if job-group-limit is set and number of jobs in the group is greater - ;; than the limit then cannot run more jobs of this kind - ((and job-group-limit - (>= num-running-in-jobgroup job-group-limit)) - (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60) - (debug:print 1 *default-log-port* "WARNING: number of jobs " num-running-in-jobgroup - " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) - #t) - (else #f)))) - (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) - -(define (runs:run-pre-hook run-id) - (let* ((run-pre-hook (configf:lookup *configdat* "runs" "pre-hook")) - (existing-tests (if run-pre-hook - (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses - #f #f ;; offset limit - #f ;; not-in - #f ;; sort-by - #f ;; sort-order - #f ;; get full data (not 'shortlist) - 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time - 'dashboard) - '())) - (log-dir (conc *toppath* "/logs")) - (log-file (conc "pre-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log")) - (full-log-fname (conc log-dir "/" log-file))) - (if run-pre-hook - (if (null? existing-tests) - (let* ((use-log-dir (if (not (directory-exists? log-dir)) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir ", exn=" exn) - #f) - (create-directory log-dir #t) - #t) - #t)) - (start-time (current-seconds)) - (actual-logf (if use-log-dir full-log-fname log-file))) - (handle-exceptions - exn - (begin - (print-call-chain *default-log-port*) - (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - (debug:print 0 *default-log-port* "ERROR: failed to run pre-hook " run-pre-hook ", check the log " log-file)) - (debug:print-info 0 *default-log-port* "running run-pre-hook: \"" run-pre-hook "\", log is " actual-logf) - (system (conc run-pre-hook " >> " actual-logf " 2>&1")) - (debug:print-info 0 *default-log-port* "pre-hook \"" run-pre-hook "\" took " (- (current-seconds) start-time) " seconds to run."))) - (debug:print 0 *default-log-port* "Skipping pre-hook call \"" run-pre-hook "\" as there are existing tests for this run."))))) - - - -(define (runs:run-post-hook run-id) - (let* ((run-post-hook (configf:lookup *configdat* "runs" "post-hook")) - (existing-tests (if run-post-hook - (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses - #f #f ;; offset limit - #f ;; not-in - #f ;; sort-by - #f ;; sort-order - #f ;; get full data (not 'shortlist) - 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time - 'dashboard) - '())) - (log-dir (conc *toppath* "/logs")) - (log-file (conc "post-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log")) - (full-log-fname (conc log-dir "/" log-file))) - (if run-post-hook - ;; (if (null? existing-tests) - ;; (debug:print 0 *default-log-port* "Skipping post-hook call \"" run-post-hook "\" as there are existing tests for this run."))))) - (let* ((use-log-dir (if (not (directory-exists? log-dir)) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir ", exn=" exn) - #f) - (create-directory log-dir #t) - #t) - #t)) - (start-time (current-seconds)) - (actual-logf (if use-log-dir full-log-fname log-file))) - (handle-exceptions - exn - (begin - (print-call-chain *default-log-port*) - (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - (debug:print 0 *default-log-port* "ERROR: failed to run post-hook " run-post-hook ", check the log " log-file)) - (debug:print-info 0 *default-log-port* "running run-post-hook: \"" run-post-hook "\", log is " actual-logf) - (system (conc run-post-hook " >> " actual-logf " 2>&1")) - (debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))))) - - -(define (runs:rerun-hook test-id new-test-path testdat rerunlst) - (let* ((rerun-hook (configf:lookup *configdat* "runs" "rerun-hook")) - (log-dir (conc *toppath* "/reruns/logs")) - (target (getenv "MT_TARGET")) - (runname (common:args-get-runname)) - (rundir (db:test-get-rundir testdat)) - (tarfiledir (conc *toppath* "/reruns")) - (status (db:test-get-status testdat)) - (comment (conc "\"" (db:test-get-comment testdat) "\"" )) - (testname (db:test-get-testname testdat)) - (itempath (db:test-get-item-path testdat)) - (file-body (conc status "-" (string-translate target "/" "-") "-" runname "." testname (if (not (string=? itempath "")) (conc "." (string-translate itempath "/" "-")) ""))) - (log-file (conc file-body ".log")) - ;; (log-file (conc status "-" (string-translate target "/" "-") "-" runname "." testname (if (not (string=? itempath "")) (conc "." (string-translate itempath "/" "-")) "") ".log")) - (full-log-fname (conc log-dir "/" log-file)) - (tarfilename (conc file-body ".tar")) - ;; (tarfilename (conc status "." (string-translate target "/" "-") "." runname "." testname (if (not (string=? itempath "")) (conc "." (string-translate itempath "/" "-")) "") ".tar")) - ) - (if rerun-hook - (let* ((use-log-dir (if (not (directory-exists? log-dir)) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir ", exn=" exn) - #f) - (create-directory log-dir #t) - #t) - #t)) - (start-time (current-seconds)) - (actual-logf (if use-log-dir full-log-fname log-file)) - (sys-call-text (conc rerun-hook " " tarfilename " " rundir " " actual-logf " " runname " " tarfiledir " " status " " target " " comment " " testname " " itempath " >> " actual-logf " 2>&1")) - ) - (debug:print 2 *default-log-port* "Found rerun-hook in config:" rerun-hook) - (handle-exceptions - exn - (begin - (print-call-chain *default-log-port*) - (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - (debug:print 0 *default-log-port* "ERROR: failed to run rerun-hook " rerun-hook ", check the log " log-file)) - (debug:print-info 0 *default-log-port* "running rerun-hook: \"" rerun-hook "\", log is " actual-logf) - ;; call the hook - (debug:print-info 0 *default-log-port* "Calling rerun-hook for " test-id new-test-path testdat rerunlst) - (debug:print-info 0 *default-log-port* "rerun hook: " rerun-hook) - (debug:print-info 0 *default-log-port* "tarfilename: " tarfilename) - (debug:print-info 0 *default-log-port* "rundir: " rundir) - (debug:print-info 0 *default-log-port* "actual-logf: " actual-logf) - (debug:print-info 0 *default-log-port* "runname: " runname) - (debug:print-info 0 *default-log-port* "sys-call-text: " sys-call-text) - (system sys-call-text) - (debug:print-info 0 *default-log-port* "rerun-hook \"" rerun-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))))) - - - - -;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise. -(define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon) - (null? (tests:filter-test-names-not-matched waitors-upon test-patt))) - -;;====================================================================== -;; runs:run-tests is called from megatest.scm and itself -;;====================================================================== -;; -;; test-names: Comma separated patterns same as test-patts but used in selection -;; of tests to run. The item portions are not respected. -;; FIXME: error out if /patt specified -;; -;; run-count is passed from megatest.scm as configf:lookup *configdat* "setup" "reruns", or defaults to 1. -(define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names - (let* ((keys (keys:config-get-fields *configdat*)) - (keyvals (keys:target->keyval keys target)) - (run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name))) - ;; (deferred '()) ;; delay running these since they have a waiton clause - (runconfigf (conc *toppath* "/runconfigs.config")) - (mtconfig (conc *toppath* "/megatest.config")) - (readonly-mode (not (file-write-access? mtconfig))) - (test-records (make-hash-table)) - ;; need to process runconfigs before generating these lists - (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names - (all-test-names #f) ;; (hash-table-keys all-tests-registry)) - (test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts)) - (required-tests #f) ;; Put fully qualified test/testpath names in this list to be done - (waitors-upon (make-hash-table)) ;; given a test, return list of tests waiting upon this test. - (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) - ;; (tdbdat (tasks:open-db)) - (config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) - (if x (string->number x) #f))) - (allowed-tests #f) - (runconf #f)) - - ;; check if readonly - (when readonly-mode - (debug:print-error 0 *default-log-port* "Megatest database is readonly. Cannot proceed.") - (exit 1)) - - ;; per user request. If less than 100Meg space on dbdir partition, bail out with error - ;; this will reduce issues in database corruption - (common:check-db-dir-and-exit-if-insufficient) - - ;; override the number of reruns from the configs - ;; this needs to be done at the place where is first runs:run-tests called - ;(if (and config-reruns - ; (> run-count config-reruns)) - ;(set! run-count config-reruns)) - - ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) - - (let ((sighand (lambda (signum) - ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting - (set! *time-to-exit* #t) - (debug:print 0 *default-log-port* "Received signal " signum ", cleaning up before exit. Please wait...") - (let ((th1 (make-thread (lambda () - ;; (let ((tdbdat (tasks:open-db))) - (rmt:tasks-set-state-given-param-key task-key "killed") ;; ) - (debug:print 0 *default-log-port* "Killed by signal " signum ". Exiting") - (thread-sleep! 3) - (exit)))) - (th2 (make-thread (lambda () - (thread-sleep! 5) - (debug:print 0 *default-log-port* "Done") - (exit 4))))) - (thread-start! th2) - (thread-start! th1) - (thread-join! th2))))) - (set-signal-handler! signal/int sighand) - (set-signal-handler! signal/term sighand)) - - ;; force the starting of a server -- removed BB 17ww28 - no longer needed. - ;;(debug:print 0 *default-log-port* "waiting on server...") - ;;(server:start-and-wait *toppath*) - - (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process - (set! runconf (if (common:file-exists? runconfigf) - (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) - (begin - (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf) - #f))) - - (if (not test-patts) ;; first time in - adjust testpatt - (set! test-patts (common:args-get-testpatt runconf))) - ;; if test-patts is #f at this point there is something wrong and we need to bail out - (if (not test-patts) - (begin - (debug:print 0 *default-log-port* "WARNING: there is no test pattern for this run. Exiting now.") - (exit 0))) - - (if (args:get-arg "-tagexpr") - (begin - (set! allowed-tests (string-join (runs:get-tests-matching-tags (args:get-arg "-tagexpr")) ",")) - (debug:print-info 0 *default-log-port* "filtering initial test list with tagexpr: " (args:get-arg "-tagexpr") " => " allowed-tests) - ));; tests will be ANDed with this list - - ;; register this run in monitor.db - (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params) - (rmt:tasks-set-state-given-param-key task-key "running") - - #;(common:telemetry-log "run-tests" - payload: - `( (target . ,target) - (run-name . ,runname) - (test-patts . ,test-patts) ) ) - - - ;; Now generate all the tests lists - (set! all-tests-registry (tests:get-all)) ;; hash of testname => path-to-test - (set! all-test-names (hash-table-keys all-tests-registry)) - ;; filter first for allowed-tests (from -tagexpr) then for test-patts. - (set! test-names (tests:filter-test-names - (if allowed-tests - (tests:filter-test-names all-test-names allowed-tests) - all-test-names) - test-patts)) - - ;; I think seeding required-tests with all test-names makes sense but lack analysis to back that up. - - ;; NEW STRATEGY HERE: - ;; 1. fill required tests with test-patts - ;; 2. scan testconfigs and if waitons, itemwait, itempatt calc prior test test-patt - ;; 3. repeat until all deps propagated - - ;; any tests with direct mention in test-patts can be added to required - ;;(set! required-tests (lset-intersection equal? (string-split test-patts ",") all-test-names)) - (set! required-tests (tests:filter-test-names all-test-names test-patts)) - ;; - ;; (set! required-tests (lset-intersection equal? test-names all-test-names)) - - ;; look up all tests matching the comma separated list of globs in - ;; test-patts (using % as wildcard) - - ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) - (debug:print-info 0 *default-log-port* "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " ")) - (debug:print-info 2 *default-log-port* "all tests: " (string-intersperse (sort all-test-names string<) " ")) - (debug:print-info 0 *default-log-port* "test names: " (string-intersperse (sort test-names string<) " ")) - (debug:print-info 0 *default-log-port* "required tests: " (string-intersperse (sort required-tests string<) " ")) - - ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if - ;; -keepgoing is specified - (if (eq? *passnum* 0) - (begin - ;; Is this still necessary? I think not. Unreachable tests are marked as such and - ;; should not cause problems here. - ;; - ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to - ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends - ;; on test A but test B reached the point on being registered as NOT_STARTED and test - ;; A failed for some reason then on re-run using -keepgoing the run can never complete. - ;; - ;; (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED") - - ;; Now convert anything in allow-auto-rerun to NOT_STARTED - ;; - (for-each - (lambda (state-status) - (let* ((ss-lst (string-split-fields "/" state-status #:infix)) - (state (if (> (length ss-lst) 0)(car ss-lst) #f)) - (status (if (> (length ss-lst) 1)(cadr ss-lst) #f))) - (rmt:set-tests-state-status run-id test-names state status "NOT_STARTED" status))) - ;; list of state/status pairs separated by spaces - (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") ""))))) - - ;; Ensure all tests are registered in the test_meta table - (runs:update-all-test_meta #f) - - ;; run the run prehook if there are no tests yet run for this run: - ;; - (runs:run-pre-hook run-id) - ;; mark all test launched flag as false in the meta table - (rmt:set-var (conc "lunch-complete-" run-id) "no") - (debug:print-info 1 *default-log-port* "Setting end-of-run to no") - (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) - (if x (string->number x) #f))) - (config-rerun-cnt (if config-reruns - config-reruns - 1))) - (if (eq? config-rerun-cnt run-count) - (rmt:set-var (conc "end-of-run-" run-id) "no"))) - - (rmt:set-run-state-status run-id "new" "n/a") - ;; now add non-directly referenced dependencies (i.e. waiton) - ;;====================================================================== - ;; refactoring this block into tests:get-full-data - ;; - ;; What happended, this code is now duplicated in tests!? - ;; - ;;====================================================================== - - (if (not (null? test-names)) ;; BEGIN test-names loop - (let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names - (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc - (debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names) - (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. - (setenv "MT_TEST_NAME" hed) ;; - (let*-values (((waitons waitors config) (tests:get-waitons hed all-tests-registry (tests:get-global-waitons *runconfigdat*))) - - ;; NOTE: Have the config - can extract [waitons] section - - ((hed-mode) - (let ((m (configf:lookup config "requirements" "mode"))) - (if m (map string->symbol (string-split m)) '(normal)))) - ((hed-itemized-waiton) ;; are items in hed waiting on items of waiton? - (not (null? (lset-intersection eq? hed-mode '(itemmatch itemwait))))) - ) - (debug:print-info 8 *default-log-port* "waitons: " waitons) - ;; check for hed in waitons => this would be circular, remove it and issue an - ;; error - (if (or (member hed waitons) - (member hed waitors)) - (begin - (debug:print-error 0 *default-log-port* "test " hed " has listed itself as a waiton or waitor, please correct this!") - (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)) - (set! waitors (filter (lambda (x)(not (equal? x hed))) waitors)))) - - ;; (items (items:get-items-from-config config))) - (if (not (hash-table-ref/default test-records hed #f)) ;; waiton-tconfig below will be #f until that test is visted here at least once - (hash-table-set! test-records ;; BB: we are doing a manual make-tests:testqueue - hed (vector hed ;; 0 ;; testname - config ;; 1 - waitons ;; 2 - (configf:lookup config "requirements" "priority") ;; priority 3 - (tests:get-items config) ;; 4 ;; expand the [items] and or [itemstable] into explict items - #f ;; itemsdat 5 - #f ;; spare - used for item-path - waitors ;; - ))) - ;; update waitors-upon here - (for-each - (lambda (waiton) - (let* ((current-waitors-upon (hash-table-ref/default waitors-upon waiton '()))) - (debug:print-info 8 *default-log-port* " current-waiters-upon["waiton"] is "current-waitors-upon ) - (when (not (member hed current-waitors-upon)) - (debug:print-info 8 *default-log-port* " current-waiters-upon["waiton"] << "hed ) - (hash-table-set! waitors-upon waiton (cons hed current-waitors-upon))))) - (if (list? waitons) waitons '())) - (debug:print-info 8 *default-log-port* " process waitons&waitors of "hed": "(delete-duplicates (append waitons waitors))) - (for-each - (lambda (waiton) - (if (and waiton (not (member waiton test-names))) - (let* ((waitors-in-testpatt (runs:testpatts-mention-waitors-upon? test-patts (hash-table-ref/default waitors-upon waiton '()))) - (waiton-record (hash-table-ref/default test-records waiton #f)) - (waiton-tconfig (if waiton-record (vector-ref waiton-record 1) #f)) - (waiton-itemized (and waiton-tconfig - (or (hash-table-ref/default waiton-tconfig "items" #f) - (hash-table-ref/default waiton-tconfig "itemstable" #f)))) - (itemmaps (tests:get-itemmaps config)) ;; (configf:lookup config "requirements" "itemmap")) - (new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps hed-itemized-waiton))) - (debug:print-info 2 *default-log-port* "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items") - ;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%" - ;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt - ;; is this satisfied by merely appending "/" to the waiton name added to the list? - ;; - ;; This approach causes all of the items in an upstream test to be run - ;; if we have this waiton already processed once we can analzye it for extending - ;; tests to be run, since we can't properly process waitons unless they have been - ;; initially added we add them again to be processed on second round AND add the hed - ;; back in to also be processed on second round - (if waiton-tconfig ;; BB: waiter should be in test-patts as well as the waiton have a tconfig. - (if waiton-itemized - (if waitors-in-testpatt - (begin - (debug:print-info 0 *default-log-port* "New test patts: " new-test-patts ", prev test patts: " test-patts) - (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read - (set! required-tests (cons (conc waiton "/") required-tests)) - (set! test-patts new-test-patts)) - (begin - (debug:print-info 0 *default-log-port* "Waitor(s) not yet on testpatt for " waiton ", setting up to re-process it") - (set! tal (append (cons waiton tal)(list hed))))) - (begin - (debug:print-info 2 *default-log-port* "Adding non-itemized test " waiton " to required-tests") - (set! required-tests (cons waiton required-tests)) - (set! test-patts new-test-patts))) - (begin - (debug:print-info 0 *default-log-port* "No testconfig info yet for " waiton ", setting up to re-process it") - (set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests)) - ;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts - ;; - doesn't work - ;; (set! test-patts (conc test-patts "," waiton "/")) - ;; (set! test-names (cons waiton test-names))))) ;; was an append, now a cons - ))) - (delete-duplicates (append waitons waitors))) - (let ((remtests (delete-duplicates (append waitons tal)))) - (debug:print-info 8 *default-log-port* " remtests are "remtests) - (if (not (null? remtests)) - (begin - ;; (debug:print-info 0 *default-log-port* "Preprocessing continues for " (string-intersperse remtests ", ")) - (loop (car remtests)(cdr remtests)))))))) ;; END test-names loop - - (if (not (null? required-tests)) - (debug:print-info 1 *default-log-port* "Adding \"" (string-intersperse required-tests " ") "\" to the run queue")) - ;; NOTE: these are all parent tests, items are not expanded yet. - (debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records)) - (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) - (if (> (length (hash-table-keys test-records)) 0) - (let* ((keep-going #t) - (run-queue-retries 5) - (run-ids (rmt:get-all-run-ids))) - #;(for-each (lambda (run-id) - (if keep-going - (handle-exceptions - exn - (debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id ", exn=" exn) - (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime))) ;; could be root of https://hsdes.intel.com/appstore/article/#/220546828/main -- Title: Megatest jobs show DEAD even though they are still running (1.64/27) - run-ids) - (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests - (any->number reglen) all-tests-registry) - (set! keep-going #f) - (if (> run-count 0) ;; handle reruns - (begin - (if (not (hash-table-ref/default flags "-preclean" #f)) - (hash-table-set! flags "-preclean" #t)) - (if (not (hash-table-ref/default flags "-rerun" #f)) - (hash-table-set! flags "-rerun" "ABORT,STUCK/DEAD,n/a,ZERO_ITEMS")) - (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))) - (launch:end-of-run-check run-id))) - (debug:print-info 0 *default-log-port* "No tests to run"))) - (debug:print-info 4 *default-log-port* "All done by here") - ;; TODO: try putting post hook call here - - ; (debug:print-info 2 *default-log-port* " run-count " run-count) - ; (runs:run-post-hook run-id)) - ; (debug:print-info 2 *default-log-port* "Not calling post hook runcount = " run-count )) - (rmt:tasks-set-state-given-param-key task-key "done") - - ;; (sqlite3:finalize! tasks-db) - )) - - -;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable. -;; -;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns -;; If reg is full (i.e. length >= n -;; loop with (car reg) tal (cdr reg) reruns -;; If tal is empty -;; but have items in reg; loop with (car reg)(cdr reg) '() reruns -;; If reg is empty => all done - -(define (runs:queue-next-hed tal reg n regfull) - (if regfull - (if (null? reg) #f (car reg)) - (if (null? tal) ;; tal is used up, pop from reg - (if (null? reg) #f (car reg)) - (car tal)))) - -(define (runs:queue-next-tal tal reg n regfull) - (if regfull - tal - (if (null? tal) ;; must transfer from reg - (if (null? reg) '() (cdr reg)) - (cdr tal)))) - -(define (runs:queue-next-reg tal reg n regfull) - (if regfull - (if (null? reg) '() (cdr reg)) ;; EXPLORE: reorder (cdr reg) such that looping is more efficient - (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal - '() - reg))) - -;; this is the list of parameters to the named loop "loop" near the top of runs:run-tests-queue, look around line 1216 -;; -(define (runs:loop-values tal reg reglen regfull reruns) - (list (runs:queue-next-hed tal reg reglen regfull) ;; hed - (runs:queue-next-tal tal reg reglen regfull) ;; tal - (runs:queue-next-reg tal reg reglen regfull) ;; reg - reruns)) ;; reruns - -;; objective - iterate thru tests -;; => want to prioritize tests we haven't seen before -;; => sometimes need to squeeze things in (added to reg) -;; => review of a previously seen test is higher priority of never visited test -;; reg - list of previously visited tests -;; tal - list of never visited tests -;; prefer next hed to be from reg than tal. - -(define runs:nothing-left-in-queue-count 0) - -;;====================================================================== -;; runs:expand-items is called by runs:run-tests-queue -;;====================================================================== -;; -;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature: -;; (let loop ((hed (car sorted-test-names)) -;; (tal (cdr sorted-test-names)) -;; (reg '()) ;; registered, put these at the head of tal -;; (reruns '())) -(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps) - (let* ((loop-list (list hed tal reg reruns)) - (junk (debug:print-info 4 *default-log-port* "expand-items calling rmt:get-prereqs-not-met")) - (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))) - (if (list? res) - res - (begin - (debug:print 0 *default-log-port* - "ERROR: rmt:get-prereqs-not-met returned non-list!\n" - " res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps) - '())))) - (have-itemized (not (null? (lset-intersection eq? testmode '(itemmatch itemwait))))) - ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) - (fails (runs:calc-fails prereqs-not-met)) - (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met)) - (runnables (runs:calc-runnable prereqs-not-met)) - (unexpanded-prereqs - (filter (lambda (testname) - (let* ((test-rec (hash-table-ref test-records testname)) - (items (tests:testqueue-get-items test-rec))) - ;;(BB> "HEY " testname "=>"items) - (or (procedure? items)(eq? items 'have-procedure)))) - waitons)) - - - ) - (debug:print-info 4 *default-log-port* "START OF INNER COND #2 " - "\n can-run-more: " can-run-more - "\n testname: " hed - "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) - "\n non-completed: " (runs:pretty-string non-completed) - "\n prereq-fails: " (runs:pretty-string prereq-fails) - "\n fails: " (runs:pretty-string fails) - "\n testmode: " testmode - "\n (member 'toplevel testmode): " (member 'toplevel testmode) - "\n (null? non-completed): " (null? non-completed) - "\n reruns: " reruns - "\n items: " items - "\n can-run-more: " can-run-more) - - (cond - ;; all prereqs met, fire off the test - ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch - - ((and (not (member 'toplevel testmode)) - (member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a) - '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here - (debug:print-info 4 *default-log-port* "cond branch - " "ei-1") - (debug:print-info 1 *default-log-port* "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue") - (if (or (not (null? tal)) - (not (null? reg))) - (runs:loop-values tal reg reglen regfull reruns) - (begin - (debug:print-info 0 *default-log-port* "Nothing left in the queue!") - ;; If get here twice then we know we've tried to expand all items - ;; since there must be a logic issue with the handling of loops in the - ;; items expand phase we will brute force an exit here. - (if (> runs:nothing-left-in-queue-count 2) - (begin - (debug:print 0 *default-log-port* "WARNING: this condition is triggered when there were no items to expand and nothing to run. Please check your run for completeness") - (exit 0)) - (set! runs:nothing-left-in-queue-count (+ runs:nothing-left-in-queue-count 1))) - #f))) - - ;; desired result of below cond branch: - ;; we want to expand items in our test of interest (hed) in the following cases: - ;; case 1 - mode is itemmatch or itemwait: - ;; - all prereq tests have been expanded - ;; - at least one prereq's items have completed - ;; case 2 - mode is toplevel - ;; - prereqs are completed. - ;; - or no prereqs can complete - ;; case 3 - mode not specified - ;; - prereqs are completed and passed (we could consider removing "and passed" -- it would change behavior from current) - ((or (null? prereqs-not-met) - (and (member 'toplevel testmode) - (null? non-completed))) - (debug:print-info 4 *default-log-port* "cond branch - " "ei-2") - (debug:print-info 4 *default-log-port* "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))") - (let ((test-name (tests:testqueue-get-testname test-record))) - (setenv "MT_TEST_NAME" test-name) ;; - (setenv "MT_RUNNAME" runname) - (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process - (let ((items-list (items:get-items-from-config tconfig))) - (if (list? items-list) - (begin - (if (null? items-list) - (let ((test-id (rmt:get-test-id run-id test-name "")) - (num-items (rmt:test-toplevel-num-items run-id test-name))) - (if (and test-id - (not (> num-items 0))) - (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites")))) - (tests:testqueue-set-items! test-record items-list) - (list hed tal reg reruns)) - (begin - (debug:print-error 0 *default-log-port* "The proc from reading the items table did not yield a list - please report this") - (exit 1)))))) - - ((and (null? fails) - (null? prereq-fails) - (not (null? non-completed))) - (debug:print-info 4 *default-log-port* "cond branch - " "ei-3") - (let* ((allinqueue (map (lambda (x)(if (string? x) x (db:test-get-testname x))) - (append newtal reruns))) - ;; prereqstrs is a list of test names as strings that are prereqs for hed - (prereqstrs (delete-duplicates (map (lambda (x)(if (string? x) x (db:test-get-testname x))) - prereqs-not-met))) - ;; a prereq that is not found in allinqueue will be put in the notinqueue list - ;; - ;; (notinqueue (filter (lambda (x) - ;; (not (member x allinqueue))) - ;; prereqstrs)) - (give-up #f)) - - ;; We can get here when a prereq has not been run due to *it* having a prereq that failed. - ;; We need to use this to dequeue this item as CANNOTRUN - ;; - (if (member 'toplevel testmode) ;; '(toplevel)) ;; NOTE: this probably should be (member 'toplevel testmode) - (for-each (lambda (prereq) - (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN) - (set! give-up #t))) - prereqstrs)) - - (if (and give-up - (not (and (null? tal)(null? reg)))) - (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) - (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) - (debug:print 1 *default-log-port* "WARNING: test " hed " has discarded prerequisites, removing it from the queue") - - (let ((test-id (rmt:get-test-id run-id hed ""))) - (if test-id (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites"))) - - (if (and (null? trimmed-tal) - (null? trimmed-reg)) - #f - (runs:loop-values trimmed-tal trimmed-reg reglen regfull reruns) - )) - (list (car newtal)(append (cdr newtal) reg) '() reruns)))) - - ((and (null? fails) ;; have not-started tests, but unable to run them. everything looks completed with no prospect of unsticking something that is stuck. we should mark hed as moribund and exit or continue if there are more tests to consider - (null? prereq-fails) - (null? non-completed)) - (debug:print-info 4 *default-log-port* "cond branch - " "ei-4") - (if (runs:can-keep-running? hed 20) - (begin - (runs:inc-cant-run-tests hed) - (debug:print-info 0 *default-log-port* "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0) ", going to wait 60 sec.") ;; - ;; getting here likely means the system is way overloaded, kill a full minute before continuing - ;; (thread-sleep! 60) ;; TODO: gate by normalized server load > 1.0 (maxload config thing) CHECKTHIS!!! - ;; No runsdat, can't do this yet - ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) - ;; - (thread-sleep! 5) ;; TODO: gate by normalized server load > 1.0 (maxload config thing) - ;; num-retries code was here - ;; we use this opportunity to move contents of reg to tal - (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met? - (begin - (debug:print-info 1 *default-log-port* "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue") - (let ((test-id (rmt:get-test-id run-id hed ""))) - (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while."))) - (runs:loop-values tal reg reglen regfull reruns) - ))) - - ((and - (or (not (null? fails)) - (not (null? prereq-fails))) - (member 'normal testmode)) - (debug:print-info 4 *default-log-port* "cond branch - " "ei-5") - (debug:print-info 1 *default-log-port* "test " hed " (mode=" testmode ") has failed prerequisite(s); " - (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") - ", removing it from to-do list") - (let ((test-id (rmt:get-test-id run-id hed ""))) - (if test-id - (if (not (null? prereq-fails)) - (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites") - (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) - ;; (debug:print 4 *default-log-port*"BB> set PREQ_FAIL on "hed) - ;; (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) ;; BB: this works, btu equivalent for itemwait mode does not work. - (if (or (not (null? reg))(not (null? tal))) - (begin - (hash-table-set! test-registry hed 'CANNOTRUN) - (runs:loop-values tal reg reglen regfull (cons hed reruns)) - ) - #f)) ;; #f flags do not loop - - ((and (not (null? fails))(member 'toplevel testmode)) - (debug:print-info 4 *default-log-port* "cond branch - " "ei-6") - (if (or (not (null? reg))(not (null? tal))) - (list (car newtal)(append (cdr newtal) reg) '() reruns) - #f)) - ((null? runnables) - (debug:print-info 4 *default-log-port* "cond branch - " "ei-7") - #f) ;; if we get here and non-completed is null then it is all over. - (else - (debug:print-info 4 *default-log-port* "cond branch - " "ei-8") - (debug:print 2 *default-log-port* "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now") - (list (car newtal)(cdr newtal) reg reruns))))) - -(define (runs:mixed-list-testname-and-testrec->list-of-strings inlst) - (if (null? inlst) - '() - (map (lambda (t) - (cond - ((vector? t) - (let ((test-name (db:test-get-testname t)) - (item-path (db:test-get-item-path t)) - (test-state (db:test-get-state t)) - (test-status (db:test-get-status t))) - (conc test-name (if (equal? item-path "") "" "/") item-path ":" test-state "/" test-status))) - ((string? t) - t) - (else - (conc t)))) - inlst))) - - -;; hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps) -(define (runs:process-expanded-tests runsdat testdat) - ;; unroll the contents of runsdat and testdat (due to ongoing refactoring). - (debug:print 2 *default-log-port* "runs:process-expanded-tests; testdat:" ) - (debug:print 2 *default-log-port* (with-output-to-string - (lambda () (pp (runs:testdat->alist testdat) )))) - (let* ((hed (runs:testdat-hed testdat)) - (tal (runs:testdat-tal testdat)) - (reg (runs:testdat-reg testdat)) - (reruns (runs:testdat-reruns testdat)) - (test-name (runs:testdat-test-name testdat)) - (item-path (runs:testdat-item-path testdat)) - (jobgroup (runs:testdat-jobgroup testdat)) - (waitons (runs:testdat-waitons testdat)) - (item-path (runs:testdat-item-path testdat)) - (testmode (runs:testdat-testmode testdat)) - (newtal (runs:testdat-newtal testdat)) - (itemmaps (runs:testdat-itemmaps testdat)) - (test-record (runs:testdat-test-record testdat)) - (prereqs-not-met (runs:testdat-prereqs-not-met testdat)) - - (reglen (runs:dat-reglen runsdat)) - (regfull (runs:dat-regfull runsdat)) - (runname (runs:dat-runname runsdat)) - (max-concurrent-jobs (runs:dat-max-concurrent-jobs runsdat)) - (run-id (runs:dat-run-id runsdat)) - (test-patts (runs:dat-test-patts runsdat)) - (required-tests (runs:dat-required-tests runsdat)) - (test-registry (runs:dat-test-registry runsdat)) - (registry-mutex (runs:dat-registry-mutex runsdat)) - (flags (runs:dat-flags runsdat)) - (keyvals (runs:dat-keyvals runsdat)) - (run-info (runs:dat-run-info runsdat)) - (all-tests-registry (runs:dat-all-tests-registry runsdat)) - (run-limits-info (runs:dat-can-run-more-tests runsdat)) - ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running - (have-resources (car run-limits-info)) - (num-running (list-ref run-limits-info 1)) - (num-running-in-jobgroup(list-ref run-limits-info 2)) - (max-concurrent-jobs (list-ref run-limits-info 3)) - (job-group-limit (list-ref run-limits-info 4)) - ;; (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) - ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) - (fails (if (list? prereqs-not-met) ;; TODO: rename fails to failed-prereqs - (runs:calc-fails prereqs-not-met) - (begin - (debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met) - '()))) - (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! - (not (equal? x hed))) - (runs:calc-not-completed prereqs-not-met))) - (loop-list (list hed tal reg reruns)) - ;; configure the load runner - (maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3.0"))) ;; use a non-number string to disable - (maxhomehostload (string->number (or (configf:lookup *configdat* "jobtools" "maxhomehostload") "2.0"))) ;; use a non-number string to disable - (waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60")))) - (debug:print-info 4 *default-log-port* "have-resources: " have-resources " prereqs-not-met: (" - (string-intersperse - (map (lambda (t) - (if (vector? t) - (conc (db:test-get-state t) "/" (db:test-get-status t)) - (conc " WARNING: t is not a vector=" t ))) - prereqs-not-met) - ", ") ") fails: " fails - "\nregistered? " (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) - - ;; well, first lets see if cpu load throttling is enabled. If so wait around until the - ;; average cpu load is under the threshold before continuing - ;; - (if (runs:dat-load-mgmt-function runsdat) - ((runs:dat-load-mgmt-function runsdat)) - (runs:dat-load-mgmt-function-set! - runsdat - (lambda () - ;; jobtools maxload is useful for where the full Megatest run is done on one machine - (if (and (not (rmt:on-homehost?)) - maxload) ;; only gate if maxload is specified, NOTE: maxload is normalized, i.e. load=1 means all cpus fully utilized - (common:wait-for-normalized-load maxload "Waiting for load to drop before starting more tests" #f)) - - ;; jobtools maxhomehostload is intended to prevent overloading on the homehost which can cause database corruption issues - (if maxhomehostload - (common:wait-for-homehost-load maxhomehostload - (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload)))))) - - - - (if (and (not (null? prereqs-not-met)) - (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) - (debug:print-info 2 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) - - ;; Don't know at this time if the test have been launched at some time in the past - ;; i.e. is this a re-launch? - (debug:print-info 4 *default-log-port* "run-limits-info = " run-limits-info) - - (cond ; cond 894- 1067 - - ;; Check item path against item-patts, - ;; - ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run - ;; else the run is stuck, temporarily or permanently - ;; but should check if it is due to lack of resources vs. prerequisites - (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) - (if (or (not (null? tal))(not (null? reg))) - (runs:loop-values tal reg reglen regfull reruns) - #f)) - - ;; Register tests - ;; - ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) - (debug:print-info 4 *default-log-port* "Pre-registering test " test-name "/" item-path " to create placeholder" ) - ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs - (let register-loop ((numtries 15)) - (rmt:register-test run-id test-name item-path) - (if (rmt:get-test-id run-id test-name item-path) - (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done) - (if (> numtries 0) - (begin - (thread-sleep! 0.5) - (register-loop (- numtries 1))) - (debug:print-error 0 *default-log-port* "failed to register test " (db:test-make-full-name test-name item-path))))) - (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done)) - (begin - (rmt:register-test run-id test-name "") - (if (rmt:get-test-id run-id test-name "") - (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) - (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) - (if (and (null? tal)(null? reg)) - (list hed tal (append reg (list hed)) reruns) - (list (runs:queue-next-hed tal reg reglen regfull) ;; cannot replace with a call to runs:loop-values as the logic is different for reg - (runs:queue-next-tal tal reg reglen regfull) - ;; NB// Here we are building reg as we register tests - ;; if regfull we must pop the front item off reg - (if regfull - (append (cdr reg) (list hed)) - (append reg (list hed))) - reruns))) - - ;; At this point hed test registration must be completed. - ;; - ((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f) - 'start) - (debug:print-info 0 *default-log-port* "Waiting on test registration(s): " - (string-intersperse - (filter (lambda (x) - (eq? (hash-table-ref/default test-registry x #f) 'start)) - (hash-table-keys test-registry)) - ", ")) - (thread-sleep! 0.051) - (list hed tal reg reruns)) - - ;; If no resources are available just kill time and loop again - ;; - ((not have-resources) ;; simply try again after waiting a second - (if (runs:lownoise "no resources" 600) - (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ...")) - - ;; Have gone back and forth on this but db starvation is an issue. - ;; wait one second before looking again to run jobs. - ;; (thread-sleep! 0.25) - - ;; new logic. - ;; If it has been more than 10 seconds since we were last here don't wait at all - ;; otherwise sleep 2 seconds to give db a rest and let dashboard read data - (if (runs:lownoise "frequent-no-resources" 10) - (thread-sleep! 0.25) ;; no significant delay - (thread-sleep! 2)) - ;; could have done hed tal here but doing car/cdr of newtal to rotate tests - (list (car newtal)(cdr newtal) reg reruns)) - - ;; This is the final stage, everything is in place so launch the test - ;; - ((and have-resources - (or (null? prereqs-not-met) - (and (member 'toplevel testmode) ;; 'toplevel) - (null? non-completed) - (not (member 'exclusive testmode))))) - ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path)) - ;; we are going to reset all the counters for test retries by setting a new hash table - ;; this means they will increment only when nothing can be run - (set! *max-tries-hash* (make-hash-table)) - - (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry runsdat testdat) - (set! *last-test-launch* (current-seconds)) - (runs:incremental-print-results run-id) - (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) - (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! *global-delta*) - (if (or (not (null? tal))(not (null? reg))) - (runs:loop-values tal reg reglen regfull reruns) ;; hed should be dropped at this time - #f)) - - ;; must be we have unmet prerequisites - ;; - (else - (debug:print 4 *default-log-port* "FAILS: " fails) - ;; If one or more of the prereqs-not-met are FAIL then we can issue - ;; a message and drop hed from the items to be processed. - ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) - (if (and (not (null? prereqs-not-met)) - (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) - (debug:print-info 1 *default-log-port* "waiting on tests; " (string-intersperse - (runs:mixed-list-testname-and-testrec->list-of-strings - prereqs-not-met) ", "))) - (if (or (null? fails) - (member 'toplevel testmode)) - (begin - ;; couldn't run, take a breather - (if (runs:lownoise "Waiting for more work to do..." 60) - (debug:print-info 0 *default-log-port* "Waiting for more work to do...")) - - ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) - (thread-sleep! 5) - (list (car newtal)(cdr newtal) reg reruns)) - ;; the waiton is FAIL so no point in trying to run hed ever again - (begin - (let ((my-test-id (rmt:get-test-id run-id test-name item-path))) - (mt:test-set-state-status-by-id-unless-completed run-id my-test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites2")) - (if (or (not (null? reg))(not (null? tal))) - (if (vector? hed) - (begin - (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path - " from the launch list as it has prerequistes that are FAIL") - (let ((test-id (rmt:get-test-id run-id hed ""))) - (if test-id (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) - (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! *global-delta*) - ;; This next is for the items - - (if (not (null? fails)) - ;;(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "PREQ_FAIL" #f) - (rmt:set-state-status-and-roll-up-items run-id test-name item-path "NOT_STARTED" "PREQ_FAIL" #f) - ;;(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) - (rmt:set-state-status-and-roll-up-items run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) ) - (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed) - (runs:loop-values tal reg reglen regfull reruns)) - (let ((nth-try (hash-table-ref/default test-registry hed 0))) ;; hed not a vector... - (debug:print 2 *default-log-port* "nth-try("hed")="nth-try) - (cond - ((member "RUNNING" (map db:test-get-state prereqs-not-met)) - (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60) - (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) - (thread-sleep! 0.1) - (runs:loop-values tal reg reglen regfull reruns)) - ((or (not nth-try) ;; BB: condition on subsequent tries, condition below fires on first try - (and (number? nth-try) - (< nth-try 2))) - (hash-table-set! test-registry hed (if (number? nth-try) - (+ nth-try 1) - 0)) - (if (runs:lownoise (conc "not removing test " hed) 60) - (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) - ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") - (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) - (runs:loop-values newtal reg reglen regfull reruns)) - ((symbol? nth-try) ;; BB: 'done matches here in one case where prereq itemwait failed. This is first "try" - (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW - (if (null? tal) - #f ;; yes, really - (list (car tal)(cdr tal) reg reruns)) - (begin - (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60) - (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state >" nth-try "< will be overridden and we'll retry.")) - ;; was: (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f) - (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path "COMPLETED" "PREQ_FAIL" #f) - (hash-table-set! test-registry hed 'removed) ;; was 0 - (if (not (and (null? reg) (null? tal))) - (runs:loop-values tal reg reglen regfull reruns) - #f)))) - (else - (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60) - (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) - ;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met) - (hash-table-set! test-registry hed 'removed) - (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) - ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug. - (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL - (list (if (null? tal)(car newtal)(car tal)) - tal - reg - reruns))))) - ;; ELSE: can't drop this - maybe running? Just keep trying - - ;;(if (not (or (not (null? reg))(not (null? tal)))) ;; old experiment - (let ((runable-tests (runs:runable-tests prereqs-not-met))) ;; SUSPICIOUS: Should look at more than just prereqs-not-met? - (if (null? runable-tests) - #f ;; I think we are truly done here - (runs:loop-values newtal reg reglen regfull reruns))) - ;;) ;;from old experiment - ) ;; end if (or (not (null? reg))(not (null? tal))) - )))))) - -;; scan a list of tests looking to see if any are potentially runnable -;; -(define (runs:runable-tests tests) - (filter (lambda (t) - (if (not (vector? t)) - t - (let ((state (db:test-get-state t)) - (status (db:test-get-status t))) - (case (string->symbol state) - ((COMPLETED INCOMPLETE) #f) - ((NOT_STARTED) - (if (member status '("TEN_STRIKES" "BLOCKED" "PREQ_FAIL" "ZERO_ITEMS" "PREQ_DISCARDED" "TIMED_OUT" )) - #f - t)) - ((DELETED) #f) - (else t))))) - tests)) - -;; move all the miscellanea into this struct -;; -(defstruct runs:gendat inc-results inc-results-last-update inc-results-fmt run-info runname target) - -(define *runs:general-data* - (make-runs:gendat - inc-results: (make-hash-table) - inc-results-last-update: 0 - inc-results-fmt: "~12a~12a~20a~12a~40a\n" ;; state status time duration test-name item-path - run-info: #f - runname: #f - target: #f - ) - ) - -(define (runs:incremental-print-results run-id) - (let ((curr-sec (current-seconds)) - (last-update (runs:gendat-inc-results-last-update *runs:general-data*))) - (if (> (- curr-sec last-update) 5) ;; at least five seconds since last update - (let* ((run-dat (or (runs:gendat-run-info *runs:general-data*)(rmt:get-run-info run-id))) - (runname (or (runs:gendat-runname *runs:general-data*) - (db:get-value-by-header (db:get-rows run-dat) - (db:get-header run-dat) "runname"))) - (target (or (runs:gendat-target *runs:general-data*)(rmt:get-target run-id))) - (testsdat (let ((res (rmt:get-tests-for-run - run-id "%" '() '() ;; run-id testpatt states statuses - #f #f ;; offset limit - #f ;; not-in - #f ;; sort-by - #f ;; sort-order - #f ;; get full data (not 'shortlist) - last-update - 'dashboard))) - (if (list? res) - res - (begin - (debug:print-error - 0 *default-log-port* - "FAILED TO GET DATA using rmt:get-tests-for-run. Notify developers if you see this. result: " res) - '()))))) - (runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 1)) - (if (not (runs:gendat-run-info *runs:general-data*)) - (runs:gendat-run-info-set! *runs:general-data* run-dat)) - (if (not (runs:gendat-runname *runs:general-data*)) - (runs:gendat-runname-set! *runs:general-data* runname)) - (if (not (runs:gendat-target *runs:general-data*)) - (runs:gendat-target-set! *runs:general-data* target)) - (for-each - (lambda (testdat) - (let* ((test-id (db:test-get-id testdat)) - (prevdat (hash-table-ref/default (runs:gendat-inc-results *runs:general-data*) - (conc run-id "," test-id) #f)) - (test-name (db:test-get-testname testdat)) - (item-path (db:test-get-item-path testdat)) - (state (db:test-get-state testdat)) - (status (db:test-get-status testdat)) - (event-time (db:test-get-event_time testdat)) - (duration (db:test-get-run_duration testdat))) - (if (and (not (member state '("DELETED" "REMOTEHOSTSTART" "RUNNING" "LAUNCHED""NOT_STARTED"))) - (not (and prevdat - (equal? state (db:test-get-state prevdat)) - (equal? status (db:test-get-status prevdat))))) - (let ((fmt (runs:gendat-inc-results-fmt *runs:general-data*)) - (dtime (seconds->year-work-week/day-time event-time))) - (if (runs:lownoise "inc-print" 600) - (format #t fmt "State" "Status" "Start Time" "Duration" "Test path")) - ;; (debug:print 0 *default-log-port* "fmt: " fmt " state: " state " status: " status " test-name: " test-name " item-path: " item-path " dtime: " dtime) - ;; (debug:print 0 #f "event-time: " event-time " duration: " duration) - (format #t fmt - state - status - dtime - (seconds->hr-min-sec duration) - (conc "lt/" target "/" runname "/" test-name (if (string-null? item-path) "" (conc "/" item-path)))) - (hash-table-set! (runs:gendat-inc-results *runs:general-data*) (conc run-id "," test-id) testdat))))) - testsdat))) - - ;; I don't think this should be here? -- Matt - #;(runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 10)) - - )) - -;; every time though the loop increment the test/itempatt val. -;; when the min is > max-allowed and none running then force exit -;; -(define *max-tries-hash* (make-hash-table)) - -(define (runs:pretty-long-list lst) - (if (> (length lst) 8)(append (take lst 3)(list "...")) lst)) - -(define *last-loop-time-ms* 0) - -;;====================================================================== -;; runs:run-tests-queue is called by runs:run-tests -;;====================================================================== -;; -;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > -(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) - ;; At this point the list of parent tests is expanded - ;; NB// Should expand items here and then insert into the run queue. - (debug:print 5 *default-log-port* "test-records: " test-records ", flags: " (hash-table->alist flags)) - - ;; Do mark-and-find clean up of db before starting runing of quue - ;; - ;; (rmt:find-and-mark-incomplete) - - (let* ((run-info (rmt:get-run-info run-id)) - (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) - (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) - (test-registry (make-hash-table)) - (registry-mutex (make-mutex)) - (num-retries 0) - (max-retries (configf:lookup *configdat* "setup" "maxretries")) - (max-concurrent-jobs (configf:lookup-number *configdat* "setup" "max_concurrent_jobs" default: 50)) - (reglen (if (number? reglen-in) reglen-in 1)) - (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle - (last-time-some-running (current-seconds)) - (incoming-tests '()) ;; queue up incoming tests here to tack on to tal when it gets low - ;; (tdbdat (tasks:open-db)) - (runsdat (make-runs:dat - ;; hed: hed - ;; tal: tal - ;; reg: reg - ;; reruns: reruns - reglen: reglen - regfull: #f ;; regfull - ;; test-record: test-record - runname: runname - ;; test-name: test-name - ;; item-path: item-path - ;; jobgroup: jobgroup - max-concurrent-jobs: max-concurrent-jobs - run-id: run-id - ;; waitons: waitons - ;; testmode: testmode - test-patts: test-patts - required-tests: required-tests - test-registry: test-registry - registry-mutex: registry-mutex - flags: flags - keyvals: keyvals - run-info: run-info - ;; newtal: newtal - all-tests-registry: all-tests-registry - ;; itemmaps: itemmaps - ;; prereqs-not-met: (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps) - ;; can-run-more-tests: (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) ;; look at the test jobgroup and tot jobs running - ))) - - ;; Initialize the test-registery hash with tests that already have a record - ;; convert state to symbol and use that as the hash value - (for-each (lambda (trec) - (let ((id (db:test-get-id trec)) - (tn (db:test-get-testname trec)) - (ip (db:test-get-item-path trec)) - (st (db:test-get-state trec))) - (if (not (equal? st "DELETED")) - (hash-table-set! test-registry (db:test-make-full-name tn ip) (string->symbol st))))) - tests-info) - (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) - - (let loop ((hed (car sorted-test-names)) - (tal (cdr sorted-test-names)) - (reg '()) ;; registered, put these at the head of tal - (reruns '())) - - (runs:incremental-print-results run-id) - - (if (not (null? reruns))(debug:print-info 4 *default-log-port* "reruns=" reruns)) - - ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes - ;; moving this to a parallel thread and just run it once. - ;; - (if (> (current-seconds)(+ last-time-incomplete 900)) - (begin - (set! last-time-incomplete (current-seconds)) - ;; (rmt:find-and-mark-incomplete-all-runs) - )) - - ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) - (let* ((test-record (hash-table-ref test-records hed)) - (test-name (tests:testqueue-get-testname test-record)) - (tconfig (tests:testqueue-get-testconfig test-record)) - (jobgroup (configf:lookup tconfig "test_meta" "jobgroup")) - (testmode (let ((m (configf:lookup tconfig "requirements" "mode"))) - (if m (map string->symbol (string-split m)) '(normal)))) - (itemmaps (tests:get-itemmaps tconfig)) ;; (configf:lookup tconfig "requirements" "itemmap")) - (priority (tests:testqueue-get-priority test-record)) - (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f - (items (tests:testqueue-get-items test-record)) - (item-path (item-list->path itemdat)) - (tfullname (db:test-make-full-name test-name item-path)) - ;; these are hard coded item-item waits test/item-path => test/item-path2 ... - (extra-waits (let* ((section (configf:get-section (tests:testqueue-get-testconfig test-record) "waitons")) - (myextra (alist-ref tfullname section equal?))) - (if myextra - (let ((extras (string-split (car myextra)))) - (if (runs:lownoise (conc tfullname "extra-waitons" tfullname) 60) - (debug:print-info 0 *default-log-port* "HAVE EXTRA WAITONS for test " tfullname ": " myextra)) - (for-each - (lambda (extra) - ;; (debug:print 0 *default-log-port* "FYI: extra = " extra " reruns = " reruns) - (let ((basetestname (car (string-split extra "/")))) - #;(if (not (member extra tal)) - (set! reruns (append tal (list extra)))) - (if (not (member basetestname tal)) - (set! reruns (append tal (list basetestname)))) - )) - extras) - extras) - '()))) - (waitons (delete-duplicates (append (tests:testqueue-get-waitons test-record) extra-waits) equal?)) - (newtal (append tal (list hed))) - (regfull (>= (length reg) reglen)) - (num-running (rmt:get-count-tests-running-for-run-id run-id)) - (testdat (make-runs:testdat - hed: hed - tal: tal - reg: reg - reruns: reruns - test-record: test-record - test-name: test-name - item-path: item-path - jobgroup: jobgroup - waitons: waitons - testmode: testmode - newtal: newtal - itemmaps: itemmaps - prereqs-not-met: '() - ))) - - ;; too-tight loop detection and delay, this might hide issues - ;; that occur in long run times. Consider commenting when debugging - ;; - (if (and (>= num-running max-concurrent-jobs) - (< (- (current-milliseconds) *last-loop-time-ms*) 500)) - (begin - (if (runs:lownoise "too-tight-loop" 5) - (debug:print-info 2 *default-log-port* "Excessively fast loop, delaying 1/2 second")) - (thread-sleep! 0.5))) - (set! *last-loop-time-ms* (current-milliseconds)) - - (runs:dat-regfull-set! runsdat regfull) - - - (if (> (- (current-seconds) *last-test-launch*) 5) ;; be pretty aggressive for five seconds after - (runs:too-soon-delay (conc "loop delay " hed) 1 0.6) ;; starting a test then apply more delay - (runs:too-soon-delay (conc "loop delay " hed) 1 0.1)) - - (if (> num-running 0) - (set! last-time-some-running (current-seconds))) - - (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000))) - (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) - ;; (debug:print 0 *default-log-port* "max-tries-hash: " (hash-table->alist *max-tries-hash*)) - - ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard - ;; and it is clear they *should* have run but did not. - (if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f)) - (begin - (rmt:register-test run-id test-name "") - (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))) - - ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( - ;; - (if (member (hash-table-ref/default test-registry tfullname #f) - '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) - (begin - (if (runs:lownoise (conc "been marked do not run " tfullname) 60) - (debug:print-info 0 *default-log-port* "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable")) - (if (or (not (null? tal))(not (null? reg))) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns)))) - ;; (loop (car tal)(cdr tal) reg reruns)))) - (runs:incremental-print-results run-id) - (debug:print 4 *default-log-port* "TOP OF LOOP => " - "test-name: " test-name - "\n hed: " hed - "\n tal: " (runs:pretty-long-list tal) - "\n reg: " reg - "\n test-record " test-record - "\n itemdat: " itemdat - "\n items: " items - "\n item-path: " item-path - "\n waitons: " waitons - "\n num-retries: " num-retries - "\n reruns: " reruns - "\n regfull: " regfull - "\n reglen: " reglen - "\n length reg: " (length reg) - ) - - ;; (runs:parallel-runners-mgmt runsdat) - - ;; check for hed in waitons => this would be circular, remove it and issue an - ;; error - (if (member test-name waitons) - (begin - (debug:print-error 0 *default-log-port* "test " test-name " has listed itself as a waiton, please correct this!") - (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) - - (cond - - ;; We want to catch tests that have waitons that are NOT in the queue and discard them IFF - ;; they have been through the wringer 10 or more times - ((and (list? waitons) - (not (null? waitons)) - (> (hash-table-ref/default *max-tries-hash* tfullname 0) 10) - (not (null? (filter - number? - (map (lambda (waiton) - (if (and (not (member waiton tal)) ;; this waiton is not in the list to be tried to run - (not (member waiton reruns))) - 1 - #f)) - waitons))))) ;; could do this more elegantly with a marker.... - (debug:print-info 4 *default-log-port* "cond branch - " "rtq-1") - (debug:print 0 *default-log-port* "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.") - (hash-table-set! test-registry tfullname 'removed)) - - ;; items is #f then the test is ok to be handed off to launch (but not before) - ;; - ((not items) - (debug:print-info 4 *default-log-port* "cond branch - " "rtq-2") - (debug:print-info 4 *default-log-port* "OUTER COND: (not items)") - (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) - (not (null? tal))) - (loop (car tal)(cdr tal) reg reruns)) - - ;; gonna try a strategy change here. - ;; - ;; check if can run more tests. if yes, continue, if no, rest until can run more - ;; look at the test jobgroup and tot jobs running - ;; - ;; NOTE: This does NOT actually gate here, only captures the proc to be called later - ;; - (if (not (runs:dat-wait-for-jobs-function runsdat)) - (runs:dat-wait-for-jobs-function-set! - runsdat - (lambda (testdat-in) - (let* ((jobgroup (runs:testdat-jobgroup testdat-in)) - (can-run-more-tests (runs:dat-can-run-more-tests runsdat)) - (last-jobs-check-time (runs:dat-last-jobs-check-time runsdat)) - (should-check-jobs (match can-run-more-tests - ((can-run-more-flag num-running nr-in-jobgroup max-concurrent-jobs . params) - (if (< (- max-concurrent-jobs num-running) 25) - (begin - (debug:print-info 2 *default-log-port* - "less than 20 jobs headroom, ("max-concurrent-jobs - "-"num-running")>20. Forcing prelaunch check.") - #t) - #f)) - (else #f)))) ;; no record yet - (if should-check-jobs - (let loop-can-run-more - ((res (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) - (remtries 1440)) ;; we can wait for up to two hours for jobs to get done - (match res - ((run-more num-running . rem) - (if (or run-more - (< remtries 1)) - (begin - (if (runs:lownoise "num-running" 30) - (debug:print-info 0 *default-log-port* "Have "num-running" tests of max " max-concurrent-jobs)) - (runs:dat-can-run-more-tests-set! runsdat res)) ;; capture the result and then drop through - (begin - (if (runs:lownoise "num-running" 10) - (debug:print-info 0 *default-log-port* "Can't run more tests, have "num-running" tests of " - max-concurrent-jobs " allowed.")) - (thread-sleep! 5) ;; if we've hit max concurrent jobs take a breather, nb// make this configurable - - ;; wait for load here - (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) - (loop-can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) - (- remtries 1))))))) - ))))) - - ;; I'm not clear on why prereqs are gathered here TODO: verfiy this is needed - (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) - - ;; I'm not clear on why we'd capture running job counts here TODO: verify this is needed - (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) - - (let ((loop-list (runs:process-expanded-tests runsdat testdat))) ;; in process-expanded-tests ultimately run:test -> launch-test -> test actually running - (if loop-list (apply loop loop-list)))) - - ;; items processed into a list but not came in as a list been processed - ;; - ((and (list? items) ;; thus we know our items are already calculated - (not itemdat)) ;; and not yet expanded into the list of things to be done - (debug:print-info 4 *default-log-port* "cond branch - " "rtq-3") - (debug:print-info 4 *default-log-port* "OUTER COND: (and (list? items)(not itemdat))") - ;; Must determine if the items list is valid. Discard the test if it is not. - (if (and (list? items) - (> (length items) 0) - (and (list? (car items)) - (> (length (car items)) 0)) - (debug:debug-mode 1)) - (debug:print 2 *default-log-port* (map (lambda (row) - (conc (string-intersperse - (map (lambda (varval) - (string-intersperse varval "=")) - row) - " ") - "\n")) - items))) - - (let* ((items-in-testpatt - (filter - (lambda (my-itemdat) - (tests:match test-patts hed (item-list->path my-itemdat) )) - ;; was: (tests:match test-patts hed (item-list->path my-itemdat) required: required-tests)) - items) )) - (if (null? items-in-testpatt) - (debug:print-error 0 *default-log-port* "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items matching the test pattern") - - (for-each (lambda (my-itemdat) - (let* ((new-test-record (let ((newrec (make-tests:testqueue))) - (vector-copy! test-record newrec) - newrec)) - (my-item-path (item-list->path my-itemdat)) - - (newtestname (db:test-make-full-name hed my-item-path))) ;; test names are unique on testname/item-path - (tests:testqueue-set-items! new-test-record #f) - (tests:testqueue-set-itemdat! new-test-record my-itemdat) - (tests:testqueue-set-item_path! new-test-record my-item-path) - (hash-table-set! test-records newtestname new-test-record) - ;; BUG: This next line sucks up a lot of horsepower - ;; (set! tal (append tal (list newtestname))) - ;; (set! tal (cons newtestname tal)) ;; 4/6/2023 - try using cons, does it matter if the test gets added at the beginning? - (set! incoming-tests (cons newtestname incoming-tests)) - )) ;; since these are itemized create new test names testname/itempath - items-in-testpatt))) - - (if (and (< (length tal) 20) - (not (null? incoming-tests))) - (begin - (set! tal (append tal (reverse incoming-tests))) - (set! incoming-tests '()))) - - ;; At this point we have possibly added items to tal but all must be handed off to - ;; INNER COND logic. I think loop without rotating the queue - ;; (loop hed tal reg reruns)) - ;; (let ((newtal (append tal (list hed)))) ;; We should discard hed as it has been expanded into it's items? Yes, but only if this *is* an itemized test - ;; (loop (car newtal)(cdr newtal) reg reruns) - (if (null? tal) - #f - (loop (car tal)(cdr tal) reg reruns))) - - ;; if items is a proc then need to run items:get-items-from-config, get the list and loop - ;; - but only do that if resources exist to kick off the job - ;; EXPAND ITEMS - ((or (procedure? items)(eq? items 'have-procedure)) - (debug:print-info 4 *default-log-port* "cond branch - " "rtq-4") - (let ((can-run-more #f)) ;; (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs))) - (if (not can-run-more) #;(and (list? can-run-more) - (car can-run-more)) - (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps))) ;; itemized test expanded here - (if loop-list - (apply loop loop-list) - (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed) - ) - ) - ;; if can't run more just loop with next possible test - (loop (car newtal)(cdr newtal) reg reruns)))) - - - ;; this case should not happen, added to help catch any bugs - ((and (list? items) itemdat) - (debug:print-info 4 *default-log-port* "cond branch - " "rtq-5") - (debug:print-error 0 *default-log-port* "Should not have a list of items in a test and the itemspath set - please report this") - (exit 1)) - - ((not (null? reruns)) - (debug:print-info 4 *default-log-port* "cond branch - " "rtq-6") - (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, - (junked (lset-difference equal? tal newlst))) - (debug:print-info 4 *default-log-port* "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) - (if (< num-retries max-retries) - (set! newlst (append reruns newlst))) - (set! num-retries (+ num-retries 1)) - ;; (thread-sleep! (+ 1 *global-delta*)) - (if (not (null? newlst)) - ;; since reruns have been tacked on to newlst create new reruns from junked - (loop (car newlst)(cdr newlst) reg (delete-duplicates junked))))) - - ((not (null? tal)) - (debug:print-info 4 *default-log-port* "cond branch - " "rtq-7") - (debug:print-info 4 *default-log-port* "I'm pretty sure I shouldn't get here.")) - ((not (null? reg)) ;; could we get here with leftovers? - (debug:print-info 4 *default-log-port* "cond branch - " "rtq-8") - (debug:print-info 0 *default-log-port* "Have leftovers!") - (loop (car reg)(cdr reg) '() reruns)) - (else - (debug:print-info 4 *default-log-port* "cond branch - " "rtq-9") - (debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) - ))) ;; end loop on sorted test names - ;; this is the point where everything is launched and now you can mark the run in metadata table as all launched - (rmt:set-var (conc "lunch-complete-" run-id) "yes") - - ;; now *if* -run-wait we wait for all tests to be done - ;; Now wait for any RUNNING tests to complete (if in run-wait mode) - ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) - (thread-sleep! 0.1) ;; I think there is a race condition here. Let states/statuses settle - - (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) - (prev-num-running 0)) - ;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running) - (if (and (or (args:get-arg "-run-wait") - (equal? (configf:lookup *configdat* "setup" "run-wait") "yes")) - (> num-running 0)) - (begin - ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes - ;; (debug:print 0 *default-log-port* "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0)) - (if (> (current-seconds)(+ last-time-incomplete 900)) - (let ((actual-num-running (rmt:get-count-tests-running-for-run-id run-id))) - (debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id - ". Running as pid " (current-process-id) " on " (get-host-name)) - (set! last-time-incomplete (current-seconds)) ;; FIXME, this might be causing slow down - use of set! - (rmt:find-and-mark-incomplete run-id #f) - (debug:print-info 0 *default-log-port* "run-wait specified, waiting on " actual-num-running - " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " - (time->string (seconds->local-time (current-seconds)))))) - ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) - (thread-sleep! 5) ;; (if (>= num-running max-concurrent-jobs) 5 1)) - (wait-loop (rmt:get-count-tests-running-for-run-id run-id) - num-running)))) - ;; LET* ((test-record - ;; we get here on "drop through". All done! - ;; this is moved to runs:run-testes since this function is getting called twice to ensure everthing is completed. - ;; (debug:print-info 0 *default-log-port* "Calling Post Hook") - ;; (runs:run-post-hook run-id) - (debug:print-info 1 *default-log-port* "All tests launched"))) - -(define (runs:calc-fails prereqs-not-met) - (filter (lambda (test) - (and (vector? test) ;; not (string? test)) - (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED")) ;; TODO: pull from *common:stuff...* - (not (member (db:test-get-status test) - '("PASS" "WARN" "WAIVED" "SKIP"))))) - prereqs-not-met)) - -(define (runs:calc-prereq-fail prereqs-not-met) ;; REMOVEME since NOT_STARTED/PREQ_FAIL is now COMPLETED/PREQ_FAIL - (filter (lambda (test) - (and (vector? test) ;; not (string? test)) - (equal? (db:test-get-state test) "NOT_STARTED") - (not (member (db:test-get-status test) - '("n/a" "KEEP_TRYING"))))) - prereqs-not-met)) - -(define (runs:calc-not-completed prereqs-not-met) - (filter - (lambda (t) - (or (not (vector? t)) - (not (member (db:test-get-state t) '("INCOMPLETE" "COMPLETED"))))) - prereqs-not-met)) - -;; (define (runs:calc-not-completed prereqs-not-met) -;; (filter -;; (lambda (t) -;; (or (not (vector? t)) -;; (not (equal? "COMPLETED" (db:test-get-state t))))) -;; prereqs-not-met)) - -(define (runs:calc-runnable prereqs-not-met) - (filter - (lambda (t) - (or (not (vector? t)) - (and (equal? "NOT_STARTED" (db:test-get-state t)) - (member (db:test-get-status t) - '("n/a" "KEEP_TRYING"))) - (and (equal? "RUNNING" (db:test-get-state t))))) ;; account for a test that is running - prereqs-not-met)) - -(define (runs:pretty-string lst) - (map (lambda (t) - (if (not (vector? t)) - (conc t) - (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) - lst)) - -;; parent-test is there as a placeholder for when parent-tests can be run as a setup step -;; -(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry runsdat testdat-rec) - ;; All these vars might be referenced by the testconfig file reader - ;; - ;; NEED to reprocess testconfig here, ensuring that item variables are available. - ;; This is for Tal's issue with item-specific env vars not being set for use in skip. - ;; HSD https://hsdes.intel.com/appstore/icf/index.html#/article?articleId=1408763273 - ;; Also later HSD https://hsdes.intel.com/appstore/article/#/14012138487 - ;; - (let* ((test-name (tests:testqueue-get-testname test-record)) - (test-waitons (tests:testqueue-get-waitons test-record)) - (itemdat (tests:testqueue-get-itemdat test-record)) - (item-path "") - (db #f) - (full-test-name #f)) - - ;; setting itemdat to a list if it is #f - (if (not itemdat)(set! itemdat '())) - (set! item-path (item-list->path itemdat)) - (set-item-env-vars itemdat) - (set! full-test-name (db:test-make-full-name test-name item-path)) - (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process - - (let* ((test-conf ;; re-instated the tests:get-testconfig to fix HSD https://hsdes.intel.com/appstore/article/#/14012138487, need to be able to skip using [items], [itemstable] variables. - ;; (tests:testqueue-get-testconfig test-record )) ;; vector-ref test-record 3 - (tests:get-testconfig test-name item-path all-tests-registry #t force-create: #t)) - (test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... - - (force (hash-table-ref/default flags "-force" #f)) - (rerun (hash-table-ref/default flags "-rerun" #f)) - (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) - (incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x"))) - ) - - (debug:print-info 4 *default-log-port* - "\nTESTNAME: " full-test-name - "\n test-config: " (hash-table->alist test-conf) - "\n itemdat: " itemdat - ) - (debug:print 2 *default-log-port* "Attempting to launch test " full-test-name) - ;; (setenv "MT_TEST_NAME" test-name) ;; - ;; (setenv "MT_ITEMPATH" item-path) - ;; (setenv "MT_RUNNAME" runname) - (change-directory *toppath*) - - ;; Here is where the test_meta table is best updated - ;; Yes, another use of a global for caching. Need a better way? - ;; - ;; There is now a single call to runs:update-all-test_meta and this - ;; per-test call is not needed. Given the delicacy of the move to - ;; v1.55 this code is being left in place for the time being. - ;; - (if (not (hash-table-exists? *test-meta-updated* test-name)) - (begin - (hash-table-set! *test-meta-updated* test-name #t) - (runs:update-test_meta test-name test-conf))) - - ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) - (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) - (test-id (rmt:get-test-id run-id test-name item-path)) - (testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f))) - (if (not testdat) - (let loop () - ;; ensure that the path exists before registering the test - ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... - ;; (system (conc "mkdir -p " new-test-path)) - ;; - ;; (open-run-close tests:register-test db run-id test-name item-path) - ;; - ;; NB// for the above line. I want the test to be registered long before this routine gets called! - ;; - (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path))) - (if (not test-id) - (begin - (debug:print 2 *default-log-port* "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) - (rmt:register-test run-id test-name item-path) - (set! test-id (rmt:get-test-id run-id test-name item-path)))) - (debug:print-info 4 *default-log-port* "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") - (set! testdat (rmt:get-test-info-by-id run-id test-id)) - (if (not testdat) - (begin - (debug:print-info 0 *default-log-port* "WARNING: server is overloaded, trying again in two seconds") - ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) - (thread-sleep! 2) - (loop))))) - (if (not testdat) ;; should NOT happen - (debug:print-error 0 *default-log-port* "failed to get test record for test-id " test-id)) - (set! test-id (db:test-get-id testdat)) - (if (common:file-exists? test-path) - (change-directory test-path) - (begin - (debug:print-error 0 *default-log-port* "test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") - (change-directory *toppath*))) - (case (if force ;; (args:get-arg "-force") - 'NOT_STARTED - (if testdat - (string->symbol (test:get-state testdat)) - 'failed-to-insert)) - ((failed-to-insert) - (debug:print-error 0 *default-log-port* "Failed to insert the record into the db")) - ((NOT_STARTED COMPLETED DELETED INCOMPLETE) - (let ((runflag #f)) - (cond - ;; -force, run no matter what - (force (set! runflag #t)) - ;; NOT_STARTED, run no matter what - ((member (test:get-state testdat) '("DELETED" "NOT_STARTED" "INCOMPLETE"))(set! runflag #t)) - ;; not -rerun and PASS, WARN or CHECK, do no run - ((and (or (not rerun) - keepgoing) - ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK - (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP" "WAIVED")) - (member (test:get-state testdat) '("COMPLETED")))) - (debug:print-info 2 *default-log-port* "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat)) - (hash-table-set! test-registry full-test-name 'DONOTRUN) ;; COMPLETED) - (set! runflag #f)) - - ;; -rerun and status is one of the specifed, run it - ((and rerun - (let* ((rerunlst (string-split rerun ",")) - (must-rerun (member (test:get-status testdat) rerunlst))) - (debug:print-info 3 *default-log-port* "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun) - must-rerun)) - (debug:print-info 2 *default-log-port* "Rerun forced for test " test-name "/" item-path) - (set! runflag #t) - (debug:print-info 2 *default-log-port* "Calling rerun hook") - (runs:rerun-hook test-id new-test-path testdat rerun) - ) - - - - ;; -keepgoing, do not rerun FAIL - ((and keepgoing - (member (test:get-status testdat) '("FAIL"))) - (set! runflag #f)) - - ((and (not rerun) - (member (test:get-status testdat) '("FAIL" "n/a"))) - (set! runflag #t)) - - (else (set! runflag #f))) - (debug:print 4 *default-log-port* "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) - (if (not runflag) - (if (not parent-test) - (if (runs:lownoise (conc "not starting test" full-test-name) 60) - (debug:print 3 *default-log-port* "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) - "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) - "\" or -force to override"))) - ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are - ;; already met. - ;; This would be a great place to do the process-fork - ;; - (let ((skip-test #f) - (skip-check (configf:get-section test-conf "skip"))) - (cond - ;; Have to check for skip conditions. This one skips if there are same-named tests - ;; currently running - ((and skip-check - (configf:lookup test-conf "skip" "prevrunning")) - ;; run-ids = #f means *all* runs - (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) - (if (not (null? running-tests)) ;; have to skip - (set! skip-test "Skipping due to previous tests running")))) - - ;; split the string and OR of file-exists? - ((and skip-check - (configf:lookup test-conf "skip" "fileexists")) - (let* ((files (string-split (configf:lookup test-conf "skip" "fileexists"))) - (existing (filter common:file-exists? files))) - (if (not (null? existing)) ;; (common:file-exists? (configf:lookup test-conf "skip" "fileexists")) - (set! skip-test (conc "Skipping due to existance of file(s) " (string-intersperse existing ", ")))))) ;; (configf:lookup test-conf "skip" "fileexists"))))) - - ((and skip-check - (configf:lookup test-conf "skip" "filenotexists")) - (let* ((files (string-split (configf:lookup test-conf "skip" "filenotexists"))) - (existing (filter common:file-exists? files))) - (if (null? existing) ;; (common:file-exists? (configf:lookup test-conf "skip" "filenotexists"))) - (set! skip-test (conc "Skipping due to non existance of files " (string-intersperse files ", ")))))) ;; (configf:lookup test-conf "skip" "filenotexists"))))) - - ((and skip-check - (configf:lookup test-conf "skip" "script")) - (if (= (system (configf:lookup test-conf "skip" "script")) 0) - (set! skip-test (conc "Skipping due to zero return value of script " (configf:lookup test-conf "skip" "script"))))) - - ((and skip-check - (configf:lookup test-conf "skip" "rundelay")) - ;; run-ids = #f means *all* runs - (let* ((numseconds (common:hms-string->seconds (configf:lookup test-conf "skip" "rundelay"))) - (running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)) - (completed-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("COMPLETED" "INCOMPLETE") '("PASS" "FAIL" "ABORT") #f)) ;; ironically INCOMPLETE is same as COMPLETED in this contex - (last-run-times (map db:mintest-get-event_time completed-tests)) - (time-since-last (- (current-seconds) (if (null? last-run-times) 0 (common:max last-run-times))))) - (if (or (not (null? running-tests)) ;; have to skip if test is running - (> numseconds time-since-last)) - (set! skip-test (conc "Skipping due to previous test run less than " (configf:lookup test-conf "skip" "rundelay") " ago")))))) - - (if skip-test - (begin - (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test) - (debug:print-info 1 *default-log-port* "SKIPPING Test " full-test-name " due to " skip-test)) - ;; - ;; Here the test is handed off to launch.scm for launch-test to complete the launch process - ;; - (begin - ;; wait for less than max jobs here - (if (runs:dat-wait-for-jobs-function runsdat) - ((runs:dat-wait-for-jobs-function runsdat) testdat-rec)) - - (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) - (begin - (debug:print 0 *default-log-port* "ERROR: Failed to launch the test. Exiting as soon as possible") - (set! *globalexitstatus* 1) ;; - (process-signal (current-process-id) signal/kill)) - ) - ;; wait again here? - )))))) - ((KILLED) - (debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") - (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED)) - ((LAUNCHED REMOTEHOSTSTART RUNNING) - (debug:print 2 *default-log-port* "NOTE: " test-name " is already running")) - ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) - ;; (or incomplete-timeout - ;; 6000)) ;; i.e. no update for more than 6000 seconds - ;; (begin - ;; (debug:print 0 *default-log-port* "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") - ;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) - ;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) - ;; (debug:print 2 *default-log-port* "NOTE: " test-name " is already running"))) - (else - (debug:print-error 0 *default-log-port* "Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) - (case (string->symbol (test:get-state testdat)) - ((COMPLETED INCOMPLETE) - (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) - (else - (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN))))))))) - -;;====================================================================== -;; END OF NEW STUFF -;;====================================================================== - -(define (get-dir-up-n dir . params) - (let ((dparts (string-split dir "/")) - (count (if (null? params) 1 (car params)))) - (conc "/" (string-intersperse - (take dparts (- (length dparts) count)) - "/")))) - -(define (runs:recursive-delete-with-error-msg real-dir) - (if (> (system (conc "rm -rf " real-dir)) 0) - (begin - ;; FAILED, possibly due to permissions, do chmod a+rwx then try one more time - (system (conc "chmod -R a+rwx " real-dir)) - (if (> (system (conc "rm -rf " real-dir)) 0) - (debug:print-error 0 *default-log-port* "There was a problem removing " real-dir " with rm -f"))))) - -(define (runs:safe-delete-test-dir real-dir) - ;; first delete all sub-directories - (directory-fold - (lambda (f x) - (let ((fullname (conc real-dir "/" f))) - (if (directory? fullname)(runs:recursive-delete-with-error-msg fullname))) - (+ 1 x)) - 0 real-dir) - ;; then files other than *testdat.db* - (directory-fold - (lambda (f x) - (let ((fullname (conc real-dir "/" f))) - (if (not (string-search (regexp "testdat.db") f)) - (runs:recursive-delete-with-error-msg fullname))) - (+ 1 x)) - 0 real-dir #t) - ;; then the entire directory - (runs:recursive-delete-with-error-msg real-dir)) - -;; cleanup often needs to remove all but the last N runs per target -;; -;; target-patts a1/b1/c1,a2/b2/c2 ... -;; -;; This will fail if called with empty target or a bad target (i.e. missing or extra fields) -;; -(define (runs:get-hash-by-target target-patts runpatt) - (let* ((targets (string-split target-patts ",")) - (keys (rmt:get-keys)) - (res-ht (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... ) - (for-each - (lambda (target-patt) - (let ((runs (rmt:simple-get-runs runpatt #f #f target-patt #f))) - (for-each - (lambda (run) - (let ((target (simple-run-target run))) - (hash-table-set! res-ht target (cons run (hash-table-ref/default res-ht target '()))))) - runs))) - targets) - res-ht)) - -;; delete runs older than X (weeks, days, months years etc.) -;; delete redundant runs within a target - N is the input -;; delete redundant runs within a target IFF older than given date/time AND keep at least N -;; -(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") "")) - (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 (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 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")) - (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 %" - (if (member 'kill-runs actions) ;; if kill-runs is specified then set -kill-wait to 0 - " -kill-wait 0" - ""))))) - ((archive) - (if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %")))) - ((kill-runs) - (if remove (system (conc precmd " megatest -kill-runs -target " target " -runname " (simple-run-runname run) " -testpatt %")))))))) - 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)) "/"))) - ) - path-out - ) -) - - -(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode #f)(options '())) - (common:clear-caches) ;; clear all caches - (let* ((db #f) - ;; (tdbdat (tasks:open-db)) - (keys (rmt:get-keys)) - (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))) - (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". - (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* "/.mtdb/main.db")) - (readonly-mode (not (file-write-access? dbfile)))) - (when (and readonly-mode - (member action write-access-actions)) - (debug:print-error 0 *default-log-port* dbfile " is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") - (exit 1))) - - (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) - (if (> 2 (length state-status)) - (begin - (debug:print-error 0 *default-log-port* "the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL") - (exit))) - (for-each - (lambda (run) - (let ((runkey (string-intersperse (map (lambda (k) - (db:get-value-by-header run header k)) keys) "/")) - (dirs-to-remove (make-hash-table)) - (proc-get-tests (lambda (run-id) - (mt:get-tests-for-run run-id - testpatt states statuses - not-in: #f - sort-by: (case action - ((remove-runs) 'rundir) - (else 'event_time)))))) - (let* ((run-id (db:get-value-by-header run header "id")) - (run-state (db:get-value-by-header run header "state")) - (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") - ;; there may be a number of different disks used in the same run. - (run-paths-hash (make-hash-table)) - (worker-thread #f)) - (debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header) - (if (not (null? tests)) - (begin - (case action - ((kill-runs) - (tasks:kill-runner target run-name "%") - (debug:print 1 *default-log-port* "Killing tests for run: " runkey " " (db:get-value-by-header run header "runname")) - ) - ((remove-runs) - ;; use this location to cleanup old DELETED records? No. See below for same call - ;; (rmt:delete-old-deleted-test-records run-id) - ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) - ;; seek and kill in flight -runtests with % as testpatt here - ;; (if (equal? testpatt "%") - (tasks:kill-runner target run-name testpatt) - ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt)) - (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) - ((set-state-status) - ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) - (debug:print 2 *default-log-port* "Modifying state and status for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) - ((print-run) - (debug:print 1 *default-log-port* "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) - 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")) - (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) ;;; 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 - ;; - (let ((sorted-tests (filter - vector? - (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry 'getstr - (db:test-get-rundir a)) ;; ) ;; (filedb:get-path *fdb* (db:test-get-rundir a))) - (dirb ;; (rmt:sdb-qry 'getstr - (db:test-get-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-get-rundir b)))) - (if (and (string? dira)(string? dirb)) - (> (string-length dira)(string-length dirb)) - #f)))))) - (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests - (test-retry-time (make-hash-table)) - (backgrounded-remove-status (make-hash-table)) - (backgrounded-remove-last-visit (make-hash-table)) - (backgrounded-remove-result (make-hash-table)) - (allow-run-time (string->number (or (args:get-arg "-kill-wait") "10")))) ;; seconds to allow for killing tests before just brutally killing 'em - (let loop ((test (car sorted-tests)) - (tal (cdr sorted-tests))) - (let* ((test-id (db:test-get-id test)) - (new-test-dat (rmt:get-test-info-by-id run-id test-id))) - (if (not new-test-dat) - (begin - (debug:print-error 0 *default-log-port* "We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") - (if (not (null? tal)) - (loop (car tal)(cdr tal)))) - (let* ((item-path (db:test-get-item-path new-test-dat)) - (test-name (db:test-get-testname new-test-dat)) - (run-dir ;;(filedb:get-path *fdb* - ;; (rmt:sdb-qry 'getid - (db:test-get-rundir new-test-dat)) ;; ) ;; run dir is from the link tree - (has-subrun (and (subrun:subrun-test-initialized? run-dir) - (not (subrun:subrun-removed? run-dir)))) - (test-state (db:test-get-state new-test-dat)) - (test-status (db:test-get-status new-test-dat)) - (test-fulln (db:test-get-fullname new-test-dat)) - (uname (db:test-get-uname new-test-dat)) - (toplevel-with-children (and (db:test-get-is-toplevel test) - (> (rmt:test-toplevel-num-items run-id test-name) 0)))) - - (case action - ((remove-runs) - ;; if the test is a toplevel-with-children issue an error and do not remove - (cond - (toplevel-with-children - (debug:print 0 *default-log-port* "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests") - (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1)) - (if (> (hash-table-ref toplevel-retries test-fulln) 3) - (if (not (null? tal)) - (loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries - (let ((newtal (append tal (list test)))) - (loop (car newtal)(cdr newtal))))) ;; loop with test still in queue - (has-subrun - ;; - (let ((last-visit (hash-table-ref/default backgrounded-remove-last-visit test-fulln 0)) - (now (current-seconds)) - (rem-status (hash-table-ref/default backgrounded-remove-status test-fulln 'not-started))) - (case rem-status - ((not-started) - (debug:print 0 *default-log-port* "WARNING: postponing removal of " test-fulln " with run-id " run-id " as it has a subrun") - (hash-table-set! backgrounded-remove-status test-fulln 'started) - (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) - (common:send-thunk-to-background-thread - (lambda () - (let* ((subrun-remove-succeeded - (subrun:remove-subrun run-dir keep-records))) - (hash-table-set! backgrounded-remove-result test-fulln subrun-remove-succeeded) - (hash-table-set! backgrounded-remove-status test-fulln 'done))) - name: (conc "remove-subrun:"test-fulln)) - - ;; send to back of line, loop - (let ((newtal (append tal (list test)))) - (loop (car newtal)(cdr newtal))) - ) - ((started) - ;; if last visit was within last second, sleep 1 second - (if (< (- now last-visit) 1.0) - (thread-sleep! 1.0)) - (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) - ;; send to back of line, loop - (let ((newtal (append tal (list test)))) - (loop (car newtal)(cdr newtal))) - ) - ((done) - ;; drop this one; if remaining, loop, else finish - (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) - (let ((subrun-remove-succeeded (hash-table-ref/default backgrounded-remove-result test-fulln 'exception))) - (cond - ((eq? subrun-remove-succeeded 'exception) - (let* ((logfile (subrun:get-log-path run-dir "remove"))) - (debug:print 0 *default-log-port* "ERROR: removing subrun of of " test-fulln " with run-id " run-id " ; see logfile @ "logfile)) - (if (not (null? tal)) - (loop (car tal)(cdr tal)))) - (subrun-remove-succeeded - (debug:print 0 *default-log-port* "Now removing of " test-fulln " with run-id " run-id " since subrun was removed.") - ;;(runs:remove-test-directory new-test-dat mode) ;; let normal case handle this. it will go thru loop again as non-subrun - (let ((newtal (append tal (list test)))) - (loop (car newtal)(cdr newtal)))) - (else - (let* ((logfile (subrun:get-log-path run-dir "remove"))) - (debug:print 0 *default-log-port* "WARNING: removal of subrun failed. Please check "logfile" for details.")) - ;; send to back of line, loop (will not match has-subrun next time through) - (if (not (null? tal)) - (loop (car tal)(cdr tal)))))) - ) - ) ; end case rem-status - ) ; end let - ); end cond has-subrun - - (else - ;; BB - TODO - consider backgrounding to threads to delete tests (work below) - (debug:print-info 2 *default-log-port* "test: " test-name " itest-state: " test-state) - (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) - (begin - (if (not (hash-table-ref/default test-retry-time test-fulln #f)) - (begin - ;; want to set to REMOVING BUT CANNOT do it here? - (hash-table-set! test-retry-time test-fulln (current-seconds)))) - (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) - ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first - ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give - ;; up and blow it away. - (begin - (debug:print 0 *default-log-port* "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") - (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) - (thread-sleep! 1)) - (begin - (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) - (thread-sleep! 1))) - ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... - (if (null? tal) - (loop new-test-dat tal) - (loop (car tal)(append tal (list new-test-dat))))) - (begin - (let ((rundir (db:test-get-rundir new-test-dat))) - (if (and (not (string= rundir "/tmp/badname")) - (file-exists? rundir) - (substring-index run-name rundir) - (tests:glob-like-match (conc "%/" target "/%") rundir) - ) - (begin - (set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal - (set! lastrealpath (remove-last-path-directory (resolve-pathname lasttpath))) - (hash-table-set! run-paths-hash lastrealpath 1) - (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) - ) - (begin - (debug:print 2 *default-log-port* "Not removing directory " rundir " because either it doesn't exist or has a bad name") - (debug:print 2 *default-log-port* "Is /tmp/badname: " (string= rundir "/tmp/badname")) - (debug:print 2 *default-log-port* "Exists: " (file-exists? rundir)) - (debug:print 2 *default-log-port* "Has run-name: " (substring-index run-name rundir)) - (debug:print 2 *default-log-port* "Has target: " (tests:glob-like-match (conc "%/" target "/%") rundir)) - (debug:print 2 *default-log-port* "Target: " target) - - ;;PJH remove record from db no need to cleanup directory - (case mode - ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) (db:test-get-state test)(db:test-get-status test) #f)) - ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) - (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test)))) - - ) - ) - ) - - (if (not (null? tal)) - (loop (car tal)(cdr tal))))))) - (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) - ((kill-runs) - ;; RUNNING -> KILLREQ - ;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED - (cond - ((and has-subrun (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))) - (common:send-thunk-to-background-thread - (lambda () - (let* ((subrun-remove-succeeded - (subrun:kill-subrun run-dir keep-records))) - #t))) - (if (not (null? tal)) - (loop (car tal)(cdr tal))) - ) - ((member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) - (debug:print 1 *default-log-port* "INFO: issuing killreq to test "test-fulln) - (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) - (if (not (null? tal)) - (loop (car tal)(cdr tal)))) - ((and (member test-status '("PREQ_FAIL" "PREQ_DISCARDED" "BLOCKED" "ZERO_ITEMS" "KEEP_TRYING" "TEN_STRIKES" "TIMED_OUT"))) - (rmt:set-state-status-and-roll-up-items run-id (db:test-get-id test) 'foo "NOT_STARTED" "n/a" (conc "kill-run moved from "test-state":"test-status" to NOT_STARTED:n/a")) - ;;(mt:test-set-state-status-by-id run-id (db:test-get-id test) "NOT_STARTED" "n/a" (conc "kill-run moved from "test-state":"test-status" to NOT_STARTED:n/a")) - (if (not (null? tal)) - (loop (car tal)(cdr tal))) - ) - (else - (if (not (null? tal)) - (loop (car tal)(cdr tal))) - ))) - ((set-state-status) - (let* ((new-state (car state-status)) - (new-status (cadr state-status)) - (test-id (db:test-get-id test)) - (test-run-dir (db:test-get-rundir new-test-dat)) - (has-subrun (and (subrun:subrun-test-initialized? test-run-dir) - (not (subrun:subrun-removed? test-run-dir))))) - (when has-subrun - (common:send-thunk-to-background-thread - (lambda () - (subrun:set-state-status test-run-dir state status new-state-status) - ) - ) - ) - (debug:print-info 2 *default-log-port* "new state " new-state ", new status " new-status ) - (mt:test-set-state-status-by-id run-id test-id new-state new-status #f)) - (if (not (null? tal)) - (loop (car tal)(cdr tal)))) - ((run-wait) - ;; BB TODO - manage has-subrun case - (debug:print-info 2 *default-log-port* "still waiting, " (length tests) " tests still running") - (thread-sleep! 5) - (let ((new-tests (proc-get-tests run-id))) - (if (null? new-tests) - (debug:print-info 1 *default-log-port* "Run completed according to zero tests matching provided criteria.") - (loop (car new-tests)(cdr new-tests))))) - ((archive) - ;; BB TODO - manage has-subrun case - (if (and run-dir (not toplevel-with-children)) - (let ((ddir (conc run-dir "/"))) - (case (string->symbol (args:get-arg "-archive")) - ((save save-remove keep-html) - (if (common:file-exists? ddir) - (debug:print-info 0 *default-log-port* "Estimating disk space usage for " test-fulln ": " (common:get-disk-space-used ddir))))))) - (if (not (null? tal)) - (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 - (let* ((linkspath (remove-last-path-directory lasttpath)) - (runpaths (hash-table-keys run-paths-hash)) - ) - - (debug:print 2 *default-log-port* "run-paths-hash: " (hash-table-keys run-paths-hash)) - - (debug:print 1 *default-log-port* "Removing target " target "run: " run-name) - (if (not keep-records) - (begin - (debug:print 1 *default-log-port* "Removing DB records for the run.") - (rmt:delete-run run-id) - (rmt:delete-old-deleted-test-records run-id)) - ) - (if (not (equal? linkspath "/does/not/exist/I")) - (begin - (debug:print 1 *default-log-port* "Recursively removing links dir " linkspath) - (runs:recursive-delete-with-error-msg linkspath))) - - (for-each (lambda(runpath) - (debug:print 1 *default-log-port* "Recursively removing runs dir " runpath) - (runs:recursive-delete-with-error-msg runpath) - ) - runpaths - ) - ))))) - )) - runs) - ;; special case - archive get - (if (equal? (args:get-arg "-archive") "get") - (archive:bup-get-data "get" #f #f test-records rp-mutex bup-mutex)) - (if (or (equal? (args:get-arg "-archive") "save") (equal? (args:get-arg "-archive") "save-remove")) - (begin - (debug:print 0 *default-log-port* "db archive started") - (archive:megatest-db target runnamepatt) - (debug:print 0 *default-log-port* "db archived"))) - ) - #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) - (common:nice-path run-dir) - #f)) - (clean-mode (or mode 'remove-all)) - (test-id (db:test-get-id test)) - ;; (lock-key (conc "test-" test-id)) - ;; (got-lock (let loop ((lock (rmt:no-sync-get-lock lock-key)) - ;; (expire-time (+ (current-seconds) 30))) ;; give up on getting the lock and steal it after 15 seconds - ;; (if (car lock) - ;; #t - ;; (if (> (current-seconds) expire-time) - ;; (begin - ;; (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to clean test with id " test-id) - ;; (rmt:no-sync-del! lock-key) ;; destroy the lock - ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;; - ;; (begin - ;; (thread-sleep! 1) - ;; (loop (rmt:no-sync-get-lock lock-key) expire-time))))))) - ) - (case clean-mode - ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) - ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) - ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) - (debug:print-info 2 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) - (if (and real-dir - (> (string-length real-dir) 5) - (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. - (let* ((realpath (resolve-pathname run-dir))) - (debug:print-info 1 *default-log-port* "Recursively removing " realpath) - (if (common:file-exists? realpath) - (runs:safe-delete-test-dir realpath) - (debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable"))) - (if real-dir - (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist") - (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) - (if (symbolic-link? run-dir) - (begin - (debug:print-info 1 *default-log-port* "Removing symlink " run-dir) - (handle-exceptions - exn - (debug:print-error 0 *default-log-port* " Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue, exn=" exn) - (delete-file run-dir))) - (if (directory? run-dir) - (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) - (debug:print 0 *default-log-port* "WARNING: refusing to remove " run-dir " as it is not empty") - (handle-exceptions - exn - (debug:print-error 0 *default-log-port* " Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue, exn=" exn) - (delete-directory run-dir))) - (if (and run-dir - (not (member run-dir (list "n/a" "/tmp/badname")))) - (debug:print 0 *default-log-port* "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") - (debug:print 0 *default-log-port* "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) - )) - ;; Only delete the records *after* removing the directory. If things fail we have a record - (case clean-mode - ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) (db:test-get-state test)(db:test-get-status test) #f)) - ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) - (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test)))) - ;; (rmt:no-sync-del! lock-key) - )) - -;;====================================================================== -;; Routines for manipulating runs -;;====================================================================== - -;; Since many calls to a run require pretty much the same setup -;; this wrapper is used to reduce the replication of code -(define (general-run-call switchname action-desc proc) - (let ((runname (common:args-get-runname)) - (target (common:args-get-target))) - (cond - ((not target) - (debug:print-error 0 *default-log-port* "Missing required parameter for " switchname ", you must specify the target with -target") - (exit 3)) - ((not runname) - (debug:print-error 0 *default-log-port* "Missing required parameter for " switchname ", you must specify the run name with -runname runname") - (exit 3)) - (else - (let (;; (db #f) - (keys #f)) - (if (launch:setup) - (begin - (full-runconfigs-read) ;; cache the run config - ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW. - ) ;; do not cache here - need to be sure runconfigs is processed - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - - - (set! keys (keys:config-get-fields *configdat*)) - ;; have enough to process -target or -reqtarg here - (if (args:get-arg "-reqtarg") - (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL - (runconfig (read-config runconfigf #f #t environ-patt: #f))) - (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) - (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) - - (begin - (debug:print-error 0 *default-log-port* "[" (args:get-arg "-reqtarg") "] not found in " runconfigf) - ;; (if db (sqlite3:finalize! db)) - (exit 1) - ))) - (if (args:get-arg "-target") - (keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash))) - (if (not (car *configinfo*)) - (begin - (debug:print-error 0 *default-log-port* "Attempted to " action-desc " but run area config file not found") - (exit 1)) - ;; Extract out stuff needed in most or many calls - ;; here then call proc - (let* ((keyvals (keys:target->keyval keys target))) - (proc target runname keys keyvals))) - ;; (if db (sqlite3:finalize! db)) - (set! *didsomething* #t)))))) - -;;====================================================================== -;; Lock/unlock runs -;;====================================================================== - -(define (runs:handle-locking target keys runname lock unlock user) - (let* ((db #f) - (rundat (mt:get-runs-by-patt keys runname target)) - (header (vector-ref rundat 0)) - (runs (vector-ref rundat 1))) - (for-each (lambda (run) - (let ((run-id (db:get-value-by-header run header "id")) - (str (if lock - "lock" - "unlock"))) - (if (or lock - (and unlock - (or (args:get-arg "-force") - (begin - (print "Do you really wish to unlock run " run-id "?\n y/n: ") - (equal? "y" (read-line)))))) - (begin - (rmt:lock/unlock-run run-id lock unlock user) - (debug:print-info 0 *default-log-port* "Done " str " on run id " run-id)) - (debug:print-info 0 *default-log-port* "Skipping lock/unlock on " run-id)))) - runs))) -;;====================================================================== -;; Rollup runs -;;====================================================================== - -;; Update the test_meta table for this test -(define (runs:update-test_meta test-name test-conf) - (let ((currrecord (rmt:testmeta-get-record test-name))) - (if (not currrecord) - (begin - (set! currrecord (make-vector 11 #f)) - (rmt:testmeta-add-record test-name))) - (for-each - (lambda (key) - (let* ((idx (cadr key)) - (fld (car key)) - (val (configf:lookup test-conf "test_meta" fld))) - ;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val) - (if (and val (not (equal? (vector-ref currrecord idx) val))) - (begin - (debug:print 0 *default-log-port* "Updating " test-name " " fld " to " val) - (rmt:testmeta-update-field test-name fld val))))) - '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) - -;; find tests with matching tags, tagpatt is a string "tagpatt1,tagpatt2%, ..." -;; -(define (runs:get-tests-matching-tags tagpatt) - (let* ((tagdata (rmt:get-tests-tags)) - (res '())) ;; list of tests that match one or more tags - (for-each - (lambda (row) - (let* ((tag (car row)) - (tests (cdr row))) - (if (patt-list-match tag tagpatt) - (set! res (append tests res))))) - tagdata) - res)) - - -;; Update test_meta for all tests -(define (runs:update-all-test_meta db) - (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) - (for-each - (lambda (test-name) - (let* ((test-conf (mt:lazy-read-test-config test-name))) - (if test-conf (runs:update-test_meta test-name test-conf)))) - (hash-table-keys test-names)))) - -;; This could probably be refactored into one complex query ... -;; NOT PORTED - DO NOT USE YET -;; -#;(define (runs:rollup-run keys runname user keyvals) - (debug:print 4 *default-log-port* "runs:rollup-run, keys: " keys " -runname " runname " user: " user) - (let* ((db #f) - ;; register run operates on the main db - (new-run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) - (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) - (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '())) - (curr-tests-hash (make-hash-table))) - (rmt:update-run-event_time new-run-id) - ;; index the already saved tests by testname and itemdat in curr-tests-hash - (for-each - (lambda (testdat) - (let* ((testname (db:test-get-testname testdat)) - (item-path (db:test-get-item-path testdat)) - (full-name (conc testname "/" item-path))) - (hash-table-set! curr-tests-hash full-name testdat))) - curr-tests) - ;; NOPE: Non-optimal approach. Try this instead. - ;; 1. tests are received in a list, most recent first - ;; 2. replace the rollup test with the new *always* - (for-each - (lambda (testdat) - (let* ((testname (db:test-get-testname testdat)) - (item-path (db:test-get-item-path testdat)) - (full-name (conc testname "/" item-path)) - (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) - (test-steps (rmt:get-steps-for-test (db:test-get-id testdat))) - (new-test-record #f)) - ;; replace these with insert ... select - (apply sqlite3:execute - db - (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " - "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") - new-run-id (cddr (vector->list testdat))) - (set! new-testdat (car (mt:get-tests-for-run new-run-id (conc testname "/" item-path) '() '()))) - (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? - ;; Now duplicate the test steps - (debug:print 4 *default-log-port* "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) - (cdb:remote-run ;; to be replaced, note: this routine is not used currently - (lambda () - (sqlite3:execute - db - (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " - "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") - (db:test-get-id testdat)) - ;; Now duplicate the test data - (debug:print 4 *default-log-port* "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) - (sqlite3:execute - db - (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) " - "SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;") - (db:test-get-id testdat)))) - )) - prev-tests))) - -(define doc-template - '(*TOP* - (*PI* xml "version='1.0'") - (testsuite))) - -(define (runs:update-junit-test-reporter-xml run-id) - (let* ( - (junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml")) - (junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir")) - (xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" )) - (if junit-test-report-dir - junit-test-report-dir - (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))) - #f)) - (xml-ts-name (if xml-dir - (conc (getenv "MT_TESTSUITENAME")"."(string-translate (getenv "MT_TARGET") "/" ".") "." (getenv "MT_RUNNAME")) - #f)) - (keyname (if xml-ts-name (common:get-signature xml-ts-name) #f)) - (xml-path (if xml-dir - (conc xml-dir "/" keyname ".xml") - #f)) - - (test-data (if xml-dir - (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses - #f #f ;; offset limit - #f ;; not-in - #f ;; sort-by - #f ;; sort-order - #f ;; get full data (not 'shortlist) - 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time - #f) - '())) - (tests-count (if xml-dir (length test-data) #f))) - (if (and junit-test-reporter (equal? junit-test-reporter "yes" )) - (begin - ;((sxml-modify! `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count)))) doc) - - (let loop ((test (car test-data)) - (tail (cdr test-data)) - (doc doc-template) - (fail-cnt 0) - (error-cnt 0)) - (let* ((test-name (vector-ref test 2)) - (test-itempath (vector-ref test 11)) - (tc-name (conc test-name (if (and test-itempath (not (equal? test-itempath ""))) (conc "." (string-translate test-itempath "/" "." )) ""))) - (test-state (vector-ref test 3)) - (comment (vector-ref test 14)) - (test-status (vector-ref test 4)) - (exc-msg (conc "No bucket for State " test-state " Status " test-status)) - (new-doc (cond - ((member test-state (list "RUNNING" )) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc)) - ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc)) - ((member test-status (list "PASS" "WARN" "WAIVED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc)) - ((member test-status (list "FAIL" "CHECK")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) - ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc)) - ((member test-status (list "SKIP")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc)) - (else - (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status)) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc)))) - (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) - (+ error-cnt 1) - error-cnt)) - (new-fail-cnt (if (member test-status (list "FAIL" "CHECK")) - (+ fail-cnt 1) - fail-cnt))) - (if (null? tail) - (let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc))) - (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt) - (handle-exceptions - exn - (let* ((msg ((condition-property-accessor 'exn 'message) exn))) - (debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg ", exn=" exn))) - - (if (not (file-exists? xml-dir)) - (create-directory xml-dir #t)) - (if (not (rmt:no-sync-get/default keyname #f)) - (begin - (rmt:no-sync-set keyname "on") - (debug:print 0 *default-log-port* "creating xml at " xml-path) - (with-output-to-file xml-path - (lambda () - (print (sxml-serializer#serialize-sxml final-doc ns-prefixes: (list (cons 'gnm "http://foo")))))) - (rmt:no-sync-del! keyname)) - (debug:print 0 *default-log-port* "Could not get the lock. Skip writing the xml file.")))) - (loop (car tail) (cdr tail) new-doc new-fail-cnt new-error-cnt)))))))) - - -;; clean cache files -(define (runs:clean-cache target runname toppath) - (if target - (if runname - (let* ((linktree (common:get-linktree)) ;; (if toppath (configf:lookup *configdat* "setup" "linktree"))) - (runtop (conc linktree "/" target "/" runname)) - (files (if (common:file-exists? runtop) - (append (glob (conc runtop "/.megatest*")) - (glob (conc runtop "/.runconfig*"))) - '()))) - (if (null? files) - (debug:print-info 2 *default-log-port* "No cached megatest or runconfigs files found. None removed.") - (begin - (debug:print-info 2 *default-log-port* "Removing cached files:\n " (string-intersperse files "\n ")) - (for-each - (lambda (f) - (handle-exceptions - exn - (debug:print 0 *default-log-port* "WARNING: Failed to remove file " f ", exn=" exn) - (delete-file f))) - files)))) - (debug:print-error 0 *default-log-port* "-clean-cache requires -runname.")) - (debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg"))) ADDED runsmod.scm Index: runsmod.scm ================================================================== --- /dev/null +++ runsmod.scm @@ -0,0 +1,4546 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +;;====================================================================== +;; Cpumod: +;; +;; Put things here don't fit anywhere else +;;====================================================================== + +(declare (unit runsmod)) +(declare (uses debugprint)) +(declare (uses mtargs)) +(declare (uses commonmod)) +(declare (uses configfmod)) +(declare (uses dbfile)) +(declare (uses dbmod)) +(declare (uses rmtmod)) +(declare (uses servermod)) +(declare (uses processmod)) +(declare (uses pgdb)) +(declare (uses mtmod)) +(declare (uses megatestmod)) +(declare (uses tasksmod)) +(declare (uses testsmod)) +(declare (uses subrunmod)) +(declare (uses archivemod)) +(declare (uses fsmod)) + +(use srfi-69) + +(module runsmod + * + +(import scheme) +(cond-expand + (chicken-4 + + (import chicken + ports + data-structures + extras + files + matchable + pathname-expand + posix + posix-extras + regex + regex-case + sparse-vectors + + ) + (use srfi-69)) + (chicken-5 + (import (prefix sqlite3 sqlite3:) + chicken.base + chicken.condition + chicken.file + chicken.file.posix + chicken.io + chicken.pathname + chicken.port + chicken.process + chicken.process-context + chicken.process-context.posix + chicken.sort + chicken.string + chicken.time + chicken.time.posix + + matchable + md5 + message-digest + pathname-expand + regex + regex-case + system-information + + ))) + +;; imports common to ck4 and ck5 +(import srfi-1 + srfi-13 + srfi-18 + srfi-69 + typed-records + (prefix base64 base64:) + (prefix sqlite3 sqlite3:) + md5 + message-digest + z3 + directory-utils + sxml-serializer + sxml-modifications + + debugprint + commonmod + configfmod + (prefix mtargs args:) + dbmod + dbfile + rmtmod + servermod + processmod + pgdb + mtmod + megatestmod + tasksmod + testsmod + subrunmod + archivemod + fsmod + ) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") +(include "test_records.scm") + +;; use this struct to facilitate refactoring +;; + +(defstruct runs:dat + reglen regfull + runname max-concurrent-jobs run-id + test-patts required-tests test-registry + registry-mutex flags keyvals run-info all-tests-registry + ;; stores results from last runs:can-run-more-tests + (can-run-more-tests #f) ;; (list can-run-more-flag num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit) + ((can-run-more-tests-count 0) : fixnum) + (last-fuel-check 0) ;; time when we last checked fuel + (beginning-of-time (current-seconds)) + (load-mgmt-function #f) + (wait-for-jobs-function #f) + (last-load-check-time 0) + (last-jobs-check-time 0) + ) + +(defstruct runs:testdat + hed tal reg reruns test-record + test-name item-path jobgroup + waitons testmode newtal itemmaps prereqs-not-met) + +;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files +;; - remove any that are over 3600 seconds old +;; - if there are any that are younger than 10 seconds +;; * sleep 10 seconds +;; * touch my key-host-pid.softlock file +;; * return +;; - if there are no files younger than 10 seconds +;; * touch my key-host-pid.softlock file +;; * return +;; +(define (runs:wait-on-softlock rdat key) + (if (not (and *toppath* (file-exists? *toppath*))) ;; don't seem to have toppath yet + (debug:print-info 0 *default-log-port* "Can't create softlocks - don't see MTRAH yet.") + (let* ((softlocks-dir (conc *toppath* "/.softlocks"))) + (if (not (file-exists? softlocks-dir)) + (create-directory softlocks-dir #t)) + (let* ((my-lock-file (conc softlocks-dir "/" key "-" (get-host-name) "-" (current-process-id) ".softlock")) + (lock-files (filter (lambda (x) + (not (equal? x my-lock-file))) + (glob (conc softlocks-dir "/" key "*.softlock")))) + (fresh-locks (any (lambda (x) ;; do we have any locks younger than 10 seconds + (let* ((mod-time (file-modification-time x)) + (age (- (current-seconds) mod-time))) + (cond + ((> age 3600) ;; too old to keep, remove it + (delete-file* x) #f) + ((< age 10) #t) + (else #f)))) + lock-files))) + (if fresh-locks + (begin + (if (runs:lownoise "runners-softlock-wait" 360) + (debug:print-info 0 *default-log-port* "Other runners in flight, giving up some time...")) + (thread-sleep! 2)) + (begin + (if (runs:lownoise "runners-softlock-nowait" 360) + (debug:print-info 0 *default-log-port* "No runners in flight, updating softlock")) + (let* ((ouf (open-output-file my-lock-file))) + (with-output-to-port ouf (lambda ()(print (current-seconds)))) + (close-output-port ouf)))) + (runs:dat-last-fuel-check-set! rdat (current-seconds)))))) + +;; Fourth try, do accounting through time.... +;; +(define (runs:parallel-runners-mgmt rdat) + (let ((time-to-check (configf:lookup-number *configdat* "runners" "time-to-check" default: 10)) ;; 28 + (time-to-wait (configf:lookup-number *configdat* "runners" "time-to-wait" default: 30)) + (now-time (current-seconds))) + (if (> (- now-time (runs:dat-last-fuel-check rdat)) time-to-check) ;; time to check + (runs:wait-on-softlock rdat "runners")))) + +;; To test parallel-runners management start a repl: +;; megatest -repl +;; then run: +;; (runs:test-parallel-runners 60) +;; +(define (runs:test-parallel-runners duration #!optional (proc #f)) + (let* ((rdat (make-runs:dat)) + (rtime 0) + (startt (current-seconds)) + (endt (+ startt duration))) + ((or proc runs:parallel-runners-mgmt) rdat) + (let loop () + (let* ((wstart (current-seconds))) + (if (< wstart endt) + (let* ((work-time (random 10))) + #;(debug:print-info 0 *default-log-port* "working for " work-time + " seconds. Total work: " rtime ", elapsed time: " (- wstart startt)) + (thread-sleep! work-time) + (set! rtime (+ rtime work-time)) + ((or proc runs:parallel-runners-mgmt) rdat) + (loop))))) + (let* ((done-time (current-seconds))) + (debug:print-info 0 *default-log-port* "DONE: rtime=" rtime ", elapsed time=" (- done-time startt) + ", ratio=" (/ rtime (- done-time startt)))))) + +(define (runs:get-mt-env-alist run-id runname target testname itempath) + ;;(bb-check-path msg: "runs:set-megatest-env-vars entry") + `(("MT_TEST_NAME" . ,testname) + + ("MT_ITEMPATH" . ,itempath) + + ("MT_TARGET" . ,target) + + ("MT_RUNNAME" . ,runname) + + ("MT_RUN_AREA_HOME" . ,*toppath*) + + ,@(let* ((link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) + (if link-tree + (list (cons "MT_LINKTREE" link-tree) + + (cons "MT_TEST_RUN_DIR" + (conc link-tree "/" target "/" runname "/" testname + (if (and (string? itempath) (not (equal? itempath ""))) + (conc "/" itempath) + ""))) + ) + '())) + + ,@(map + (lambda (key) + (cons (car key) (cadr key))) + (keys:target->keyval (rmt:get-keys) target)) + + ,@(map (lambda (var) + (let ((val (configf:lookup *configdat* "env-override" var))) + (cons var val))) + (configf:section-vars *configdat* "env-override")))) + + +;; Every time can-run-more-tests is called increment the delay +;; +;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine +;; +(define *last-num-running-tests* 0) +;; (define *runs:can-run-more-tests-count* 0) +(define (runs:shrink-can-run-more-tests-count runsdat) + (runs:dat-can-run-more-tests-count-set! runsdat 0)) + +(define (runs:inc-can-run-more-tests-count runsdat) + (runs:dat-can-run-more-tests-count-set! + runsdat + (+ (runs:dat-can-run-more-tests-count runsdat) 1))) + +;; (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2))) + +;; Temporary globals. Move these into the logic or into common +;; +(define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run +(define (runs:inc-cant-run-tests testname) + (hash-table-set! *seen-cant-run-tests* testname + (+ (hash-table-ref/default *seen-cant-run-tests* testname 0) 1))) + +(define (runs:can-keep-running? testname n) + (< (hash-table-ref/default *seen-cant-run-tests* testname 0) n)) + +(define *runs:denoise* (make-hash-table)) ;; key => last-time-ran + +;; mechanism to limit printing info to the screen that is repetitive. +;; +;; Example: +;; (if (runs:lownoise "waiting on tasks" 60) +;; (debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ...")) +;; +(define (runs:lownoise key waitval) + (let ((lasttime (hash-table-ref/default *runs:denoise* key 0)) + (currtime (current-seconds))) + (if (> (- currtime lasttime) waitval) + (begin + (hash-table-set! *runs:denoise* key currtime) + #t) + #f))) + +(define *last-test-launch* 0) +(define *too-soon-delays* (make-hash-table)) + +;; to-soon delay, when matching event happened in less than dseconds delay wseconds +;; +(define (runs:too-soon-delay key dseconds wseconds) + (let* ((last-time (hash-table-ref/default *too-soon-delays* key #f))) + (if (and last-time + (< (- (current-seconds) last-time) dseconds)) + (begin + (if (runs:lownoise (conc "too-soon-delay"key) 60) + (debug:print-info 2 *default-log-port* "Polling throttle for "key)) + (thread-sleep! wseconds))) + (hash-table-set! *too-soon-delays* key (current-seconds)))) + +(define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) + + ;; Take advantage of a good place to exit if running the one-pass methodology + (if (and (> (runs:dat-can-run-more-tests-count runsdat) 20) + (args:get-arg "-one-pass")) + (exit 0)) + + (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) + + (let* ((num-running (rmt:get-count-tests-running-for-run-id run-id)) + (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) + (job-group-limit (let ((jobg-count (configf:lookup *configdat* "jobgroups" jobgroup))) + (if (string? jobg-count) + (string->number jobg-count) + jobg-count)))) + (if (> (+ num-running num-running-in-jobgroup) 0) + (runs:inc-can-run-more-tests-count runsdat)) ;; (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) + (if (not (eq? *last-num-running-tests* num-running)) + (begin + (debug:print 2 *default-log-port* "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) + (set! *last-num-running-tests* num-running))) + (if (not (eq? 0 *globalexitstatus*)) + (list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit) + (let* ((can-not-run-more (cond + ;; if max-concurrent-jobs is set and the number running is greater + ;; than it then cannot run more jobs + ((and max-concurrent-jobs (>= num-running max-concurrent-jobs)) + (if (runs:lownoise "mcj msg" 60) + (debug:print 0 *default-log-port* "WARNING: Max running jobs exceeded, current number running: " num-running + ", max_concurrent_jobs: " max-concurrent-jobs)) + #t) + ;; if job-group-limit is set and number of jobs in the group is greater + ;; than the limit then cannot run more jobs of this kind + ((and job-group-limit + (>= num-running-in-jobgroup job-group-limit)) + (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60) + (debug:print 1 *default-log-port* "WARNING: number of jobs " num-running-in-jobgroup + " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) + #t) + (else #f)))) + (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) + +(define (runs:run-pre-hook run-id) + (let* ((run-pre-hook (configf:lookup *configdat* "runs" "pre-hook")) + (existing-tests (if run-pre-hook + (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses + #f #f ;; offset limit + #f ;; not-in + #f ;; sort-by + #f ;; sort-order + #f ;; get full data (not 'shortlist) + 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time + 'dashboard) + '())) + (log-dir (conc *toppath* "/logs")) + (log-file (conc "pre-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log")) + (full-log-fname (conc log-dir "/" log-file))) + (if run-pre-hook + (if (null? existing-tests) + (let* ((use-log-dir (if (not (directory-exists? log-dir)) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir ", exn=" exn) + #f) + (create-directory log-dir #t) + #t) + #t)) + (start-time (current-seconds)) + (actual-logf (if use-log-dir full-log-fname log-file))) + (handle-exceptions + exn + (begin + (print-call-chain *default-log-port*) + (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + (debug:print 0 *default-log-port* "ERROR: failed to run pre-hook " run-pre-hook ", check the log " log-file)) + (debug:print-info 0 *default-log-port* "running run-pre-hook: \"" run-pre-hook "\", log is " actual-logf) + (system (conc run-pre-hook " >> " actual-logf " 2>&1")) + (debug:print-info 0 *default-log-port* "pre-hook \"" run-pre-hook "\" took " (- (current-seconds) start-time) " seconds to run."))) + (debug:print 0 *default-log-port* "Skipping pre-hook call \"" run-pre-hook "\" as there are existing tests for this run."))))) + + + +(define (runs:run-post-hook run-id) + (let* ((run-post-hook (configf:lookup *configdat* "runs" "post-hook")) + (existing-tests (if run-post-hook + (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses + #f #f ;; offset limit + #f ;; not-in + #f ;; sort-by + #f ;; sort-order + #f ;; get full data (not 'shortlist) + 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time + 'dashboard) + '())) + (log-dir (conc *toppath* "/logs")) + (log-file (conc "post-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log")) + (full-log-fname (conc log-dir "/" log-file))) + (if run-post-hook + ;; (if (null? existing-tests) + ;; (debug:print 0 *default-log-port* "Skipping post-hook call \"" run-post-hook "\" as there are existing tests for this run."))))) + (let* ((use-log-dir (if (not (directory-exists? log-dir)) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir ", exn=" exn) + #f) + (create-directory log-dir #t) + #t) + #t)) + (start-time (current-seconds)) + (actual-logf (if use-log-dir full-log-fname log-file))) + (handle-exceptions + exn + (begin + (print-call-chain *default-log-port*) + (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + (debug:print 0 *default-log-port* "ERROR: failed to run post-hook " run-post-hook ", check the log " log-file)) + (debug:print-info 0 *default-log-port* "running run-post-hook: \"" run-post-hook "\", log is " actual-logf) + (system (conc run-post-hook " >> " actual-logf " 2>&1")) + (debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))))) + + +(define (runs:rerun-hook test-id new-test-path testdat rerunlst) + (let* ((rerun-hook (configf:lookup *configdat* "runs" "rerun-hook")) + (log-dir (conc *toppath* "/reruns/logs")) + (target (getenv "MT_TARGET")) + (runname (common:args-get-runname)) + (rundir (db:test-get-rundir testdat)) + (tarfiledir (conc *toppath* "/reruns")) + (status (db:test-get-status testdat)) + (comment (conc "\"" (db:test-get-comment testdat) "\"" )) + (testname (db:test-get-testname testdat)) + (itempath (db:test-get-item-path testdat)) + (file-body (conc status "-" (string-translate target "/" "-") "-" runname "." testname (if (not (string=? itempath "")) (conc "." (string-translate itempath "/" "-")) ""))) + (log-file (conc file-body ".log")) + ;; (log-file (conc status "-" (string-translate target "/" "-") "-" runname "." testname (if (not (string=? itempath "")) (conc "." (string-translate itempath "/" "-")) "") ".log")) + (full-log-fname (conc log-dir "/" log-file)) + (tarfilename (conc file-body ".tar")) + ;; (tarfilename (conc status "." (string-translate target "/" "-") "." runname "." testname (if (not (string=? itempath "")) (conc "." (string-translate itempath "/" "-")) "") ".tar")) + ) + (if rerun-hook + (let* ((use-log-dir (if (not (directory-exists? log-dir)) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir ", exn=" exn) + #f) + (create-directory log-dir #t) + #t) + #t)) + (start-time (current-seconds)) + (actual-logf (if use-log-dir full-log-fname log-file)) + (sys-call-text (conc rerun-hook " " tarfilename " " rundir " " actual-logf " " runname " " tarfiledir " " status " " target " " comment " " testname " " itempath " >> " actual-logf " 2>&1")) + ) + (debug:print 2 *default-log-port* "Found rerun-hook in config:" rerun-hook) + (handle-exceptions + exn + (begin + (print-call-chain *default-log-port*) + (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + (debug:print 0 *default-log-port* "ERROR: failed to run rerun-hook " rerun-hook ", check the log " log-file)) + (debug:print-info 0 *default-log-port* "running rerun-hook: \"" rerun-hook "\", log is " actual-logf) + ;; call the hook + (debug:print-info 0 *default-log-port* "Calling rerun-hook for " test-id new-test-path testdat rerunlst) + (debug:print-info 0 *default-log-port* "rerun hook: " rerun-hook) + (debug:print-info 0 *default-log-port* "tarfilename: " tarfilename) + (debug:print-info 0 *default-log-port* "rundir: " rundir) + (debug:print-info 0 *default-log-port* "actual-logf: " actual-logf) + (debug:print-info 0 *default-log-port* "runname: " runname) + (debug:print-info 0 *default-log-port* "sys-call-text: " sys-call-text) + (system sys-call-text) + (debug:print-info 0 *default-log-port* "rerun-hook \"" rerun-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))))) + + + + +;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise. +(define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon) + (null? (tests:filter-test-names-not-matched waitors-upon test-patt))) + +;;====================================================================== +;; runs:run-tests is called from megatest.scm and itself +;;====================================================================== +;; +;; test-names: Comma separated patterns same as test-patts but used in selection +;; of tests to run. The item portions are not respected. +;; FIXME: error out if /patt specified +;; +;; run-count is passed from megatest.scm as configf:lookup *configdat* "setup" "reruns", or defaults to 1. +(define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names + (let* ((keys (keys:config-get-fields *configdat*)) + (keyvals (keys:target->keyval keys target)) + (run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name))) + ;; (deferred '()) ;; delay running these since they have a waiton clause + (runconfigf (conc *toppath* "/runconfigs.config")) + (mtconfig (conc *toppath* "/megatest.config")) + (readonly-mode (not (file-write-access? mtconfig))) + (test-records (make-hash-table)) + ;; need to process runconfigs before generating these lists + (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names + (all-test-names #f) ;; (hash-table-keys all-tests-registry)) + (test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts)) + (required-tests #f) ;; Put fully qualified test/testpath names in this list to be done + (waitors-upon (make-hash-table)) ;; given a test, return list of tests waiting upon this test. + (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) + ;; (tdbdat (tasks:open-db)) + (config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) + (if x (string->number x) #f))) + (allowed-tests #f) + (runconf #f)) + + ;; check if readonly + (when readonly-mode + (debug:print-error 0 *default-log-port* "Megatest database is readonly. Cannot proceed.") + (exit 1)) + + ;; per user request. If less than 100Meg space on dbdir partition, bail out with error + ;; this will reduce issues in database corruption + (common:check-db-dir-and-exit-if-insufficient) + + ;; override the number of reruns from the configs + ;; this needs to be done at the place where is first runs:run-tests called + ;(if (and config-reruns + ; (> run-count config-reruns)) + ;(set! run-count config-reruns)) + + ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) + + (let ((sighand (lambda (signum) + ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting + (set! *time-to-exit* #t) + (debug:print 0 *default-log-port* "Received signal " signum ", cleaning up before exit. Please wait...") + (let ((th1 (make-thread (lambda () + ;; (let ((tdbdat (tasks:open-db))) + (rmt:tasks-set-state-given-param-key task-key "killed") ;; ) + (debug:print 0 *default-log-port* "Killed by signal " signum ". Exiting") + (thread-sleep! 3) + (exit)))) + (th2 (make-thread (lambda () + (thread-sleep! 5) + (debug:print 0 *default-log-port* "Done") + (exit 4))))) + (thread-start! th2) + (thread-start! th1) + (thread-join! th2))))) + (set-signal-handler! signal/int sighand) + (set-signal-handler! signal/term sighand)) + + ;; force the starting of a server -- removed BB 17ww28 - no longer needed. + ;;(debug:print 0 *default-log-port* "waiting on server...") + ;;(server:start-and-wait *toppath*) + + (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process + (set! runconf (if (common:file-exists? runconfigf) + (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) + (begin + (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf) + #f))) + + (if (not test-patts) ;; first time in - adjust testpatt + (set! test-patts (common:args-get-testpatt runconf))) + ;; if test-patts is #f at this point there is something wrong and we need to bail out + (if (not test-patts) + (begin + (debug:print 0 *default-log-port* "WARNING: there is no test pattern for this run. Exiting now.") + (exit 0))) + + (if (args:get-arg "-tagexpr") + (begin + (set! allowed-tests (string-join (runs:get-tests-matching-tags (args:get-arg "-tagexpr")) ",")) + (debug:print-info 0 *default-log-port* "filtering initial test list with tagexpr: " (args:get-arg "-tagexpr") " => " allowed-tests) + ));; tests will be ANDed with this list + + ;; register this run in monitor.db + (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params) + (rmt:tasks-set-state-given-param-key task-key "running") + + #;(common:telemetry-log "run-tests" + payload: + `( (target . ,target) + (run-name . ,runname) + (test-patts . ,test-patts) ) ) + + + ;; Now generate all the tests lists + (set! all-tests-registry (tests:get-all)) ;; hash of testname => path-to-test + (set! all-test-names (hash-table-keys all-tests-registry)) + ;; filter first for allowed-tests (from -tagexpr) then for test-patts. + (set! test-names (tests:filter-test-names + (if allowed-tests + (tests:filter-test-names all-test-names allowed-tests) + all-test-names) + test-patts)) + + ;; I think seeding required-tests with all test-names makes sense but lack analysis to back that up. + + ;; NEW STRATEGY HERE: + ;; 1. fill required tests with test-patts + ;; 2. scan testconfigs and if waitons, itemwait, itempatt calc prior test test-patt + ;; 3. repeat until all deps propagated + + ;; any tests with direct mention in test-patts can be added to required + ;;(set! required-tests (lset-intersection equal? (string-split test-patts ",") all-test-names)) + (set! required-tests (tests:filter-test-names all-test-names test-patts)) + ;; + ;; (set! required-tests (lset-intersection equal? test-names all-test-names)) + + ;; look up all tests matching the comma separated list of globs in + ;; test-patts (using % as wildcard) + + ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) + (debug:print-info 0 *default-log-port* "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " ")) + (debug:print-info 2 *default-log-port* "all tests: " (string-intersperse (sort all-test-names string<) " ")) + (debug:print-info 0 *default-log-port* "test names: " (string-intersperse (sort test-names string<) " ")) + (debug:print-info 0 *default-log-port* "required tests: " (string-intersperse (sort required-tests string<) " ")) + + ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if + ;; -keepgoing is specified + (if (eq? *passnum* 0) + (begin + ;; Is this still necessary? I think not. Unreachable tests are marked as such and + ;; should not cause problems here. + ;; + ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to + ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends + ;; on test A but test B reached the point on being registered as NOT_STARTED and test + ;; A failed for some reason then on re-run using -keepgoing the run can never complete. + ;; + ;; (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED") + + ;; Now convert anything in allow-auto-rerun to NOT_STARTED + ;; + (for-each + (lambda (state-status) + (let* ((ss-lst (string-split-fields "/" state-status #:infix)) + (state (if (> (length ss-lst) 0)(car ss-lst) #f)) + (status (if (> (length ss-lst) 1)(cadr ss-lst) #f))) + (rmt:set-tests-state-status run-id test-names state status "NOT_STARTED" status))) + ;; list of state/status pairs separated by spaces + (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") ""))))) + + ;; Ensure all tests are registered in the test_meta table + (runs:update-all-test_meta #f) + + ;; run the run prehook if there are no tests yet run for this run: + ;; + (runs:run-pre-hook run-id) + ;; mark all test launched flag as false in the meta table + (rmt:set-var (conc "lunch-complete-" run-id) "no") + (debug:print-info 1 *default-log-port* "Setting end-of-run to no") + (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) + (if x (string->number x) #f))) + (config-rerun-cnt (if config-reruns + config-reruns + 1))) + (if (eq? config-rerun-cnt run-count) + (rmt:set-var (conc "end-of-run-" run-id) "no"))) + + (rmt:set-run-state-status run-id "new" "n/a") + ;; now add non-directly referenced dependencies (i.e. waiton) + ;;====================================================================== + ;; refactoring this block into tests:get-full-data + ;; + ;; What happended, this code is now duplicated in tests!? + ;; + ;;====================================================================== + + (if (not (null? test-names)) ;; BEGIN test-names loop + (let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names + (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc + (debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names) + (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. + (setenv "MT_TEST_NAME" hed) ;; + (let*-values (((waitons waitors config) (tests:get-waitons hed all-tests-registry (tests:get-global-waitons *runconfigdat*))) + + ;; NOTE: Have the config - can extract [waitons] section + + ((hed-mode) + (let ((m (configf:lookup config "requirements" "mode"))) + (if m (map string->symbol (string-split m)) '(normal)))) + ((hed-itemized-waiton) ;; are items in hed waiting on items of waiton? + (not (null? (lset-intersection eq? hed-mode '(itemmatch itemwait))))) + ) + (debug:print-info 8 *default-log-port* "waitons: " waitons) + ;; check for hed in waitons => this would be circular, remove it and issue an + ;; error + (if (or (member hed waitons) + (member hed waitors)) + (begin + (debug:print-error 0 *default-log-port* "test " hed " has listed itself as a waiton or waitor, please correct this!") + (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)) + (set! waitors (filter (lambda (x)(not (equal? x hed))) waitors)))) + + ;; (items (items:get-items-from-config config))) + (if (not (hash-table-ref/default test-records hed #f)) ;; waiton-tconfig below will be #f until that test is visted here at least once + (hash-table-set! test-records ;; BB: we are doing a manual make-tests:testqueue + hed (vector hed ;; 0 ;; testname + config ;; 1 + waitons ;; 2 + (configf:lookup config "requirements" "priority") ;; priority 3 + (tests:get-items config) ;; 4 ;; expand the [items] and or [itemstable] into explict items + #f ;; itemsdat 5 + #f ;; spare - used for item-path + waitors ;; + ))) + ;; update waitors-upon here + (for-each + (lambda (waiton) + (let* ((current-waitors-upon (hash-table-ref/default waitors-upon waiton '()))) + (debug:print-info 8 *default-log-port* " current-waiters-upon["waiton"] is "current-waitors-upon ) + (when (not (member hed current-waitors-upon)) + (debug:print-info 8 *default-log-port* " current-waiters-upon["waiton"] << "hed ) + (hash-table-set! waitors-upon waiton (cons hed current-waitors-upon))))) + (if (list? waitons) waitons '())) + (debug:print-info 8 *default-log-port* " process waitons&waitors of "hed": "(delete-duplicates (append waitons waitors))) + (for-each + (lambda (waiton) + (if (and waiton (not (member waiton test-names))) + (let* ((waitors-in-testpatt (runs:testpatts-mention-waitors-upon? test-patts (hash-table-ref/default waitors-upon waiton '()))) + (waiton-record (hash-table-ref/default test-records waiton #f)) + (waiton-tconfig (if waiton-record (vector-ref waiton-record 1) #f)) + (waiton-itemized (and waiton-tconfig + (or (hash-table-ref/default waiton-tconfig "items" #f) + (hash-table-ref/default waiton-tconfig "itemstable" #f)))) + (itemmaps (tests:get-itemmaps config)) ;; (configf:lookup config "requirements" "itemmap")) + (new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps hed-itemized-waiton))) + (debug:print-info 2 *default-log-port* "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items") + ;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%" + ;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt + ;; is this satisfied by merely appending "/" to the waiton name added to the list? + ;; + ;; This approach causes all of the items in an upstream test to be run + ;; if we have this waiton already processed once we can analzye it for extending + ;; tests to be run, since we can't properly process waitons unless they have been + ;; initially added we add them again to be processed on second round AND add the hed + ;; back in to also be processed on second round + (if waiton-tconfig ;; BB: waiter should be in test-patts as well as the waiton have a tconfig. + (if waiton-itemized + (if waitors-in-testpatt + (begin + (debug:print-info 0 *default-log-port* "New test patts: " new-test-patts ", prev test patts: " test-patts) + (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read + (set! required-tests (cons (conc waiton "/") required-tests)) + (set! test-patts new-test-patts)) + (begin + (debug:print-info 0 *default-log-port* "Waitor(s) not yet on testpatt for " waiton ", setting up to re-process it") + (set! tal (append (cons waiton tal)(list hed))))) + (begin + (debug:print-info 2 *default-log-port* "Adding non-itemized test " waiton " to required-tests") + (set! required-tests (cons waiton required-tests)) + (set! test-patts new-test-patts))) + (begin + (debug:print-info 0 *default-log-port* "No testconfig info yet for " waiton ", setting up to re-process it") + (set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests)) + ;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts + ;; - doesn't work + ;; (set! test-patts (conc test-patts "," waiton "/")) + ;; (set! test-names (cons waiton test-names))))) ;; was an append, now a cons + ))) + (delete-duplicates (append waitons waitors))) + (let ((remtests (delete-duplicates (append waitons tal)))) + (debug:print-info 8 *default-log-port* " remtests are "remtests) + (if (not (null? remtests)) + (begin + ;; (debug:print-info 0 *default-log-port* "Preprocessing continues for " (string-intersperse remtests ", ")) + (loop (car remtests)(cdr remtests)))))))) ;; END test-names loop + + (if (not (null? required-tests)) + (debug:print-info 1 *default-log-port* "Adding \"" (string-intersperse required-tests " ") "\" to the run queue")) + ;; NOTE: these are all parent tests, items are not expanded yet. + (debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records)) + (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) + (if (> (length (hash-table-keys test-records)) 0) + (let* ((keep-going #t) + (run-queue-retries 5) + (run-ids (rmt:get-all-run-ids))) + #;(for-each (lambda (run-id) + (if keep-going + (handle-exceptions + exn + (debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id ", exn=" exn) + (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime))) ;; could be root of https://hsdes.intel.com/appstore/article/#/220546828/main -- Title: Megatest jobs show DEAD even though they are still running (1.64/27) + run-ids) + (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests + (any->number reglen) all-tests-registry) + (set! keep-going #f) + (if (> run-count 0) ;; handle reruns + (begin + (if (not (hash-table-ref/default flags "-preclean" #f)) + (hash-table-set! flags "-preclean" #t)) + (if (not (hash-table-ref/default flags "-rerun" #f)) + (hash-table-set! flags "-rerun" "ABORT,STUCK/DEAD,n/a,ZERO_ITEMS")) + (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))) + (launch:end-of-run-check run-id))) + (debug:print-info 0 *default-log-port* "No tests to run"))) + (debug:print-info 4 *default-log-port* "All done by here") + ;; TODO: try putting post hook call here + + ; (debug:print-info 2 *default-log-port* " run-count " run-count) + ; (runs:run-post-hook run-id)) + ; (debug:print-info 2 *default-log-port* "Not calling post hook runcount = " run-count )) + (rmt:tasks-set-state-given-param-key task-key "done") + + ;; (sqlite3:finalize! tasks-db) + )) + + +;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable. +;; +;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns +;; If reg is full (i.e. length >= n +;; loop with (car reg) tal (cdr reg) reruns +;; If tal is empty +;; but have items in reg; loop with (car reg)(cdr reg) '() reruns +;; If reg is empty => all done + +(define (runs:queue-next-hed tal reg n regfull) + (if regfull + (if (null? reg) #f (car reg)) + (if (null? tal) ;; tal is used up, pop from reg + (if (null? reg) #f (car reg)) + (car tal)))) + +(define (runs:queue-next-tal tal reg n regfull) + (if regfull + tal + (if (null? tal) ;; must transfer from reg + (if (null? reg) '() (cdr reg)) + (cdr tal)))) + +(define (runs:queue-next-reg tal reg n regfull) + (if regfull + (if (null? reg) '() (cdr reg)) ;; EXPLORE: reorder (cdr reg) such that looping is more efficient + (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal + '() + reg))) + +;; this is the list of parameters to the named loop "loop" near the top of runs:run-tests-queue, look around line 1216 +;; +(define (runs:loop-values tal reg reglen regfull reruns) + (list (runs:queue-next-hed tal reg reglen regfull) ;; hed + (runs:queue-next-tal tal reg reglen regfull) ;; tal + (runs:queue-next-reg tal reg reglen regfull) ;; reg + reruns)) ;; reruns + +;; objective - iterate thru tests +;; => want to prioritize tests we haven't seen before +;; => sometimes need to squeeze things in (added to reg) +;; => review of a previously seen test is higher priority of never visited test +;; reg - list of previously visited tests +;; tal - list of never visited tests +;; prefer next hed to be from reg than tal. + +(define runs:nothing-left-in-queue-count 0) + +;;====================================================================== +;; runs:expand-items is called by runs:run-tests-queue +;;====================================================================== +;; +;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature: +;; (let loop ((hed (car sorted-test-names)) +;; (tal (cdr sorted-test-names)) +;; (reg '()) ;; registered, put these at the head of tal +;; (reruns '())) +(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps) + (let* ((loop-list (list hed tal reg reruns)) + (junk (debug:print-info 4 *default-log-port* "expand-items calling rmt:get-prereqs-not-met")) + (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))) + (if (list? res) + res + (begin + (debug:print 0 *default-log-port* + "ERROR: rmt:get-prereqs-not-met returned non-list!\n" + " res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps) + '())))) + (have-itemized (not (null? (lset-intersection eq? testmode '(itemmatch itemwait))))) + ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) + (fails (runs:calc-fails prereqs-not-met)) + (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) + (non-completed (runs:calc-not-completed prereqs-not-met)) + (runnables (runs:calc-runnable prereqs-not-met)) + (unexpanded-prereqs + (filter (lambda (testname) + (let* ((test-rec (hash-table-ref test-records testname)) + (items (tests:testqueue-get-items test-rec))) + ;;(BB> "HEY " testname "=>"items) + (or (procedure? items)(eq? items 'have-procedure)))) + waitons)) + + + ) + (debug:print-info 4 *default-log-port* "START OF INNER COND #2 " + "\n can-run-more: " can-run-more + "\n testname: " hed + "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) + "\n non-completed: " (runs:pretty-string non-completed) + "\n prereq-fails: " (runs:pretty-string prereq-fails) + "\n fails: " (runs:pretty-string fails) + "\n testmode: " testmode + "\n (member 'toplevel testmode): " (member 'toplevel testmode) + "\n (null? non-completed): " (null? non-completed) + "\n reruns: " reruns + "\n items: " items + "\n can-run-more: " can-run-more) + + (cond + ;; all prereqs met, fire off the test + ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch + + ((and (not (member 'toplevel testmode)) + (member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a) + '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here + (debug:print-info 4 *default-log-port* "cond branch - " "ei-1") + (debug:print-info 1 *default-log-port* "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue") + (if (or (not (null? tal)) + (not (null? reg))) + (runs:loop-values tal reg reglen regfull reruns) + (begin + (debug:print-info 0 *default-log-port* "Nothing left in the queue!") + ;; If get here twice then we know we've tried to expand all items + ;; since there must be a logic issue with the handling of loops in the + ;; items expand phase we will brute force an exit here. + (if (> runs:nothing-left-in-queue-count 2) + (begin + (debug:print 0 *default-log-port* "WARNING: this condition is triggered when there were no items to expand and nothing to run. Please check your run for completeness") + (exit 0)) + (set! runs:nothing-left-in-queue-count (+ runs:nothing-left-in-queue-count 1))) + #f))) + + ;; desired result of below cond branch: + ;; we want to expand items in our test of interest (hed) in the following cases: + ;; case 1 - mode is itemmatch or itemwait: + ;; - all prereq tests have been expanded + ;; - at least one prereq's items have completed + ;; case 2 - mode is toplevel + ;; - prereqs are completed. + ;; - or no prereqs can complete + ;; case 3 - mode not specified + ;; - prereqs are completed and passed (we could consider removing "and passed" -- it would change behavior from current) + ((or (null? prereqs-not-met) + (and (member 'toplevel testmode) + (null? non-completed))) + (debug:print-info 4 *default-log-port* "cond branch - " "ei-2") + (debug:print-info 4 *default-log-port* "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))") + (let ((test-name (tests:testqueue-get-testname test-record))) + (setenv "MT_TEST_NAME" test-name) ;; + (setenv "MT_RUNNAME" runname) + (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process + (let ((items-list (items:get-items-from-config tconfig))) + (if (list? items-list) + (begin + (if (null? items-list) + (let ((test-id (rmt:get-test-id run-id test-name "")) + (num-items (rmt:test-toplevel-num-items run-id test-name))) + (if (and test-id + (not (> num-items 0))) + (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites")))) + (tests:testqueue-set-items! test-record items-list) + (list hed tal reg reruns)) + (begin + (debug:print-error 0 *default-log-port* "The proc from reading the items table did not yield a list - please report this") + (exit 1)))))) + + ((and (null? fails) + (null? prereq-fails) + (not (null? non-completed))) + (debug:print-info 4 *default-log-port* "cond branch - " "ei-3") + (let* ((allinqueue (map (lambda (x)(if (string? x) x (db:test-get-testname x))) + (append newtal reruns))) + ;; prereqstrs is a list of test names as strings that are prereqs for hed + (prereqstrs (delete-duplicates (map (lambda (x)(if (string? x) x (db:test-get-testname x))) + prereqs-not-met))) + ;; a prereq that is not found in allinqueue will be put in the notinqueue list + ;; + ;; (notinqueue (filter (lambda (x) + ;; (not (member x allinqueue))) + ;; prereqstrs)) + (give-up #f)) + + ;; We can get here when a prereq has not been run due to *it* having a prereq that failed. + ;; We need to use this to dequeue this item as CANNOTRUN + ;; + (if (member 'toplevel testmode) ;; '(toplevel)) ;; NOTE: this probably should be (member 'toplevel testmode) + (for-each (lambda (prereq) + (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN) + (set! give-up #t))) + prereqstrs)) + + (if (and give-up + (not (and (null? tal)(null? reg)))) + (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) + (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) + (debug:print 1 *default-log-port* "WARNING: test " hed " has discarded prerequisites, removing it from the queue") + + (let ((test-id (rmt:get-test-id run-id hed ""))) + (if test-id (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites"))) + + (if (and (null? trimmed-tal) + (null? trimmed-reg)) + #f + (runs:loop-values trimmed-tal trimmed-reg reglen regfull reruns) + )) + (list (car newtal)(append (cdr newtal) reg) '() reruns)))) + + ((and (null? fails) ;; have not-started tests, but unable to run them. everything looks completed with no prospect of unsticking something that is stuck. we should mark hed as moribund and exit or continue if there are more tests to consider + (null? prereq-fails) + (null? non-completed)) + (debug:print-info 4 *default-log-port* "cond branch - " "ei-4") + (if (runs:can-keep-running? hed 20) + (begin + (runs:inc-cant-run-tests hed) + (debug:print-info 0 *default-log-port* "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0) ", going to wait 60 sec.") ;; + ;; getting here likely means the system is way overloaded, kill a full minute before continuing + ;; (thread-sleep! 60) ;; TODO: gate by normalized server load > 1.0 (maxload config thing) CHECKTHIS!!! + ;; No runsdat, can't do this yet + ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) + ;; + (thread-sleep! 5) ;; TODO: gate by normalized server load > 1.0 (maxload config thing) + ;; num-retries code was here + ;; we use this opportunity to move contents of reg to tal + (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met? + (begin + (debug:print-info 1 *default-log-port* "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue") + (let ((test-id (rmt:get-test-id run-id hed ""))) + (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while."))) + (runs:loop-values tal reg reglen regfull reruns) + ))) + + ((and + (or (not (null? fails)) + (not (null? prereq-fails))) + (member 'normal testmode)) + (debug:print-info 4 *default-log-port* "cond branch - " "ei-5") + (debug:print-info 1 *default-log-port* "test " hed " (mode=" testmode ") has failed prerequisite(s); " + (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") + ", removing it from to-do list") + (let ((test-id (rmt:get-test-id run-id hed ""))) + (if test-id + (if (not (null? prereq-fails)) + (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites") + (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) + ;; (debug:print 4 *default-log-port*"BB> set PREQ_FAIL on "hed) + ;; (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) ;; BB: this works, btu equivalent for itemwait mode does not work. + (if (or (not (null? reg))(not (null? tal))) + (begin + (hash-table-set! test-registry hed 'CANNOTRUN) + (runs:loop-values tal reg reglen regfull (cons hed reruns)) + ) + #f)) ;; #f flags do not loop + + ((and (not (null? fails))(member 'toplevel testmode)) + (debug:print-info 4 *default-log-port* "cond branch - " "ei-6") + (if (or (not (null? reg))(not (null? tal))) + (list (car newtal)(append (cdr newtal) reg) '() reruns) + #f)) + ((null? runnables) + (debug:print-info 4 *default-log-port* "cond branch - " "ei-7") + #f) ;; if we get here and non-completed is null then it is all over. + (else + (debug:print-info 4 *default-log-port* "cond branch - " "ei-8") + (debug:print 2 *default-log-port* "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now") + (list (car newtal)(cdr newtal) reg reruns))))) + +(define (runs:mixed-list-testname-and-testrec->list-of-strings inlst) + (if (null? inlst) + '() + (map (lambda (t) + (cond + ((vector? t) + (let ((test-name (db:test-get-testname t)) + (item-path (db:test-get-item-path t)) + (test-state (db:test-get-state t)) + (test-status (db:test-get-status t))) + (conc test-name (if (equal? item-path "") "" "/") item-path ":" test-state "/" test-status))) + ((string? t) + t) + (else + (conc t)))) + inlst))) + + +;; hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps) +(define (runs:process-expanded-tests runsdat testdat) + ;; unroll the contents of runsdat and testdat (due to ongoing refactoring). + (debug:print 2 *default-log-port* "runs:process-expanded-tests; testdat:" ) + (debug:print 2 *default-log-port* (with-output-to-string + (lambda () (pp (runs:testdat->alist testdat) )))) + (let* ((hed (runs:testdat-hed testdat)) + (tal (runs:testdat-tal testdat)) + (reg (runs:testdat-reg testdat)) + (reruns (runs:testdat-reruns testdat)) + (test-name (runs:testdat-test-name testdat)) + (item-path (runs:testdat-item-path testdat)) + (jobgroup (runs:testdat-jobgroup testdat)) + (waitons (runs:testdat-waitons testdat)) + (item-path (runs:testdat-item-path testdat)) + (testmode (runs:testdat-testmode testdat)) + (newtal (runs:testdat-newtal testdat)) + (itemmaps (runs:testdat-itemmaps testdat)) + (test-record (runs:testdat-test-record testdat)) + (prereqs-not-met (runs:testdat-prereqs-not-met testdat)) + + (reglen (runs:dat-reglen runsdat)) + (regfull (runs:dat-regfull runsdat)) + (runname (runs:dat-runname runsdat)) + (max-concurrent-jobs (runs:dat-max-concurrent-jobs runsdat)) + (run-id (runs:dat-run-id runsdat)) + (test-patts (runs:dat-test-patts runsdat)) + (required-tests (runs:dat-required-tests runsdat)) + (test-registry (runs:dat-test-registry runsdat)) + (registry-mutex (runs:dat-registry-mutex runsdat)) + (flags (runs:dat-flags runsdat)) + (keyvals (runs:dat-keyvals runsdat)) + (run-info (runs:dat-run-info runsdat)) + (all-tests-registry (runs:dat-all-tests-registry runsdat)) + (run-limits-info (runs:dat-can-run-more-tests runsdat)) + ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running + (have-resources (car run-limits-info)) + (num-running (list-ref run-limits-info 1)) + (num-running-in-jobgroup(list-ref run-limits-info 2)) + (max-concurrent-jobs (list-ref run-limits-info 3)) + (job-group-limit (list-ref run-limits-info 4)) + ;; (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) + ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) + (fails (if (list? prereqs-not-met) ;; TODO: rename fails to failed-prereqs + (runs:calc-fails prereqs-not-met) + (begin + (debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met) + '()))) + (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! + (not (equal? x hed))) + (runs:calc-not-completed prereqs-not-met))) + (loop-list (list hed tal reg reruns)) + ;; configure the load runner + (maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3.0"))) ;; use a non-number string to disable + (maxhomehostload (string->number (or (configf:lookup *configdat* "jobtools" "maxhomehostload") "2.0"))) ;; use a non-number string to disable + (waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60")))) + (debug:print-info 4 *default-log-port* "have-resources: " have-resources " prereqs-not-met: (" + (string-intersperse + (map (lambda (t) + (if (vector? t) + (conc (db:test-get-state t) "/" (db:test-get-status t)) + (conc " WARNING: t is not a vector=" t ))) + prereqs-not-met) + ", ") ") fails: " fails + "\nregistered? " (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) + + ;; well, first lets see if cpu load throttling is enabled. If so wait around until the + ;; average cpu load is under the threshold before continuing + ;; + (if (runs:dat-load-mgmt-function runsdat) + ((runs:dat-load-mgmt-function runsdat)) + (runs:dat-load-mgmt-function-set! + runsdat + (lambda () + ;; jobtools maxload is useful for where the full Megatest run is done on one machine + (if (and (not (rmt:on-homehost?)) + maxload) ;; only gate if maxload is specified, NOTE: maxload is normalized, i.e. load=1 means all cpus fully utilized + (common:wait-for-normalized-load maxload "Waiting for load to drop before starting more tests" #f)) + + ;; jobtools maxhomehostload is intended to prevent overloading on the homehost which can cause database corruption issues + (if maxhomehostload + (common:wait-for-homehost-load maxhomehostload + (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload)))))) + + + + (if (and (not (null? prereqs-not-met)) + (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) + (debug:print-info 2 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) + + ;; Don't know at this time if the test have been launched at some time in the past + ;; i.e. is this a re-launch? + (debug:print-info 4 *default-log-port* "run-limits-info = " run-limits-info) + + (cond ; cond 894- 1067 + + ;; Check item path against item-patts, + ;; + ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run + ;; else the run is stuck, temporarily or permanently + ;; but should check if it is due to lack of resources vs. prerequisites + (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) + (if (or (not (null? tal))(not (null? reg))) + (runs:loop-values tal reg reglen regfull reruns) + #f)) + + ;; Register tests + ;; + ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) + (debug:print-info 4 *default-log-port* "Pre-registering test " test-name "/" item-path " to create placeholder" ) + ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs + (let register-loop ((numtries 15)) + (rmt:register-test run-id test-name item-path) + (if (rmt:get-test-id run-id test-name item-path) + (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done) + (if (> numtries 0) + (begin + (thread-sleep! 0.5) + (register-loop (- numtries 1))) + (debug:print-error 0 *default-log-port* "failed to register test " (db:test-make-full-name test-name item-path))))) + (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done)) + (begin + (rmt:register-test run-id test-name "") + (if (rmt:get-test-id run-id test-name "") + (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) + (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) + (if (and (null? tal)(null? reg)) + (list hed tal (append reg (list hed)) reruns) + (list (runs:queue-next-hed tal reg reglen regfull) ;; cannot replace with a call to runs:loop-values as the logic is different for reg + (runs:queue-next-tal tal reg reglen regfull) + ;; NB// Here we are building reg as we register tests + ;; if regfull we must pop the front item off reg + (if regfull + (append (cdr reg) (list hed)) + (append reg (list hed))) + reruns))) + + ;; At this point hed test registration must be completed. + ;; + ((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f) + 'start) + (debug:print-info 0 *default-log-port* "Waiting on test registration(s): " + (string-intersperse + (filter (lambda (x) + (eq? (hash-table-ref/default test-registry x #f) 'start)) + (hash-table-keys test-registry)) + ", ")) + (thread-sleep! 0.051) + (list hed tal reg reruns)) + + ;; If no resources are available just kill time and loop again + ;; + ((not have-resources) ;; simply try again after waiting a second + (if (runs:lownoise "no resources" 600) + (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ...")) + + ;; Have gone back and forth on this but db starvation is an issue. + ;; wait one second before looking again to run jobs. + ;; (thread-sleep! 0.25) + + ;; new logic. + ;; If it has been more than 10 seconds since we were last here don't wait at all + ;; otherwise sleep 2 seconds to give db a rest and let dashboard read data + (if (runs:lownoise "frequent-no-resources" 10) + (thread-sleep! 0.25) ;; no significant delay + (thread-sleep! 2)) + ;; could have done hed tal here but doing car/cdr of newtal to rotate tests + (list (car newtal)(cdr newtal) reg reruns)) + + ;; This is the final stage, everything is in place so launch the test + ;; + ((and have-resources + (or (null? prereqs-not-met) + (and (member 'toplevel testmode) ;; 'toplevel) + (null? non-completed) + (not (member 'exclusive testmode))))) + ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path)) + ;; we are going to reset all the counters for test retries by setting a new hash table + ;; this means they will increment only when nothing can be run + (set! *max-tries-hash* (make-hash-table)) + + (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry runsdat testdat) + (set! *last-test-launch* (current-seconds)) + (runs:incremental-print-results run-id) + (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) + (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) + ;; (thread-sleep! *global-delta*) + (if (or (not (null? tal))(not (null? reg))) + (runs:loop-values tal reg reglen regfull reruns) ;; hed should be dropped at this time + #f)) + + ;; must be we have unmet prerequisites + ;; + (else + (debug:print 4 *default-log-port* "FAILS: " fails) + ;; If one or more of the prereqs-not-met are FAIL then we can issue + ;; a message and drop hed from the items to be processed. + ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) + (if (and (not (null? prereqs-not-met)) + (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) + (debug:print-info 1 *default-log-port* "waiting on tests; " (string-intersperse + (runs:mixed-list-testname-and-testrec->list-of-strings + prereqs-not-met) ", "))) + (if (or (null? fails) + (member 'toplevel testmode)) + (begin + ;; couldn't run, take a breather + (if (runs:lownoise "Waiting for more work to do..." 60) + (debug:print-info 0 *default-log-port* "Waiting for more work to do...")) + + ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) + (thread-sleep! 5) + (list (car newtal)(cdr newtal) reg reruns)) + ;; the waiton is FAIL so no point in trying to run hed ever again + (begin + (let ((my-test-id (rmt:get-test-id run-id test-name item-path))) + (mt:test-set-state-status-by-id-unless-completed run-id my-test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites2")) + (if (or (not (null? reg))(not (null? tal))) + (if (vector? hed) + (begin + (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path + " from the launch list as it has prerequistes that are FAIL") + (let ((test-id (rmt:get-test-id run-id hed ""))) + (if test-id (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) + (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) + ;; (thread-sleep! *global-delta*) + ;; This next is for the items + + (if (not (null? fails)) + ;;(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "PREQ_FAIL" #f) + (rmt:set-state-status-and-roll-up-items run-id test-name item-path "NOT_STARTED" "PREQ_FAIL" #f) + ;;(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) + (rmt:set-state-status-and-roll-up-items run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) ) + (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed) + (runs:loop-values tal reg reglen regfull reruns)) + (let ((nth-try (hash-table-ref/default test-registry hed 0))) ;; hed not a vector... + (debug:print 2 *default-log-port* "nth-try("hed")="nth-try) + (cond + ((member "RUNNING" (map db:test-get-state prereqs-not-met)) + (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60) + (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) + (thread-sleep! 0.1) + (runs:loop-values tal reg reglen regfull reruns)) + ((or (not nth-try) ;; BB: condition on subsequent tries, condition below fires on first try + (and (number? nth-try) + (< nth-try 2))) + (hash-table-set! test-registry hed (if (number? nth-try) + (+ nth-try 1) + 0)) + (if (runs:lownoise (conc "not removing test " hed) 60) + (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) + ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") + (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) + (runs:loop-values newtal reg reglen regfull reruns)) + ((symbol? nth-try) ;; BB: 'done matches here in one case where prereq itemwait failed. This is first "try" + (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW + (if (null? tal) + #f ;; yes, really + (list (car tal)(cdr tal) reg reruns)) + (begin + (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60) + (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state >" nth-try "< will be overridden and we'll retry.")) + ;; was: (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f) + (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path "COMPLETED" "PREQ_FAIL" #f) + (hash-table-set! test-registry hed 'removed) ;; was 0 + (if (not (and (null? reg) (null? tal))) + (runs:loop-values tal reg reglen regfull reruns) + #f)))) + (else + (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60) + (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) + ;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met) + (hash-table-set! test-registry hed 'removed) + (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) + ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug. + (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL + (list (if (null? tal)(car newtal)(car tal)) + tal + reg + reruns))))) + ;; ELSE: can't drop this - maybe running? Just keep trying + + ;;(if (not (or (not (null? reg))(not (null? tal)))) ;; old experiment + (let ((runable-tests (runs:runable-tests prereqs-not-met))) ;; SUSPICIOUS: Should look at more than just prereqs-not-met? + (if (null? runable-tests) + #f ;; I think we are truly done here + (runs:loop-values newtal reg reglen regfull reruns))) + ;;) ;;from old experiment + ) ;; end if (or (not (null? reg))(not (null? tal))) + )))))) + +;; scan a list of tests looking to see if any are potentially runnable +;; +(define (runs:runable-tests tests) + (filter (lambda (t) + (if (not (vector? t)) + t + (let ((state (db:test-get-state t)) + (status (db:test-get-status t))) + (case (string->symbol state) + ((COMPLETED INCOMPLETE) #f) + ((NOT_STARTED) + (if (member status '("TEN_STRIKES" "BLOCKED" "PREQ_FAIL" "ZERO_ITEMS" "PREQ_DISCARDED" "TIMED_OUT" )) + #f + t)) + ((DELETED) #f) + (else t))))) + tests)) + +;; move all the miscellanea into this struct +;; +(defstruct runs:gendat inc-results inc-results-last-update inc-results-fmt run-info runname target) + +(define *runs:general-data* + (make-runs:gendat + inc-results: (make-hash-table) + inc-results-last-update: 0 + inc-results-fmt: "~12a~12a~20a~12a~40a\n" ;; state status time duration test-name item-path + run-info: #f + runname: #f + target: #f + ) + ) + +(define (runs:incremental-print-results run-id) + (let ((curr-sec (current-seconds)) + (last-update (runs:gendat-inc-results-last-update *runs:general-data*))) + (if (> (- curr-sec last-update) 5) ;; at least five seconds since last update + (let* ((run-dat (or (runs:gendat-run-info *runs:general-data*)(rmt:get-run-info run-id))) + (runname (or (runs:gendat-runname *runs:general-data*) + (db:get-value-by-header (db:get-rows run-dat) + (db:get-header run-dat) "runname"))) + (target (or (runs:gendat-target *runs:general-data*)(rmt:get-target run-id))) + (testsdat (let ((res (rmt:get-tests-for-run + run-id "%" '() '() ;; run-id testpatt states statuses + #f #f ;; offset limit + #f ;; not-in + #f ;; sort-by + #f ;; sort-order + #f ;; get full data (not 'shortlist) + last-update + 'dashboard))) + (if (list? res) + res + (begin + (debug:print-error + 0 *default-log-port* + "FAILED TO GET DATA using rmt:get-tests-for-run. Notify developers if you see this. result: " res) + '()))))) + (runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 1)) + (if (not (runs:gendat-run-info *runs:general-data*)) + (runs:gendat-run-info-set! *runs:general-data* run-dat)) + (if (not (runs:gendat-runname *runs:general-data*)) + (runs:gendat-runname-set! *runs:general-data* runname)) + (if (not (runs:gendat-target *runs:general-data*)) + (runs:gendat-target-set! *runs:general-data* target)) + (for-each + (lambda (testdat) + (let* ((test-id (db:test-get-id testdat)) + (prevdat (hash-table-ref/default (runs:gendat-inc-results *runs:general-data*) + (conc run-id "," test-id) #f)) + (test-name (db:test-get-testname testdat)) + (item-path (db:test-get-item-path testdat)) + (state (db:test-get-state testdat)) + (status (db:test-get-status testdat)) + (event-time (db:test-get-event_time testdat)) + (duration (db:test-get-run_duration testdat))) + (if (and (not (member state '("DELETED" "REMOTEHOSTSTART" "RUNNING" "LAUNCHED""NOT_STARTED"))) + (not (and prevdat + (equal? state (db:test-get-state prevdat)) + (equal? status (db:test-get-status prevdat))))) + (let ((fmt (runs:gendat-inc-results-fmt *runs:general-data*)) + (dtime (seconds->year-work-week/day-time event-time))) + (if (runs:lownoise "inc-print" 600) + (format #t fmt "State" "Status" "Start Time" "Duration" "Test path")) + ;; (debug:print 0 *default-log-port* "fmt: " fmt " state: " state " status: " status " test-name: " test-name " item-path: " item-path " dtime: " dtime) + ;; (debug:print 0 #f "event-time: " event-time " duration: " duration) + (format #t fmt + state + status + dtime + (seconds->hr-min-sec duration) + (conc "lt/" target "/" runname "/" test-name (if (string-null? item-path) "" (conc "/" item-path)))) + (hash-table-set! (runs:gendat-inc-results *runs:general-data*) (conc run-id "," test-id) testdat))))) + testsdat))) + + ;; I don't think this should be here? -- Matt + #;(runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 10)) + + )) + +;; every time though the loop increment the test/itempatt val. +;; when the min is > max-allowed and none running then force exit +;; +(define *max-tries-hash* (make-hash-table)) + +(define (runs:pretty-long-list lst) + (if (> (length lst) 8)(append (take lst 3)(list "...")) lst)) + +(define *last-loop-time-ms* 0) + +;;====================================================================== +;; runs:run-tests-queue is called by runs:run-tests +;;====================================================================== +;; +;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > +(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) + ;; At this point the list of parent tests is expanded + ;; NB// Should expand items here and then insert into the run queue. + (debug:print 5 *default-log-port* "test-records: " test-records ", flags: " (hash-table->alist flags)) + + ;; Do mark-and-find clean up of db before starting runing of quue + ;; + ;; (rmt:find-and-mark-incomplete) + + (let* ((run-info (rmt:get-run-info run-id)) + (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) + (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) + (test-registry (make-hash-table)) + (registry-mutex (make-mutex)) + (num-retries 0) + (max-retries (configf:lookup *configdat* "setup" "maxretries")) + (max-concurrent-jobs (configf:lookup-number *configdat* "setup" "max_concurrent_jobs" default: 50)) + (reglen (if (number? reglen-in) reglen-in 1)) + (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle + (last-time-some-running (current-seconds)) + (incoming-tests '()) ;; queue up incoming tests here to tack on to tal when it gets low + ;; (tdbdat (tasks:open-db)) + (runsdat (make-runs:dat + ;; hed: hed + ;; tal: tal + ;; reg: reg + ;; reruns: reruns + reglen: reglen + regfull: #f ;; regfull + ;; test-record: test-record + runname: runname + ;; test-name: test-name + ;; item-path: item-path + ;; jobgroup: jobgroup + max-concurrent-jobs: max-concurrent-jobs + run-id: run-id + ;; waitons: waitons + ;; testmode: testmode + test-patts: test-patts + required-tests: required-tests + test-registry: test-registry + registry-mutex: registry-mutex + flags: flags + keyvals: keyvals + run-info: run-info + ;; newtal: newtal + all-tests-registry: all-tests-registry + ;; itemmaps: itemmaps + ;; prereqs-not-met: (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps) + ;; can-run-more-tests: (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) ;; look at the test jobgroup and tot jobs running + ))) + + ;; Initialize the test-registery hash with tests that already have a record + ;; convert state to symbol and use that as the hash value + (for-each (lambda (trec) + (let ((id (db:test-get-id trec)) + (tn (db:test-get-testname trec)) + (ip (db:test-get-item-path trec)) + (st (db:test-get-state trec))) + (if (not (equal? st "DELETED")) + (hash-table-set! test-registry (db:test-make-full-name tn ip) (string->symbol st))))) + tests-info) + (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) + + (let loop ((hed (car sorted-test-names)) + (tal (cdr sorted-test-names)) + (reg '()) ;; registered, put these at the head of tal + (reruns '())) + + (runs:incremental-print-results run-id) + + (if (not (null? reruns))(debug:print-info 4 *default-log-port* "reruns=" reruns)) + + ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes + ;; moving this to a parallel thread and just run it once. + ;; + (if (> (current-seconds)(+ last-time-incomplete 900)) + (begin + (set! last-time-incomplete (current-seconds)) + ;; (rmt:find-and-mark-incomplete-all-runs) + )) + + ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) + (let* ((test-record (hash-table-ref test-records hed)) + (test-name (tests:testqueue-get-testname test-record)) + (tconfig (tests:testqueue-get-testconfig test-record)) + (jobgroup (configf:lookup tconfig "test_meta" "jobgroup")) + (testmode (let ((m (configf:lookup tconfig "requirements" "mode"))) + (if m (map string->symbol (string-split m)) '(normal)))) + (itemmaps (tests:get-itemmaps tconfig)) ;; (configf:lookup tconfig "requirements" "itemmap")) + (priority (tests:testqueue-get-priority test-record)) + (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f + (items (tests:testqueue-get-items test-record)) + (item-path (item-list->path itemdat)) + (tfullname (db:test-make-full-name test-name item-path)) + ;; these are hard coded item-item waits test/item-path => test/item-path2 ... + (extra-waits (let* ((section (configf:get-section (tests:testqueue-get-testconfig test-record) "waitons")) + (myextra (alist-ref tfullname section equal?))) + (if myextra + (let ((extras (string-split (car myextra)))) + (if (runs:lownoise (conc tfullname "extra-waitons" tfullname) 60) + (debug:print-info 0 *default-log-port* "HAVE EXTRA WAITONS for test " tfullname ": " myextra)) + (for-each + (lambda (extra) + ;; (debug:print 0 *default-log-port* "FYI: extra = " extra " reruns = " reruns) + (let ((basetestname (car (string-split extra "/")))) + #;(if (not (member extra tal)) + (set! reruns (append tal (list extra)))) + (if (not (member basetestname tal)) + (set! reruns (append tal (list basetestname)))) + )) + extras) + extras) + '()))) + (waitons (delete-duplicates (append (tests:testqueue-get-waitons test-record) extra-waits) equal?)) + (newtal (append tal (list hed))) + (regfull (>= (length reg) reglen)) + (num-running (rmt:get-count-tests-running-for-run-id run-id)) + (testdat (make-runs:testdat + hed: hed + tal: tal + reg: reg + reruns: reruns + test-record: test-record + test-name: test-name + item-path: item-path + jobgroup: jobgroup + waitons: waitons + testmode: testmode + newtal: newtal + itemmaps: itemmaps + prereqs-not-met: '() + ))) + + ;; too-tight loop detection and delay, this might hide issues + ;; that occur in long run times. Consider commenting when debugging + ;; + (if (and (>= num-running max-concurrent-jobs) + (< (- (current-milliseconds) *last-loop-time-ms*) 500)) + (begin + (if (runs:lownoise "too-tight-loop" 5) + (debug:print-info 2 *default-log-port* "Excessively fast loop, delaying 1/2 second")) + (thread-sleep! 0.5))) + (set! *last-loop-time-ms* (current-milliseconds)) + + (runs:dat-regfull-set! runsdat regfull) + + + (if (> (- (current-seconds) *last-test-launch*) 5) ;; be pretty aggressive for five seconds after + (runs:too-soon-delay (conc "loop delay " hed) 1 0.6) ;; starting a test then apply more delay + (runs:too-soon-delay (conc "loop delay " hed) 1 0.1)) + + (if (> num-running 0) + (set! last-time-some-running (current-seconds))) + + (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000))) + (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) + ;; (debug:print 0 *default-log-port* "max-tries-hash: " (hash-table->alist *max-tries-hash*)) + + ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard + ;; and it is clear they *should* have run but did not. + (if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f)) + (begin + (rmt:register-test run-id test-name "") + (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))) + + ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( + ;; + (if (member (hash-table-ref/default test-registry tfullname #f) + '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) + (begin + (if (runs:lownoise (conc "been marked do not run " tfullname) 60) + (debug:print-info 0 *default-log-port* "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable")) + (if (or (not (null? tal))(not (null? reg))) + (loop (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns)))) + ;; (loop (car tal)(cdr tal) reg reruns)))) + (runs:incremental-print-results run-id) + (debug:print 4 *default-log-port* "TOP OF LOOP => " + "test-name: " test-name + "\n hed: " hed + "\n tal: " (runs:pretty-long-list tal) + "\n reg: " reg + "\n test-record " test-record + "\n itemdat: " itemdat + "\n items: " items + "\n item-path: " item-path + "\n waitons: " waitons + "\n num-retries: " num-retries + "\n reruns: " reruns + "\n regfull: " regfull + "\n reglen: " reglen + "\n length reg: " (length reg) + ) + + ;; (runs:parallel-runners-mgmt runsdat) + + ;; check for hed in waitons => this would be circular, remove it and issue an + ;; error + (if (member test-name waitons) + (begin + (debug:print-error 0 *default-log-port* "test " test-name " has listed itself as a waiton, please correct this!") + (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) + + (cond + + ;; We want to catch tests that have waitons that are NOT in the queue and discard them IFF + ;; they have been through the wringer 10 or more times + ((and (list? waitons) + (not (null? waitons)) + (> (hash-table-ref/default *max-tries-hash* tfullname 0) 10) + (not (null? (filter + number? + (map (lambda (waiton) + (if (and (not (member waiton tal)) ;; this waiton is not in the list to be tried to run + (not (member waiton reruns))) + 1 + #f)) + waitons))))) ;; could do this more elegantly with a marker.... + (debug:print-info 4 *default-log-port* "cond branch - " "rtq-1") + (debug:print 0 *default-log-port* "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.") + (hash-table-set! test-registry tfullname 'removed)) + + ;; items is #f then the test is ok to be handed off to launch (but not before) + ;; + ((not items) + (debug:print-info 4 *default-log-port* "cond branch - " "rtq-2") + (debug:print-info 4 *default-log-port* "OUTER COND: (not items)") + (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) + (not (null? tal))) + (loop (car tal)(cdr tal) reg reruns)) + + ;; gonna try a strategy change here. + ;; + ;; check if can run more tests. if yes, continue, if no, rest until can run more + ;; look at the test jobgroup and tot jobs running + ;; + ;; NOTE: This does NOT actually gate here, only captures the proc to be called later + ;; + (if (not (runs:dat-wait-for-jobs-function runsdat)) + (runs:dat-wait-for-jobs-function-set! + runsdat + (lambda (testdat-in) + (let* ((jobgroup (runs:testdat-jobgroup testdat-in)) + (can-run-more-tests (runs:dat-can-run-more-tests runsdat)) + (last-jobs-check-time (runs:dat-last-jobs-check-time runsdat)) + (should-check-jobs (match can-run-more-tests + ((can-run-more-flag num-running nr-in-jobgroup max-concurrent-jobs . params) + (if (< (- max-concurrent-jobs num-running) 25) + (begin + (debug:print-info 2 *default-log-port* + "less than 20 jobs headroom, ("max-concurrent-jobs + "-"num-running")>20. Forcing prelaunch check.") + #t) + #f)) + (else #f)))) ;; no record yet + (if should-check-jobs + (let loop-can-run-more + ((res (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) + (remtries 1440)) ;; we can wait for up to two hours for jobs to get done + (match res + ((run-more num-running . rem) + (if (or run-more + (< remtries 1)) + (begin + (if (runs:lownoise "num-running" 30) + (debug:print-info 0 *default-log-port* "Have "num-running" tests of max " max-concurrent-jobs)) + (runs:dat-can-run-more-tests-set! runsdat res)) ;; capture the result and then drop through + (begin + (if (runs:lownoise "num-running" 10) + (debug:print-info 0 *default-log-port* "Can't run more tests, have "num-running" tests of " + max-concurrent-jobs " allowed.")) + (thread-sleep! 5) ;; if we've hit max concurrent jobs take a breather, nb// make this configurable + + ;; wait for load here + (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) + (loop-can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) + (- remtries 1))))))) + ))))) + + ;; I'm not clear on why prereqs are gathered here TODO: verfiy this is needed + (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) + + ;; I'm not clear on why we'd capture running job counts here TODO: verify this is needed + (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) + + (let ((loop-list (runs:process-expanded-tests runsdat testdat))) ;; in process-expanded-tests ultimately run:test -> launch-test -> test actually running + (if loop-list (apply loop loop-list)))) + + ;; items processed into a list but not came in as a list been processed + ;; + ((and (list? items) ;; thus we know our items are already calculated + (not itemdat)) ;; and not yet expanded into the list of things to be done + (debug:print-info 4 *default-log-port* "cond branch - " "rtq-3") + (debug:print-info 4 *default-log-port* "OUTER COND: (and (list? items)(not itemdat))") + ;; Must determine if the items list is valid. Discard the test if it is not. + (if (and (list? items) + (> (length items) 0) + (and (list? (car items)) + (> (length (car items)) 0)) + (debug:debug-mode 1)) + (debug:print 2 *default-log-port* (map (lambda (row) + (conc (string-intersperse + (map (lambda (varval) + (string-intersperse varval "=")) + row) + " ") + "\n")) + items))) + + (let* ((items-in-testpatt + (filter + (lambda (my-itemdat) + (tests:match test-patts hed (item-list->path my-itemdat) )) + ;; was: (tests:match test-patts hed (item-list->path my-itemdat) required: required-tests)) + items) )) + (if (null? items-in-testpatt) + (debug:print-error 0 *default-log-port* "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items matching the test pattern") + + (for-each (lambda (my-itemdat) + (let* ((new-test-record (let ((newrec (make-tests:testqueue))) + (vector-copy! test-record newrec) + newrec)) + (my-item-path (item-list->path my-itemdat)) + + (newtestname (db:test-make-full-name hed my-item-path))) ;; test names are unique on testname/item-path + (tests:testqueue-set-items! new-test-record #f) + (tests:testqueue-set-itemdat! new-test-record my-itemdat) + (tests:testqueue-set-item_path! new-test-record my-item-path) + (hash-table-set! test-records newtestname new-test-record) + ;; BUG: This next line sucks up a lot of horsepower + ;; (set! tal (append tal (list newtestname))) + ;; (set! tal (cons newtestname tal)) ;; 4/6/2023 - try using cons, does it matter if the test gets added at the beginning? + (set! incoming-tests (cons newtestname incoming-tests)) + )) ;; since these are itemized create new test names testname/itempath + items-in-testpatt))) + + (if (and (< (length tal) 20) + (not (null? incoming-tests))) + (begin + (set! tal (append tal (reverse incoming-tests))) + (set! incoming-tests '()))) + + ;; At this point we have possibly added items to tal but all must be handed off to + ;; INNER COND logic. I think loop without rotating the queue + ;; (loop hed tal reg reruns)) + ;; (let ((newtal (append tal (list hed)))) ;; We should discard hed as it has been expanded into it's items? Yes, but only if this *is* an itemized test + ;; (loop (car newtal)(cdr newtal) reg reruns) + (if (null? tal) + #f + (loop (car tal)(cdr tal) reg reruns))) + + ;; if items is a proc then need to run items:get-items-from-config, get the list and loop + ;; - but only do that if resources exist to kick off the job + ;; EXPAND ITEMS + ((or (procedure? items)(eq? items 'have-procedure)) + (debug:print-info 4 *default-log-port* "cond branch - " "rtq-4") + (let ((can-run-more #f)) ;; (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs))) + (if (not can-run-more) #;(and (list? can-run-more) + (car can-run-more)) + (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps))) ;; itemized test expanded here + (if loop-list + (apply loop loop-list) + (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed) + ) + ) + ;; if can't run more just loop with next possible test + (loop (car newtal)(cdr newtal) reg reruns)))) + + + ;; this case should not happen, added to help catch any bugs + ((and (list? items) itemdat) + (debug:print-info 4 *default-log-port* "cond branch - " "rtq-5") + (debug:print-error 0 *default-log-port* "Should not have a list of items in a test and the itemspath set - please report this") + (exit 1)) + + ((not (null? reruns)) + (debug:print-info 4 *default-log-port* "cond branch - " "rtq-6") + (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, + (junked (lset-difference equal? tal newlst))) + (debug:print-info 4 *default-log-port* "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) + (if (< num-retries max-retries) + (set! newlst (append reruns newlst))) + (set! num-retries (+ num-retries 1)) + ;; (thread-sleep! (+ 1 *global-delta*)) + (if (not (null? newlst)) + ;; since reruns have been tacked on to newlst create new reruns from junked + (loop (car newlst)(cdr newlst) reg (delete-duplicates junked))))) + + ((not (null? tal)) + (debug:print-info 4 *default-log-port* "cond branch - " "rtq-7") + (debug:print-info 4 *default-log-port* "I'm pretty sure I shouldn't get here.")) + ((not (null? reg)) ;; could we get here with leftovers? + (debug:print-info 4 *default-log-port* "cond branch - " "rtq-8") + (debug:print-info 0 *default-log-port* "Have leftovers!") + (loop (car reg)(cdr reg) '() reruns)) + (else + (debug:print-info 4 *default-log-port* "cond branch - " "rtq-9") + (debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) + ))) ;; end loop on sorted test names + ;; this is the point where everything is launched and now you can mark the run in metadata table as all launched + (rmt:set-var (conc "lunch-complete-" run-id) "yes") + + ;; now *if* -run-wait we wait for all tests to be done + ;; Now wait for any RUNNING tests to complete (if in run-wait mode) + ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) + (thread-sleep! 0.1) ;; I think there is a race condition here. Let states/statuses settle + + (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) + (prev-num-running 0)) + ;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running) + (if (and (or (args:get-arg "-run-wait") + (equal? (configf:lookup *configdat* "setup" "run-wait") "yes")) + (> num-running 0)) + (begin + ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes + ;; (debug:print 0 *default-log-port* "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0)) + (if (> (current-seconds)(+ last-time-incomplete 900)) + (let ((actual-num-running (rmt:get-count-tests-running-for-run-id run-id))) + (debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id + ". Running as pid " (current-process-id) " on " (get-host-name)) + (set! last-time-incomplete (current-seconds)) ;; FIXME, this might be causing slow down - use of set! + (rmt:find-and-mark-incomplete run-id #f) + (debug:print-info 0 *default-log-port* "run-wait specified, waiting on " actual-num-running + " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " + (time->string (seconds->local-time (current-seconds)))))) + ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) + (thread-sleep! 5) ;; (if (>= num-running max-concurrent-jobs) 5 1)) + (wait-loop (rmt:get-count-tests-running-for-run-id run-id) + num-running)))) + ;; LET* ((test-record + ;; we get here on "drop through". All done! + ;; this is moved to runs:run-testes since this function is getting called twice to ensure everthing is completed. + ;; (debug:print-info 0 *default-log-port* "Calling Post Hook") + ;; (runs:run-post-hook run-id) + (debug:print-info 1 *default-log-port* "All tests launched"))) + +(define (runs:calc-fails prereqs-not-met) + (filter (lambda (test) + (and (vector? test) ;; not (string? test)) + (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED")) ;; TODO: pull from *common:stuff...* + (not (member (db:test-get-status test) + '("PASS" "WARN" "WAIVED" "SKIP"))))) + prereqs-not-met)) + +(define (runs:calc-prereq-fail prereqs-not-met) ;; REMOVEME since NOT_STARTED/PREQ_FAIL is now COMPLETED/PREQ_FAIL + (filter (lambda (test) + (and (vector? test) ;; not (string? test)) + (equal? (db:test-get-state test) "NOT_STARTED") + (not (member (db:test-get-status test) + '("n/a" "KEEP_TRYING"))))) + prereqs-not-met)) + +(define (runs:calc-not-completed prereqs-not-met) + (filter + (lambda (t) + (or (not (vector? t)) + (not (member (db:test-get-state t) '("INCOMPLETE" "COMPLETED"))))) + prereqs-not-met)) + +;; (define (runs:calc-not-completed prereqs-not-met) +;; (filter +;; (lambda (t) +;; (or (not (vector? t)) +;; (not (equal? "COMPLETED" (db:test-get-state t))))) +;; prereqs-not-met)) + +(define (runs:calc-runnable prereqs-not-met) + (filter + (lambda (t) + (or (not (vector? t)) + (and (equal? "NOT_STARTED" (db:test-get-state t)) + (member (db:test-get-status t) + '("n/a" "KEEP_TRYING"))) + (and (equal? "RUNNING" (db:test-get-state t))))) ;; account for a test that is running + prereqs-not-met)) + +(define (runs:pretty-string lst) + (map (lambda (t) + (if (not (vector? t)) + (conc t) + (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) + lst)) + +;; parent-test is there as a placeholder for when parent-tests can be run as a setup step +;; +(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry runsdat testdat-rec) + ;; All these vars might be referenced by the testconfig file reader + ;; + ;; NEED to reprocess testconfig here, ensuring that item variables are available. + ;; This is for Tal's issue with item-specific env vars not being set for use in skip. + ;; HSD https://hsdes.intel.com/appstore/icf/index.html#/article?articleId=1408763273 + ;; Also later HSD https://hsdes.intel.com/appstore/article/#/14012138487 + ;; + (let* ((test-name (tests:testqueue-get-testname test-record)) + (test-waitons (tests:testqueue-get-waitons test-record)) + (itemdat (tests:testqueue-get-itemdat test-record)) + (item-path "") + (db #f) + (full-test-name #f)) + + ;; setting itemdat to a list if it is #f + (if (not itemdat)(set! itemdat '())) + (set! item-path (item-list->path itemdat)) + (set-item-env-vars itemdat) + (set! full-test-name (db:test-make-full-name test-name item-path)) + (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process + + (let* ((test-conf ;; re-instated the tests:get-testconfig to fix HSD https://hsdes.intel.com/appstore/article/#/14012138487, need to be able to skip using [items], [itemstable] variables. + ;; (tests:testqueue-get-testconfig test-record )) ;; vector-ref test-record 3 + (tests:get-testconfig test-name item-path all-tests-registry #t force-create: #t)) + (test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... + + (force (hash-table-ref/default flags "-force" #f)) + (rerun (hash-table-ref/default flags "-rerun" #f)) + (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) + (incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x"))) + ) + + (debug:print-info 4 *default-log-port* + "\nTESTNAME: " full-test-name + "\n test-config: " (hash-table->alist test-conf) + "\n itemdat: " itemdat + ) + (debug:print 2 *default-log-port* "Attempting to launch test " full-test-name) + ;; (setenv "MT_TEST_NAME" test-name) ;; + ;; (setenv "MT_ITEMPATH" item-path) + ;; (setenv "MT_RUNNAME" runname) + (change-directory *toppath*) + + ;; Here is where the test_meta table is best updated + ;; Yes, another use of a global for caching. Need a better way? + ;; + ;; There is now a single call to runs:update-all-test_meta and this + ;; per-test call is not needed. Given the delicacy of the move to + ;; v1.55 this code is being left in place for the time being. + ;; + (if (not (hash-table-exists? *test-meta-updated* test-name)) + (begin + (hash-table-set! *test-meta-updated* test-name #t) + (runs:update-test_meta test-name test-conf))) + + ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) + (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) + (test-id (rmt:get-test-id run-id test-name item-path)) + (testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f))) + (if (not testdat) + (let loop () + ;; ensure that the path exists before registering the test + ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... + ;; (system (conc "mkdir -p " new-test-path)) + ;; + ;; (open-run-close tests:register-test db run-id test-name item-path) + ;; + ;; NB// for the above line. I want the test to be registered long before this routine gets called! + ;; + (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path))) + (if (not test-id) + (begin + (debug:print 2 *default-log-port* "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) + (rmt:register-test run-id test-name item-path) + (set! test-id (rmt:get-test-id run-id test-name item-path)))) + (debug:print-info 4 *default-log-port* "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") + (set! testdat (rmt:get-test-info-by-id run-id test-id)) + (if (not testdat) + (begin + (debug:print-info 0 *default-log-port* "WARNING: server is overloaded, trying again in two seconds") + ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) + (thread-sleep! 2) + (loop))))) + (if (not testdat) ;; should NOT happen + (debug:print-error 0 *default-log-port* "failed to get test record for test-id " test-id)) + (set! test-id (db:test-get-id testdat)) + (if (common:file-exists? test-path) + (change-directory test-path) + (begin + (debug:print-error 0 *default-log-port* "test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") + (change-directory *toppath*))) + (case (if force ;; (args:get-arg "-force") + 'NOT_STARTED + (if testdat + (string->symbol (test:get-state testdat)) + 'failed-to-insert)) + ((failed-to-insert) + (debug:print-error 0 *default-log-port* "Failed to insert the record into the db")) + ((NOT_STARTED COMPLETED DELETED INCOMPLETE) + (let ((runflag #f)) + (cond + ;; -force, run no matter what + (force (set! runflag #t)) + ;; NOT_STARTED, run no matter what + ((member (test:get-state testdat) '("DELETED" "NOT_STARTED" "INCOMPLETE"))(set! runflag #t)) + ;; not -rerun and PASS, WARN or CHECK, do no run + ((and (or (not rerun) + keepgoing) + ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK + (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP" "WAIVED")) + (member (test:get-state testdat) '("COMPLETED")))) + (debug:print-info 2 *default-log-port* "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat)) + (hash-table-set! test-registry full-test-name 'DONOTRUN) ;; COMPLETED) + (set! runflag #f)) + + ;; -rerun and status is one of the specifed, run it + ((and rerun + (let* ((rerunlst (string-split rerun ",")) + (must-rerun (member (test:get-status testdat) rerunlst))) + (debug:print-info 3 *default-log-port* "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun) + must-rerun)) + (debug:print-info 2 *default-log-port* "Rerun forced for test " test-name "/" item-path) + (set! runflag #t) + (debug:print-info 2 *default-log-port* "Calling rerun hook") + (runs:rerun-hook test-id new-test-path testdat rerun) + ) + + + + ;; -keepgoing, do not rerun FAIL + ((and keepgoing + (member (test:get-status testdat) '("FAIL"))) + (set! runflag #f)) + + ((and (not rerun) + (member (test:get-status testdat) '("FAIL" "n/a"))) + (set! runflag #t)) + + (else (set! runflag #f))) + (debug:print 4 *default-log-port* "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) + (if (not runflag) + (if (not parent-test) + (if (runs:lownoise (conc "not starting test" full-test-name) 60) + (debug:print 3 *default-log-port* "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) + "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) + "\" or -force to override"))) + ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are + ;; already met. + ;; This would be a great place to do the process-fork + ;; + (let ((skip-test #f) + (skip-check (configf:get-section test-conf "skip"))) + (cond + ;; Have to check for skip conditions. This one skips if there are same-named tests + ;; currently running + ((and skip-check + (configf:lookup test-conf "skip" "prevrunning")) + ;; run-ids = #f means *all* runs + (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) + (if (not (null? running-tests)) ;; have to skip + (set! skip-test "Skipping due to previous tests running")))) + + ;; split the string and OR of file-exists? + ((and skip-check + (configf:lookup test-conf "skip" "fileexists")) + (let* ((files (string-split (configf:lookup test-conf "skip" "fileexists"))) + (existing (filter common:file-exists? files))) + (if (not (null? existing)) ;; (common:file-exists? (configf:lookup test-conf "skip" "fileexists")) + (set! skip-test (conc "Skipping due to existance of file(s) " (string-intersperse existing ", ")))))) ;; (configf:lookup test-conf "skip" "fileexists"))))) + + ((and skip-check + (configf:lookup test-conf "skip" "filenotexists")) + (let* ((files (string-split (configf:lookup test-conf "skip" "filenotexists"))) + (existing (filter common:file-exists? files))) + (if (null? existing) ;; (common:file-exists? (configf:lookup test-conf "skip" "filenotexists"))) + (set! skip-test (conc "Skipping due to non existance of files " (string-intersperse files ", ")))))) ;; (configf:lookup test-conf "skip" "filenotexists"))))) + + ((and skip-check + (configf:lookup test-conf "skip" "script")) + (if (= (system (configf:lookup test-conf "skip" "script")) 0) + (set! skip-test (conc "Skipping due to zero return value of script " (configf:lookup test-conf "skip" "script"))))) + + ((and skip-check + (configf:lookup test-conf "skip" "rundelay")) + ;; run-ids = #f means *all* runs + (let* ((numseconds (common:hms-string->seconds (configf:lookup test-conf "skip" "rundelay"))) + (running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)) + (completed-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("COMPLETED" "INCOMPLETE") '("PASS" "FAIL" "ABORT") #f)) ;; ironically INCOMPLETE is same as COMPLETED in this contex + (last-run-times (map db:mintest-get-event_time completed-tests)) + (time-since-last (- (current-seconds) (if (null? last-run-times) 0 (common:max last-run-times))))) + (if (or (not (null? running-tests)) ;; have to skip if test is running + (> numseconds time-since-last)) + (set! skip-test (conc "Skipping due to previous test run less than " (configf:lookup test-conf "skip" "rundelay") " ago")))))) + + (if skip-test + (begin + (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test) + (debug:print-info 1 *default-log-port* "SKIPPING Test " full-test-name " due to " skip-test)) + ;; + ;; Here the test is handed off to launch.scm for launch-test to complete the launch process + ;; + (begin + ;; wait for less than max jobs here + (if (runs:dat-wait-for-jobs-function runsdat) + ((runs:dat-wait-for-jobs-function runsdat) testdat-rec)) + + (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) + (begin + (debug:print 0 *default-log-port* "ERROR: Failed to launch the test. Exiting as soon as possible") + (set! *globalexitstatus* 1) ;; + (process-signal (current-process-id) signal/kill)) + ) + ;; wait again here? + )))))) + ((KILLED) + (debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") + (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED)) + ((LAUNCHED REMOTEHOSTSTART RUNNING) + (debug:print 2 *default-log-port* "NOTE: " test-name " is already running")) + ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) + ;; (db:test-get-run_duration testdat))) + ;; (or incomplete-timeout + ;; 6000)) ;; i.e. no update for more than 6000 seconds + ;; (begin + ;; (debug:print 0 *default-log-port* "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") + ;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) + ;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) + ;; (debug:print 2 *default-log-port* "NOTE: " test-name " is already running"))) + (else + (debug:print-error 0 *default-log-port* "Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) + (case (string->symbol (test:get-state testdat)) + ((COMPLETED INCOMPLETE) + (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) + (else + (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN))))))))) + +;;====================================================================== +;; END OF NEW STUFF +;;====================================================================== + +(define (get-dir-up-n dir . params) + (let ((dparts (string-split dir "/")) + (count (if (null? params) 1 (car params)))) + (conc "/" (string-intersperse + (take dparts (- (length dparts) count)) + "/")))) + +(define (runs:recursive-delete-with-error-msg real-dir) + (if (> (system (conc "rm -rf " real-dir)) 0) + (begin + ;; FAILED, possibly due to permissions, do chmod a+rwx then try one more time + (system (conc "chmod -R a+rwx " real-dir)) + (if (> (system (conc "rm -rf " real-dir)) 0) + (debug:print-error 0 *default-log-port* "There was a problem removing " real-dir " with rm -f"))))) + +(define (runs:safe-delete-test-dir real-dir) + ;; first delete all sub-directories + (directory-fold + (lambda (f x) + (let ((fullname (conc real-dir "/" f))) + (if (directory? fullname)(runs:recursive-delete-with-error-msg fullname))) + (+ 1 x)) + 0 real-dir) + ;; then files other than *testdat.db* + (directory-fold + (lambda (f x) + (let ((fullname (conc real-dir "/" f))) + (if (not (string-search (regexp "testdat.db") f)) + (runs:recursive-delete-with-error-msg fullname))) + (+ 1 x)) + 0 real-dir #t) + ;; then the entire directory + (runs:recursive-delete-with-error-msg real-dir)) + +;; cleanup often needs to remove all but the last N runs per target +;; +;; target-patts a1/b1/c1,a2/b2/c2 ... +;; +;; This will fail if called with empty target or a bad target (i.e. missing or extra fields) +;; +(define (runs:get-hash-by-target target-patts runpatt) + (let* ((targets (string-split target-patts ",")) + (keys (rmt:get-keys)) + (res-ht (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... ) + (for-each + (lambda (target-patt) + (let ((runs (rmt:simple-get-runs runpatt #f #f target-patt #f))) + (for-each + (lambda (run) + (let ((target (simple-run-target run))) + (hash-table-set! res-ht target (cons run (hash-table-ref/default res-ht target '()))))) + runs))) + targets) + res-ht)) + +;; delete runs older than X (weeks, days, months years etc.) +;; delete redundant runs within a target - N is the input +;; delete redundant runs within a target IFF older than given date/time AND keep at least N +;; +(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") "")) + (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 (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 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")) + (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 %" + (if (member 'kill-runs actions) ;; if kill-runs is specified then set -kill-wait to 0 + " -kill-wait 0" + ""))))) + ((archive) + (if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %")))) + ((kill-runs) + (if remove (system (conc precmd " megatest -kill-runs -target " target " -runname " (simple-run-runname run) " -testpatt %")))))))) + 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)) "/"))) + ) + path-out + ) +) + + +(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode #f)(options '())) + (common:clear-caches) ;; clear all caches + (let* ((db #f) + ;; (tdbdat (tasks:open-db)) + (keys (rmt:get-keys)) + (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))) + (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". + (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* "/.mtdb/main.db")) + (readonly-mode (not (file-write-access? dbfile)))) + (when (and readonly-mode + (member action write-access-actions)) + (debug:print-error 0 *default-log-port* dbfile " is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") + (exit 1))) + + (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) + (if (> 2 (length state-status)) + (begin + (debug:print-error 0 *default-log-port* "the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL") + (exit))) + (for-each + (lambda (run) + (let ((runkey (string-intersperse (map (lambda (k) + (db:get-value-by-header run header k)) keys) "/")) + (dirs-to-remove (make-hash-table)) + (proc-get-tests (lambda (run-id) + (mt:get-tests-for-run run-id + testpatt states statuses + not-in: #f + sort-by: (case action + ((remove-runs) 'rundir) + (else 'event_time)))))) + (let* ((run-id (db:get-value-by-header run header "id")) + (run-state (db:get-value-by-header run header "state")) + (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") + ;; there may be a number of different disks used in the same run. + (run-paths-hash (make-hash-table)) + (worker-thread #f)) + (debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header) + (if (not (null? tests)) + (begin + (case action + ((kill-runs) + (tasks:kill-runner target run-name "%") + (debug:print 1 *default-log-port* "Killing tests for run: " runkey " " (db:get-value-by-header run header "runname")) + ) + ((remove-runs) + ;; use this location to cleanup old DELETED records? No. See below for same call + ;; (rmt:delete-old-deleted-test-records run-id) + ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) + ;; seek and kill in flight -runtests with % as testpatt here + ;; (if (equal? testpatt "%") + (tasks:kill-runner target run-name testpatt) + ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt)) + (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) + ((set-state-status) + ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) + (debug:print 2 *default-log-port* "Modifying state and status for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) + ((print-run) + (debug:print 1 *default-log-port* "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) + 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")) + (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) ;;; 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 + ;; + (let ((sorted-tests (filter + vector? + (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry 'getstr + (db:test-get-rundir a)) ;; ) ;; (filedb:get-path *fdb* (db:test-get-rundir a))) + (dirb ;; (rmt:sdb-qry 'getstr + (db:test-get-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-get-rundir b)))) + (if (and (string? dira)(string? dirb)) + (> (string-length dira)(string-length dirb)) + #f)))))) + (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests + (test-retry-time (make-hash-table)) + (backgrounded-remove-status (make-hash-table)) + (backgrounded-remove-last-visit (make-hash-table)) + (backgrounded-remove-result (make-hash-table)) + (allow-run-time (string->number (or (args:get-arg "-kill-wait") "10")))) ;; seconds to allow for killing tests before just brutally killing 'em + (let loop ((test (car sorted-tests)) + (tal (cdr sorted-tests))) + (let* ((test-id (db:test-get-id test)) + (new-test-dat (rmt:get-test-info-by-id run-id test-id))) + (if (not new-test-dat) + (begin + (debug:print-error 0 *default-log-port* "We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") + (if (not (null? tal)) + (loop (car tal)(cdr tal)))) + (let* ((item-path (db:test-get-item-path new-test-dat)) + (test-name (db:test-get-testname new-test-dat)) + (run-dir ;;(filedb:get-path *fdb* + ;; (rmt:sdb-qry 'getid + (db:test-get-rundir new-test-dat)) ;; ) ;; run dir is from the link tree + (has-subrun (and (subrun:subrun-test-initialized? run-dir) + (not (subrun:subrun-removed? run-dir)))) + (test-state (db:test-get-state new-test-dat)) + (test-status (db:test-get-status new-test-dat)) + (test-fulln (db:test-get-fullname new-test-dat)) + (uname (db:test-get-uname new-test-dat)) + (toplevel-with-children (and (db:test-get-is-toplevel test) + (> (rmt:test-toplevel-num-items run-id test-name) 0)))) + + (case action + ((remove-runs) + ;; if the test is a toplevel-with-children issue an error and do not remove + (cond + (toplevel-with-children + (debug:print 0 *default-log-port* "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests") + (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1)) + (if (> (hash-table-ref toplevel-retries test-fulln) 3) + (if (not (null? tal)) + (loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries + (let ((newtal (append tal (list test)))) + (loop (car newtal)(cdr newtal))))) ;; loop with test still in queue + (has-subrun + ;; + (let ((last-visit (hash-table-ref/default backgrounded-remove-last-visit test-fulln 0)) + (now (current-seconds)) + (rem-status (hash-table-ref/default backgrounded-remove-status test-fulln 'not-started))) + (case rem-status + ((not-started) + (debug:print 0 *default-log-port* "WARNING: postponing removal of " test-fulln " with run-id " run-id " as it has a subrun") + (hash-table-set! backgrounded-remove-status test-fulln 'started) + (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) + (common:send-thunk-to-background-thread + (lambda () + (let* ((subrun-remove-succeeded + (subrun:remove-subrun run-dir keep-records))) + (hash-table-set! backgrounded-remove-result test-fulln subrun-remove-succeeded) + (hash-table-set! backgrounded-remove-status test-fulln 'done))) + name: (conc "remove-subrun:"test-fulln)) + + ;; send to back of line, loop + (let ((newtal (append tal (list test)))) + (loop (car newtal)(cdr newtal))) + ) + ((started) + ;; if last visit was within last second, sleep 1 second + (if (< (- now last-visit) 1.0) + (thread-sleep! 1.0)) + (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) + ;; send to back of line, loop + (let ((newtal (append tal (list test)))) + (loop (car newtal)(cdr newtal))) + ) + ((done) + ;; drop this one; if remaining, loop, else finish + (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) + (let ((subrun-remove-succeeded (hash-table-ref/default backgrounded-remove-result test-fulln 'exception))) + (cond + ((eq? subrun-remove-succeeded 'exception) + (let* ((logfile (subrun:get-log-path run-dir "remove"))) + (debug:print 0 *default-log-port* "ERROR: removing subrun of of " test-fulln " with run-id " run-id " ; see logfile @ "logfile)) + (if (not (null? tal)) + (loop (car tal)(cdr tal)))) + (subrun-remove-succeeded + (debug:print 0 *default-log-port* "Now removing of " test-fulln " with run-id " run-id " since subrun was removed.") + ;;(runs:remove-test-directory new-test-dat mode) ;; let normal case handle this. it will go thru loop again as non-subrun + (let ((newtal (append tal (list test)))) + (loop (car newtal)(cdr newtal)))) + (else + (let* ((logfile (subrun:get-log-path run-dir "remove"))) + (debug:print 0 *default-log-port* "WARNING: removal of subrun failed. Please check "logfile" for details.")) + ;; send to back of line, loop (will not match has-subrun next time through) + (if (not (null? tal)) + (loop (car tal)(cdr tal)))))) + ) + ) ; end case rem-status + ) ; end let + ); end cond has-subrun + + (else + ;; BB - TODO - consider backgrounding to threads to delete tests (work below) + (debug:print-info 2 *default-log-port* "test: " test-name " itest-state: " test-state) + (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) + (begin + (if (not (hash-table-ref/default test-retry-time test-fulln #f)) + (begin + ;; want to set to REMOVING BUT CANNOT do it here? + (hash-table-set! test-retry-time test-fulln (current-seconds)))) + (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) + ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first + ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give + ;; up and blow it away. + (begin + (debug:print 0 *default-log-port* "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) + (thread-sleep! 1)) + (begin + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) + (thread-sleep! 1))) + ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... + (if (null? tal) + (loop new-test-dat tal) + (loop (car tal)(append tal (list new-test-dat))))) + (begin + (let ((rundir (db:test-get-rundir new-test-dat))) + (if (and (not (string= rundir "/tmp/badname")) + (file-exists? rundir) + (substring-index run-name rundir) + (tests:glob-like-match (conc "%/" target "/%") rundir) + ) + (begin + (set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal + (set! lastrealpath (remove-last-path-directory (resolve-pathname lasttpath))) + (hash-table-set! run-paths-hash lastrealpath 1) + (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) + ) + (begin + (debug:print 2 *default-log-port* "Not removing directory " rundir " because either it doesn't exist or has a bad name") + (debug:print 2 *default-log-port* "Is /tmp/badname: " (string= rundir "/tmp/badname")) + (debug:print 2 *default-log-port* "Exists: " (file-exists? rundir)) + (debug:print 2 *default-log-port* "Has run-name: " (substring-index run-name rundir)) + (debug:print 2 *default-log-port* "Has target: " (tests:glob-like-match (conc "%/" target "/%") rundir)) + (debug:print 2 *default-log-port* "Target: " target) + + ;;PJH remove record from db no need to cleanup directory + (case mode + ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) (db:test-get-state test)(db:test-get-status test) #f)) + ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) + (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test)))) + + ) + ) + ) + + (if (not (null? tal)) + (loop (car tal)(cdr tal))))))) + (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) + ((kill-runs) + ;; RUNNING -> KILLREQ + ;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED + (cond + ((and has-subrun (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))) + (common:send-thunk-to-background-thread + (lambda () + (let* ((subrun-remove-succeeded + (subrun:kill-subrun run-dir keep-records))) + #t))) + (if (not (null? tal)) + (loop (car tal)(cdr tal))) + ) + ((member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) + (debug:print 1 *default-log-port* "INFO: issuing killreq to test "test-fulln) + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) + (if (not (null? tal)) + (loop (car tal)(cdr tal)))) + ((and (member test-status '("PREQ_FAIL" "PREQ_DISCARDED" "BLOCKED" "ZERO_ITEMS" "KEEP_TRYING" "TEN_STRIKES" "TIMED_OUT"))) + (rmt:set-state-status-and-roll-up-items run-id (db:test-get-id test) 'foo "NOT_STARTED" "n/a" (conc "kill-run moved from "test-state":"test-status" to NOT_STARTED:n/a")) + ;;(mt:test-set-state-status-by-id run-id (db:test-get-id test) "NOT_STARTED" "n/a" (conc "kill-run moved from "test-state":"test-status" to NOT_STARTED:n/a")) + (if (not (null? tal)) + (loop (car tal)(cdr tal))) + ) + (else + (if (not (null? tal)) + (loop (car tal)(cdr tal))) + ))) + ((set-state-status) + (let* ((new-state (car state-status)) + (new-status (cadr state-status)) + (test-id (db:test-get-id test)) + (test-run-dir (db:test-get-rundir new-test-dat)) + (has-subrun (and (subrun:subrun-test-initialized? test-run-dir) + (not (subrun:subrun-removed? test-run-dir))))) + (when has-subrun + (common:send-thunk-to-background-thread + (lambda () + (subrun:set-state-status test-run-dir state status new-state-status) + ) + ) + ) + (debug:print-info 2 *default-log-port* "new state " new-state ", new status " new-status ) + (mt:test-set-state-status-by-id run-id test-id new-state new-status #f)) + (if (not (null? tal)) + (loop (car tal)(cdr tal)))) + ((run-wait) + ;; BB TODO - manage has-subrun case + (debug:print-info 2 *default-log-port* "still waiting, " (length tests) " tests still running") + (thread-sleep! 5) + (let ((new-tests (proc-get-tests run-id))) + (if (null? new-tests) + (debug:print-info 1 *default-log-port* "Run completed according to zero tests matching provided criteria.") + (loop (car new-tests)(cdr new-tests))))) + ((archive) + ;; BB TODO - manage has-subrun case + (if (and run-dir (not toplevel-with-children)) + (let ((ddir (conc run-dir "/"))) + (case (string->symbol (args:get-arg "-archive")) + ((save save-remove keep-html) + (if (common:file-exists? ddir) + (debug:print-info 0 *default-log-port* "Estimating disk space usage for " test-fulln ": " (common:get-disk-space-used ddir))))))) + (if (not (null? tal)) + (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 + (let* ((linkspath (remove-last-path-directory lasttpath)) + (runpaths (hash-table-keys run-paths-hash)) + ) + + (debug:print 2 *default-log-port* "run-paths-hash: " (hash-table-keys run-paths-hash)) + + (debug:print 1 *default-log-port* "Removing target " target "run: " run-name) + (if (not keep-records) + (begin + (debug:print 1 *default-log-port* "Removing DB records for the run.") + (rmt:delete-run run-id) + (rmt:delete-old-deleted-test-records run-id)) + ) + (if (not (equal? linkspath "/does/not/exist/I")) + (begin + (debug:print 1 *default-log-port* "Recursively removing links dir " linkspath) + (runs:recursive-delete-with-error-msg linkspath))) + + (for-each (lambda(runpath) + (debug:print 1 *default-log-port* "Recursively removing runs dir " runpath) + (runs:recursive-delete-with-error-msg runpath) + ) + runpaths + ) + ))))) + )) + runs) + ;; special case - archive get + (if (equal? (args:get-arg "-archive") "get") + (archive:bup-get-data "get" #f #f test-records rp-mutex bup-mutex)) + (if (or (equal? (args:get-arg "-archive") "save") (equal? (args:get-arg "-archive") "save-remove")) + (begin + (debug:print 0 *default-log-port* "db archive started") + (archive:megatest-db target runnamepatt) + (debug:print 0 *default-log-port* "db archived"))) + ) + #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) + (common:nice-path run-dir) + #f)) + (clean-mode (or mode 'remove-all)) + (test-id (db:test-get-id test)) + ;; (lock-key (conc "test-" test-id)) + ;; (got-lock (let loop ((lock (rmt:no-sync-get-lock lock-key)) + ;; (expire-time (+ (current-seconds) 30))) ;; give up on getting the lock and steal it after 15 seconds + ;; (if (car lock) + ;; #t + ;; (if (> (current-seconds) expire-time) + ;; (begin + ;; (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to clean test with id " test-id) + ;; (rmt:no-sync-del! lock-key) ;; destroy the lock + ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;; + ;; (begin + ;; (thread-sleep! 1) + ;; (loop (rmt:no-sync-get-lock lock-key) expire-time))))))) + ) + (case clean-mode + ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) + ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) + ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) + (debug:print-info 2 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) + (if (and real-dir + (> (string-length real-dir) 5) + (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. + (let* ((realpath (resolve-pathname run-dir))) + (debug:print-info 1 *default-log-port* "Recursively removing " realpath) + (if (common:file-exists? realpath) + (runs:safe-delete-test-dir realpath) + (debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable"))) + (if real-dir + (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist") + (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) + (if (symbolic-link? run-dir) + (begin + (debug:print-info 1 *default-log-port* "Removing symlink " run-dir) + (handle-exceptions + exn + (debug:print-error 0 *default-log-port* " Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue, exn=" exn) + (delete-file run-dir))) + (if (directory? run-dir) + (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) + (debug:print 0 *default-log-port* "WARNING: refusing to remove " run-dir " as it is not empty") + (handle-exceptions + exn + (debug:print-error 0 *default-log-port* " Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue, exn=" exn) + (delete-directory run-dir))) + (if (and run-dir + (not (member run-dir (list "n/a" "/tmp/badname")))) + (debug:print 0 *default-log-port* "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") + (debug:print 0 *default-log-port* "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) + )) + ;; Only delete the records *after* removing the directory. If things fail we have a record + (case clean-mode + ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) (db:test-get-state test)(db:test-get-status test) #f)) + ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) + (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test)))) + ;; (rmt:no-sync-del! lock-key) + )) + +;;====================================================================== +;; Routines for manipulating runs +;;====================================================================== + +;; Since many calls to a run require pretty much the same setup +;; this wrapper is used to reduce the replication of code +(define (general-run-call switchname action-desc proc) + (let ((runname (common:args-get-runname)) + (target (common:args-get-target))) + (cond + ((not target) + (debug:print-error 0 *default-log-port* "Missing required parameter for " switchname ", you must specify the target with -target") + (exit 3)) + ((not runname) + (debug:print-error 0 *default-log-port* "Missing required parameter for " switchname ", you must specify the run name with -runname runname") + (exit 3)) + (else + (let (;; (db #f) + (keys #f)) + (if (launch:setup) + (begin + (full-runconfigs-read) ;; cache the run config + ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW. + ) ;; do not cache here - need to be sure runconfigs is processed + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + + + (set! keys (keys:config-get-fields *configdat*)) + ;; have enough to process -target or -reqtarg here + (if (args:get-arg "-reqtarg") + (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL + (runconfig (read-config runconfigf #f #t environ-patt: #f))) + (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) + (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) + + (begin + (debug:print-error 0 *default-log-port* "[" (args:get-arg "-reqtarg") "] not found in " runconfigf) + ;; (if db (sqlite3:finalize! db)) + (exit 1) + ))) + (if (args:get-arg "-target") + (keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash))) + (if (not (car *configinfo*)) + (begin + (debug:print-error 0 *default-log-port* "Attempted to " action-desc " but run area config file not found") + (exit 1)) + ;; Extract out stuff needed in most or many calls + ;; here then call proc + (let* ((keyvals (keys:target->keyval keys target))) + (proc target runname keys keyvals))) + ;; (if db (sqlite3:finalize! db)) + (set! *didsomething* #t)))))) + +;;====================================================================== +;; Lock/unlock runs +;;====================================================================== + +(define (runs:handle-locking target keys runname lock unlock user) + (let* ((db #f) + (rundat (mt:get-runs-by-patt keys runname target)) + (header (vector-ref rundat 0)) + (runs (vector-ref rundat 1))) + (for-each (lambda (run) + (let ((run-id (db:get-value-by-header run header "id")) + (str (if lock + "lock" + "unlock"))) + (if (or lock + (and unlock + (or (args:get-arg "-force") + (begin + (print "Do you really wish to unlock run " run-id "?\n y/n: ") + (equal? "y" (read-line)))))) + (begin + (rmt:lock/unlock-run run-id lock unlock user) + (debug:print-info 0 *default-log-port* "Done " str " on run id " run-id)) + (debug:print-info 0 *default-log-port* "Skipping lock/unlock on " run-id)))) + runs))) +;;====================================================================== +;; Rollup runs +;;====================================================================== + +;; Update the test_meta table for this test +(define (runs:update-test_meta test-name test-conf) + (let ((currrecord (rmt:testmeta-get-record test-name))) + (if (not currrecord) + (begin + (set! currrecord (make-vector 11 #f)) + (rmt:testmeta-add-record test-name))) + (for-each + (lambda (key) + (let* ((idx (cadr key)) + (fld (car key)) + (val (configf:lookup test-conf "test_meta" fld))) + ;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val) + (if (and val (not (equal? (vector-ref currrecord idx) val))) + (begin + (debug:print 0 *default-log-port* "Updating " test-name " " fld " to " val) + (rmt:testmeta-update-field test-name fld val))))) + '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) + +;; find tests with matching tags, tagpatt is a string "tagpatt1,tagpatt2%, ..." +;; +(define (runs:get-tests-matching-tags tagpatt) + (let* ((tagdata (rmt:get-tests-tags)) + (res '())) ;; list of tests that match one or more tags + (for-each + (lambda (row) + (let* ((tag (car row)) + (tests (cdr row))) + (if (patt-list-match tag tagpatt) + (set! res (append tests res))))) + tagdata) + res)) + + +;; Update test_meta for all tests +(define (runs:update-all-test_meta db) + (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) + (for-each + (lambda (test-name) + (let* ((test-conf (mt:lazy-read-test-config test-name))) + (if test-conf (runs:update-test_meta test-name test-conf)))) + (hash-table-keys test-names)))) + +;; This could probably be refactored into one complex query ... +;; NOT PORTED - DO NOT USE YET +;; +#;(define (runs:rollup-run keys runname user keyvals) + (debug:print 4 *default-log-port* "runs:rollup-run, keys: " keys " -runname " runname " user: " user) + (let* ((db #f) + ;; register run operates on the main db + (new-run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) + (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) + (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '())) + (curr-tests-hash (make-hash-table))) + (rmt:update-run-event_time new-run-id) + ;; index the already saved tests by testname and itemdat in curr-tests-hash + (for-each + (lambda (testdat) + (let* ((testname (db:test-get-testname testdat)) + (item-path (db:test-get-item-path testdat)) + (full-name (conc testname "/" item-path))) + (hash-table-set! curr-tests-hash full-name testdat))) + curr-tests) + ;; NOPE: Non-optimal approach. Try this instead. + ;; 1. tests are received in a list, most recent first + ;; 2. replace the rollup test with the new *always* + (for-each + (lambda (testdat) + (let* ((testname (db:test-get-testname testdat)) + (item-path (db:test-get-item-path testdat)) + (full-name (conc testname "/" item-path)) + (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) + (test-steps (rmt:get-steps-for-test (db:test-get-id testdat))) + (new-test-record #f)) + ;; replace these with insert ... select + (apply sqlite3:execute + db + (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " + "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") + new-run-id (cddr (vector->list testdat))) + (set! new-testdat (car (mt:get-tests-for-run new-run-id (conc testname "/" item-path) '() '()))) + (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? + ;; Now duplicate the test steps + (debug:print 4 *default-log-port* "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) + (cdb:remote-run ;; to be replaced, note: this routine is not used currently + (lambda () + (sqlite3:execute + db + (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " + "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") + (db:test-get-id testdat)) + ;; Now duplicate the test data + (debug:print 4 *default-log-port* "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) + (sqlite3:execute + db + (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) " + "SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;") + (db:test-get-id testdat)))) + )) + prev-tests))) + +(define doc-template + '(*TOP* + (*PI* xml "version='1.0'") + (testsuite))) + +(define (runs:update-junit-test-reporter-xml run-id) + (let* ( + (junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml")) + (junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir")) + (xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" )) + (if junit-test-report-dir + junit-test-report-dir + (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))) + #f)) + (xml-ts-name (if xml-dir + (conc (getenv "MT_TESTSUITENAME")"."(string-translate (getenv "MT_TARGET") "/" ".") "." (getenv "MT_RUNNAME")) + #f)) + (keyname (if xml-ts-name (common:get-signature xml-ts-name) #f)) + (xml-path (if xml-dir + (conc xml-dir "/" keyname ".xml") + #f)) + + (test-data (if xml-dir + (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses + #f #f ;; offset limit + #f ;; not-in + #f ;; sort-by + #f ;; sort-order + #f ;; get full data (not 'shortlist) + 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time + #f) + '())) + (tests-count (if xml-dir (length test-data) #f))) + (if (and junit-test-reporter (equal? junit-test-reporter "yes" )) + (begin + ;((sxml-modify! `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count)))) doc) + + (let loop ((test (car test-data)) + (tail (cdr test-data)) + (doc doc-template) + (fail-cnt 0) + (error-cnt 0)) + (let* ((test-name (vector-ref test 2)) + (test-itempath (vector-ref test 11)) + (tc-name (conc test-name (if (and test-itempath (not (equal? test-itempath ""))) (conc "." (string-translate test-itempath "/" "." )) ""))) + (test-state (vector-ref test 3)) + (comment (vector-ref test 14)) + (test-status (vector-ref test 4)) + (exc-msg (conc "No bucket for State " test-state " Status " test-status)) + (new-doc (cond + ((member test-state (list "RUNNING" )) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc)) + ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED")) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc)) + ((member test-status (list "PASS" "WARN" "WAIVED")) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc)) + ((member test-status (list "FAIL" "CHECK")) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) + ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc)) + ((member test-status (list "SKIP")) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc)) + (else + (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status)) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc)))) + (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) + (+ error-cnt 1) + error-cnt)) + (new-fail-cnt (if (member test-status (list "FAIL" "CHECK")) + (+ fail-cnt 1) + fail-cnt))) + (if (null? tail) + (let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc))) + (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt) + (handle-exceptions + exn + (let* ((msg ((condition-property-accessor 'exn 'message) exn))) + (debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg ", exn=" exn))) + + (if (not (file-exists? xml-dir)) + (create-directory xml-dir #t)) + (if (not (rmt:no-sync-get/default keyname #f)) + (begin + (rmt:no-sync-set keyname "on") + (debug:print 0 *default-log-port* "creating xml at " xml-path) + (with-output-to-file xml-path + (lambda () + (print (sxml-serializer#serialize-sxml final-doc ns-prefixes: (list (cons 'gnm "http://foo")))))) + (rmt:no-sync-del! keyname)) + (debug:print 0 *default-log-port* "Could not get the lock. Skip writing the xml file.")))) + (loop (car tail) (cdr tail) new-doc new-fail-cnt new-error-cnt)))))))) + + +;; clean cache files +(define (runs:clean-cache target runname toppath) + (if target + (if runname + (let* ((linktree (common:get-linktree)) ;; (if toppath (configf:lookup *configdat* "setup" "linktree"))) + (runtop (conc linktree "/" target "/" runname)) + (files (if (common:file-exists? runtop) + (append (glob (conc runtop "/.megatest*")) + (glob (conc runtop "/.runconfig*"))) + '()))) + (if (null? files) + (debug:print-info 2 *default-log-port* "No cached megatest or runconfigs files found. None removed.") + (begin + (debug:print-info 2 *default-log-port* "Removing cached files:\n " (string-intersperse files "\n ")) + (for-each + (lambda (f) + (handle-exceptions + exn + (debug:print 0 *default-log-port* "WARNING: Failed to remove file " f ", exn=" exn) + (delete-file f))) + files)))) + (debug:print-error 0 *default-log-port* "-clean-cache requires -runname.")) + (debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg"))) + +;; set up needed environment variables given a run-id and optionally a target, itempath etc. +;; +(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) + ;;(bb-check-path msg: "runs:set-megatest-env-vars entry") + (let* ((target (or intarget + (common:args-get-target) + (get-environment-variable "MT_TARGET"))) + (keys (if inkeys inkeys (rmt:get-keys))) + (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) + (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) + (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) + (if testname (setenv "MT_TEST_NAME" testname)) + (if itempath (setenv "MT_ITEMPATH" itempath)) + + ;; get the info from the db and put it in the cache + (if link-tree + (setenv "MT_LINKTREE" link-tree) + (debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section.")) + (if (not vals) + (let ((ht (make-hash-table))) + (hash-table-set! *env-vars-by-run-id* run-id ht) + (set! vals ht) + (for-each + (lambda (key) + (hash-table-set! vals (car key) (cadr key))) + keyvals))) + ;; from the cached data set the vars + + (hash-table-for-each + vals + (lambda (key val) + (debug:print 2 *default-log-port* "setenv " key " " val) + (safe-setenv key val))) + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1") + ;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals)) + + (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) + ;; we had a case where there was an exception generated by the hash-table-ref + ;; due to *configdat* being #f Adding a handle and exit + (let fatal-loop ((count 0)) + (handle-exceptions + exn + (let ((call-chain (get-call-chain)) + (msg ((condition-property-accessor 'exn 'message) exn))) + (if (< count 5) + (begin ;; this call is colliding, do some crude stuff to fix it. + (debug:print 0 *default-log-port* "ERROR: *configdat* was inaccessible! This should never happen. Retry #" count + ", exn=" exn) + (launch:setup force-reread: #t) + (fatal-loop (+ count 1))) + (begin + (debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count + " times. Message: " msg) + (debug:print 0 *default-log-port* "Call chain:") + (with-output-to-port *default-log-port* + (lambda () + (print "*configdat* is >>"*configdat*"<<") + (pp *configdat*) + (pp call-chain))) + + (exit 1)))) + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5") + (when (or (not *configdat*) (not (hash-table? *configdat*))) + (debug:print 0 *default-log-port* "WARNING: *configdat* was inaccessible! This should never happen. Brute force reread.") + ;;(BB> "ERROR: *configdat* was inaccessible! This should never happen. Brute force reread.") + (thread-sleep! 2) ;; assuming nfs lag. + (launch:setup force-reread: #t)) + (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block. + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 2") + ;; Lets use this as an opportunity to put MT_RUNNAME in the environment + (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) + (if runname + (setenv "MT_RUNNAME" runname) + (debug:print-error 0 *default-log-port* "no value for runname for id " run-id))) + (setenv "MT_RUN_AREA_HOME" *toppath*) + ;; if a testname and itempath are available set the remaining appropriate variables + (if testname (setenv "MT_TEST_NAME" testname)) + (if itempath (setenv "MT_ITEMPATH" itempath)) + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 3") + (if (and testname link-tree) + (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/" + (getenv "MT_TARGET") "/" + (getenv "MT_RUNNAME") "/" + (getenv "MT_TEST_NAME") + (if (and itempath + (not (equal? itempath ""))) + (conc "/" itempath) + "")))))) +(define (set-item-env-vars itemdat) + (for-each (lambda (item) + (debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item)) + (setenv (car item) (cadr item))) + itemdat)) + +(define (runconfig:read fname target environ-patt) + (let ((ht (make-hash-table))) + (if target (hash-table-set! ht target '())) + (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f)))) + +;; NB// to process a runconfig ensure to use environ-patt with target! +;; +(define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t)) + (let* ((keys (map car keyvals)) + (thekey (if keyvals + (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/") + (or (common:args-get-target) + (get-environment-variable "MT_TARGET") + (begin + (debug:print-error 0 *default-log-port* "setup-env-defaults called with no run-id or -target or -reqtarg") + "nothing matches this I hope")))) + ;; Why was system disallowed in the reading of the runconfigs file? + ;; NOTE: Should be setting env vars based on (target|default) + (confdat (runconfig:read fname thekey environ-patt)) + (whatfound (make-hash-table)) + (finaldat (make-hash-table)) + (sections (list "default" thekey))) + (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code + (debug:print 4 *default-log-port* "Using key=\"" thekey "\"") + + (if change-env + (for-each ;; NB// This can be simplified with new content of keyvals having all that is needed. + (lambda (keyval) + (safe-setenv (car keyval)(cadr keyval))) + keyvals)) + + (for-each + (lambda (section) + (let ((section-dat (hash-table-ref/default confdat section #f))) + (if section-dat + (for-each + (lambda (envvar) + (let ((val (cadr (assoc envvar section-dat)))) + (hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1)) + (if (and (string? envvar) + (string? val) + change-env) + (safe-setenv envvar val)) + (hash-table-set! finaldat envvar val))) + (map car section-dat))))) + sections) + (if already-seen + (begin + (debug:print 2 *default-log-port* "Key settings found in runconfigs.config:") + (for-each (lambda (fullkey) + (debug:print 2 *default-log-port* (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0)))) + sections) + (debug:print 2 *default-log-port* "---") + (set! *already-seen-runconfig-info* #t))) + ;; finaldat ;; was returning this "finaldat" which would be good but conflicts with other uses + confdat + )) + +(define (set-run-config-vars run-id keyvals targ-from-db) + (push-directory *toppath*) ;; the push/pop doesn't appear to do anything ... + (let ((runconfigf (conc *toppath* "/runconfigs.config")) + (targ (or (common:args-get-target) + targ-from-db + (get-environment-variable "MT_TARGET")))) + (pop-directory) + (if (common:file-exists? runconfigf) + (setup-env-defaults runconfigf run-id #t keyvals + environ-patt: (conc "(default" + (if targ + (conc "|" targ ")") + ")"))) + (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf)))) + +;; given (a (b c) d) return ((a b d)(a c d)) +;; NOTE: this feels like it has been done before - perhaps with items handling? +;; +(define (runconfig:combinations inlst) + (let loop ((hed (car inlst)) + (tal (cdr inlst)) + (res '())) + ;; (print "res: " res " hed: " hed) + (if (list? hed) + (let ((newres (if (null? res) ;; first time through convert incoming items to list of items + (map list hed) + (apply append + (map (lambda (r) ;; iterate over items in res + (map (lambda (h) ;; iterate over items in hed + (append r (list h))) + hed)) + res))))) + ;; (print "newres1: " newres) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres))) + (let ((newres (if (null? res) + (list (list hed)) + (map (lambda (r) + (append r (list hed))) + res)))) + ;; (print "newres2: " newres) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres)))))) + +;; multi-part expand +;; Given a/b,c,d/e,f return a/b/e a/b/f a/c/e a/c/f a/d/e a/d/f +;; +(define (runconfig:expand target) + (let* ((parts (map (lambda (x) + (string-split x ",")) + (string-split target "/")))) + (map (lambda (x) + (string-intersperse x "/")) + (runconfig:combinations parts)))) + +;; multi-target expansion +;; a/b/c/x,y,z a/b/d/x,y => a/b/c/x a/b/c/y a/b/c/z a/b/d/x a/b/d/y +;; +(define (runconfig:expand-target target-strs) + (delete-duplicates + (apply append (map runconfig:expand (string-split target-strs " "))))) + +#| + (if (null? target-strs) + '() + (let loop ((hed (car target-strs)) + (tal (cdr target-strs)) + (res '())) + ;; first break all parts into individual target patterns + (if (string-index hed " ") ;; this is a multi-target target + (let ((newres (append (string-split hed " ") res))) + (runconfig:expand-target newres)) + (if (string-index hed ",") ;; this is a multi-target where one or more parts are comma separated + +|# + +;; Spec for End of test +;; At end of each test call, after marking self as COMPLETED do run-state-status-rollup +;; At transition to run COMPLETED/X do hooks +;; Definition: test_dead if event_time + duration + 1 minute? < current_time AND +;; we can prove the process is not alive (ssh host pstree -A pid) +;; if dead safe to mark the test as killed in the db +;; State/status table +;; new +;; 100% COMPLETED/ (PASS,FAIL,ABORT etc.) ==> COMPLETED / X where X is same as itemized rollup +;; > 3 RUNNING with not test_dead do nothing (run should already be RUNNING/ na +;; > 0 RUNNING and test_dead then send KILLREQ ==> COMPLETED +;; 0 RUNNING ==> this is actually the first condition, should not get here +(define *last-rollup* 0) +(define (launch:end-of-run-check run-id ) + (let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id)) + (running-cnt (rmt:get-count-tests-running-for-run-id run-id)) + (all-test-launched (rmt:get-var (conc "lunch-complete-" run-id))) + (current-state-status (rmt:get-run-state-status run-id)) + (current-state (car current-state-status)) ;; (rmt:get-run-state run-id)) + (current-status (cdr current-state-status))) ;; (rmt:get-run-status run-id))) + ;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing + (debug:print 0 *default-log-port* "Running test cnt :" running-cnt) + ;; + ;; TODO: add a final rollup when run is done (if there isn't one already) + ;; + (if (or (< running-cnt 3) ;; have only few running + (> (- (current-seconds) *last-rollup*) 10)) ;; or haven't rolled up in past ten seconds + (begin + (rmt:set-state-status-and-roll-up-run run-id current-state current-status) + (set! *last-rollup* (current-seconds)))) + (runs:update-junit-test-reporter-xml run-id) + (cond + ((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" )) + (if (and (equal? (rmt:get-var (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id))) + (begin + (debug:print 4 *default-log-port* "look for post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var (conc "end-of-run-" run-id))) + (debug:print 0 *default-log-port* "End of Run Detected.") + (rmt:set-var (conc "end-of-run-" run-id) "yes") + ;(thread-sleep! 10) + (runs:run-post-hook run-id) + (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var (conc "end-of-run-" run-id))) + (common:simple-unlock (conc "endOfRun" run-id))) + (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var (conc "end-of-run-" run-id))))) + ((> running-cnt 3) + (debug:print 0 *default-log-port* "There are " running-cnt " tests running." )) + ((> running-cnt 0) + (debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" ) + (let ((kill-cnt (launch:kill-tests-if-dead run-id))) + (if (and all-test-launched (equal? all-test-launched "yes") (eq? kill-cnt running-cnt)) + (launch:end-of-run-check run-id)))) ;;todo + (else (debug:print 0 *default-log-port* "Should it get here?? May be everything is not launched yet. Running test cnt:" running-cnt " Not completed test cnt:" not-completed-cnt) + (let* ((not-completed-tests (rmt:get-tests-for-run run-id "%" `("NOT_STARTED" "RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f))) + (if (> (length not-completed-tests) 0) + (let loop ((running-test (car not-completed-tests)) + (tal (cdr not-completed-tests))) + (let* ((test-name (vector-ref running-test 2)) + (item-path (vector-ref running-test 11))) + (debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed") + (if (not (null? tal)) + (loop (car tal) (cdr tal))))))))))) + +(define (launch:kill-tests-if-dead run-id) + (let* ((running-tests (rmt:get-tests-for-run run-id "%" `("RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f))) + (let loop ((running-test (car running-tests)) + (tal (cdr running-tests)) + (kill-cnt 0)) + (let* ((test-name (vector-ref running-test 2)) + (item-path (vector-ref running-test 11)) + (test-id (vector-ref running-test 0)) + (host (vector-ref running-test 6)) + (pid (rmt:test-get-top-process-pid run-id test-id)) + (event-time (vector-ref running-test 5)) + (duration (vector-ref running-test 12)) + (flag 0) + (curr-time (current-seconds))) + (if (and (< (+ event-time duration 600) curr-time) (not (commonmod:is-test-alive host pid))) ;;test has not updated duration in last 10 min then likely its not running but confirm before marking it as killed + (begin + (debug:print 0 *default-log-port* "test " test-name "/" item-path " needs to be killed") + (set! flag 1) + (rmt:set-state-status-and-roll-up-items run-id test-name item-path "KILLREQ" "n/a" #f))) + (if (not (null? tal)) + (loop (car tal) (cdr tal) (+ kill-cnt flag)) + (+ kill-cnt flag)))))) + +;; 1. look though disks list for disk with most space +;; 2. create run dir on disk, path name is meaningful +;; 3. create link from run dir to megatest runs area +;; 4. remotely run the test on allocated host +;; - could be ssh to host from hosts table (update regularly with load) +;; - could be netbatch +;; (launch-test db (cadr status) test-conf)) +(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) + (assert runname "FATAL: launch-test called with no runname") + (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex + (let* ( ;; (lock-key (conc "test-" test-id)) + ;; (got-lock (let loop ((lock (rmt:no-sync-get-lock lock-key)) + ;; (expire-time (+ (current-seconds) 15))) ;; give up on getting the lock and steal it after 15 seconds + ;; (if (car lock) + ;; #t + ;; (if (> (current-seconds) expire-time) + ;; (begin + ;; (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to launch test " keyvals " " runname " " test-name " " test-path) + ;; (rmt:no-sync-del! lock-key) ;; destroy the lock + ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;; + ;; (begin + ;; (thread-sleep! 1) + ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)))))) + (item-path (item-list->path itemdat)) + (contour #f)) ;; NOT READY FOR THIS (args:get-arg "-contour"))) + (let loop ((delta (- (current-seconds) *last-launch*)) + (launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 0))) + (if (> launch-delay delta) + (begin + ;; (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay. + ;; (debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds")) + (thread-sleep! (- launch-delay delta)) + (loop (- (current-seconds) *last-launch*) launch-delay)))) + (change-directory *toppath*) + (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute", *maybe* - the longer they are set the longer each launch takes (must be non-overlapping with the vars) + (append + (list + (list "MT_RUN_AREA_HOME" *toppath*) + (list "MT_TEST_NAME" test-name) + (list "MT_RUNNAME" runname) + (list "MT_ITEMPATH" item-path) + (list "MT_CONTOUR" contour) + ) + itemdat)) + (let* ((tregistry (tests:get-all)) ;; third param (below) is system-allowed + ;; for tconfig, why do we allow fallback to test-conf? + (tconfig (or (tests:get-testconfig test-name item-path tregistry #t force-create: #t) + (begin + (debug:print 0 *default-log-port* "WARNING: falling back to pre-calculated testconfig. This is likely not desired.") + test-conf))) ;; force re-read now that all vars are set + (useshell (let ((ush (configf:lookup *configdat* "jobtools" "useshell"))) + (if ush + (if (equal? ush "no") ;; must use "no" to NOT use shell + #f + ush) + #t))) ;; default is yes + (runscript (configf:lookup tconfig "setup" "runscript")) + (ezsteps (> (length (hash-table-ref/default tconfig "ezsteps" '())) 0)) ;; don't send all the steps, could be big, just send a flag + (subrun (> (length (hash-table-ref/default tconfig "subrun" '())) 0)) ;; send a flag to process a subrun + ;; (diskspace (configf:lookup tconfig "requirements" "diskspace")) + ;; (memory (configf:lookup tconfig "requirements" "memory")) + ;; (hosts (configf:lookup *configdat* "jobtools" "workhosts")) ;; I'm pretty sure this was never completed + (remote-megatest (configf:lookup *configdat* "setup" "executable")) + (run-time-limit (or (configf:lookup tconfig "requirements" "runtimelim") + (configf:lookup *configdat* "setup" "runtimelim"))) + ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to + ;; allow running from dashboard. Extract the path + ;; from the called megatest and convert dashboard + ;; or dboard to megatest + (local-megatest (common:find-local-megatest)) + #;(local-megatest (let* ((lm (car (argv))) + (dir (pathname-directory lm)) + (exe (pathname-strip-directory lm))) + (conc (if dir (conc dir "/") "") + (case (string->symbol exe) + ((dboard) "../megatest") + ((mtest) "../megatest") + ((dashboard) "megatest") + (else exe))))) + (launcher (common:get-launcher *configdat* test-name item-path)) ;; (configf:lookup *configdat* "jobtools" "launcher")) + (test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path + (work-area #f) + (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all + (diskpath #f) + (cmdparms #f) + (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) + (mt-bindir-path #f) + (testinfo (rmt:get-test-info-by-id run-id test-id)) + (mt_target (string-intersperse (map cadr keyvals) "/")) + (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) + (if (args:get-arg "-logging")(list "-logging") '()) + (if (configf:lookup *configdat* "misc" "profilesw") + (list (configf:lookup *configdat* "misc" "profilesw")) + '())))) + ;; (if hosts (set! hosts (string-split hosts))) + ;; set the megatest to be called on the remote host + (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) + (set! mt-bindir-path (pathname-directory remote-megatest)) + (if launcher (set! launcher (string-split launcher))) + ;; set up the run work area for this test + (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run + (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir + (begin + (debug:print-info 0 *default-log-port* "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path) + (runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record + + ;; prevent overlapping actions - set to LAUNCHED as early as possible + ;; + ;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail + (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) + (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "LAUNCHED" #f) + ;; (pp (hash-table->alist tconfig)) + (set! diskpath (get-best-disk *configdat* tconfig)) + (debug:print 2 *default-log-port* "best disk path = " diskpath) + (if diskpath + (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) + (set! work-area (car dat)) + (set! toptest-work-area (cadr dat)) + (debug:print-info 2 *default-log-port* "Using work area " work-area)) + (begin + (set! work-area (conc test-path "/tmp_run")) + (create-directory work-area #t) + (debug:print 0 *default-log-port* "WARNING: No disk work area specified - running in the test directory under tmp_run"))) + (set! cmdparms (base64:base64-encode + (z3:encode-buffer + (with-output-to-string + (lambda () ;; (list 'hosts hosts) + (write (list (list 'testpath test-path) + ;; (list 'transport (conc *transport-type*)) + ;; (list 'serverinf *server-info*) + #;(list 'homehost (let* ((hhdat (server:get-homehost))) + (if hhdat + (car hhdat) + #f))) + #;(list 'serverurl (if *runremote* ;; would like to add this back ... WORK NEEDED + (remote-server-url *runremote*) + #f)) ;; + (list 'areaname (common:get-testsuite-name)) + (list 'toppath *toppath*) + (list 'work-area work-area) + (list 'test-name test-name) + (list 'runscript runscript) + (list 'run-id run-id ) + (list 'test-id test-id ) + ;; (list 'item-path item-path ) + (list 'itemdat itemdat ) + (list 'megatest remote-megatest) + (list 'ezsteps ezsteps) + (list 'subrun subrun) + (list 'target mt_target) + (list 'contour contour) + (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) + (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) + (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) + (list 'runname runname) + (list 'mt-bindir-path mt-bindir-path)))))))) + + (setenv "MT_CMDINFO" cmdparms) ;; setting this for use in nblauncher + + ;; clean out step records from previous run if they exist + ;; (rmt:delete-test-step-records run-id test-id) + ;; if the dir does not exist we may have a itempath where individual variables are a path, launch anyway + (if (common:file-exists? work-area) + (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir + (cond + ;; ((and launcher hosts) ;; must be using ssh hostname + ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param))) + ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) + (launcher + (set! fullcmd (append launcher (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param))) + ;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms)))) + (else + (if (not useshell)(debug:print 0 *default-log-port* "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section")) + (set! fullcmd (append (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param (list (if useshell "&" "")))))) + ;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" ""))))) + (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) + (debug:print 1 *default-log-port* "Launching " work-area) + ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done + (debug:print 4 *default-log-port* "fullcmd: " fullcmd) + (set! *last-launch* (current-seconds)) ;; all that junk above takes time, set this as late as possible. + (let* ((commonprevvals (alist->env-vars + (hash-table-ref/default *configdat* "env-override" '()))) + (miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" + (append (list (list "MT_TEST_RUN_DIR" work-area) + (list "MT_TEST_NAME" test-name) + (list "MT_ITEM_INFO" (conc itemdat)) + (list "MT_RUNNAME" runname) + (list "MT_TARGET" mt_target) + (list "MT_ITEMPATH" item-path) + ) + itemdat))) + (testprevvals (alist->env-vars + (hash-table-ref/default tconfig "pre-launch-env-overrides" '()))) + ;; Launchwait defaults to true, must override it to turn off wait + (launchwait (if (equal? (configf:lookup *configdat* "setup" "launchwait") "no") #f #t)) + (launch-results-prev (apply (if launchwait ;; BB: TODO: refactor this to examine return code of launcher, if nonzero, set state to launch failed. + process:cmd-run-with-stderr-and-exitcode->list + process-run) + (if useshell + (let ((cmdstr (string-intersperse fullcmd " "))) + (if launchwait + cmdstr + (conc cmdstr " >> mt_launch.log 2>&1 &"))) + (car fullcmd)) + (if useshell + '() + (cdr fullcmd)))) + (success (if launchwait (equal? 0 (cadr launch-results-prev)) #t)) + (launch-results (if launchwait (car launch-results-prev) launch-results-prev))) + (if (not success) + (tests:test-set-status! run-id test-id "COMPLETED" "DEAD" "launcher failed; exited non-zero; check mt_launch.log" #f)) ;; (if launch-results launch-results "FAILED")) + (mutex-unlock! *launch-setup-mutex*) ;; yes, really should mutex all the way to here. Need to put this entire process into a fork. + ;; (rmt:no-sync-del! lock-key) ;; release the lock for starting this test + (if (not launchwait) ;; give the OS a little time to allow the process to start + (thread-sleep! 0.01)) + (with-output-to-file "mt_launch.log" + (lambda () + (print "LAUNCHCMD: " (string-intersperse fullcmd " ")) + (if (list? launch-results) + (apply print launch-results) + (print "NOTE: launched \"" fullcmd "\"\n but did not wait for it to proceed. Add the following to megatest.config \n[setup]\nlaunchwait yes\n if you have problems with this")) + #:append)) + (debug:print 2 *default-log-port* "Launching completed, updating db") + (debug:print 2 *default-log-port* "Launch results: " launch-results) + (if (not launch-results) + (begin + (debug:print 0 *default-log-port* "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") + ;; (sqlite3:finalize! db) + ;; good ole "exit" seems not to work + ;; (_exit 9) + ;; but this hack will work! Thanks go to Alan Post of the Chicken email list + ;; NB// Is this still needed? Should be safe to go back to "exit" now? + (process-signal (current-process-id) signal/kill) + )) + (alist->env-vars miscprevvals) + (alist->env-vars testprevvals) + (alist->env-vars commonprevvals) + launch-results)) + (change-directory *toppath*) + (thread-sleep! (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.0)))) + + +;; gather available information, if legit read configs in this order: +;; +;; if have cache; +;; read it a return it +;; else +;; megatest.config (do not cache) +;; runconfigs.config (cache if all vars avail) +;; megatest.config (cache if all vars avail) +;; returns: +;; *toppath* +;; side effects: +;; sets; *configdat* (megatest.config info) +;; *runconfigdat* (runconfigs.config info) +;; *configstatus* (status of the read data) +;; +(define (launch:setup #!key (force-reread #f) (areapath #f)) + (mutex-lock! *launch-setup-mutex*) + ;; this stops the train quickly for new processes + (if (and *toppath* + (file-exists? (conc *toppath*"/stop-the-train"))) + (begin + (debug:print 0 *default-log-port* "ERROR: found file "*toppath*"/stop-the-train, exiting immediately") + (exit 1))) + (if (and *toppath* + (eq? *configstatus* 'fulldata) (not force-reread)) ;; got it all + (begin + (debug:print 2 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata") + (mutex-unlock! *launch-setup-mutex*) + *toppath*) + (let ((res (launch:setup-body force-reread: force-reread areapath: areapath))) + (mutex-unlock! *launch-setup-mutex*) + res))) + +;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig +;; +(define (full-runconfigs-read) +;; in the envprocessing branch the below code replaces the further below code +;; (if (eq? *configstatus* 'fulldata) +;; *runconfigdat* +;; (begin +;; (launch:setup) +;; *runconfigdat*))) + + (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME")) + (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")) + #f)) + (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f))) + (if (and cfgf + (common:file-exists? cfgf) + (file-write-access? cfgf) + (common:use-cache?)) + (configf:read-alist cfgf) + (let* ((keys (rmt:get-keys)) + (target (common:args-get-target)) + (key-vals (if target (keys:target->keyval keys target) #f)) + (sections (if target (list "default" target) #f)) + (data (begin + (setenv "MT_RUN_AREA_HOME" *toppath*) + (if key-vals + (for-each (lambda (kt) + (setenv (car kt) (cadr kt))) + key-vals)) + ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) + (runconfig:read (conc *toppath* "/runconfigs.config") target #f)))) + (if (and rundir ;; have all needed variabless + (directory-exists? rundir) + (file-write-access? rundir)) + (begin + (if (not (common:in-running-test?)) + (configf:write-alist data cfgf)) + ;; force re-read of megatest.config - this resolves circular references between megatest.config + (launch:setup force-reread: #t) + ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW. + )) ;; we can safely cache megatest.config since we have a valid runconfig + data)))) + + +(define (get-best-disk confdat testconfig) + (let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f)) + (hash-table-ref/default confdat "disks" #f))) + (minspace (let ((m (configf:lookup confdat "setup" "minspace"))) + (string->number (or m "10000"))))) + (if disks + (let ((res (common:get-disk-with-most-free-space disks minspace))) + (if res + (cdr res) + ;; else if no valid disks... + (begin + (debug:print 0 *default-log-port* "WARNING: No valid disks or no disk with enough space found from " disks) + (if (null? disks) + (cons 1 (conc *toppath* "/runs")) + + ;; else try to create the directories anyway. + (let ((paths (sort disks (lambda (x y) (> (string-length (cadr x)) (string-length (cadr y))))))) + (let loop ((head (car paths)) (tail (cdr paths))) + (let ((result (handle-exceptions exn + (begin + (debug:print 0 *default-log-port* "failed to create dir " (cadr head) ", exn=" exn) + #f) + (create-directory (cadr head) #t)))) + (if result + result + (if (null? tail) + (begin + (debug:print 0 *default-log-port* "Using toppath/runs") + (conc *toppath* "/runs") + ) + (loop (car tail) (cdr tail)))))) + ) + ) ;; if null? disks + ) ;; if not res + ) + ) + ;; no disks definition - use toppath/runs, fall back to currdir/runs + (let* ((toppath (or *toppath* + (common:get-toppath *toppath*) + (begin + (debug:print-error 0 *default-log-port* "Creating runs dir in current directory, this is probably not what you wanted. Please check your setup.") + (current-directory)))) + (runsdir (conc toppath "/runs"))) + (if (not (file-exists? runsdir))(create-directory runsdir)) + runsdir) + ))) ;; the code creates the necessary directories if it does not exist and returns the path. + +;; Desired directory structure: +;; +;; - - -. +;; | +;; v +;; - - -|- +;; +;; dir stored in test is: +;; +;; - - [ - ] +;; +;; All log file links should be stored relative to the top of link path +;; +;; - [ - ] +;; +(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat #!key (remtries 2)) + (let* ((item-path (if (string? itemdat) itemdat (item-list->path itemdat))) ;; if pass in string - just use it + (runname (if (string? run-info) ;; if we pass in a string as run-info use it as run-name. + run-info + (db:get-value-by-header (db:get-rows run-info) + (db:get-header run-info) + "runname"))) + (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour")) + ;; convert back to db: from rdb: - this is always run at server end + (target (string-intersperse (map cadr keyvals) "/")) + + (not-iterated (equal? "" item-path)) + + ;; all tests are found at /test-base or /test-base + (testtop-base (conc target "/" runname "/" testname)) + (test-base (conc testtop-base (if not-iterated "" "/") item-path)) + + ;; nb// if itempath is not "" then it is prefixed with "/" + (toptest-path (conc disk-path (if contour (conc "/" contour) "") "/" testtop-base)) + (test-path (conc disk-path (if contour (conc "/" contour) "") "/" test-base)) + + ;; ensure this exists first as links to subtests must be created there + (linktree (common:get-linktree)) + ;; WAS: (let ((rd (configf:lookup *configdat* "setup" "linktree"))) + ;; (if rd rd (conc *toppath* "/runs")))) + ;; which seems wrong ... + + (lnkbase (conc linktree (if contour (conc "/" contour) "") "/" target "/" runname)) + (lnkpath (conc lnkbase "/" testname)) + (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)) + (lnktarget (conc lnkpath "/" item-path))) + + ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical + ;; rundir shortdir + (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path run-id) + + (debug:print 2 *default-log-port* "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) + (if (not (common:file-exists? linktree)) + (begin + (debug:print 0 *default-log-port* "WARNING: linktree did not exist! Creating it now at " linktree) + (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree)))) + ;; create the directory for the tests dir links, this is needed no matter what... try up to three times + (let loop ((done 3)) + (let ((success (if (and (not (common:directory-exists? lnkbase)) + (not (common:file-exists? lnkbase))) + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "Problem creating linktree base at " lnkbase ", exn=" exn) + (print-error-message exn (current-error-port)) + #t) + (create-directory lnkbase #t) + #f)))) + (if (and (not success)(> done 0)) + (loop (- done 1))))) + + ;; update the toptest record with its location rundir, cache the path + ;; This wass highly inefficient, one db write for every subtest, potentially + ;; thousands of unnecessary updates, cache the fact it was set and don't set it + ;; again. + + ;; Now create the link from the test path to the link tree, however + ;; if the test is iterated it is necessary to create the parent path + ;; to the iteration. use pathname-directory to trim the path by one + ;; level + (if (not not-iterated) ;; i.e. iterated + (let ((iterated-parent (pathname-directory (conc lnkpath "/" item-path)))) + (debug:print-info 2 *default-log-port* "Creating iterated parent " iterated-parent) + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* " Failed to create directory " iterated-parent ((condition-property-accessor 'exn 'message) exn) + ", continuing but link tree may be corrupted, exn=" exn) + #;(exit 1)) + (create-directory iterated-parent #t)))) + + (if (symbolic-link? lnkpath) + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* " Failed to remove symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) + ", continuing but link tree may be corrupted. exn=" exn) + #;(exit 1)) + (delete-file lnkpath))) + + (if (not (or (common:file-exists? lnkpath) + (symbolic-link? lnkpath))) + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* " Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) + ", continuing but link tree may be corrupted. exn=" exn) + #;(exit 1)) + (create-symbolic-link toptest-path lnkpath))) + + ;; NB - This was not working right - some top tests are not getting the path set!!! + ;; + ;; Do the setting of this record after the paths are created so that the shortdir can + ;; be set to the real directory location. This is safer for future clean up if the link + ;; tree is damaged or lost. + ;; + (if (not (hash-table-ref/default *toptest-paths* testname #f)) + (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path)) + (curr-test-path (if testinfo ;; (filedb:get-path *fdb* + ;; (db:get-path dbstruct + ;; (rmt:sdb-qry 'getstr + (db:test-get-rundir testinfo) ;; ) ;; ) + #f))) + (hash-table-set! *toptest-paths* testname curr-test-path) + ;; NB// Was this for the test or for the parent in an iterated test? + (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath + (if (common:file-exists? lnkpath) + ;; (resolve-pathname lnkpath) + (common:nice-path lnkpath) + lnkpath) + testname "" run-id) + ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) + (if (or (not curr-test-path) + (not (directory-exists? toptest-path))) + (begin + (debug:print-info 2 *default-log-port* "Creating " toptest-path " and link " lnkpath) + (handle-exceptions + exn + (if (directory-exists? toptest-path) ;; it was likely created in parallel + #t + (begin + (debug:print-info 0 *default-log-port* "failed to create directory " toptest-path ", exn=" exn) + #f)) + (create-directory toptest-path #t)) + (hash-table-set! *toptest-paths* testname toptest-path))))) + + ;; The toptest path has been created, the link to the test in the linktree has + ;; been created. Now, if this is an iterated test the real test dir must be created + (if (not not-iterated) ;; this is an iterated test + (begin ;; (let ((lnktarget (conc lnkpath "/" item-path))) + (debug:print 2 *default-log-port* "Setting up sub test run area") + (debug:print 2 *default-log-port* " - creating run area in " test-path) + (handle-exceptions + exn + (if (directory-exists? test-path) + #t + (begin + (debug:print-error 0 *default-log-port* " Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) + ", exiting, exn=" exn) + (exit 1))) + (create-directory test-path #t)) + (debug:print 2 *default-log-port* + " - creating link from: " test-path "\n" + " to: " lnktarget) + + ;; If there is already a symlink delete it and recreate it. + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* " Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting, exn=" exn) + (exit)) + (if (symbolic-link? lnktarget) (delete-file lnktarget)) + (if (not (common:file-exists? lnktarget)) (create-symbolic-link test-path lnktarget))))) + + (if (not (directory? test-path)) + (create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes + + (if (and test-src-path (directory? test-path)) + (begin + (launch:test-copy test-src-path test-path) + (list lnkpathf lnkpath )) + (if (and test-src-path (> remtries 0)) + (begin + (debug:print-error 0 *default-log-port* "Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) + ;; + (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat remtries: (- remtries 1))) + (list #f #f))))) + +(define (launch:setup-body #!key (force-reread #f) (areapath #f)) + (if (and (eq? *configstatus* 'fulldata) + *toppath* + (not force-reread)) ;; no need to reprocess + *toppath* ;; return toppath + (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting. We do not have *configdat*. Bootstrapping problem here. + (toppath (common:get-toppath areapath)) + (target (common:args-get-target)) + (sections (if target (list "default" target) #f)) ;; for runconfigs + (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config + (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) + ;; checking for null cachefiles should not be necessary, I was seeing error car of '(), might be a chicken bug or a red herring ... + (mtcachef (if (null? cachefiles) + #f + (car cachefiles))) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) + (rccachef (if (null? cachefiles) + #f + (cdr cachefiles)))) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) + ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?))))) + (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource + ;;(BB> "launch:setup-body -- cachefiles="cachefiles) + (cond + ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME + ((and (not force-reread) + mtcachef rccachef + use-cache + (get-environment-variable "MT_RUN_AREA_HOME") + (common:file-exists? mtcachef) + (common:file-exists? rccachef)) + ;;(BB> "launch:setup-body -- cond branch 1 - use-cache") + (set! *configdat* (configf:read-alist mtcachef)) + ;;(BB> "launch:setup-body -- 1 set! *configdat*="*configdat*) + (set! *runconfigdat* (configf:read-alist rccachef)) + (set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME"))) + (set! *configstatus* 'fulldata) + (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) + *toppath*) + ;; there are no existing cached configs, do full reads of the configs and cache them + ;; we have all the info needed to fully process runconfigs and megatest.config + ((and ;; (not force-reread) ;; force-reread is irrelevant in the AND, could however OR it? + mtcachef + rccachef) ;; BB- why are we doing this without asking if caching is desired? + ;;(BB> "launch:setup-body -- cond branch 2") + (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect + mtconfig + environ-patt: "env-override" + given-toppath: toppath + pathenvvar: "MT_RUN_AREA_HOME")) + (first-rundat (let ((toppath (if toppath + toppath + (car first-pass)))) + (read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now. + (conc (if (string? toppath) + toppath + (get-environment-variable "MT_RUN_AREA_HOME")) + "/runconfigs.config") + *runconfigdat* #t + sections: sections)))) + (set! *runconfigdat* first-rundat) + (if first-pass ;; + (begin + ;;(BB> "launch:setup-body -- \"first-pass\"=first-pass") + (set! *configdat* (car first-pass)) + ;;(BB> "launch:setup-body -- 2 set! *configdat*="*configdat*) + (set! *configinfo* first-pass) + (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it + (set! toppath *toppath*) + (if (not *toppath*) + (begin + (debug:print-error 0 *default-log-port* "you are not in a megatest area!") + (exit 1))) + (setenv "MT_RUN_AREA_HOME" *toppath*) + ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it + (let* ((keys (common:list-or-null (rmt:get-keys) + message: "Failed to retrieve keys in launch.scm. Please report this to the developers.")) + (key-vals (keys:target->keyval keys target)) + (linktree (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) + ; (if *configdat* + ; (configf:lookup *configdat* "setup" "linktree") + ; (conc *toppath* "/lt")))) + (second-pass (find-and-read-config + mtconfig + environ-patt: "env-override" + given-toppath: toppath + pathenvvar: "MT_RUN_AREA_HOME")) + (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config + (for-each (lambda (kt) + (setenv (car kt) (cadr kt))) + key-vals) + (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ... + sections: sections))) + (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) + (mtcachef (car cachefiles)) + (rccachef (cdr cachefiles))) + ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "/p/fdk/gwa/lefkowit/mtTesting/qa/primbeqa/links/p1222/11/PDK_r1.1.1/prim/clean/pcell_testgen/.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342 + ;; TODO - consider 1) using simple-lock to bracket cache write + ;; 2) cache in hash on server, since need to do rmt: anyway to lock. + + (if rccachef + (common:fail-safe + (lambda () + (configf:write-alist runconfigdat rccachef)) + (conc "Could not write cache file - "rccachef))) + (if mtcachef + (common:fail-safe + (lambda () + (configf:write-alist *configdat* mtcachef)) + (conc "Could not write cache file - "mtcachef))) + (set! *runconfigdat* runconfigdat) + (if (and rccachef mtcachef) (set! *configstatus* 'fulldata)))) + ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table + (set! *configdat* (make-hash-table)) + ))) + + ;; else read what you can and set the flag accordingly + ;; here we don't have either mtconfig or rccachef + (else + ;;(BB> "launch:setup-body -- cond branch 3 - else") + (let* ((cfgdat (find-and-read-config + (or (args:get-arg "-config") "megatest.config") + environ-patt: "env-override" + given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") + pathenvvar: "MT_RUN_AREA_HOME"))) + + (if (and cfgdat (list? cfgdat) (> (length cfgdat) 0) (hash-table? (car cfgdat))) + (let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat))) + (rdat (read-config (conc toppath ;; convert this to use runconfig:read! + "/runconfigs.config") *runconfigdat* #t sections: sections))) + (set! *configinfo* cfgdat) + (set! *configdat* (car cfgdat)) + (set! *runconfigdat* rdat) + (set! *toppath* toppath) + (set! *configstatus* 'partial)) + (begin + (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.") + (exit 2)))))) + ;; COND ends here. + + ;; additional house keeping + (let* ((linktree (or (common:get-linktree) + (conc *toppath* "/lt")))) + (if linktree + (begin + (if (not (common:file-exists? linktree)) + (begin + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "Something went wrong when trying to create linktree dir at " linktree) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + (exit 1)) + (create-directory linktree #t)))) + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "Something went wrong when trying to create link to linktree at " *toppath*) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) + (let ((tlink (conc *toppath* "/lt"))) + (if (not (common:file-exists? tlink)) + (create-symbolic-link linktree tlink))))) + (begin + (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config") + ))) + (if (and *toppath* + (directory-exists? *toppath*)) + (begin + (setenv "MT_RUN_AREA_HOME" *toppath*) + (setenv "MT_TESTSUITENAME" (common:get-testsuite-name))) + (begin + (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") + (set! *toppath* #f) ;; force it to be false so we return #f + #f)) + + ;; needed by various transport and db modules + (dbfile:testsuite-name (common:get-testsuite-name)) ;; (get-testsuite-name *toppath* *configdat*)) + + ;; one more attempt to cache the configs for future reading + (let* ((cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) + (mtcachef (car cachefiles)) + (rccachef (cdr cachefiles))) + + ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "...somepath.../.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342 + ;; TODO - consider 1) using simple-lock to bracket cache write + ;; 2) cache in hash on server, since need to do rmt: anyway to lock. + (if (and rccachef *runconfigdat* (not (common:file-exists? rccachef))) + (common:fail-safe + (lambda () + (configf:write-alist *runconfigdat* rccachef)) + (conc "Could not write cache file - "rccachef)) + ) + (if (and mtcachef *configdat* (not (common:file-exists? mtcachef))) + (common:fail-safe + (lambda () + (configf:write-alist *configdat* mtcachef)) + (conc "Could not write cache file - "mtcachef)) + ) + (if (and rccachef mtcachef *runconfigdat* *configdat*) + (set! *configstatus* 'fulldata))) + + ;; if have -append-config then read and append here + (let ((cfname (args:get-arg "-append-config"))) + (if (and cfname + (file-read-access? cfname)) + (read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special. + + ;; have config at this time, this is a good place to set params based on config file settings + (let* ((dbmode (configf:lookup *configdat* "setup" "dbcache-mode")) + (syncmode (configf:lookup *configdat* "setup" "sync-mode")) + (srvdebug (configf:lookup *configdat* "server" "debug-parameter"))) + (if dbmode + (begin + (debug:print-info 0 *default-log-port* "Overriding dbmode to "dbmode) + (dbcache-mode (string->symbol dbmode)))) + (if syncmode + (begin + (debug:print-info 0 *default-log-port* "Overriding syncmode to "syncmode) + (dbfile:sync-method (string->symbol syncmode)))) + (if srvdebug + (begin + (debug:print-info 0 *default-log-port* "Overriding server debug parameter to "srvdebug) + (tt-server-profile-string srvdebug))) + ) + + *toppath*))) + + +(define (launch:test-copy test-src-path test-path) + (let* ((ovrcmd (let ((cmd (configf:lookup *configdat* "setup" "testcopycmd"))) + (if cmd + ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH + (string-substitute "TEST_TARG_PATH" test-path + (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t) + #f))) + (cmd (if ovrcmd + ovrcmd + (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/" + " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log"))) + (status (system cmd))) + (if (not (eq? status 0)) + (debug:print 2 *default-log-port* "ERROR: problem with running \"" cmd "\"")))) + +;; return paths depending on what info is available. +;; +(define (launch:get-cache-file-paths areapath toppath target mtconfig) + (let* ((use-cache (common:use-cache?)) + (runname (common:args-get-runname)) + (linktree (common:get-linktree)) + (testname (common:get-full-test-name)) + (rundir (if (and runname target linktree) + (common:directory-writable? (conc linktree "/" target "/" runname)) + #f)) + (testdir (if (and rundir testname) + (common:directory-writable? (conc rundir "/" testname)) + #f)) + (cachedir (or testdir rundir)) + (mtcachef (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) + (rccachef (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))) + (debug:print-info 6 *default-log-port* + "runname=" runname + "\n linktree=" linktree + "\n testname=" testname + "\n rundir=" rundir + "\n testdir=" testdir + "\n cachedir=" cachedir + "\n mtcachef=" mtcachef + "\n rccachef=" rccachef) + (cons mtcachef rccachef))) + +(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)))) + +;; 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)) + +) Index: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -36,239 +36,5 @@ (import commonmod configfmod debugprint tasksmod) -;(include "common_records.scm") -;;(include "key_records.scm") -(include "db_records.scm") ;; provides db:test-get-id -;;(include "run_records.scm") -;;(include "test_records.scm") - -(define (subrun:subrun-test-initialized? test-run-dir) - (if (and (common:file-exists? (conc test-run-dir "/subrun-area") ) - (common:file-exists? (conc test-run-dir "/testconfig.subrun") )) - #t - #f)) - -(define (subrun:launch-dashboard test-run-dir) - (if (subrun:subrun-test-initialized? test-run-dir) - (let* ((subarea (subrun:get-runarea test-run-dir))) - (if (and subarea (common:file-exists? subarea)) - (system (conc "cd " subarea ";env -i PATH=\"$PATH\" DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &")))))) - -(define (subrun:subrun-removed? test-run-dir) - (if (subrun:subrun-test-initialized? test-run-dir) - (let ((flagfile (conc test-run-dir "/subrun.removed"))) - (if (common:file-exists? flagfile) - #t - #f)) - #t)) - -(define (subrun:set-subrun-removed test-run-dir) - (let ((flagfile (conc test-run-dir "/subrun.removed"))) - (if (and (subrun:subrun-test-initialized? test-run-dir) (not (common:file-exists? flagfile))) - (with-output-to-file flagfile - (lambda () (print (current-seconds))))))) - -(define (subrun:unset-subrun-removed test-run-dir) - (let ((flagfile (conc test-run-dir "/subrun.removed"))) - (if (and (subrun:subrun-test-initialized? test-run-dir) (common:file-exists? flagfile)) - (delete-file flagfile)))) - - -(define (subrun:testconfig-defines-subrun? testconfig) - (configf:lookup testconfig "subrun" "runwait")) ;; we use runwait as the flag that a subrun is requested - -(define (subrun:initialize-toprun-test testconfig test-run-dir) - (let ((ra (configf:lookup testconfig "subrun" "run-area")) - (logpro (configf:lookup testconfig "subrun" "logpro")) - (symlink-target (conc test-run-dir "/subrun-area")) - ) - (if (not ra) ;; when runarea is not set we default to *toppath*. However - (let ((fallback-run-area (or *toppath* (conc test-run-dir "/subrun")))) - ;; we need to force the setting in the testconfig so it will - ;; be preserved in the testconfig.subrun file - (configf:set-section-var testconfig "subrun" "run-area" fallback-run-area) - (set! ra fallback-run-area))) - (configf:set-section-var testconfig "logpro" "subrun" logpro) ;; append the logpro rules to the logpro section as stepname subrun - (if (common:file-exists? symlink-target) - (delete-file symlink-target)) - (create-symbolic-link ra symlink-target) - (configf:write-alist testconfig "testconfig.subrun"))) - -(define (subrun:set-state-status test-run-dir state status new-state-status) - (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) - (let* ((action-switches-str - (conc "-set-state-status "new-state-status - (if state (conc " -state "state) "") - (if status (conc " -status "status) ""))) - (log-prefix - (subrun:sanitize-path - (conc "set-state-status="new-state-status - (if state (conc ":state="state) "") - (if status (conc "+status="status) "")))) - (submt-result - (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix))) - submt-result))) - -(define (subrun:remove-subrun test-run-dir keep-records ) - (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) - (let* ((action-switches-str - (conc "-remove-runs" - (if keep-records "-keep-records " "") - )) - (remove-result - (subrun:exec-sub-megatest test-run-dir action-switches-str "remove"))) - (if remove-result - (begin - (subrun:set-subrun-removed test-run-dir) - #t) - #f)) - #t)) - -(define (subrun:kill-subrun test-run-dir ) - (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) - (let* ((action-switches-str - (conc "-kill-runs" )) - (kill-result - (subrun:exec-sub-megatest test-run-dir action-switches-str "kill"))) - kill-result) - #t)) - -(define (subrun:launch-cmd test-run-dir run-mode #!optional (sub-cmd "-run")) ;; BUG: "-run" should be changed to "-rerun-clean" but current doesn't work - (if (subrun:subrun-removed? test-run-dir) - (subrun:unset-subrun-removed test-run-dir)) - - (let* ((log-prefix "run") - (switches (subrun:selector+log-switches test-run-dir log-prefix)) - (run-wait (equal? run-mode "yes")) - (cmd (conc (common:get-mtexe)" "sub-cmd" "switches" " - (if run-wait "-run-wait " "")))) - cmd)) - - -(define (subrun:sanitize-path inpath) - (let* ((insane-pattern (irregex "[^[a-zA-Z0-9_\\-]"))) - (regex#string-substitute insane-pattern "_" inpath #t))) - -(define (subrun:get-runarea test-run-dir) - (if (subrun:subrun-test-initialized? test-run-dir) - (let* ((info-alist (subrun:selector+log-alist - test-run-dir - "foo")) - (run-area (if (list? info-alist) - (alist-ref "-start-dir" info-alist equal? #f) - #f))) - run-area) - #f)) - -(define (subrun:selector+log-alist test-run-dir log-prefix) - (let* ((switch-def-alist (common:get-param-mapping flavor: 'config)) - (subrunfile (conc test-run-dir "/testconfig.subrun" )) - (subrundata (with-input-from-file subrunfile read)) - (subrunconfig (configf:alist->config subrundata)) - (run-area (configf:lookup subrunconfig "subrun" "run-area")) - (defvals `(("start-dir" . ,(or run-area ;; default values if not specified in subrun section of tconf - (get-environment-variable "MT_RUN_AREA_HOME") - "/no/rundir/found")) - ("run-name" . ,(or (get-environment-variable "MT_RUNNAME") "NO-RUNNAME")) - ("target" . ,(or (get-environment-variable "MT_TARGET") "NO-TARGET")))) - (switch-alist-pre (filter-map (lambda (item) - (let* ((config-key (car item)) - (switch (cdr item)) - (defval (alist-ref config-key defvals equal? #f)) - (val (or (configf:lookup subrunconfig "subrun" config-key) - defval))) - (if val - (cons switch val) - #f))) - switch-def-alist)) - - ;; testpatt may be modified if all three of mode-patt, tag-expr, and testpatt are null - (mode-patt (alist-ref "-modepatt" switch-alist-pre equal? #f)) - (tag-expr (alist-ref "-tagexpr" switch-alist-pre equal? #f)) - (testpatt (alist-ref "-testpatt" switch-alist-pre equal? - (if (not (or mode-patt tag-expr)) "%" #f))) ;; testpatt is % if not - ;; otherwise specified - - ;; define compact-stem for logfile - (target (alist-ref "-target" switch-alist-pre equal? #f)) ;; want data-structures alist-ref, not alist-lib alist-ref - (runname (alist-ref "-runname" switch-alist-pre equal? #f)) - - - (compact-stem (subrun:sanitize-path - (conc - target - "-" - runname - "-" (or testpatt mode-patt tag-expr "NO-TESTPATT")))) - (logfile (conc - test-run-dir "/" - (if log-prefix - (conc (subrun:sanitize-path log-prefix) "-") - "") - compact-stem - ".log")) - ;; swap out testpatt with modified test-patt and add -log - (switch-alist (cons - (cons "-log" logfile) - (map (lambda (item) - (if (equal? (car item) "-testpatt") - (cons "-testpatt" testpatt) - item)) - switch-alist-pre)))) - switch-alist)) - ;; note - get precmd from subrun section - ;; apply to submegatest commands - -(define (subrun:get-log-path test-run-dir log-prefix) - (let* ((alist (subrun:selector+log-alist test-run-dir log-prefix)) - (res (alist-ref "-log" alist equal? #f))) - res)) - -(define (subrun:selector+log-switches test-run-dir log-prefix) - (let* ((switch-alist (subrun:selector+log-alist test-run-dir log-prefix)) - (res - (string-intersperse - (apply - append - (map - (lambda (x) - (list (car x) (cdr x))) - switch-alist)) - " "))) - res)) - -;; NOTE: Here we run sub megatest but this is not intended for one version -;; of megatest to test another version. Thus we propagate the -(define (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix) - (let* ((mtpathdir (common:get-megatest-exe-dir)) - (mtexe (common:get-mtexe)) - (selector-switches (subrun:selector+log-switches test-run-dir log-prefix)) - (cmd (conc mtexe" "selector-switches" "action-switches-str )) - (pid #f) - (proc (lambda () - (debug:print-info 0 *default-log-port* "Running sub megatest command: "cmd) - ;;(set! pid (process-run "/usr/bin/xterm" (list )))))) - (set! pid (process-run "/bin/bash" (list "-c" cmd)))))) - (call-with-environment-variables - (list (cons "PATH" (common:get-megatest-exe-path))) - (lambda () - (common:without-vars proc "^MT_.*"))) - (let processloop ((i 0)) - (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) - (if (eq? pid-val 0) - (begin - (thread-sleep! 2) - (processloop (+ i 1))) - (begin - (debug:print-info 0 *default-log-port* "sub megatest " action-switches-str " completed with exit code " exit-code) - (if (eq? 0 exit-code) - (begin - #t) - (begin - #f)))))))) - - - -;; (subrun:exec-sub-megatest "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/165/megatest/ext-tests/tests/subrun-usecases/toparea/links/SYSTEM_val/RELEASE_val/go/toptest" "-foo" "foo") ADDED subrunmod.scm Index: subrunmod.scm ================================================================== --- /dev/null +++ subrunmod.scm @@ -0,0 +1,360 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +;;====================================================================== +;; Cpumod: +;; +;; Put things here don't fit anywhere else +;;====================================================================== + +(declare (unit subrunmod)) +(declare (uses debugprint)) +(declare (uses mtargs)) +(declare (uses commonmod)) +(declare (uses configfmod)) +(declare (uses dbfile)) +(declare (uses dbmod)) +(declare (uses rmtmod)) +(declare (uses servermod)) +(declare (uses processmod)) +(declare (uses pgdb)) +(declare (uses mtmod)) +(declare (uses megatestmod)) +(declare (uses tasksmod)) + +(use srfi-69) + +(module subrunmod + * + +(import scheme) +(cond-expand + (chicken-4 + + (import chicken + ports + data-structures + extras + files + matchable + pathname-expand + posix + posix-extras + regex + regex-case + sparse-vectors + + ) + (use srfi-69)) + (chicken-5 + (import (prefix sqlite3 sqlite3:) + chicken.base + chicken.condition + chicken.file + chicken.file.posix + chicken.io + chicken.pathname + chicken.port + chicken.process + chicken.process-context + chicken.process-context.posix + chicken.sort + chicken.string + chicken.time + chicken.time.posix + + matchable + md5 + message-digest + pathname-expand + regex + regex-case + system-information + + ))) + +;; imports common to ck4 and ck5 +(import srfi-1 + srfi-13 + srfi-18 + srfi-69 + typed-records + (prefix base64 base64:) + (prefix sqlite3 sqlite3:) + md5 + message-digest + z3 + directory-utils + call-with-environment-variables + regex + irregex + + debugprint + commonmod + configfmod + (prefix mtargs args:) + dbmod + dbfile + rmtmod + servermod + processmod + pgdb + mtmod + megatestmod + tasksmod + ) + +;(include "common_records.scm") +;;(include "key_records.scm") +(include "db_records.scm") ;; provides db:test-get-id +;;(include "run_records.scm") +;;(include "test_records.scm") + +(define (subrun:subrun-test-initialized? test-run-dir) + (if (and (common:file-exists? (conc test-run-dir "/subrun-area") ) + (common:file-exists? (conc test-run-dir "/testconfig.subrun") )) + #t + #f)) + +(define (subrun:launch-dashboard test-run-dir) + (if (subrun:subrun-test-initialized? test-run-dir) + (let* ((subarea (subrun:get-runarea test-run-dir))) + (if (and subarea (common:file-exists? subarea)) + (system (conc "cd " subarea ";env -i PATH=\"$PATH\" DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &")))))) + +(define (subrun:subrun-removed? test-run-dir) + (if (subrun:subrun-test-initialized? test-run-dir) + (let ((flagfile (conc test-run-dir "/subrun.removed"))) + (if (common:file-exists? flagfile) + #t + #f)) + #t)) + +(define (subrun:set-subrun-removed test-run-dir) + (let ((flagfile (conc test-run-dir "/subrun.removed"))) + (if (and (subrun:subrun-test-initialized? test-run-dir) (not (common:file-exists? flagfile))) + (with-output-to-file flagfile + (lambda () (print (current-seconds))))))) + +(define (subrun:unset-subrun-removed test-run-dir) + (let ((flagfile (conc test-run-dir "/subrun.removed"))) + (if (and (subrun:subrun-test-initialized? test-run-dir) (common:file-exists? flagfile)) + (delete-file flagfile)))) + + +(define (subrun:testconfig-defines-subrun? testconfig) + (configf:lookup testconfig "subrun" "runwait")) ;; we use runwait as the flag that a subrun is requested + +(define (subrun:initialize-toprun-test testconfig test-run-dir) + (let ((ra (configf:lookup testconfig "subrun" "run-area")) + (logpro (configf:lookup testconfig "subrun" "logpro")) + (symlink-target (conc test-run-dir "/subrun-area")) + ) + (if (not ra) ;; when runarea is not set we default to *toppath*. However + (let ((fallback-run-area (or *toppath* (conc test-run-dir "/subrun")))) + ;; we need to force the setting in the testconfig so it will + ;; be preserved in the testconfig.subrun file + (configf:set-section-var testconfig "subrun" "run-area" fallback-run-area) + (set! ra fallback-run-area))) + (configf:set-section-var testconfig "logpro" "subrun" logpro) ;; append the logpro rules to the logpro section as stepname subrun + (if (common:file-exists? symlink-target) + (delete-file symlink-target)) + (create-symbolic-link ra symlink-target) + (configf:write-alist testconfig "testconfig.subrun"))) + +(define (subrun:set-state-status test-run-dir state status new-state-status) + (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) + (let* ((action-switches-str + (conc "-set-state-status "new-state-status + (if state (conc " -state "state) "") + (if status (conc " -status "status) ""))) + (log-prefix + (subrun:sanitize-path + (conc "set-state-status="new-state-status + (if state (conc ":state="state) "") + (if status (conc "+status="status) "")))) + (submt-result + (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix))) + submt-result))) + +(define (subrun:remove-subrun test-run-dir keep-records ) + (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) + (let* ((action-switches-str + (conc "-remove-runs" + (if keep-records "-keep-records " "") + )) + (remove-result + (subrun:exec-sub-megatest test-run-dir action-switches-str "remove"))) + (if remove-result + (begin + (subrun:set-subrun-removed test-run-dir) + #t) + #f)) + #t)) + +(define (subrun:kill-subrun test-run-dir ) + (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) + (let* ((action-switches-str + (conc "-kill-runs" )) + (kill-result + (subrun:exec-sub-megatest test-run-dir action-switches-str "kill"))) + kill-result) + #t)) + +(define (subrun:launch-cmd test-run-dir run-mode #!optional (sub-cmd "-run")) ;; BUG: "-run" should be changed to "-rerun-clean" but current doesn't work + (if (subrun:subrun-removed? test-run-dir) + (subrun:unset-subrun-removed test-run-dir)) + + (let* ((log-prefix "run") + (switches (subrun:selector+log-switches test-run-dir log-prefix)) + (run-wait (equal? run-mode "yes")) + (cmd (conc (common:get-mtexe)" "sub-cmd" "switches" " + (if run-wait "-run-wait " "")))) + cmd)) + + +(define (subrun:sanitize-path inpath) + (let* ((insane-pattern (irregex "[^[a-zA-Z0-9_\\-]"))) + (regex#string-substitute insane-pattern "_" inpath #t))) + +(define (subrun:get-runarea test-run-dir) + (if (subrun:subrun-test-initialized? test-run-dir) + (let* ((info-alist (subrun:selector+log-alist + test-run-dir + "foo")) + (run-area (if (list? info-alist) + (alist-ref "-start-dir" info-alist equal? #f) + #f))) + run-area) + #f)) + +(define (subrun:selector+log-alist test-run-dir log-prefix) + (let* ((switch-def-alist (common:get-param-mapping flavor: 'config)) + (subrunfile (conc test-run-dir "/testconfig.subrun" )) + (subrundata (with-input-from-file subrunfile read)) + (subrunconfig (configf:alist->config subrundata)) + (run-area (configf:lookup subrunconfig "subrun" "run-area")) + (defvals `(("start-dir" . ,(or run-area ;; default values if not specified in subrun section of tconf + (get-environment-variable "MT_RUN_AREA_HOME") + "/no/rundir/found")) + ("run-name" . ,(or (get-environment-variable "MT_RUNNAME") "NO-RUNNAME")) + ("target" . ,(or (get-environment-variable "MT_TARGET") "NO-TARGET")))) + (switch-alist-pre (filter-map (lambda (item) + (let* ((config-key (car item)) + (switch (cdr item)) + (defval (alist-ref config-key defvals equal? #f)) + (val (or (configf:lookup subrunconfig "subrun" config-key) + defval))) + (if val + (cons switch val) + #f))) + switch-def-alist)) + + ;; testpatt may be modified if all three of mode-patt, tag-expr, and testpatt are null + (mode-patt (alist-ref "-modepatt" switch-alist-pre equal? #f)) + (tag-expr (alist-ref "-tagexpr" switch-alist-pre equal? #f)) + (testpatt (alist-ref "-testpatt" switch-alist-pre equal? + (if (not (or mode-patt tag-expr)) "%" #f))) ;; testpatt is % if not + ;; otherwise specified + + ;; define compact-stem for logfile + (target (alist-ref "-target" switch-alist-pre equal? #f)) ;; want data-structures alist-ref, not alist-lib alist-ref + (runname (alist-ref "-runname" switch-alist-pre equal? #f)) + + + (compact-stem (subrun:sanitize-path + (conc + target + "-" + runname + "-" (or testpatt mode-patt tag-expr "NO-TESTPATT")))) + (logfile (conc + test-run-dir "/" + (if log-prefix + (conc (subrun:sanitize-path log-prefix) "-") + "") + compact-stem + ".log")) + ;; swap out testpatt with modified test-patt and add -log + (switch-alist (cons + (cons "-log" logfile) + (map (lambda (item) + (if (equal? (car item) "-testpatt") + (cons "-testpatt" testpatt) + item)) + switch-alist-pre)))) + switch-alist)) + ;; note - get precmd from subrun section + ;; apply to submegatest commands + +(define (subrun:get-log-path test-run-dir log-prefix) + (let* ((alist (subrun:selector+log-alist test-run-dir log-prefix)) + (res (alist-ref "-log" alist equal? #f))) + res)) + +(define (subrun:selector+log-switches test-run-dir log-prefix) + (let* ((switch-alist (subrun:selector+log-alist test-run-dir log-prefix)) + (res + (string-intersperse + (apply + append + (map + (lambda (x) + (list (car x) (cdr x))) + switch-alist)) + " "))) + res)) + +;; NOTE: Here we run sub megatest but this is not intended for one version +;; of megatest to test another version. Thus we propagate the +(define (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix) + (let* ((mtpathdir (common:get-megatest-exe-dir)) + (mtexe (common:get-mtexe)) + (selector-switches (subrun:selector+log-switches test-run-dir log-prefix)) + (cmd (conc mtexe" "selector-switches" "action-switches-str )) + (pid #f) + (proc (lambda () + (debug:print-info 0 *default-log-port* "Running sub megatest command: "cmd) + ;;(set! pid (process-run "/usr/bin/xterm" (list )))))) + (set! pid (process-run "/bin/bash" (list "-c" cmd)))))) + (call-with-environment-variables + (list (cons "PATH" (common:get-megatest-exe-path))) + (lambda () + (common:without-vars proc "^MT_.*"))) + (let processloop ((i 0)) + (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) + (if (eq? pid-val 0) + (begin + (thread-sleep! 2) + (processloop (+ i 1))) + (begin + (debug:print-info 0 *default-log-port* "sub megatest " action-switches-str " completed with exit code " exit-code) + (if (eq? 0 exit-code) + (begin + #t) + (begin + #f)))))))) + + + +;; (subrun:exec-sub-megatest "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/165/megatest/ext-tests/tests/subrun-usecases/toparea/links/SYSTEM_val/RELEASE_val/go/toptest" "-foo" "foo") + + +) Index: tasksmod.scm ================================================================== --- tasksmod.scm +++ tasksmod.scm @@ -1760,8 +1760,114 @@ (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) (rmt:general-call 'set-test-comment run-id cmt test-id))))) + +;;====================================================================== +;; refactoring this block into tests:get-full-data from line 263 of runs.scm +;;====================================================================== +;; hed is the test name +;; test-records is a hash of test-name => test record +(define (tests:get-full-data test-names test-records required-tests all-tests-registry) + (let ((missing-waitons (make-hash-table))) + (if (not (null? test-names)) + (let loop ((hed (car test-names)) + (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc + (debug:print-info 4 *default-log-port* "hed=" hed " at top of loop") + ;; don't know item-path at this time, let the testconfig get the top level testconfig + (let* ((config (tests:get-testconfig hed #f all-tests-registry 'return-procs)) + (waitons (let ((instr (if config + (configf:lookup config "requirements" "waiton") + (begin ;; No config means this is a non-existent test + (let ((waiters '())) + ;; find the waiter(s) for this waiton. + (for-each + (lambda(waiter) + ;; (print "test-record = " (hash-table-ref test-records waiter)) + ;; (print "waitons = " (vector-ref (hash-table-ref test-records waiter) 2)) + (if (member hed (vector-ref (hash-table-ref test-records waiter) 2)) + (set! waiters (cons waiter waiters)) + ) + ) + (hash-table-keys test-records)) + (hash-table-set! missing-waitons hed waiters) + ) + "")))) + (debug:print-info 8 *default-log-port* "waitons string is " instr) + (string-split (cond + ((procedure? instr) + (let ((res (instr))) + (debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " hed) + res)) + ((string? instr) instr) + (else + ;; NOTE: This is actually the case of *no* waitons! ;; + "")))))) + (if (not config) ;; this is a non-existant test called in a waiton. + (if (null? tal) + test-records + (loop (car tal)(cdr tal))) + (begin + (debug:print-info 8 *default-log-port* "waitons: " waitons) + ;; check for hed in waitons => this would be circular, remove it and issue an + ;; error + (if (member hed waitons) + (begin + (debug:print-error 0 *default-log-port* "test " hed " has listed itself as a waiton, please correct this!") + (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)))) + + ;; (items (items:get-items-from-config config))) + (if (not (hash-table-ref/default test-records hed #f)) + (hash-table-set! test-records + hed (vector hed ;; 0 + config ;; 1 + waitons ;; 2 + (configf:lookup config "requirements" "priority") ;; priority 3 + (let ((items (hash-table-ref/default config "items" #f)) ;; items 4 + (itemstable (hash-table-ref/default config "itemstable" #f))) + ;; if either items or items table is a proc return it so test running + ;; process can know to call items:get-items-from-config + ;; if either is a list and none is a proc go ahead and call get-items + ;; otherwise return #f - this is not an iterated test + (cond + ((procedure? items) + (debug:print-info 4 *default-log-port* "items is a procedure, will calc later") + items) ;; calc later + ((procedure? itemstable) + (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later") + itemstable) ;; calc later + ((filter (lambda (x) + (let ((val (car x))) + (if (procedure? val) val #f))) + (append (if (list? items) items '()) + (if (list? itemstable) itemstable '()))) + 'have-procedure) + ((or (list? items)(list? itemstable)) ;; calc now + (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n" + " items: " items " itemstable: " itemstable) + (items:get-items-from-config config)) + (else #f))) ;; not iterated + #f ;; itemsdat 5 + #f ;; spare - used for item-path + ))) + (for-each + (lambda (waiton) + (if (and waiton (not (string= "#f" waiton)) (not (member waiton test-names))) + (begin + (set! required-tests (cons waiton required-tests)) + (set! test-names (cons waiton test-names))))) ;; was an append, now a cons + waitons) + (let ((remtests (delete-duplicates (append waitons tal)))) + (if (not (null? remtests)) + (loop (car remtests)(cdr remtests)) + test-records))))))) + (for-each + (lambda (missing-waiton) + (debug:print-error 0 *default-log-port* "non-existent test \"" missing-waiton "\" is a waiton for tests " (hash-table-ref missing-waitons missing-waiton)) + ) + (hash-table-keys missing-waitons) + ) +)) ) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -48,1423 +48,5 @@ megatestmod tasksmod ) (require-library stml) -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") -(include "js-path.scm") - -(define (init-java-script-lib) - (set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js")) - ) -(define (tests:summarize-items run-id test-id test-name force) - ;; if not force then only update the record if one of these is true: - ;; 1. logf is "log/final.log - ;; 2. logf is same as outputfilename - (let* ((outputfilename (conc "megatest-rollup-" test-name ".html")) - (orig-dir (current-directory)) - (logf-info (rmt:test-get-logfile-info run-id test-name)) - (logf (if logf-info (cadr logf-info) #f)) - (path (if logf-info (car logf-info) #f))) - ;; This query finds the path and changes the directory to it for the test - (if (and (string? path) - (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ... - (begin - (debug:print 4 *default-log-port* "Found path: " path) - (change-directory path)) - ;; (set! outputfilename (conc path "/" outputfilename))) - (debug:print-error 0 *default-log-port* "summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path)) - (debug:print 4 *default-log-port* "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) - (if (or (equal? logf "logs/final.log") - (equal? logf outputfilename) - force) - (let ((my-start-time (current-seconds)) - (lockf (conc outputfilename ".lock"))) - (let loop ((have-lock (common:simple-file-lock lockf))) - (if have-lock - (let ((script (configf:lookup *configdat* "testrollup" test-name))) - (debug:print 0 *default-log-port* "Obtained lock for " outputfilename) - (rmt:set-state-status-and-roll-up-items run-id test-name "" #f #f #f) - (if script - (system (conc script " > " outputfilename " & ")) - (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)) - (common:simple-file-release-lock lockf) - (change-directory orig-dir) - ;; NB// tests:test-set-toplog! is remote internal... - (tests:test-set-toplog! run-id test-name outputfilename)) - ;; didn't get the lock, check to see if current update started later than this - ;; update, if so we can exit without doing any work - (if (> my-start-time (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "failed to get mod time on " lockf ", exn=" exn) - 0) - (file-modification-time lockf))) - ;; we started since current re-gen in flight, delay a little and try again - (begin - (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it") - (thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds - (loop (common:simple-file-lock lockf)))))))))) - -(define (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename) - (let ((counts (make-hash-table)) - (statecounts (make-hash-table)) - (outtxt "") - (tot 0) - (testdat (rmt:test-get-records-for-index-file run-id test-name))) - (with-output-to-file outputfilename - (lambda () - (set! outtxt (conc outtxt "Summary: " test-name - "

Summary for " test-name "

")) - (for-each - (lambda (testrecord) - (let ((id (vector-ref testrecord 0)) - (itempath (vector-ref testrecord 1)) - (state (vector-ref testrecord 2)) - (status (vector-ref testrecord 3)) - (run_duration (vector-ref testrecord 4)) - (logf (vector-ref testrecord 5)) - (comment (vector-ref testrecord 6))) - (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0))) - (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0))) - (set! outtxt (conc outtxt "" - ;; " " itempath "" - " " itempath "" - "" state "" - "" status "" - "" (if (equal? comment "") - " " - comment) "" - "")))) - (if (list? testdat) - testdat - (begin - (debug:print 0 *default-log-port* "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name) - '()))) - - (print "
") - ;; Print out stats for status - (set! tot 0) - (print "") - (for-each (lambda (state) - (set! tot (+ tot (hash-table-ref statecounts state))) - (print "")) - (hash-table-keys statecounts)) - (print "

State stats

" state "" (hash-table-ref statecounts state) "
Total" tot "
") - (print "		") - ;; Print out stats for state - (set! tot 0) - (print "") - (for-each (lambda (status) - (set! tot (+ tot (hash-table-ref counts status))) - (print "")) - (hash-table-keys counts)) - (print "

Status stats

" status - "" (hash-table-ref counts status) "
Total" tot "
") - (print "
") - - (print "" - "" - outtxt "
ItemStateStatusComment
") - ;; (release-dot-lock outputfilename) - ;;(rmt:update-run-stats - ;; run-id - ;; (hash-table-map - ;; state-status-counts - ;; (lambda (key val) - ;; (append key (list val))))) - )))) - -(define tests:css-jscript-block -#< -ul.LinkedList { display: block; } -/* ul.LinkedList ul { display: none; } */ -.HandCursorStyle { cursor: pointer; cursor: hand; } /* For IE */ -th {background-color: #8c8c8c;} -td.test {background-color: #d9dbdd;} -td.PASS {background-color: #347533;} -td.FAIL {background-color: #cc2812;} -td.SKIP{background-color: #FFD733;} -td.WARN {background-color: #EA8724;} -td.WAIVED {background-color: #838A12;} -td.ABORT{background-color: #EA24B7;} -.PASS .link, .SKIP .link, .WARN .link,.WAIVED .link,.ABORT .link, .FAIL .link{color: #FFFFFF;} - - - - - - -EOF -) - -(define tests:css-jscript-block-dynamic -#< -EOF -) - -(define (test:js-block javascript-lib) - (conc "" )) - - -(define tests:css-jscript-block-static (test:js-block *java-script-lib*)) - -(define (tests:css-jscript-block-cond dynamic) - (if (equal? dynamic #t) - tests:css-jscript-block-dynamic - tests:css-jscript-block-static)) - - -(define (tests:run-record->test-path run numkeys) - (append (take (vector->list run) numkeys) - (list (vector-ref run (+ 1 numkeys))))) - - -(define (tests:get-rest-data runs header numkeys) - (let ((resh (make-hash-table))) - (for-each - (lambda (run) - (let* ((run-id (db:get-value-by-header run header "id")) - (run-dir (tests:run-record->test-path run numkeys)) - (test-data (rmt:get-tests-for-run - run-id - "%" ;; testnamepatt - '() ;; states - '() ;; statuses - #f ;; offset - #f ;; num-to-get - #f ;; hide/not-hide - #f ;; sort-by - #f ;; sort-order - #f ;; 'shortlist ;; qrytype - 0 ;; last update - #f))) - - (map (lambda (test) - (let* ((test-name (vector-ref test 2)) - (test-html-path (conc (vector-ref test 10) "/" (vector-ref test 13))) - (test-item (conc test-name ":" (vector-ref test 11))) - (test-status (vector-ref test 4))) - - (if (not (hash-table-ref/default resh test-name #f)) - (hash-table-set! resh test-name (make-hash-table))) - (if (not (hash-table-ref/default (hash-table-ref/default resh test-name #f) test-item #f)) - (hash-table-set! (hash-table-ref/default resh test-name #f) test-item (make-hash-table))) - (hash-table-set! (hash-table-ref/default (hash-table-ref/default resh test-name #f) test-item #f) run-id (list test-status test-html-path)))) - test-data))) - runs) - resh)) - - -;; tests:genrate dashboard body -;; - -(define (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links flag run-patt target-patt) - (let* ((start (* page pg-size)) - ;(runsdat (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys))) - (runsdat (rmt:get-runs-by-patt keys run-patt target-patt start pg-size #f 0 sort-order: "desc")) - ; db:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-update - (header (vector-ref runsdat 0)) - (runs (vector-ref runsdat 1)) - (ctr 0) - (test-runs-hash (tests:get-rest-data runs header numkeys)) - (test-list (hash-table-keys test-runs-hash))) - - (s:html tests:css-jscript-block (tests:css-jscript-block-cond flag) - (s:title "Summary for " area-name) - (s:body 'onload "addEvents();" - (get-prev-links page linktree) - (get-next-links page linktree total-runs) - - (s:h1 "Summary for " area-name) - (s:h3 "Filter" ) - (s:input 'type "text" 'name "testname" 'id "testname" 'length "30" 'onkeyup "filtersome()") - ;; top list - - (s:table 'id "LinkedList1" 'border "1" 'cellspacing 0 - (map (lambda (key) - (let* ((res (s:tr 'class "something" - (s:th key ) - (map (lambda (run) - (s:th (vector-ref run ctr))) - runs)))) - (set! ctr (+ ctr 1)) - res)) - keys) - (s:tr - (s:th "Run Name") - (map (lambda (run) - (s:th (db:get-value-by-header run header "runname"))) - runs)) - - (map (lambda (test-name) - (let* ((item-hash (hash-table-ref/default test-runs-hash test-name #f)) - (item-keys (sort (hash-table-keys item-hash) string<=?))) - (map (lambda (item-name) - (let* ((res (s:tr 'class item-name - (s:td item-name 'class "test" ) - (map (lambda (run) - (let* ((run-test (hash-table-ref/default item-hash item-name #f)) - (run-id (db:get-value-by-header run header "id")) - (result (hash-table-ref/default run-test run-id "n/a")) - ;(relative-path (get-relative-path)) - (status (if (string? result) - result - (car result))) - (link (if (string? result) - result - (if (equal? flag #t) - (s:a (car result) 'href (conc "./test_log?runid=" run-id "&testname=" item-name )) - (s:a (car result) 'href (string-substitute (conc linktree "/") "" (cadr result) "-")))))) - (s:td link 'class status))) - runs)))) - res)) - item-keys))) - test-list)))))) - -;; (tests:create-html-tree "test-index.html") -;; -(define (tests:create-html-tree outf) - (let* ((lockfile (conc outf ".lock")) - (runs-to-process '()) - (linktree (common:get-linktree)) - (area-name (common:get-testsuite-name)) - (keys (rmt:get-keys)) - (numkeys (length keys)) - (run-patt (or (args:get-arg "-run-patt") - (args:get-arg "-runname") - "%")) - (target (or (args:get-arg "-target-patt") - (args:get-arg "-target") - "%")) - (targlist (string-split target "/")) - (numtarg (length targlist)) - (targtweaked (if (> numkeys numtarg) - (append targlist (make-list (- numkeys numtarg) "%")) - targlist)) - (target-patt (string-join targtweaked "/")) - ;(total-runs (rmt:get-num-runs "%")) ;;this needs to be changed to filter by target - (total-runs (rmt:get-runs-cnt-by-patt run-patt target-patt keys )) - (pg-size 10)) - (if (common:simple-file-lock lockfile) - (begin - ;(print total-runs) - (let loop ((page 0)) - (let* ((oup (open-output-file (or outf (conc linktree "/page" page ".html")))) - (get-prev-links (lambda (page linktree ) - (let* ((link (if (not (eq? page 0)) - (s:a "<<prev" 'href (conc "page" (- page 1) ".html")) - (s:a "" 'href (conc "page" page ".html"))))) - link))) - (get-next-links (lambda (page linktree total-runs) - (let* ((link (if (> total-runs (+ 10 (* page pg-size))) - (s:a "next>>" 'href (conc "page" (+ page 1) ".html")) - (s:a "" 'href (conc "page" page ".html"))))) - link))) ) - (print "total runs: " total-runs) - (s:output-new - oup - (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function - (close-output-port oup) - ; (set! page (+ 1 page)) - (if (> total-runs (* (+ 1 page) pg-size)) - (loop (+ 1 page))))) - (common:simple-file-release-lock lockfile)) - (begin - (debug:print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f)))) - - -(define (tests:readlines filename) - (call-with-input-file filename - (lambda (p) - (let loop ((line (read-line p)) - (result '())) - (if (eof-object? line) - (reverse result) - (loop (read-line p) (cons line result))))))) - -(define (tests:get-test-log run-id test-name item-name) - (let* ((test-data (rmt:get-tests-for-run - (string->number run-id) - test-name ;; testnamepatt - '() ;; states - '() ;; statuses - #f ;; offset - #f ;; num-to-get - #f ;; hide/not-hide - #f ;; sort-by - #f ;; sort-order - #f ;; 'shortlist ;; qrytype - 0 ;; last update - #f)) - (path "") - (found 0)) - (debug:print-info 0 *default-log-port* "found: " found ) - - (let loop ((hed (car test-data)) - (tal (cdr test-data))) - (debug:print-info 0 *default-log-port* "item: " (vector-ref hed 11) (vector-ref hed 10) "/" (vector-ref hed 13)) - - (if (equal? (vector-ref hed 11) item-name) - (begin - (set! found 1) - (set! path (conc (vector-ref hed 10) "/" (vector-ref hed 13))))) - (if (and (not (null? tal)) (equal? found 0)) - (loop (car tal)(cdr tal)))) - (if (equal? path "") - "

Data not found

" - (string-join (tests:readlines path) "\n")))) - - -(define (tests:dynamic-dboard page) -;(define (tests:create-html-tree o) - (let* ( -;(page "1") - (linktree (common:get-linktree)) - (area-name (common:get-testsuite-name)) - (keys (rmt:get-keys)) - (numkeys (length keys)) - (targtweaked (make-list numkeys "%")) - (target-patt (string-join targtweaked "/")) - (total-runs (rmt:get-num-runs "%")) - (pg-size 10) - (pg (if (equal? page #f) - 0 - (- (string->number page) 1))) - (get-prev-links (lambda (pg linktree) - (debug:print-info 0 *default-log-port* "val: " (- 1 pg)) - (let* ((link (if (not (eq? pg 0)) - (s:a "<<prev " 'href (conc "dashboard?page=" pg )) - (s:a "" 'href (conc "dashboard?page=" pg))))) - link))) - (get-next-links (lambda (pg linktree total-runs) - (debug:print-info 0 *default-log-port* "val: " pg) - (debug:print-info 0 *default-log-port* "val: " total-runs " size" pg-size) - - (let* ((link (if (> total-runs (+ 10 (* pg pg-size))) - (s:a "next>> " 'href (conc "dashboard?page=" (+ pg 2) )) - (s:a "" 'href (conc "dashboard?page=" pg ))))) - link))) - (html-body (tests:dashboard-body pg pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #t "%" target-patt))) ;; update tis function - html-body)) - -(define (tests:create-html-summary outf) - (let* ((lockfile (conc outf ".lock")) - (linktree (common:get-linktree)) - (keys (rmt:get-keys)) - (area-name (common:get-testsuite-name)) - (run-patt (or (args:get-arg "-run-patt") - (args:get-arg "-runname") - "%")) - (target (or (args:get-arg "-target-patt") - (args:get-arg "-target") - "%")) - (targlist (string-split target "/")) - (numkeys (length keys)) - (numtarg (length targlist)) - (targtweaked (if (> numkeys numtarg) - (append targlist (make-list (- numkeys numtarg) "%")) - targlist)) - (target-patt (string-join targtweaked "/"))) - (if (common:simple-file-lock lockfile) - (begin - (let* (;(runsdat1 (rmt:get-runs run-patt #f #f (map (lambda (x)(list x "%")) keys))) - (runsdat (rmt:get-runs-by-patt keys run-patt target-patt #f #f #f 0)) - (runs (vector-ref runsdat 1)) - (header (vector-ref runsdat 0)) - (oup (open-output-file (or outf (conc linktree "/targets.html")))) - (target-hash (test:create-target-hash runs header (length keys)))) - (test:create-target-html target-hash oup area-name linktree) - (test:create-run-html runs area-name linktree (length keys) header)) - (common:simple-file-release-lock lockfile)) - #f))) - -(define (test:get-test-hash test-data) - (let ((resh (make-hash-table))) - (map (lambda (test) - (let* ((test-name (vector-ref test 2)) - (test-html-path (if (file-exists? (conc (vector-ref test 10) "/test-summary.html")) - (conc (vector-ref test 10) "/test-summary.html" ) - (conc (vector-ref test 10) "/" (vector-ref test 13)))) - (test-item (vector-ref test 11)) - (test-status (vector-ref test 4))) - (if (not (hash-table-ref/default resh test-item #f)) - (hash-table-set! resh test-item (make-hash-table))) - (hash-table-set! (hash-table-ref/default resh test-item #f) test-name (list test-status test-html-path)))) - test-data) -resh)) - -(define (test:get-data->b-keys ordered-data a-keys) - (delete-duplicates - (sort (apply - append - (map (lambda (sub-key) - (let ((subdat (hash-table-ref ordered-data sub-key))) - (hash-table-keys subdat))) - a-keys)) - string>=?))) - - -(define (test:create-run-html runs area-name linktree numkeys header) - (map (lambda (run) - (let* ((target (string-join (take (vector->list run) numkeys) "/")) - (run-name (db:get-value-by-header run header "runname")) - (run-time (seconds->work-week/day-time (db:get-value-by-header run header "event_time"))) - (oup (if (file-exists? (conc linktree "/" target "/" run-name)) - (open-output-file (conc linktree "/" target "/" run-name "/run.html")) - #f)) - (run-id (db:get-value-by-header run header "id")) - (test-data (rmt:get-tests-for-run - run-id - "%" ;; testnamepatt - '() ;; states - '() ;; statuses - #f ;; offset - #f ;; num-to-get - #f ;; hide/not-hide - #f ;; sort-by - #f ;; sort-order - #f ;; 'shortlist ;; qrytype - 0 ;; last update - #f)) - (item-test-hash (test:get-test-hash test-data)) - (items (hash-table-keys item-test-hash)) - (test-names (test:get-data->b-keys item-test-hash items))) - (if oup - (begin - (s:output-new - oup - (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f) - (s:title "Runs View " run-name) - (s:body - (s:h1 "Runs View " ) - (s:h3 "Target" target) - (s:p - (s:b "Run name" ) run-name) - (s:p - (s:b "Run Date" ) run-time) - (s:table 'border 1 'cellspacing 0 - (s:tr - (s:th "Items") - (map (lambda (test) - (s:th test)) - test-names)) - (map (lambda (item) - (let* ((test-hash (hash-table-ref/default item-test-hash item #f))) - (if test-hash - (begin - (s:tr - (s:td 'class "test" item) - (map (lambda (test) - (let* ((test-details (hash-table-ref/default test-hash test #f)) - (status (if test-details - (car test-details))) - (link (if test-details - (string-substitute (conc linktree "/" target "/" run-name "/") "" (cadr test-details) "-")))) - (if test-details - (s:td 'class status - (s:a 'class "link" 'href link status )) - (s:td "")))) - test-names)))))) - (sort items string<=?)))))) - (close-output-port oup)) - (debug:print-info 0 "Skip: Dirctory structure " linktree "/" target "/" run-name " does not exist. Megatest will not create run.html")))) -runs)) - -(define (test:create-target-hash runs header numkeys) - (let ((resh (make-hash-table))) - (for-each - (lambda (run) - (let* ((run-name (db:get-value-by-header run header "runname")) - (target (string-join (take (vector->list run) numkeys) "/")) - (run-list (hash-table-ref/default resh target #f))) - - (if (not run-list) - (hash-table-set! resh target (list run-name)) - (hash-table-set! resh target (cons run-name run-list))))) - runs) - resh)) - -(define (test:get-max-run-cnt target-hash targets) - (let* ((cnt 0 )) - (map (lambda (target) - (let* ((runs (hash-table-ref/default target-hash target #f)) - (run-length (if runs - (length runs) - 0))) - - (if (< cnt run-length) - (set! cnt run-length)))) - targets) -cnt)) - -(define (test:pad-runs target-hash targets max-row-length) - (map (lambda (target) - (let loop ((run-list (hash-table-ref/default target-hash target #f))) - (if (< (length run-list) max-row-length) - (begin - (hash-table-set! target-hash target (cons "" run-list)) - (loop (hash-table-ref/default target-hash target #f) ))))) - targets) - target-hash) - -(define (test:create-target-html target-hash oup area-name linktree) - (let* ((targets (hash-table-keys target-hash)) - (max-row-length (test:get-max-run-cnt target-hash targets)) - (pad-runs-hash (test:pad-runs target-hash targets max-row-length))) - (s:output-new - oup - (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f) - - (s:title "Target View " area-name) - (s:body - (s:h1 "Target View " area-name) - (s:table 'id "LinkedList1" 'border "1" 'cellspacing 0 - (s:tr 'class "something" - (s:th "Target") - (s:th 'colspan max-row-length "Runs")) - (let* ((tbl (map (lambda (target) - (s:tr - (s:td 'class "test" target) - (let* ((runs (hash-table-ref/default target-hash target #f)) - (rest-row (map (lambda (run) - (if (equal? run "") - (s:td run) - (if (file-exists?(conc linktree "/" target "/" run )) - (begin - (s:td - (s:a 'href (conc target "/" run "/run.html") run)))))) - (reverse runs)))) - rest-row))) - targets))) - tbl))))) - (close-output-port oup))) - - -(define (tests:create-html-tree-old outf) - (let* ((lockfile (conc outf ".lock")) - (runs-to-process '())) - (if (common:simple-file-lock lockfile) - (let* ((linktree (common:get-linktree)) - (oup (open-output-file (or outf (conc linktree "/runs-index.html")))) - (area-name (common:get-testsuite-name)) - (keys (rmt:get-keys)) - (numkeys (length keys)) - (runsdat (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys))) - (header (vector-ref runsdat 0)) - (runs (vector-ref runsdat 1)) - (runtreedat (map (lambda (x) - (tests:run-record->test-path x numkeys)) - runs)) - (runs-htree (common:list->htree runtreedat))) - (set! runs-to-process runs) - (s:output-new - oup - (s:html tests:css-jscript-block - (s:title "Summary for " area-name) - (s:body 'onload "addEvents();" - (s:h1 "Summary for " area-name) - ;; top list - (s:ul 'id "LinkedList1" 'class "LinkedList" - (s:li - "Runs" - (common:htree->html runs-htree - '() - (lambda (x p) - (let* ((targ-path (string-intersperse p "/")) - (full-path (conc linktree "/" targ-path)) - (run-name (car (reverse p)))) - (if (and (common:file-exists? full-path) - (directory? full-path) - (file-write-access? full-path)) - (s:a run-name 'href (conc targ-path "/run-summary.html")) - (begin - (debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html") - (conc run-name " (Not able to create summary at " targ-path ")"))))))))))) - (close-output-port oup) - (common:simple-file-release-lock lockfile) - - (for-each - (lambda (run) - (let* ((test-subpath (tests:run-record->test-path run numkeys)) - (run-id (db:get-value-by-header run header "id")) - (run-dir (tests:run-record->test-path run numkeys)) - (test-dats (rmt:get-tests-for-run - run-id - "%/" ;; testnamepatt - '() ;; states - '() ;; statuses - #f ;; offset - #f ;; num-to-get - #f ;; hide/not-hide - #f ;; sort-by - #f ;; sort-order - #f ;; 'shortlist ;; qrytype - 0 ;; last update - #f)) - (tests-tree-dat (map (lambda (test-dat) - ;; (tests:run-record->test-path x numkeys)) - (let* ((test-name (db:test-get-testname test-dat)) - (item-path (db:test-get-item-path test-dat)) - (full-name (db:test-make-full-name test-name item-path)) - (path-parts (string-split full-name))) - path-parts)) - test-dats)) - (tests-htree (common:list->htree tests-tree-dat)) - (html-dir (conc linktree "/" (string-intersperse run-dir "/"))) - (html-path (conc html-dir "/run-summary.html")) - (oup (if (and (common:file-exists? html-dir) - (directory? html-dir) - (file-write-access? html-dir)) - (open-output-file html-path) - #f))) - ;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat) - (if oup - (begin - (s:output-new - oup - (s:html tests:css-jscript-block - (s:title "Summary for " area-name) - (s:body 'onload "addEvents();" - (s:h1 "Summary for " (string-intersperse run-dir "/")) - ;; top list - (s:ul 'id "LinkedList1" 'class "LinkedList" - (s:li - "Tests" - (common:htree->html tests-htree - '() - (lambda (x p) - (let* ((targ-path (string-intersperse p "/")) - (test-name (car p)) - (item-path ;; (if (> (length p) 2) ;; test-name + run-name - (string-intersperse p "/")) - (full-targ (conc html-dir "/" targ-path)) - (std-file (conc full-targ "/test-summary.html")) - (alt-file (conc full-targ "/megatest-rollup-" test-name ".html")) - (html-file (if (common:file-exists? alt-file) - alt-file - std-file)) - (run-name (car (reverse p)))) - (if (and (not (common:file-exists? full-targ)) - (directory? full-targ) - (file-write-access? full-targ)) - (tests:summarize-test - run-id - (rmt:get-test-id run-id test-name item-path))) - (if (common:file-exists? full-targ) - (s:a run-name 'href html-file) - (begin - (debug:print 0 *default-log-port* "ERROR: can't access " full-targ) - (conc "No summary for " run-name))))) - )))))) - (close-output-port oup))))) - runs) - #t) - #f))) - - - - - - - -;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!! -;; -;; get a pretty table to summarize steps -;; -;; (define (dcommon:process-steps-table steps);; db test-id #!key (work-area #f)) -(define (tests:process-steps-table steps);; db test-id #!key (work-area #f)) -;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) - ;; organise the steps for better readability - (let ((res (make-hash-table))) - (for-each - (lambda (step) - (debug:print 6 *default-log-port* "step=" step) - (let ((record (hash-table-ref/default - res - (tdb:step-get-stepname step) - ;; 0 1 2 3 4 5 6 7 - ;; stepname start end status Duration Logfile Comment first-id - (vector (tdb:step-get-stepname step) "" "" "" "" "" "" #f)))) - (debug:print 6 *default-log-port* "record(before) = " record - "\nid: " (tdb:step-get-id step) - "\nstepname: " (tdb:step-get-stepname step) - "\nstate: " (tdb:step-get-state step) - "\nstatus: " (tdb:step-get-status step) - "\ntime: " (tdb:step-get-event_time step)) - (if (not (vector-ref record 7))(vector-set! record 7 (tdb:step-get-id step))) ;; do not clobber the id if previously set - (case (string->symbol (tdb:step-get-state step)) - ((start)(vector-set! record 1 (tdb:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") - (tdb:step-get-status step))) - (if (> (string-length (tdb:step-get-logfile step)) - 0) - (vector-set! record 5 (tdb:step-get-logfile step)))) - ((end) - (vector-set! record 2 (any->number (tdb:step-get-event_time step))) - (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) - (endt (any->number (vector-ref record 2)))) - (debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1) - ", startt=" startt ", endt=" endt - ", get-status: " (tdb:step-get-status step)) - (if (and (number? startt)(number? endt)) - (seconds->hr-min-sec (- endt startt)) "-1"))) - (if (> (string-length (tdb:step-get-logfile step)) - 0) - (vector-set! record 5 (tdb:step-get-logfile step))) - (if (> (string-length (tdb:step-get-comment step)) - 0) - (vector-set! record 6 (tdb:step-get-comment step)))) - (else - (vector-set! record 2 (tdb:step-get-state step)) - (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (tdb:step-get-event_time step)) - (vector-set! record 6 (tdb:step-get-comment step)))) - (hash-table-set! res (tdb:step-get-stepname step) record) - (debug:print 6 *default-log-port* "record(after) = " record - "\nid: " (tdb:step-get-id step) - "\nstepname: " (tdb:step-get-stepname step) - "\nstate: " (tdb:step-get-state step) - "\nstatus: " (tdb:step-get-status step) - "\ntime: " (tdb:step-get-event_time step)))) - ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) - (sort steps (lambda (a b) - (cond - ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) - ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) - (< (tdb:step-get-id a) (tdb:step-get-id b))) - (else #f))))) - res)) - -;; -;; -(define (tests:get-compressed-steps run-id test-id) - (let* ((steps-data (rmt:get-steps-for-test run-id test-id)) ;; 0 1 2 3 4 5 6 7 - (comprsteps (tests:process-steps-table steps-data))) ;; # - (map (lambda (x) - ;; take advantage of the \n on time->string - (vector ;; we are constructing basically the original vector but collapsing start end records - (vector-ref x 0) ;; id 0 - (let ((s (vector-ref x 1))) - (if (number? s)(seconds->time-string s) s)) ;; starttime 1 - (let ((s (vector-ref x 2))) - (if (number? s)(seconds->time-string s) s)) ;; endtime 2 - (vector-ref x 3) ;; status 3 - (vector-ref x 4) ;; duration 4 - (vector-ref x 5) ;; logfile 5 - (vector-ref x 6) ;; comment 6 - (vector-ref x 7))) ;; id 7 - (sort (hash-table-values comprsteps) - (lambda (a b) - (let ((time-a (vector-ref a 1)) - (time-b (vector-ref b 1)) - (id-a (vector-ref a 7)) - (id-b (vector-ref b 7))) - (if (and (number? time-a)(number? time-b)) - (if (< time-a time-b) - #t - (if (eq? time-a time-b) - (< id-a id-b) - ;; (stringwork-week/day-time - (db:test-get-event_time test-dat))) - (s:td "Duration") (s:td (seconds->hr-min-sec (db:test-get-run_duration test-dat))))) - (s:h3 "Log files") - (s:table - 'cellspacing "0" 'border "1" - (s:tr (s:td "Final log")(s:td (s:a 'href logf logf)))) - (s:table - 'cellspacing "0" 'border "1" - (s:tr (s:td "Step Name")(s:td "Start")(s:td "End")(s:td "Status")(s:td "Duration")(s:td "Log File")) - (map (lambda (step-dat) - (s:tr (s:td (tdb:steps-table-get-stepname step-dat)) - (s:td (tdb:steps-table-get-start step-dat)) - (s:td (tdb:steps-table-get-end step-dat)) - (s:td (tdb:steps-table-get-status step-dat)) - (s:td (tdb:steps-table-get-runtime step-dat)) - (s:td (let ((step-log (tdb:steps-table-get-log-file step-dat))) - (s:a 'href step-log step-log))))) - steps-dat)) - ))) - (close-output-port oup))))) - - -;; MUST BE CALLED local! -;; -(define (tests:test-get-paths-matching keynames target fnamepatt #!key (res '())) - ;; BUG: Move the values derived from args to parameters and push to megatest.scm - (let* ((testpatt (or (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) - (statepatt (or (args:get-arg "-state") (args:get-arg ":state") "%")) - (statuspatt (or (args:get-arg "-status") (args:get-arg ":status") "%")) - (runname (or (args:get-arg "-runname") (args:get-arg ":runname") "%")) - (paths-from-db (rmt:test-get-paths-matching-keynames-target-new keynames target res - testpatt - statepatt - statuspatt - runname))) - (if fnamepatt - (apply append - (map (lambda (p) - (if (directory-exists? p) - (let ((glob-query (conc p "/" fnamepatt))) - (handle-exceptions - exn - (begin - (print "built-in glob on " glob-query ", failed, try using the shell. exn=" exn) - (with-input-from-pipe - (conc "echo " glob-query) - read-lines)) ;; we aren't going to try too hard. If glob breaks it is likely because someone tried to do */*/*.log or similar - (glob glob-query))) - '())) - paths-from-db)) - paths-from-db))) - - -;;====================================================================== -;; Gather data from test/task specifications -;;====================================================================== - -;; (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '())) -;; (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*"))))) -;; (set! tests (filter (lambda (test)(common:file-exists? (conc test "/testconfig"))) tests)) -;; (delete-duplicates -;; (filter (lambda (testname) -;; (tests:match test-patts testname #f)) -;; (map (lambda (testp) -;; (last (string-split testp "/"))) -;; tests))))) -;; sort tests by priority and waiton -;; Move test specific stuff to a test unit FIXME one of these days -(define (tests:sort-by-priority-and-waiton test-records) - (if (eq? (hash-table-size test-records) 0) - '() - (let* ((mungepriority (lambda (priority) - (if priority - (let ((tmp (any->number priority))) - (if tmp tmp (begin (debug:print-error 0 *default-log-port* "bad priority value " priority ", using 0") 0))) - 0))) - (all-tests (hash-table-keys test-records)) - (all-waited-on (let loop ((hed (car all-tests)) - (tal (cdr all-tests)) - (res '())) - (let* ((trec (hash-table-ref test-records hed)) - (waitons (or (tests:testqueue-get-waitons trec) '()))) - (if (null? tal) - (append res waitons) - (loop (car tal)(cdr tal)(append res waitons)))))) - (sort-fn1 - (lambda (a b) - (let* ((a-record (hash-table-ref test-records a)) - (b-record (hash-table-ref test-records b)) - (a-waitons (or (tests:testqueue-get-waitons a-record) '())) - (b-waitons (or (tests:testqueue-get-waitons b-record) '())) - (a-config (tests:testqueue-get-testconfig a-record)) - (b-config (tests:testqueue-get-testconfig b-record)) - (a-raw-pri (configf:lookup a-config "requirements" "priority")) - (b-raw-pri (configf:lookup b-config "requirements" "priority")) - (a-priority (mungepriority a-raw-pri)) - (b-priority (mungepriority b-raw-pri))) - (tests:testqueue-set-priority! a-record a-priority) - (tests:testqueue-set-priority! b-record b-priority) - ;; (debug:print 0 *default-log-port* "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons) - (cond - ;; is - ((member a b-waitons) ;; is b waiting on a? - ;; (debug:print 0 *default-log-port* "case1") - #t) - ((member b a-waitons) ;; is a waiting on b? - ;; (debug:print 0 *default-log-port* "case2") - #f) - ((and (not (null? a-waitons)) ;; both have waitons - do not disturb - (not (null? b-waitons))) - ;; (debug:print 0 *default-log-port* "case2.1") - #t) - ((and (null? a-waitons) ;; no waitons for a but b has waitons - (not (null? b-waitons))) - ;; (debug:print 0 *default-log-port* "case3") - #f) - ((and (not (null? a-waitons)) ;; a has waitons but b does not - (null? b-waitons)) - ;; (debug:print 0 *default-log-port* "case4") - #t) - ((not (eq? a-priority b-priority)) ;; use - (> a-priority b-priority)) - (else - ;; (debug:print 0 *default-log-port* "case5") - (string>? a b)))))) - - (sort-fn2 - (lambda (a b) - (> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a))) - (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records b))))))) - ;; (let ((dot-res (tests:run-dot (tests:tests->dot test-records) "plain"))) - ;; (debug:print "dot-res=" dot-res)) - ;; (let ((data (map cdr (filter - ;; (lambda (x)(equal? "node" (car x))) - ;; (map string-split (tests:easy-dot test-records "plain")))))) - ;; (map car (sort data (lambda (a b) - ;; (> (string->number (caddr a))(string->number (caddr b))))))) - ;; )) - (sort all-tests sort-fn1)))) ;; avoid dealing with deleted tests, look at the hash table - -(define (tests:easy-dot test-records outtype) - (let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX")))) - (let ((all-testnames (hash-table-keys test-records)) - (temp-port (open-output-file* fd))) - ;; (format temp-port "This file is ~A.~%" temp-path) - (format temp-port "digraph tests {\n") - (format temp-port " size=4,8\n") - ;; (format temp-port " splines=none\n") - (for-each - (lambda (testname) - (let* ((testrec (hash-table-ref test-records testname)) - (waitons (or (tests:testqueue-get-waitons testrec) '()))) - (for-each - (lambda (waiton) - (format temp-port (conc " " waiton " -> " testname " [splines=ortho]\n"))) - waitons))) - all-testnames) - (format temp-port "}\n") - (close-output-port temp-port) - (with-input-from-pipe - (conc "env -i PATH=$PATH dot -T" outtype " < " temp-path) - (lambda () - (let ((res (read-lines))) - ;; (delete-file temp-path) - res)))))) - -(define (tests:write-dot-file test-records fname sizex sizey) - (if (file-write-access? (pathname-directory fname)) - (with-output-to-file fname - (lambda () - (map print (tests:tests->dot test-records sizex sizey)))))) - -(define (tests:tests->dot test-records sizex sizey) - (let ((all-testnames (hash-table-keys test-records))) - (if (null? all-testnames) - '() - (let loop ((hed (car all-testnames)) - (tal (cdr all-testnames)) - (res (list "digraph tests {" - (conc " size=\"" (or sizex 11) "," (or sizey 11) "\";") - " ratio=0.95;" - ))) - (let* ((testrec (hash-table-ref test-records hed)) - (waitons (or (tests:testqueue-get-waitons testrec) '())) - (newres (append res - (if (null? waitons) - (list (conc " \"" hed "\" [shape=box];")) - (map (lambda (waiton) - (conc " \"" waiton "\" -> \"" hed "\" [shape=box];")) - waitons) - )))) - (if (null? tal) - (append newres (list "}")) - (loop (car tal)(cdr tal) newres) - )))))) - -;; (tests:run-dot (list "digraph tests {" "a -> b" "}") "plain") - -(define (tests:run-dot indat outtype) ;; outtype is plain, fig, dot, etc. http://www.graphviz.org/content/output-formats - (let-values (((inp oup pid)(process "env -i PATH=\"$PATH\" dot" (list "-T" outtype)))) - (with-output-to-port oup - (lambda () - (map print indat))) - (close-output-port oup) - (let ((res (with-input-from-port inp - (lambda () - (read-lines))))) - (close-input-port inp) - res))) - -;; read data from tmp file or create if not exists -;; if exists regen in background -;; -(define (tests:lazy-dot testrecords outtype sizex sizey) - (let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot")) - (fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat"))) - (tests:write-dot-file testrecords dfile sizex sizey) - (if (common:file-exists? fname) - (let ((res (with-input-from-file fname - (lambda () - (read-lines))))) - (system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname "&")) - res) - (begin - (system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname)) - (with-input-from-file fname - (lambda () - (read-lines))))))) - - -;; for each test: -;; -(define (tests:filter-non-runnable run-id testkeynames testrecordshash) - (let ((runnables '())) - (for-each - (lambda (testkeyname) - (let* ((test-record (hash-table-ref testrecordshash testkeyname)) - (test-name (tests:testqueue-get-testname test-record)) - (itemdat (tests:testqueue-get-itemdat test-record)) - (item-path (tests:testqueue-get-item_path test-record)) - (waitons (tests:testqueue-get-waitons test-record)) - (keep-test #t) - (test-id (rmt:get-test-id run-id test-name item-path)) - (tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) - (if tdat - (begin - ;; Look at the test state and status - (if (or (and (member (db:test-get-status tdat) - '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) - (equal? (db:test-get-state tdat) "COMPLETED")) - (member (db:test-get-state tdat) - '("INCOMPLETE" "KILLED"))) - (set! keep-test #f)) - - ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test - ;; from the runnable list - (if keep-test - (for-each (lambda (waiton) - ;; for now we are waiting only on the parent test - (let* ((parent-test-id (rmt:get-test-id run-id waiton "")) - (wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) - (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED") - (member (db:test-get-status wtdat) '("FAIL" "ABORT"))) - (member (db:test-get-status wtdat) '("KILLED")) - (member (db:test-get-state wtdat) '("INCOMPETE"))) - ;; (if (or (member (db:test-get-status wtdat) - ;; '("FAIL" "KILLED")) - ;; (member (db:test-get-state wtdat) - ;; '("INCOMPETE"))) - (set! keep-test #f)))) ;; no point in running this one again - waitons)))) - (if keep-test (set! runnables (cons testkeyname runnables))))) - testkeynames) - runnables)) - -;;====================================================================== -;; refactoring this block into tests:get-full-data from line 263 of runs.scm -;;====================================================================== -;; hed is the test name -;; test-records is a hash of test-name => test record -(define (tests:get-full-data test-names test-records required-tests all-tests-registry) - (let ((missing-waitons (make-hash-table))) - (if (not (null? test-names)) - (let loop ((hed (car test-names)) - (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc - (debug:print-info 4 *default-log-port* "hed=" hed " at top of loop") - ;; don't know item-path at this time, let the testconfig get the top level testconfig - (let* ((config (tests:get-testconfig hed #f all-tests-registry 'return-procs)) - (waitons (let ((instr (if config - (configf:lookup config "requirements" "waiton") - (begin ;; No config means this is a non-existent test - (let ((waiters '())) - ;; find the waiter(s) for this waiton. - (for-each - (lambda(waiter) - ;; (print "test-record = " (hash-table-ref test-records waiter)) - ;; (print "waitons = " (vector-ref (hash-table-ref test-records waiter) 2)) - (if (member hed (vector-ref (hash-table-ref test-records waiter) 2)) - (set! waiters (cons waiter waiters)) - ) - ) - (hash-table-keys test-records)) - (hash-table-set! missing-waitons hed waiters) - ) - "")))) - (debug:print-info 8 *default-log-port* "waitons string is " instr) - (string-split (cond - ((procedure? instr) - (let ((res (instr))) - (debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " hed) - res)) - ((string? instr) instr) - (else - ;; NOTE: This is actually the case of *no* waitons! ;; - "")))))) - (if (not config) ;; this is a non-existant test called in a waiton. - (if (null? tal) - test-records - (loop (car tal)(cdr tal))) - (begin - (debug:print-info 8 *default-log-port* "waitons: " waitons) - ;; check for hed in waitons => this would be circular, remove it and issue an - ;; error - (if (member hed waitons) - (begin - (debug:print-error 0 *default-log-port* "test " hed " has listed itself as a waiton, please correct this!") - (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)))) - - ;; (items (items:get-items-from-config config))) - (if (not (hash-table-ref/default test-records hed #f)) - (hash-table-set! test-records - hed (vector hed ;; 0 - config ;; 1 - waitons ;; 2 - (configf:lookup config "requirements" "priority") ;; priority 3 - (let ((items (hash-table-ref/default config "items" #f)) ;; items 4 - (itemstable (hash-table-ref/default config "itemstable" #f))) - ;; if either items or items table is a proc return it so test running - ;; process can know to call items:get-items-from-config - ;; if either is a list and none is a proc go ahead and call get-items - ;; otherwise return #f - this is not an iterated test - (cond - ((procedure? items) - (debug:print-info 4 *default-log-port* "items is a procedure, will calc later") - items) ;; calc later - ((procedure? itemstable) - (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later") - itemstable) ;; calc later - ((filter (lambda (x) - (let ((val (car x))) - (if (procedure? val) val #f))) - (append (if (list? items) items '()) - (if (list? itemstable) itemstable '()))) - 'have-procedure) - ((or (list? items)(list? itemstable)) ;; calc now - (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n" - " items: " items " itemstable: " itemstable) - (items:get-items-from-config config)) - (else #f))) ;; not iterated - #f ;; itemsdat 5 - #f ;; spare - used for item-path - ))) - (for-each - (lambda (waiton) - (if (and waiton (not (string= "#f" waiton)) (not (member waiton test-names))) - (begin - (set! required-tests (cons waiton required-tests)) - (set! test-names (cons waiton test-names))))) ;; was an append, now a cons - waitons) - (let ((remtests (delete-duplicates (append waitons tal)))) - (if (not (null? remtests)) - (loop (car remtests)(cdr remtests)) - test-records))))))) - (for-each - (lambda (missing-waiton) - (debug:print-error 0 *default-log-port* "non-existent test \"" missing-waiton "\" is a waiton for tests " (hash-table-ref missing-waitons missing-waiton)) - ) - (hash-table-keys missing-waitons) - ) -)) - -;;====================================================================== -;; test steps -;;====================================================================== - -;; teststep-set-status! used to be here - -;; NOT NEEDED -#;(define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat) - (let* ((testdat (rmt:get-test-state-status-by-id run-id test-id))) - (and testdat - (equal? (car testdat) "KILLREQ")))) - -(define (test:tdb-get-rundat-count tdb) - (if tdb - (let ((res 0)) - (sqlite3:for-each-row - (lambda (count) - (set! res count)) - 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))) - -;; 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 test-id run-id minutes work-area) -;; (let ((remtries 10)) - (let* ((cpuload (commonmod: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) - ))) - -;;====================================================================== -;; A R C H I V I N G -;;====================================================================== - -(define (test:archive db test-id) - #f) - -(define (test:archive-tests db keynames target) - #f) - Index: testsmod.scm ================================================================== --- testsmod.scm +++ testsmod.scm @@ -29,11 +29,15 @@ (declare (uses mtargs)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses dbmod)) (declare (uses dbfile)) -;; (declare (uses megatestmod)) +(declare (uses megatestmod)) +(declare (uses rmtmod)) +(declare (uses stml2)) +(declare (uses mtmod)) +(declare (uses servermod)) (use srfi-69) (module testsmod * @@ -58,10 +62,11 @@ posix-extras regex regex-case sparse-vectors srfi-1 + srfi-13 srfi-18 srfi-69 typed-records z3 @@ -107,14 +112,1330 @@ ))) (import directory-utils debugprint - ;; commonmod - ;; configfmod - ;; dbmod - ;; dbfile - ;; megatestmod + commonmod + configfmod + dbmod + dbfile + megatestmod + rmtmod + stml2 + mtmod + servermod ) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") +(include "test_records.scm") +(include "js-path.scm") + +(define (init-java-script-lib) + (set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js")) + ) +(define (tests:summarize-items run-id test-id test-name force) + ;; if not force then only update the record if one of these is true: + ;; 1. logf is "log/final.log + ;; 2. logf is same as outputfilename + (let* ((outputfilename (conc "megatest-rollup-" test-name ".html")) + (orig-dir (current-directory)) + (logf-info (rmt:test-get-logfile-info run-id test-name)) + (logf (if logf-info (cadr logf-info) #f)) + (path (if logf-info (car logf-info) #f))) + ;; This query finds the path and changes the directory to it for the test + (if (and (string? path) + (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ... + (begin + (debug:print 4 *default-log-port* "Found path: " path) + (change-directory path)) + ;; (set! outputfilename (conc path "/" outputfilename))) + (debug:print-error 0 *default-log-port* "summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path)) + (debug:print 4 *default-log-port* "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) + (if (or (equal? logf "logs/final.log") + (equal? logf outputfilename) + force) + (let ((my-start-time (current-seconds)) + (lockf (conc outputfilename ".lock"))) + (let loop ((have-lock (common:simple-file-lock lockf))) + (if have-lock + (let ((script (configf:lookup *configdat* "testrollup" test-name))) + (debug:print 0 *default-log-port* "Obtained lock for " outputfilename) + (rmt:set-state-status-and-roll-up-items run-id test-name "" #f #f #f) + (if script + (system (conc script " > " outputfilename " & ")) + (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)) + (common:simple-file-release-lock lockf) + (change-directory orig-dir) + ;; NB// tests:test-set-toplog! is remote internal... + (tests:test-set-toplog! run-id test-name outputfilename)) + ;; didn't get the lock, check to see if current update started later than this + ;; update, if so we can exit without doing any work + (if (> my-start-time (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "failed to get mod time on " lockf ", exn=" exn) + 0) + (file-modification-time lockf))) + ;; we started since current re-gen in flight, delay a little and try again + (begin + (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it") + (thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds + (loop (common:simple-file-lock lockf)))))))))) + +(define (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename) + (let ((counts (make-hash-table)) + (statecounts (make-hash-table)) + (outtxt "") + (tot 0) + (testdat (rmt:test-get-records-for-index-file run-id test-name))) + (with-output-to-file outputfilename + (lambda () + (set! outtxt (conc outtxt "Summary: " test-name + "

Summary for " test-name "

")) + (for-each + (lambda (testrecord) + (let ((id (vector-ref testrecord 0)) + (itempath (vector-ref testrecord 1)) + (state (vector-ref testrecord 2)) + (status (vector-ref testrecord 3)) + (run_duration (vector-ref testrecord 4)) + (logf (vector-ref testrecord 5)) + (comment (vector-ref testrecord 6))) + (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0))) + (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0))) + (set! outtxt (conc outtxt "" + ;; " " itempath "" + " " itempath "" + "" state "" + "" status "" + "" (if (equal? comment "") + " " + comment) "" + "")))) + (if (list? testdat) + testdat + (begin + (debug:print 0 *default-log-port* "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name) + '()))) + + (print "
") + ;; Print out stats for status + (set! tot 0) + (print "") + (for-each (lambda (state) + (set! tot (+ tot (hash-table-ref statecounts state))) + (print "")) + (hash-table-keys statecounts)) + (print "

State stats

" state "" (hash-table-ref statecounts state) "
Total" tot "
") + (print "		") + ;; Print out stats for state + (set! tot 0) + (print "") + (for-each (lambda (status) + (set! tot (+ tot (hash-table-ref counts status))) + (print "")) + (hash-table-keys counts)) + (print "

Status stats

" status + "" (hash-table-ref counts status) "
Total" tot "
") + (print "
") + + (print "" + "" + outtxt "
ItemStateStatusComment
") + ;; (release-dot-lock outputfilename) + ;;(rmt:update-run-stats + ;; run-id + ;; (hash-table-map + ;; state-status-counts + ;; (lambda (key val) + ;; (append key (list val))))) + )))) + +(define tests:css-jscript-block +#< +ul.LinkedList { display: block; } +/* ul.LinkedList ul { display: none; } */ +.HandCursorStyle { cursor: pointer; cursor: hand; } /* For IE */ +th {background-color: #8c8c8c;} +td.test {background-color: #d9dbdd;} +td.PASS {background-color: #347533;} +td.FAIL {background-color: #cc2812;} +td.SKIP{background-color: #FFD733;} +td.WARN {background-color: #EA8724;} +td.WAIVED {background-color: #838A12;} +td.ABORT{background-color: #EA24B7;} +.PASS .link, .SKIP .link, .WARN .link,.WAIVED .link,.ABORT .link, .FAIL .link{color: #FFFFFF;} + + + + + + +EOF +) + +(define tests:css-jscript-block-dynamic +#< +EOF +) + +(define (test:js-block javascript-lib) + (conc "" )) + + +(define tests:css-jscript-block-static (test:js-block *java-script-lib*)) + +(define (tests:css-jscript-block-cond dynamic) + (if (equal? dynamic #t) + tests:css-jscript-block-dynamic + tests:css-jscript-block-static)) + + +(define (tests:run-record->test-path run numkeys) + (append (take (vector->list run) numkeys) + (list (vector-ref run (+ 1 numkeys))))) + + +(define (tests:get-rest-data runs header numkeys) + (let ((resh (make-hash-table))) + (for-each + (lambda (run) + (let* ((run-id (db:get-value-by-header run header "id")) + (run-dir (tests:run-record->test-path run numkeys)) + (test-data (rmt:get-tests-for-run + run-id + "%" ;; testnamepatt + '() ;; states + '() ;; statuses + #f ;; offset + #f ;; num-to-get + #f ;; hide/not-hide + #f ;; sort-by + #f ;; sort-order + #f ;; 'shortlist ;; qrytype + 0 ;; last update + #f))) + + (map (lambda (test) + (let* ((test-name (vector-ref test 2)) + (test-html-path (conc (vector-ref test 10) "/" (vector-ref test 13))) + (test-item (conc test-name ":" (vector-ref test 11))) + (test-status (vector-ref test 4))) + + (if (not (hash-table-ref/default resh test-name #f)) + (hash-table-set! resh test-name (make-hash-table))) + (if (not (hash-table-ref/default (hash-table-ref/default resh test-name #f) test-item #f)) + (hash-table-set! (hash-table-ref/default resh test-name #f) test-item (make-hash-table))) + (hash-table-set! (hash-table-ref/default (hash-table-ref/default resh test-name #f) test-item #f) run-id (list test-status test-html-path)))) + test-data))) + runs) + resh)) + + +;; tests:genrate dashboard body +;; + +(define (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links flag run-patt target-patt) + (let* ((start (* page pg-size)) + ;(runsdat (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys))) + (runsdat (rmt:get-runs-by-patt keys run-patt target-patt start pg-size #f 0 sort-order: "desc")) + ; db:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-update + (header (vector-ref runsdat 0)) + (runs (vector-ref runsdat 1)) + (ctr 0) + (test-runs-hash (tests:get-rest-data runs header numkeys)) + (test-list (hash-table-keys test-runs-hash))) + + (s:html tests:css-jscript-block (tests:css-jscript-block-cond flag) + (s:title "Summary for " area-name) + (s:body 'onload "addEvents();" + (get-prev-links page linktree) + (get-next-links page linktree total-runs) + + (s:h1 "Summary for " area-name) + (s:h3 "Filter" ) + (s:input 'type "text" 'name "testname" 'id "testname" 'length "30" 'onkeyup "filtersome()") + ;; top list + + (s:table 'id "LinkedList1" 'border "1" 'cellspacing 0 + (map (lambda (key) + (let* ((res (s:tr 'class "something" + (s:th key ) + (map (lambda (run) + (s:th (vector-ref run ctr))) + runs)))) + (set! ctr (+ ctr 1)) + res)) + keys) + (s:tr + (s:th "Run Name") + (map (lambda (run) + (s:th (db:get-value-by-header run header "runname"))) + runs)) + + (map (lambda (test-name) + (let* ((item-hash (hash-table-ref/default test-runs-hash test-name #f)) + (item-keys (sort (hash-table-keys item-hash) string<=?))) + (map (lambda (item-name) + (let* ((res (s:tr 'class item-name + (s:td item-name 'class "test" ) + (map (lambda (run) + (let* ((run-test (hash-table-ref/default item-hash item-name #f)) + (run-id (db:get-value-by-header run header "id")) + (result (hash-table-ref/default run-test run-id "n/a")) + ;(relative-path (get-relative-path)) + (status (if (string? result) + result + (car result))) + (link (if (string? result) + result + (if (equal? flag #t) + (s:a (car result) 'href (conc "./test_log?runid=" run-id "&testname=" item-name )) + (s:a (car result) 'href (string-substitute (conc linktree "/") "" (cadr result) "-")))))) + (s:td link 'class status))) + runs)))) + res)) + item-keys))) + test-list)))))) + +;; (tests:create-html-tree "test-index.html") +;; +(define (tests:create-html-tree outf) + (let* ((lockfile (conc outf ".lock")) + (runs-to-process '()) + (linktree (common:get-linktree)) + (area-name (common:get-testsuite-name)) + (keys (rmt:get-keys)) + (numkeys (length keys)) + (run-patt (or (args:get-arg "-run-patt") + (args:get-arg "-runname") + "%")) + (target (or (args:get-arg "-target-patt") + (args:get-arg "-target") + "%")) + (targlist (string-split target "/")) + (numtarg (length targlist)) + (targtweaked (if (> numkeys numtarg) + (append targlist (make-list (- numkeys numtarg) "%")) + targlist)) + (target-patt (string-join targtweaked "/")) + ;(total-runs (rmt:get-num-runs "%")) ;;this needs to be changed to filter by target + (total-runs (rmt:get-runs-cnt-by-patt run-patt target-patt keys )) + (pg-size 10)) + (if (common:simple-file-lock lockfile) + (begin + ;(print total-runs) + (let loop ((page 0)) + (let* ((oup (open-output-file (or outf (conc linktree "/page" page ".html")))) + (get-prev-links (lambda (page linktree ) + (let* ((link (if (not (eq? page 0)) + (s:a "<<prev" 'href (conc "page" (- page 1) ".html")) + (s:a "" 'href (conc "page" page ".html"))))) + link))) + (get-next-links (lambda (page linktree total-runs) + (let* ((link (if (> total-runs (+ 10 (* page pg-size))) + (s:a "next>>" 'href (conc "page" (+ page 1) ".html")) + (s:a "" 'href (conc "page" page ".html"))))) + link))) ) + (print "total runs: " total-runs) + (s:output-new + oup + (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function + (close-output-port oup) + ; (set! page (+ 1 page)) + (if (> total-runs (* (+ 1 page) pg-size)) + (loop (+ 1 page))))) + (common:simple-file-release-lock lockfile)) + (begin + (debug:print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f)))) + + +(define (tests:readlines filename) + (call-with-input-file filename + (lambda (p) + (let loop ((line (read-line p)) + (result '())) + (if (eof-object? line) + (reverse result) + (loop (read-line p) (cons line result))))))) + +(define (tests:get-test-log run-id test-name item-name) + (let* ((test-data (rmt:get-tests-for-run + (string->number run-id) + test-name ;; testnamepatt + '() ;; states + '() ;; statuses + #f ;; offset + #f ;; num-to-get + #f ;; hide/not-hide + #f ;; sort-by + #f ;; sort-order + #f ;; 'shortlist ;; qrytype + 0 ;; last update + #f)) + (path "") + (found 0)) + (debug:print-info 0 *default-log-port* "found: " found ) + + (let loop ((hed (car test-data)) + (tal (cdr test-data))) + (debug:print-info 0 *default-log-port* "item: " (vector-ref hed 11) (vector-ref hed 10) "/" (vector-ref hed 13)) + + (if (equal? (vector-ref hed 11) item-name) + (begin + (set! found 1) + (set! path (conc (vector-ref hed 10) "/" (vector-ref hed 13))))) + (if (and (not (null? tal)) (equal? found 0)) + (loop (car tal)(cdr tal)))) + (if (equal? path "") + "

Data not found

" + (string-join (tests:readlines path) "\n")))) + + +(define (tests:dynamic-dboard page) +;(define (tests:create-html-tree o) + (let* ( +;(page "1") + (linktree (common:get-linktree)) + (area-name (common:get-testsuite-name)) + (keys (rmt:get-keys)) + (numkeys (length keys)) + (targtweaked (make-list numkeys "%")) + (target-patt (string-join targtweaked "/")) + (total-runs (rmt:get-num-runs "%")) + (pg-size 10) + (pg (if (equal? page #f) + 0 + (- (string->number page) 1))) + (get-prev-links (lambda (pg linktree) + (debug:print-info 0 *default-log-port* "val: " (- 1 pg)) + (let* ((link (if (not (eq? pg 0)) + (s:a "<<prev " 'href (conc "dashboard?page=" pg )) + (s:a "" 'href (conc "dashboard?page=" pg))))) + link))) + (get-next-links (lambda (pg linktree total-runs) + (debug:print-info 0 *default-log-port* "val: " pg) + (debug:print-info 0 *default-log-port* "val: " total-runs " size" pg-size) + + (let* ((link (if (> total-runs (+ 10 (* pg pg-size))) + (s:a "next>> " 'href (conc "dashboard?page=" (+ pg 2) )) + (s:a "" 'href (conc "dashboard?page=" pg ))))) + link))) + (html-body (tests:dashboard-body pg pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #t "%" target-patt))) ;; update tis function + html-body)) + +(define (tests:create-html-summary outf) + (let* ((lockfile (conc outf ".lock")) + (linktree (common:get-linktree)) + (keys (rmt:get-keys)) + (area-name (common:get-testsuite-name)) + (run-patt (or (args:get-arg "-run-patt") + (args:get-arg "-runname") + "%")) + (target (or (args:get-arg "-target-patt") + (args:get-arg "-target") + "%")) + (targlist (string-split target "/")) + (numkeys (length keys)) + (numtarg (length targlist)) + (targtweaked (if (> numkeys numtarg) + (append targlist (make-list (- numkeys numtarg) "%")) + targlist)) + (target-patt (string-join targtweaked "/"))) + (if (common:simple-file-lock lockfile) + (begin + (let* (;(runsdat1 (rmt:get-runs run-patt #f #f (map (lambda (x)(list x "%")) keys))) + (runsdat (rmt:get-runs-by-patt keys run-patt target-patt #f #f #f 0)) + (runs (vector-ref runsdat 1)) + (header (vector-ref runsdat 0)) + (oup (open-output-file (or outf (conc linktree "/targets.html")))) + (target-hash (test:create-target-hash runs header (length keys)))) + (test:create-target-html target-hash oup area-name linktree) + (test:create-run-html runs area-name linktree (length keys) header)) + (common:simple-file-release-lock lockfile)) + #f))) + +(define (test:get-test-hash test-data) + (let ((resh (make-hash-table))) + (map (lambda (test) + (let* ((test-name (vector-ref test 2)) + (test-html-path (if (file-exists? (conc (vector-ref test 10) "/test-summary.html")) + (conc (vector-ref test 10) "/test-summary.html" ) + (conc (vector-ref test 10) "/" (vector-ref test 13)))) + (test-item (vector-ref test 11)) + (test-status (vector-ref test 4))) + (if (not (hash-table-ref/default resh test-item #f)) + (hash-table-set! resh test-item (make-hash-table))) + (hash-table-set! (hash-table-ref/default resh test-item #f) test-name (list test-status test-html-path)))) + test-data) +resh)) + +(define (test:get-data->b-keys ordered-data a-keys) + (delete-duplicates + (sort (apply + append + (map (lambda (sub-key) + (let ((subdat (hash-table-ref ordered-data sub-key))) + (hash-table-keys subdat))) + a-keys)) + string>=?))) + + +(define (test:create-run-html runs area-name linktree numkeys header) + (map (lambda (run) + (let* ((target (string-join (take (vector->list run) numkeys) "/")) + (run-name (db:get-value-by-header run header "runname")) + (run-time (seconds->work-week/day-time (db:get-value-by-header run header "event_time"))) + (oup (if (file-exists? (conc linktree "/" target "/" run-name)) + (open-output-file (conc linktree "/" target "/" run-name "/run.html")) + #f)) + (run-id (db:get-value-by-header run header "id")) + (test-data (rmt:get-tests-for-run + run-id + "%" ;; testnamepatt + '() ;; states + '() ;; statuses + #f ;; offset + #f ;; num-to-get + #f ;; hide/not-hide + #f ;; sort-by + #f ;; sort-order + #f ;; 'shortlist ;; qrytype + 0 ;; last update + #f)) + (item-test-hash (test:get-test-hash test-data)) + (items (hash-table-keys item-test-hash)) + (test-names (test:get-data->b-keys item-test-hash items))) + (if oup + (begin + (s:output-new + oup + (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f) + (s:title "Runs View " run-name) + (s:body + (s:h1 "Runs View " ) + (s:h3 "Target" target) + (s:p + (s:b "Run name" ) run-name) + (s:p + (s:b "Run Date" ) run-time) + (s:table 'border 1 'cellspacing 0 + (s:tr + (s:th "Items") + (map (lambda (test) + (s:th test)) + test-names)) + (map (lambda (item) + (let* ((test-hash (hash-table-ref/default item-test-hash item #f))) + (if test-hash + (begin + (s:tr + (s:td 'class "test" item) + (map (lambda (test) + (let* ((test-details (hash-table-ref/default test-hash test #f)) + (status (if test-details + (car test-details))) + (link (if test-details + (string-substitute (conc linktree "/" target "/" run-name "/") "" (cadr test-details) "-")))) + (if test-details + (s:td 'class status + (s:a 'class "link" 'href link status )) + (s:td "")))) + test-names)))))) + (sort items string<=?)))))) + (close-output-port oup)) + (debug:print-info 0 "Skip: Dirctory structure " linktree "/" target "/" run-name " does not exist. Megatest will not create run.html")))) +runs)) + +(define (test:create-target-hash runs header numkeys) + (let ((resh (make-hash-table))) + (for-each + (lambda (run) + (let* ((run-name (db:get-value-by-header run header "runname")) + (target (string-join (take (vector->list run) numkeys) "/")) + (run-list (hash-table-ref/default resh target #f))) + + (if (not run-list) + (hash-table-set! resh target (list run-name)) + (hash-table-set! resh target (cons run-name run-list))))) + runs) + resh)) + +(define (test:get-max-run-cnt target-hash targets) + (let* ((cnt 0 )) + (map (lambda (target) + (let* ((runs (hash-table-ref/default target-hash target #f)) + (run-length (if runs + (length runs) + 0))) + + (if (< cnt run-length) + (set! cnt run-length)))) + targets) +cnt)) + +(define (test:pad-runs target-hash targets max-row-length) + (map (lambda (target) + (let loop ((run-list (hash-table-ref/default target-hash target #f))) + (if (< (length run-list) max-row-length) + (begin + (hash-table-set! target-hash target (cons "" run-list)) + (loop (hash-table-ref/default target-hash target #f) ))))) + targets) + target-hash) + +(define (test:create-target-html target-hash oup area-name linktree) + (let* ((targets (hash-table-keys target-hash)) + (max-row-length (test:get-max-run-cnt target-hash targets)) + (pad-runs-hash (test:pad-runs target-hash targets max-row-length))) + (s:output-new + oup + (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f) + + (s:title "Target View " area-name) + (s:body + (s:h1 "Target View " area-name) + (s:table 'id "LinkedList1" 'border "1" 'cellspacing 0 + (s:tr 'class "something" + (s:th "Target") + (s:th 'colspan max-row-length "Runs")) + (let* ((tbl (map (lambda (target) + (s:tr + (s:td 'class "test" target) + (let* ((runs (hash-table-ref/default target-hash target #f)) + (rest-row (map (lambda (run) + (if (equal? run "") + (s:td run) + (if (file-exists?(conc linktree "/" target "/" run )) + (begin + (s:td + (s:a 'href (conc target "/" run "/run.html") run)))))) + (reverse runs)))) + rest-row))) + targets))) + tbl))))) + (close-output-port oup))) + + +(define (tests:create-html-tree-old outf) + (let* ((lockfile (conc outf ".lock")) + (runs-to-process '())) + (if (common:simple-file-lock lockfile) + (let* ((linktree (common:get-linktree)) + (oup (open-output-file (or outf (conc linktree "/runs-index.html")))) + (area-name (common:get-testsuite-name)) + (keys (rmt:get-keys)) + (numkeys (length keys)) + (runsdat (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys))) + (header (vector-ref runsdat 0)) + (runs (vector-ref runsdat 1)) + (runtreedat (map (lambda (x) + (tests:run-record->test-path x numkeys)) + runs)) + (runs-htree (common:list->htree runtreedat))) + (set! runs-to-process runs) + (s:output-new + oup + (s:html tests:css-jscript-block + (s:title "Summary for " area-name) + (s:body 'onload "addEvents();" + (s:h1 "Summary for " area-name) + ;; top list + (s:ul 'id "LinkedList1" 'class "LinkedList" + (s:li + "Runs" + (common:htree->html runs-htree + '() + (lambda (x p) + (let* ((targ-path (string-intersperse p "/")) + (full-path (conc linktree "/" targ-path)) + (run-name (car (reverse p)))) + (if (and (common:file-exists? full-path) + (directory? full-path) + (file-write-access? full-path)) + (s:a run-name 'href (conc targ-path "/run-summary.html")) + (begin + (debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html") + (conc run-name " (Not able to create summary at " targ-path ")"))))))))))) + (close-output-port oup) + (common:simple-file-release-lock lockfile) + + (for-each + (lambda (run) + (let* ((test-subpath (tests:run-record->test-path run numkeys)) + (run-id (db:get-value-by-header run header "id")) + (run-dir (tests:run-record->test-path run numkeys)) + (test-dats (rmt:get-tests-for-run + run-id + "%/" ;; testnamepatt + '() ;; states + '() ;; statuses + #f ;; offset + #f ;; num-to-get + #f ;; hide/not-hide + #f ;; sort-by + #f ;; sort-order + #f ;; 'shortlist ;; qrytype + 0 ;; last update + #f)) + (tests-tree-dat (map (lambda (test-dat) + ;; (tests:run-record->test-path x numkeys)) + (let* ((test-name (db:test-get-testname test-dat)) + (item-path (db:test-get-item-path test-dat)) + (full-name (db:test-make-full-name test-name item-path)) + (path-parts (string-split full-name))) + path-parts)) + test-dats)) + (tests-htree (common:list->htree tests-tree-dat)) + (html-dir (conc linktree "/" (string-intersperse run-dir "/"))) + (html-path (conc html-dir "/run-summary.html")) + (oup (if (and (common:file-exists? html-dir) + (directory? html-dir) + (file-write-access? html-dir)) + (open-output-file html-path) + #f))) + ;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat) + (if oup + (begin + (s:output-new + oup + (s:html tests:css-jscript-block + (s:title "Summary for " area-name) + (s:body 'onload "addEvents();" + (s:h1 "Summary for " (string-intersperse run-dir "/")) + ;; top list + (s:ul 'id "LinkedList1" 'class "LinkedList" + (s:li + "Tests" + (common:htree->html tests-htree + '() + (lambda (x p) + (let* ((targ-path (string-intersperse p "/")) + (test-name (car p)) + (item-path ;; (if (> (length p) 2) ;; test-name + run-name + (string-intersperse p "/")) + (full-targ (conc html-dir "/" targ-path)) + (std-file (conc full-targ "/test-summary.html")) + (alt-file (conc full-targ "/megatest-rollup-" test-name ".html")) + (html-file (if (common:file-exists? alt-file) + alt-file + std-file)) + (run-name (car (reverse p)))) + (if (and (not (common:file-exists? full-targ)) + (directory? full-targ) + (file-write-access? full-targ)) + (tests:summarize-test + run-id + (rmt:get-test-id run-id test-name item-path))) + (if (common:file-exists? full-targ) + (s:a run-name 'href html-file) + (begin + (debug:print 0 *default-log-port* "ERROR: can't access " full-targ) + (conc "No summary for " run-name))))) + )))))) + (close-output-port oup))))) + runs) + #t) + #f))) + + + + + + + +;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!! +;; +;; get a pretty table to summarize steps +;; +;; (define (dcommon:process-steps-table steps);; db test-id #!key (work-area #f)) +(define (tests:process-steps-table steps);; db test-id #!key (work-area #f)) +;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) + ;; organise the steps for better readability + (let ((res (make-hash-table))) + (for-each + (lambda (step) + (debug:print 6 *default-log-port* "step=" step) + (let ((record (hash-table-ref/default + res + (tdb:step-get-stepname step) + ;; 0 1 2 3 4 5 6 7 + ;; stepname start end status Duration Logfile Comment first-id + (vector (tdb:step-get-stepname step) "" "" "" "" "" "" #f)))) + (debug:print 6 *default-log-port* "record(before) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)) + (if (not (vector-ref record 7))(vector-set! record 7 (tdb:step-get-id step))) ;; do not clobber the id if previously set + (case (string->symbol (tdb:step-get-state step)) + ((start)(vector-set! record 1 (tdb:step-get-event_time step)) + (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (tdb:step-get-status step))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + ((end) + (vector-set! record 2 (any->number (tdb:step-get-event_time step))) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) + (endt (any->number (vector-ref record 2)))) + (debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1) + ", startt=" startt ", endt=" endt + ", get-status: " (tdb:step-get-status step)) + (if (and (number? startt)(number? endt)) + (seconds->hr-min-sec (- endt startt)) "-1"))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step))) + (if (> (string-length (tdb:step-get-comment step)) + 0) + (vector-set! record 6 (tdb:step-get-comment step)))) + (else + (vector-set! record 2 (tdb:step-get-state step)) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (tdb:step-get-event_time step)) + (vector-set! record 6 (tdb:step-get-comment step)))) + (hash-table-set! res (tdb:step-get-stepname step) record) + (debug:print 6 *default-log-port* "record(after) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)))) + ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) + (sort steps (lambda (a b) + (cond + ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) + ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) + (< (tdb:step-get-id a) (tdb:step-get-id b))) + (else #f))))) + res)) + +;; +;; +(define (tests:get-compressed-steps run-id test-id) + (let* ((steps-data (rmt:get-steps-for-test run-id test-id)) ;; 0 1 2 3 4 5 6 7 + (comprsteps (tests:process-steps-table steps-data))) ;; # + (map (lambda (x) + ;; take advantage of the \n on time->string + (vector ;; we are constructing basically the original vector but collapsing start end records + (vector-ref x 0) ;; id 0 + (let ((s (vector-ref x 1))) + (if (number? s)(seconds->time-string s) s)) ;; starttime 1 + (let ((s (vector-ref x 2))) + (if (number? s)(seconds->time-string s) s)) ;; endtime 2 + (vector-ref x 3) ;; status 3 + (vector-ref x 4) ;; duration 4 + (vector-ref x 5) ;; logfile 5 + (vector-ref x 6) ;; comment 6 + (vector-ref x 7))) ;; id 7 + (sort (hash-table-values comprsteps) + (lambda (a b) + (let ((time-a (vector-ref a 1)) + (time-b (vector-ref b 1)) + (id-a (vector-ref a 7)) + (id-b (vector-ref b 7))) + (if (and (number? time-a)(number? time-b)) + (if (< time-a time-b) + #t + (if (eq? time-a time-b) + (< id-a id-b) + ;; (stringwork-week/day-time + (db:test-get-event_time test-dat))) + (s:td "Duration") (s:td (seconds->hr-min-sec (db:test-get-run_duration test-dat))))) + (s:h3 "Log files") + (s:table + 'cellspacing "0" 'border "1" + (s:tr (s:td "Final log")(s:td (s:a 'href logf logf)))) + (s:table + 'cellspacing "0" 'border "1" + (s:tr (s:td "Step Name")(s:td "Start")(s:td "End")(s:td "Status")(s:td "Duration")(s:td "Log File")) + (map (lambda (step-dat) + (s:tr (s:td (tdb:steps-table-get-stepname step-dat)) + (s:td (tdb:steps-table-get-start step-dat)) + (s:td (tdb:steps-table-get-end step-dat)) + (s:td (tdb:steps-table-get-status step-dat)) + (s:td (tdb:steps-table-get-runtime step-dat)) + (s:td (let ((step-log (tdb:steps-table-get-log-file step-dat))) + (s:a 'href step-log step-log))))) + steps-dat)) + ))) + (close-output-port oup))))) + + +;; MUST BE CALLED local! +;; +(define (tests:test-get-paths-matching keynames target fnamepatt #!key (res '())) + ;; BUG: Move the values derived from args to parameters and push to megatest.scm + (let* ((testpatt (or (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) + (statepatt (or (args:get-arg "-state") (args:get-arg ":state") "%")) + (statuspatt (or (args:get-arg "-status") (args:get-arg ":status") "%")) + (runname (or (args:get-arg "-runname") (args:get-arg ":runname") "%")) + (paths-from-db (rmt:test-get-paths-matching-keynames-target-new keynames target res + testpatt + statepatt + statuspatt + runname))) + (if fnamepatt + (apply append + (map (lambda (p) + (if (directory-exists? p) + (let ((glob-query (conc p "/" fnamepatt))) + (handle-exceptions + exn + (begin + (print "built-in glob on " glob-query ", failed, try using the shell. exn=" exn) + (with-input-from-pipe + (conc "echo " glob-query) + read-lines)) ;; we aren't going to try too hard. If glob breaks it is likely because someone tried to do */*/*.log or similar + (glob glob-query))) + '())) + paths-from-db)) + paths-from-db))) + + +;;====================================================================== +;; Gather data from test/task specifications +;;====================================================================== + +;; (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '())) +;; (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*"))))) +;; (set! tests (filter (lambda (test)(common:file-exists? (conc test "/testconfig"))) tests)) +;; (delete-duplicates +;; (filter (lambda (testname) +;; (tests:match test-patts testname #f)) +;; (map (lambda (testp) +;; (last (string-split testp "/"))) +;; tests))))) +;; sort tests by priority and waiton +;; Move test specific stuff to a test unit FIXME one of these days +(define (tests:sort-by-priority-and-waiton test-records) + (if (eq? (hash-table-size test-records) 0) + '() + (let* ((mungepriority (lambda (priority) + (if priority + (let ((tmp (any->number priority))) + (if tmp tmp (begin (debug:print-error 0 *default-log-port* "bad priority value " priority ", using 0") 0))) + 0))) + (all-tests (hash-table-keys test-records)) + (all-waited-on (let loop ((hed (car all-tests)) + (tal (cdr all-tests)) + (res '())) + (let* ((trec (hash-table-ref test-records hed)) + (waitons (or (tests:testqueue-get-waitons trec) '()))) + (if (null? tal) + (append res waitons) + (loop (car tal)(cdr tal)(append res waitons)))))) + (sort-fn1 + (lambda (a b) + (let* ((a-record (hash-table-ref test-records a)) + (b-record (hash-table-ref test-records b)) + (a-waitons (or (tests:testqueue-get-waitons a-record) '())) + (b-waitons (or (tests:testqueue-get-waitons b-record) '())) + (a-config (tests:testqueue-get-testconfig a-record)) + (b-config (tests:testqueue-get-testconfig b-record)) + (a-raw-pri (configf:lookup a-config "requirements" "priority")) + (b-raw-pri (configf:lookup b-config "requirements" "priority")) + (a-priority (mungepriority a-raw-pri)) + (b-priority (mungepriority b-raw-pri))) + (tests:testqueue-set-priority! a-record a-priority) + (tests:testqueue-set-priority! b-record b-priority) + ;; (debug:print 0 *default-log-port* "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons) + (cond + ;; is + ((member a b-waitons) ;; is b waiting on a? + ;; (debug:print 0 *default-log-port* "case1") + #t) + ((member b a-waitons) ;; is a waiting on b? + ;; (debug:print 0 *default-log-port* "case2") + #f) + ((and (not (null? a-waitons)) ;; both have waitons - do not disturb + (not (null? b-waitons))) + ;; (debug:print 0 *default-log-port* "case2.1") + #t) + ((and (null? a-waitons) ;; no waitons for a but b has waitons + (not (null? b-waitons))) + ;; (debug:print 0 *default-log-port* "case3") + #f) + ((and (not (null? a-waitons)) ;; a has waitons but b does not + (null? b-waitons)) + ;; (debug:print 0 *default-log-port* "case4") + #t) + ((not (eq? a-priority b-priority)) ;; use + (> a-priority b-priority)) + (else + ;; (debug:print 0 *default-log-port* "case5") + (string>? a b)))))) + + (sort-fn2 + (lambda (a b) + (> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a))) + (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records b))))))) + ;; (let ((dot-res (tests:run-dot (tests:tests->dot test-records) "plain"))) + ;; (debug:print "dot-res=" dot-res)) + ;; (let ((data (map cdr (filter + ;; (lambda (x)(equal? "node" (car x))) + ;; (map string-split (tests:easy-dot test-records "plain")))))) + ;; (map car (sort data (lambda (a b) + ;; (> (string->number (caddr a))(string->number (caddr b))))))) + ;; )) + (sort all-tests sort-fn1)))) ;; avoid dealing with deleted tests, look at the hash table + +(define (tests:easy-dot test-records outtype) + (let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX")))) + (let ((all-testnames (hash-table-keys test-records)) + (temp-port (open-output-file* fd))) + ;; (format temp-port "This file is ~A.~%" temp-path) + (format temp-port "digraph tests {\n") + (format temp-port " size=4,8\n") + ;; (format temp-port " splines=none\n") + (for-each + (lambda (testname) + (let* ((testrec (hash-table-ref test-records testname)) + (waitons (or (tests:testqueue-get-waitons testrec) '()))) + (for-each + (lambda (waiton) + (format temp-port (conc " " waiton " -> " testname " [splines=ortho]\n"))) + waitons))) + all-testnames) + (format temp-port "}\n") + (close-output-port temp-port) + (with-input-from-pipe + (conc "env -i PATH=$PATH dot -T" outtype " < " temp-path) + (lambda () + (let ((res (read-lines))) + ;; (delete-file temp-path) + res)))))) + +(define (tests:write-dot-file test-records fname sizex sizey) + (if (file-write-access? (pathname-directory fname)) + (with-output-to-file fname + (lambda () + (map print (tests:tests->dot test-records sizex sizey)))))) + +(define (tests:tests->dot test-records sizex sizey) + (let ((all-testnames (hash-table-keys test-records))) + (if (null? all-testnames) + '() + (let loop ((hed (car all-testnames)) + (tal (cdr all-testnames)) + (res (list "digraph tests {" + (conc " size=\"" (or sizex 11) "," (or sizey 11) "\";") + " ratio=0.95;" + ))) + (let* ((testrec (hash-table-ref test-records hed)) + (waitons (or (tests:testqueue-get-waitons testrec) '())) + (newres (append res + (if (null? waitons) + (list (conc " \"" hed "\" [shape=box];")) + (map (lambda (waiton) + (conc " \"" waiton "\" -> \"" hed "\" [shape=box];")) + waitons) + )))) + (if (null? tal) + (append newres (list "}")) + (loop (car tal)(cdr tal) newres) + )))))) + +;; (tests:run-dot (list "digraph tests {" "a -> b" "}") "plain") + +(define (tests:run-dot indat outtype) ;; outtype is plain, fig, dot, etc. http://www.graphviz.org/content/output-formats + (let-values (((inp oup pid)(process "env -i PATH=\"$PATH\" dot" (list "-T" outtype)))) + (with-output-to-port oup + (lambda () + (map print indat))) + (close-output-port oup) + (let ((res (with-input-from-port inp + (lambda () + (read-lines))))) + (close-input-port inp) + res))) + +;; read data from tmp file or create if not exists +;; if exists regen in background +;; +(define (tests:lazy-dot testrecords outtype sizex sizey) + (let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot")) + (fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat"))) + (tests:write-dot-file testrecords dfile sizex sizey) + (if (common:file-exists? fname) + (let ((res (with-input-from-file fname + (lambda () + (read-lines))))) + (system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname "&")) + res) + (begin + (system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname)) + (with-input-from-file fname + (lambda () + (read-lines))))))) + + +;; for each test: +;; +(define (tests:filter-non-runnable run-id testkeynames testrecordshash) + (let ((runnables '())) + (for-each + (lambda (testkeyname) + (let* ((test-record (hash-table-ref testrecordshash testkeyname)) + (test-name (tests:testqueue-get-testname test-record)) + (itemdat (tests:testqueue-get-itemdat test-record)) + (item-path (tests:testqueue-get-item_path test-record)) + (waitons (tests:testqueue-get-waitons test-record)) + (keep-test #t) + (test-id (rmt:get-test-id run-id test-name item-path)) + (tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) + (if tdat + (begin + ;; Look at the test state and status + (if (or (and (member (db:test-get-status tdat) + '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) + (equal? (db:test-get-state tdat) "COMPLETED")) + (member (db:test-get-state tdat) + '("INCOMPLETE" "KILLED"))) + (set! keep-test #f)) + + ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test + ;; from the runnable list + (if keep-test + (for-each (lambda (waiton) + ;; for now we are waiting only on the parent test + (let* ((parent-test-id (rmt:get-test-id run-id waiton "")) + (wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) + (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED") + (member (db:test-get-status wtdat) '("FAIL" "ABORT"))) + (member (db:test-get-status wtdat) '("KILLED")) + (member (db:test-get-state wtdat) '("INCOMPETE"))) + ;; (if (or (member (db:test-get-status wtdat) + ;; '("FAIL" "KILLED")) + ;; (member (db:test-get-state wtdat) + ;; '("INCOMPETE"))) + (set! keep-test #f)))) ;; no point in running this one again + waitons)))) + (if keep-test (set! runnables (cons testkeyname runnables))))) + testkeynames) + runnables)) + +;;====================================================================== +;; test steps +;;====================================================================== + +;; teststep-set-status! used to be here + +;; NOT NEEDED +#;(define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat) + (let* ((testdat (rmt:get-test-state-status-by-id run-id test-id))) + (and testdat + (equal? (car testdat) "KILLREQ")))) + +(define (test:tdb-get-rundat-count tdb) + (if tdb + (let ((res 0)) + (sqlite3:for-each-row + (lambda (count) + (set! res count)) + 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))) + +;; 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 test-id run-id minutes work-area) +;; (let ((remtries 10)) + (let* ((cpuload (commonmod: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) + ))) + +;;====================================================================== +;; A R C H I V I N G +;;====================================================================== + +(define (test:archive db test-id) + #f) + +(define (test:archive-tests db keynames target) + #f) )