Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -16,11 +16,11 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) -(include "../margs/margs.scm") +(include "margs.scm") (include "keys.scm") (include "items.scm") (include "db.scm") (include "configf.scm") (include "process.scm") Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -150,11 +150,14 @@ db (conc "SELECT " keystr " FROM runs WHERE id=?;") run-id) (vector header res))) -;; Tests +;;====================================================================== +;; T E S T S +;;====================================================================== + (define (make-db:test)(make-vector 6)) (define-inline (db:test-get-id vec) (vector-ref vec 0)) (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) (define-inline (db:test-get-testname vec) (vector-ref vec 2)) (define-inline (db:test-get-state vec) (vector-ref vec 3)) @@ -177,10 +180,22 @@ (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) db "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE run_id=? ORDER BY id DESC;" run-id) res)) + +(define (db:delete-test-step-records db run-id test-name) + (sqlite3:execute db "DELETE FROM test_steps WHERE test_id in (SELECT id FROM tests WHERE run_id=? AND testname=?);" run-id test-name)) + +(define (db:get-count-tests-running db) + (let ((res 0)) + (sqlite3:for-each-row + (lambda (count) + (set! res count)) + db + "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART';") + res)) ;; NB// Sync this with runs:get-test-info (define (db:get-test-info db run-id testname item-path) (let ((res '())) (sqlite3:for-each-row Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -16,11 +16,11 @@ (define (setup-for-run) (set! *configinfo* (find-and-read-config (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config"))) (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) (if *toppath* - (setenv "MT_RUN_AREA_HOME" *toppath*) + (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated (print "ERROR: failed to find the top path to your run setup.")) *toppath*) (define (setup-env-defaults db fname run-id . already-seen) (let* ((keys (get-keys db)) @@ -113,13 +113,15 @@ (local-megatest (car (argv))) ;; (item-path (item-list->path itemdat)) test-path is the full path including the item-path (work-area #f) (diskpath #f) (cmdparms #f) - (fullcmd #f));; (define a (with-output-to-string (lambda ()(write x)))) + (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) + (mt-bindir-path #f)) (if hosts (set! hosts (string-split hosts))) - (if (not remote-megatest)(set! remote-megatest "megatest")) + (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 (set! diskpath (get-best-disk *configdat*)) (if diskpath (set! work-area (create-work-area db run-id test-path diskpath test-name itemdat)) @@ -131,11 +133,12 @@ (write (list (list 'testpath test-path) (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) (list 'run-id run-id ) - (list 'itemdat itemdat))))))) ;; (string-intersperse keyvallst " ")))) + (list 'itemdat itemdat) + (list 'mt-bindir-path mt-bindir-path))))))) ;; (string-intersperse keyvallst " ")))) (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 "-execute" cmdparms)))) (launcher @@ -143,15 +146,19 @@ (else (set! fullcmd (list remote-megatest "-execute" cmdparms)))) (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) (print "Launching megatest for test " test-name " in " work-area" ...") (test-set-status! db run-id test-name "LAUNCHED" "n/a" itemdat) ;; (if launch-results launch-results "FAILED")) - ;; set "pre-launch-env-vars - (let* ((prevvals (alist->env-vars + ;; set + ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done + (let* ((commonprevvals (alist->env-vars + (hash-table-ref/default *configdat* "env-override" '()))) + (testprevvals (alist->env-vars (hash-table-ref/default test-conf "pre-launch-env-overrides" '()))) (launch-results (apply cmd-run-proc-each-line (car fullcmd) print (cdr fullcmd)))) ;; launcher fullcmd)));; (apply cmd-run-proc-each-line launcher print fullcmd))) ;; (cmd-run->list fullcmd)) (print "Launching completed, updating db") - (alist->env-vars prevvals)))) + (alist->env-vars testprevvals) + (alist->env-vars commonprevvals)))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -21,11 +21,11 @@ Process and test running -runall : run all tests that are not state COMPLETED and status PASS -runtests tst1,tst2 ... : run tests Run status updates (these require that you are in a test directory - and you have sourced the \"megatest.csh\" or + and you have sourced the \"megatest.csh\" \"megatest.sh\" file.) -step stepname -test-status : set the state and status of a test (use :state and :status) -setlog logfname : set the path/filename to the final log relative to the test directory. may be used with -test-status @@ -39,12 +39,11 @@ Queries -list-runs patt : list runs matching pattern \"patt\", % is the wildcard -showkeys : show the keys used in this megatest setup -Misc (note: there is a bug in argument processing, put these at the beginning - of the command line or it may fail) +Misc -force : override some checks -xterm : start an xterm instead of launching the test Helpers @@ -272,14 +271,17 @@ (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) + (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (fullrunscript (conc testpath "/" runscript)) (db #f)) (print "Exectuing " test-name " on " (get-host-name)) (change-directory testpath) + (setenv "MT_TEST_RUN_DIR" testpath) + (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)) (if (not (setup-for-run)) (begin (print "Failed to setup, exiting") (exit 1))) ;; now can find our db @@ -441,17 +443,23 @@ (test-set-status! db run-id test-name "start" "n/a" itemdat (args:get-arg "-m")) ;; close the db (sqlite3:finalize! db) ;; run the test step (set! exitstat (process-run cmd params)) + ;; re-open the db + (set! db (open-db)) ;; run logpro if applicable (if logpro - (set! exitstat (process-run "logpro" logpro (conc test-name ".html")))) - (test-set-status! db run-id test-name "end" FINISH MEEEEE!!!!!! + (let ((logfile (conc test-name ".html"))) + (set! exitstat (process-run "logpro" logpro logfile)) + (test-set-log! db run-id test-name itemdat logfile))) + (test-set-status! db run-id test-name "end" exitstat itemdat (args:get-arg "-m")) + (sqlite3:finalize! db) + (exit exitstat) ;; open the db ;; mark the end of the test - )) + ))) (sqlite3:finalize! db) (set! *didsomething* #t)))) (if (args:get-arg "-showkeys") (let ((db #f) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -185,11 +185,20 @@ res)) (define (run-tests db test-names) (for-each (lambda (test-name) - (run-one-test db test-name)) + (let ((num-running (db:get-count-tests-running db)) + (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))) + (print "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) + (if (or (not max-concurrent-jobs) + (and max-concurrent-jobs + (string->number max-concurrent-jobs) + (not (> num-running (string->number max-concurrent-jobs))))) + (run-one-test db test-name) + (print "WARNING: Max running jobs exceeded, current number running: " num-running + ", max_concurrent_jobs: " max-concurrent-jobs)))) test-names)) (define (run-one-test db test-name) (print "Launching test " test-name) (let* ((test-path (conc *toppath* "/tests/" test-name)) @@ -215,58 +224,69 @@ (tal (cdr allitems))) ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/")) (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique - (test-status #f)) - (let loop2 ((ts #f) - (ct 0)) - (if (and (not ts) - (< ct 10)) - (begin - (register-test db run-id test-name item-path) - (loop2 (runs:get-test-info db run-id test-name item-path) - (+ ct 1))) - (if ts - (set! test-status ts) - (begin - (print "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping") - (if (not (null? tal)) - (loop (car tal)(cdr tal))))))) - (change-directory test-path) - ;; this block is here only to inform the user early on - (if (file-exists? runconfigf) - (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*) - (print "WARNING: You do not have a run config file: " runconfigf)) - ;; (print "run-id: " run-id " test-name: " test-name " item-path: " item-path " test-status: " (test:get-status test-status) " test-state: " (test:get-state test-status)) - (case (if (args:get-arg "-force") - 'NOT_STARTED - (if test-status - (string->symbol (test:get-state test-status)) - 'failed-to-insert)) - ((failed-to-insert) - (print "ERROR: Failed to insert the record into the db")) - ((NOT_STARTED COMPLETED) ;; (cadr status is the row id for the run record) - (if (and (equal? (test:get-state test-status) "COMPLETED") - (equal? (test:get-status test-status) "PASS") - (not (args:get-arg "-force"))) - (print "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"PASS\", use -force to override") - (let* ((get-prereqs-cmd (lambda () - (db-get-prereqs-not-met db run-id waiton))) ;; check before running .... - (launch-cmd (lambda () - (launch-test db run-id test-conf keyvallst test-name test-path itemdat))) - (testrundat (list get-prereqs-cmd launch-cmd))) - (if (or (args:get-arg "-force") - (null? ((car testrundat)))) ;; are there any tests that must be run before this one... - ((cadr testrundat)) ;; this is the line that launches the test to the remote host - (hash-table-set! *waiting-queue* new-test-name testrundat))))) - ((LAUNCHED REMOTEHOSTSTART KILLED) - (print "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) - ((RUNNING) (print "NOTE: " test-name " is already running")) - (else (print "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state test-status))))) - (if (not (null? tal)) - (loop (car tal)(cdr tal)))))))) + (test-status #f) + (num-running (db:get-count-tests-running db)) + (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))) + (print "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) + (if (not (or (not max-concurrent-jobs) + (and max-concurrent-jobs + (string->number max-concurrent-jobs) + (not (> num-running (string->number max-concurrent-jobs)))))) + (print "WARNING: Max running jobs exceeded, current number running: " num-running + ", max_concurrent_jobs: " max-concurrent-jobs) + (begin + (let loop2 ((ts #f) + (ct 0)) + (if (and (not ts) + (< ct 10)) + (begin + (register-test db run-id test-name item-path) + (db:delete-test-step-records db run-id test-name) ;; clean out if this is a re-run + (loop2 (runs:get-test-info db run-id test-name item-path) + (+ ct 1))) + (if ts + (set! test-status ts) + (begin + (print "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping") + (if (not (null? tal)) + (loop (car tal)(cdr tal))))))) + (change-directory test-path) + ;; this block is here only to inform the user early on + (if (file-exists? runconfigf) + (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*) + (print "WARNING: You do not have a run config file: " runconfigf)) + ;; (print "run-id: " run-id " test-name: " test-name " item-path: " item-path " test-status: " (test:get-status test-status) " test-state: " (test:get-state test-status)) + (case (if (args:get-arg "-force") + 'NOT_STARTED + (if test-status + (string->symbol (test:get-state test-status)) + 'failed-to-insert)) + ((failed-to-insert) + (print "ERROR: Failed to insert the record into the db")) + ((NOT_STARTED COMPLETED) ;; (cadr status is the row id for the run record) + (if (and (equal? (test:get-state test-status) "COMPLETED") + (equal? (test:get-status test-status) "PASS") + (not (args:get-arg "-force"))) + (print "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"PASS\", use -force to override") + (let* ((get-prereqs-cmd (lambda () + (db-get-prereqs-not-met db run-id waiton))) ;; check before running .... + (launch-cmd (lambda () + (launch-test db run-id test-conf keyvallst test-name test-path itemdat))) + (testrundat (list get-prereqs-cmd launch-cmd))) + (if (or (args:get-arg "-force") + (null? ((car testrundat)))) ;; are there any tests that must be run before this one... + ((cadr testrundat)) ;; this is the line that launches the test to the remote host + (hash-table-set! *waiting-queue* new-test-name testrundat))))) + ((LAUNCHED REMOTEHOSTSTART KILLED) + (print "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) + ((RUNNING) (print "NOTE: " test-name " is already running")) + (else (print "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state test-status)))))) + (if (not (null? tal)) + (loop (car tal)(cdr tal))))))))) (define (run-waiting-tests db) (let ((numtries 0) (last-try-time (current-seconds)) (times (list 1))) ;; minutes to wait before trying again to kick off runs Index: tests/megatest.config ================================================================== --- tests/megatest.config +++ tests/megatest.config @@ -2,11 +2,12 @@ sysname TEXT fsname TEXT datapath TEXT [setup] -executable megatest +executable /home/matt/data/megatest/megatest +max_concurrent_jobs 3 [jobtools] # ## launcher launches jobs, the job is managed on the target host ## by megatest, comment out launcher to run local # workhosts localhost hermes @@ -14,14 +15,16 @@ [validvalues] state start end completed status pass fail n/a +# These are set before all tests, override them +# in the testconfig [pre-launch-env-overrides] section [env-override] SPECIAL_ENV_VARS overide them here - all tests see these ## disks are: ## name host:/path/to/area ## -or- ## name /path/to/area [disks] 1 /tmp