Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -28,11 +28,11 @@
ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \
subrun.scm portlogger.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
-MSRCFILES = dbmod.scm
+MSRCFILES = dbmod.scm adjutant.scm mutils.scm mttop.scm
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
# mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
Index: adjutant.scm
==================================================================
--- adjutant.scm
+++ adjutant.scm
@@ -22,12 +22,23 @@
(module adjutant *
(import scheme chicken data-structures extras files)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
- md5 message-digest
+ md5 message-digest matchable
regex srfi-1)
-(define (adjutant-run)
- (print "Running the adjutant!"))
+(define (adjutant-run host-type rmt:no-sync-take-job)
+ (print "Running the adjutant!")
+ (let loop ((wait-count 0))
+ (if (< wait-count 10) ;; 6 x 10 seconds = one minute
+ (let* ((dat (rmt:no-sync-take-job host-type)))
+ (match dat
+ ((id ht vars exekey cmdline state event-time last-update)
+ (system cmdline)
+ (loop 0))
+ (else
+ (thread-sleep! 10)
+ (loop (+ wait-count 1)))))
+ (print "I'm bored. Exiting."))))
)
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -256,17 +256,20 @@
;; NO SYNC DB
((no-sync-set) (apply db:no-sync-set *no-sync-db* params))
((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params))
((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params))
((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params))
+ ((no-sync-add-job) (apply db:no-sync-add-job *no-sync-db* params))
+ ((no-sync-take-job) (apply db:no-sync-take-job *no-sync-db* params))
+ ((no-sync-job-records-clean) (apply db:no-sync-job-records-clean *no-sync-db* params))
;; ARCHIVES
;; ((archive-get-allocations)
((archive-register-disk) (apply db:archive-register-disk dbstruct params))
((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
-
+
;;======================================================================
;; READ ONLY QUERIES
;;======================================================================
;; KEYS
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -3223,31 +3223,39 @@
;; arm cubie01 cubie02
;; x86_64 zeus xena myth01
;; allhosts #{g hosts arm} #{g hosts x86_64}
;;
;; [host-types]
+;; C/M/A lets megatest know this launcher provides C cores, M bytes memory for architecture A
+;; 2/2G/arm smart -cores 2 -memory 2G -arch arm
;; general #MTLOWESTLOAD #{g hosts allhosts}
;; arm #MTLOWESTLOAD #{g hosts arm}
;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo
+;;
+;; NOTE: host-rules is ONLY used for MTLOWESTLOAD
;;
;; [host-rules]
;; # maxnload => max normalized load
;; # maxnjobs => max jobs per cpu
;; # maxjobrate => max jobs per second
;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1
;;
;; [launchers]
;; envsetup general
-;; xor/%/n 4C16G
+;; xor/%/n 2/2G/arm
;; % nbgeneral
;;
;; [jobtools]
;; # if defined and not "no" flexi-launcher will bypass "launcher" unless no match.
;; flexi-launcher yes
;; launcher nbfake
+;; mode adjutant|normal (default is normal)
+;;
+;;
+;; mode is 'normal (i.e. directly use launcher) or 'adjutant (i.e. use adjutant)
;;
-(define (common:get-launcher configdat testname itempath)
+(define (common:get-launcher configdat testname itempath mode)
(let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher")))
(if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher
(not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no")))
(let* ((launchers (hash-table-ref/default configdat "launchers" '())))
(if (null? launchers)
@@ -3254,32 +3262,36 @@
fallback-launcher
(let loop ((hed (car launchers))
(tal (cdr launchers)))
(let ((patt (car hed))
(host-type (cadr hed)))
- (if (tests:match patt testname itempath)
+ (if (tests:match patt testname itempath) ;; have a launcher match for this test
(begin
(debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type)
- (let ((launcher (configf:lookup configdat "host-types" host-type)))
+ (let ((launcher (configf:lookup configdat "host-types" host-type))) ;; find the actual launcher from the host-types table
+ ;; if we are in adjutant mode then we want to return both host-type and launcher
(if launcher
(let* ((launcher-parts (string-split launcher))
(launcher-exe (car launcher-parts)))
(if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline
(let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat))
(count 100))
(if targ-host
(conc "remrun " targ-host)
(if (> count 0)
+
(begin
(debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type)
(thread-sleep! (- 101 count))
(host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)
(- count 1)))
(begin
(debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type)
(exit)))))
- launcher))
+ (case mode
+ ((adjutant) (list host-type launcher))
+ (else launcher))))
(begin
(debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
(if (null? tal)
fallback-launcher
(loop (car tal)(cdr tal)))))))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -2147,14 +2147,66 @@
(db-exists (common:file-exists? dbname))
(db (sqlite3:open-database dbname)))
(sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
(if (not db-exists)
(begin
- (sqlite3:execute db "PRAGMA synchronous = 0;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")
(sqlite3:execute db "PRAGMA journal_mode=WAL;")))
+ ;; MOVE THIS TABLE CREATION TO THE (begin above in about six months (it is Sep 2020 right now).
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS jobs_queue (id INTEGER PRIMARY KEY, host_type TEXT, cores INTEGER, memory TEXT, vars TEXT, exekey TEXT, cmdline TEXT, state TEXT, event_time INTEGER, last_update INTEGER);")
+ ;; not sure I'll use this next one. I prefer if tests simply append to a file:
+ ;; last-update-seconds cpuload tmpspace rundirspace
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_extra_data (id INTEGER PRIMARY KEY, run_id INTEGER, test_id INTEGER, last_seen_running INTEGER);")
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
db))
+
+(define (db:no-sync-add-job db-in host-type vars-list exekey cmdline)
+ (sqlite3:execute (db:no-sync-db db-in) "INSERT INTO jobs_queue (host_type,vars,exekey,cmdline,state,event_time,last_update) VALUES (?,?,?,?,?,?,?);"
+ host-type
+ (with-output-to-string
+ (lambda ()
+ (write vars-list)))
+ exekey cmdline "waiting" (current-seconds)(current-seconds)))
+
+;; find next job (waiting longest) that matches host-type - future, we'll find jobs that fit if no exact match
+(define (db:no-sync-take-job db-in host-type)
+ (let* ((db (db:no-sync-db db-in))
+ (stmt1 "SELECT id,host_type,vars,exekey,cmdline,state,event_time,last_update FROM jobs_queue WHERE host_type=? AND state != 'taken' ORDER BY event_time ASC;")
+ (stmt1h (sqlite3:prepare db stmt1))
+ (stmt2 "UPDATE jobs_queue SET state='taken',last_update=? WHERE id=?;")
+ (stmt2h (sqlite3:prepare db stmt2))
+ (res (sqlite3:with-transaction
+ db
+ (lambda ()
+ (let* ((matching-jobs (sqlite3:fold-row
+ (lambda (res . row) ;; id host-type vars exekey state event-time last-update)
+ (cons row res))
+ '()
+ stmt1h
+ host-type)))
+ (if (null? matching-jobs)
+ #f
+ (let ((choosen-one (let loop ((tal matching-jobs)
+ (res #f)) ;; put bestest one in here
+ (if (null? tal)
+ res
+ (let ((curr (car tal))
+ (rem (cdr tal)))
+ curr) ;; here we will compare with res, if better candidate the loop with curr else loop with res
+ ))))
+ (if choosen-one ;; we need to mark it as taken
+ (sqlite3:execute stmt2h (current-seconds) (car choosen-one)))
+ choosen-one)))))))
+ (sqlite3:finalize! stmt1h) ;; it'd be nice to cache these and finalize on exit.
+ (sqlite3:finalize! stmt2h)
+ res))
+
+;; clean out old jobs in queue, i.e. taken and event_time > 24 hrs ago
+;;
+(define (db:no-sync-job-records-clean db)
+ (sqlite3:execute (db:no-sync-db db) "DELETE FROM jobs_queue WHERE state='taken' AND event_time < ?;" (- (current-seconds)(* 24 3600))))
+
;; if we are not a server create a db handle. this is not finalized
;; so watch for problems. I'm still not clear if it is needed to manually
;; finalize sqlite3 dbs with the sqlite3 egg.
;;
@@ -2172,12 +2224,13 @@
(sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val))
(define (db:no-sync-del! db var)
(sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var))
-(define (db:no-sync-get/default db var default)
- (let ((res default))
+(define (db:no-sync-get/default db-in var default)
+ (let ((db (db:no-sync-db db-in))
+ (res default))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
(db:no-sync-db db)
"SELECT val FROM no_sync_metadat WHERE var=?;"
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -1419,12 +1419,20 @@
(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))))
-
+(defstruct launch:ajt
+ (vars '())
+ (exekey #f)
+ (host-type #f)
+ (test-sig #f)
+ (cmdline #f))
+;; append vars
+(define (launch:ajt-add-vars dat vars)
+ (launch:ajt-vars-set! dat (append (launch:ajt-vars dat) vars)))
;; 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
@@ -1431,44 +1439,41 @@
;; - 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)
(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))))))
+ (let* (;; locking code removed from here commented out and pasted at end of file
(item-path (item-list->path itemdat))
- (contour #f)) ;; NOT READY FOR THIS (args:get-arg "-contour")))
+ (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour")))
+ ;; launcher-mode will be 'adjutant or 'normal
+ (launcher-mode (string->symbol (or (configf:lookup *configdat* "jobtools" "mode") "normal")))
+ (ajtdat (make-launch:ajt)))
(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 ((var-list (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)))
+ ;; 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)
+ (alist->env-vars var-list)
+ ;; the var-list into the ajtdat adjutant record whether it is needed or not.
+ (launch:ajt-add-vars ajtdat var-list))
+
(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.")
@@ -1486,26 +1491,17 @@
;; (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
+ (launcher (let ((l (common:get-launcher *configdat* test-name item-path launcher-mode)))
+ (if (string? l)
+ (string-split l)
+ l))) ;; some nonhomogenuity here. '(cmd param1 param2 ...) OR '(host-type launcher)
+ ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path
+ (test-sig (conc (common:get-testsuite-name) ":" test-name ":" 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))))
@@ -1515,15 +1511,24 @@
(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"))
'()))))
+ ;; save the test-sig in the ajtdat record
+ (launch:ajt-test-sig-set! ajtdat test-sig)
+ ;; go ahead and figure out if we have a host-type from the
+ ;; launcher call above and save it in the ajtdat record
+ (if (and (eq? launcher-mode 'adjutant)
+ (list? launcher)
+ (> (length launcher) 1))
+ (launch:ajt-host-type-set! ajtdat (car launcher)))
+
;; (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)))
+ ;; (if launcher (set! launcher (string-split launcher))) ;; yuk!
;; 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)
@@ -1577,66 +1582,94 @@
(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))))))))
+ ;; save the cmdparms in the ajtdat
+ (launch:ajt-exekey-set! ajtdat cmdparms)
(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))))
+
+ ;; save the command line for adjutant mode (might never be needed but best to assemble it here)
+ (launch:ajt-cmdline-set! ajtdat (string-intersperse
+ (append (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param)))
+ (cond
(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" '())))
+ (let* ((env-override-vars (hash-table-ref/default *configdat* "env-override" '()))
+ (commonprevvals (alist->env-vars env-override-vars))
+ (misc-vars (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))
+ (miscprevvals (alist->env-vars misc-vars));; consolidate this code with the code in megatest.scm for "-execute"
+ (test-vars (hash-table-ref/default tconfig "pre-launch-env-overrides" '()))
+ (testprevvals (alist->env-vars test-vars))
+
;; 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))))
+ ;; BB: TODO: refactor this to examine return code of launcher, if nonzero, set state to launch failed.
+ (launch-results-prev (if (eq? launcher-mode 'adjutant)
+ '(#t 0) ;; just some fake data to fool downstream but non-applicable code
+ (apply (if launchwait
+ 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)
+
+ (launch:ajt-add-vars ajtdat env-override-vars)
+ (launch:ajt-add-vars ajtdat misc-vars)
+ (launch:ajt-add-vars ajtdat test-vars)
+
+ ;; if in adjutant mode we register the job in the jobs_queue
+ ;; then fire off an adjutant runner
+ ;;
+ (if (eq? launcher-mode 'adjutant)
+ (let* ((adjutant-runner-cmd (append (cdr launcher)
+ (list remote-megatest "-adjutant"
+ (launch:ajt-host-type ajtdat)
+ "-start-dir" *toppath*)))
+ (adj-cmd (conc (string-intersperse (map conc adjutant-runner-cmd) " ")
+ "&")))
+ (rmt:no-sync-add-job
+ (launch:ajt-host-type ajtdat)
+ (launch:ajt-vars ajtdat)
+ (launch:ajt-exekey ajtdat)
+ (launch:ajt-cmdline ajtdat))
+ (print "adj-cmd: " adj-cmd)
+ (system adj-cmd)
+ ))
+
+ (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 ()
@@ -1658,10 +1691,14 @@
(process-signal (current-process-id) signal/kill)
))
(alist->env-vars miscprevvals)
(alist->env-vars testprevvals)
(alist->env-vars commonprevvals)
+ ;; yes, really should mutex all the way to here. Need to put this entire process into a fork.
+ ;; the unlock previously was further up. This seemed wrong as we should not proceed until the
+ ;; vars have been reset.
+ (mutex-unlock! *launch-setup-mutex*)
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
@@ -1687,5 +1724,21 @@
;; 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)))
+
+
+ ;; (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))))))
+
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -39,10 +39,17 @@
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
+
+(declare (uses adjutant))
+(import adjutant)
+
+(declare (uses mttop))
+(import mttop)
+
;; (declare (uses ftail))
;; (import ftail)
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
@@ -51,12 +58,12 @@
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
- readline apropos json http-client directory-utils typed-records
- http-client srfi-18 extras format)
+ readline apropos json http-client directory-utils typed-records matchable
+ http-client srfi-18 extras format call-with-environment-variables)
;; Added for csv stuff - will be removed
;;
(use sparse-vectors)
@@ -102,10 +109,11 @@
Usage: megatest [options]
-h : this help
-manual : show the Megatest user manual
-version : print megatest version (currently " megatest-version ")
+ help : help for the new Megatest interface
Launching and managing runs
-run : run all tests or as specified by -testpatt
-remove-runs : remove the data for a run, requires -runname and -testpatt
Optionally use :state and :status, use -keep-records to remove only
@@ -199,11 +207,11 @@
-update-meta : update the tests metadata for all tests
-setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
overwritten by values set in config files.
-server -|hostname : start the server (reduces contention on megatest.db), use
- to automatically figure out hostname
- -adjutant C,M : start the server/adjutant with allocated cores C and Mem M (Gig),
+ -adjutant host-type : start the server/adjutant with given host-type
use 0,0 to auto use full machine
-transport http|rpc : use http or rpc for transport (default is http)
-log logfile : send stdout and stderr to logfile
-list-servers : list the servers
-kill-servers : kill all servers
@@ -268,10 +276,14 @@
Version " megatest-version ", built from " megatest-fossil-hash ))
;; -gui : start a gui interface
;; -config fname : override the runconfigs file with fname
+
+(mttop-run (command-line-arguments)
+ '("help"))
+
;; process args
(define remargs (args:get-args
(argv)
(list "-runtests" ;; run a specific test
"-config" ;; override the config file name
@@ -918,16 +930,47 @@
(let ((tl (launch:setup))
(transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
(server:launch 0 transport-type)
(set! *didsomething* #t)))
+
+(define (naylist->alist inlst)
+ (map (lambda (dat)
+ (cons (car dat)
+ (or (if (list? (cdr dat))
+ (if (null? (cdr dat)) ""
+ (cadr dat))
+ (cdr dat))
+ ""))) ;; we need a string for call-with-environment-variables
+ inlst))
+
;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")
- (begin
- (adjutant-run)
+ (let* ((host-type (args:get-arg "-adjutant")))
+ (launch:setup) ;; dang it, wish this wasn't needed
+ (print "Running the adjutant!")
+ (let loop ((wait-count 0))
+ (if (< wait-count 10) ;; 6 x 10 seconds = one minute
+ (let* ((dat (rmt:no-sync-take-job host-type)))
+ (match dat
+ ((id ht vars exekey cmdline state event-time last-update)
+ (let ((vars-alist (with-input-from-string vars read)
+ ))
+ (print "Vars:")
+ (pp vars-alist)
+ (call-with-environment-variables
+ (naylist->alist vars-alist)
+ (lambda ()
+ (system cmdline))))
+ (loop 0))
+ (else
+ (thread-sleep! 10)
+ (loop (+ wait-count 1)))))
+ (print "I'm bored. Exiting.")))
+ ;; (adjutant-run (args:get-arg "-ajutant") rmt:no-sync-take-job)
(set! *didsomething* #t)))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-kill-servers"))
(let ((tl (launch:setup)))
ADDED mttop.scm
Index: mttop.scm
==================================================================
--- /dev/null
+++ mttop.scm
@@ -0,0 +1,55 @@
+;; Copyright 2006-2011, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+
+;; This is from the perl world, a hash of hashes is a super easy way to keep a handle on
+;; lots of disparate data
+;;
+
+(declare (unit mttop))
+
+(module mttop
+ *
+
+(import chicken scheme
+ ;; data-structures posix
+ srfi-1
+ ;; srfi-13
+ srfi-69
+ ports
+ extras
+ regex
+ posix
+ data-structures
+ matchable
+ )
+
+(define (str-is-cmd cmd all-cmds)
+ (let* ((rx (regexp (conc "^" cmd ".*")))
+ (mx (filter string? (map (lambda (x)
+ (let ((res (string-match rx x)))
+ (if res (car res) #f)))
+ all-cmds))))
+ (if (eq? (length mx) 1) ;; have a command
+ (car mx)
+ #f)))
+
+(define (mttop-run args all-cmds)
+ ;; any path through this call must end in exit if it is NOT an old Megatest call
+ (if (null? args)
+ #f ;; continue on and do the old Megatest stuff
+ (let ((cmd (str-is-cmd (car args) all-cmds)))
+ (if cmd
+ (begin
+ (case (string->symbol cmd)
+ ((help)(print "New help"))
+ (else (print "Command " cmd " is not implemented yet.")))
+ (exit)) ;; always exit here
+ #f)))) ;; or continue on to Megatest old stuff here
+
+)
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -945,10 +945,19 @@
(define (rmt:no-sync-del! var)
(rmt:send-receive 'no-sync-del! #f `(,var)))
(define (rmt:no-sync-get-lock keyname)
(rmt:send-receive 'no-sync-get-lock #f `(,keyname)))
+
+(define (rmt:no-sync-add-job host-type vars-list exekey cmdline)
+ (rmt:send-receive 'no-sync-add-job #f `(,host-type ,vars-list ,exekey ,cmdline)))
+
+(define (rmt:no-sync-take-job host-type)
+ (rmt:send-receive 'no-sync-take-job #f `(,host-type)))
+
+(define (rmt:no-sync-job-records-clean)
+ (rmt:set-receive 'no-sync-job-records-clean #f '()))
;;======================================================================
;; A R C H I V E S
;;======================================================================