Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -53,10 +53,12 @@ (define *server-id* #f) (define *server-info* #f) (define *time-to-exit* #f) (define *received-response* #f) (define *default-numtries* 10) +(define *server-run* #t) + (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define *keys* (make-hash-table)) ;; cache the keys here (define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -98,12 +98,13 @@ (define dlg #f) (define max-test-num 0) ;; (define *keys* (open-run-close db:get-keys #f)) (define *keys* (cdb:remote-run db:get-keys #f)) ;; (define *keys* (db:get-keys *db*)) -(define *dbkeys* (map (lambda (x)(vector-ref x 0)) - (append *keys* (list (vector "runname" "blah"))))) + +(define *dbkeys* (append *keys* (list "runname"))) + (define *header* #f) (define *allruns* '()) (define *allruns-by-id* (make-hash-table)) ;; (define *runchangerate* (make-hash-table)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -133,16 +133,16 @@ res)) (define (db:initialize db) (debug:print-info 11 "db:initialize START") (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... - (keys (config-get-fields configdat)) + (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys))) (for-each (lambda (key) - (let ((keyn (vector-ref key 0))) + (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")) (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table") @@ -151,11 +151,11 @@ keys) ;; (sqlite3:execute db "PRAGMA synchronous = OFF;") (db:set-sync db) (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") (for-each (lambda (key) - (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" (key:get-fieldname key)(key:get-fieldtype key))) + (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) keys) (sqlite3:execute db (conc "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " fieldstr (if havekeys "," "") "runname TEXT," @@ -492,24 +492,26 @@ (define (db:del-var db var) (debug:print-info 11 "db:del-var START " var) (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var) (debug:print-info 11 "db:del-var END " var)) -;; use a global for some primitive caching, it is just silly to re-read the db -;; over and over again for the keys since they never change +;; use a global for some primitive caching, it is just silly to +;; re-read the db over and over again for the keys since they never +;; change + +;; why get the keys from the db? why not get from the *configdat* +;; using keys:config-get-fields? (define (db:get-keys db) (if *db-keys* *db-keys* (let ((res '())) - (debug:print-info 11 "db:get-keys START (cache miss)") (sqlite3:for-each-row - (lambda (key keytype) - (set! res (cons (vector key keytype) res))) + (lambda (key) + (set! res (cons key res))) db - "SELECT fieldname,fieldtype FROM keys ORDER BY id DESC;") + "SELECT fieldname FROM keys ORDER BY id DESC;") (set! *db-keys* res) - (debug:print-info 11 "db:get-keys END (cache miss)") res))) (define (db:get-value-by-header row header field) (debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field) (if (null? header) #f @@ -521,15 +523,34 @@ (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) ;;====================================================================== ;; R U N S ;;====================================================================== + +(define (db:get-run-name-from-id db run-id) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (runname) + (set! res runname)) + db + "SELECT runname FROM runs WHERE id=?;" + run-id) + res)) + +(define (db:get-run-key-val db run-id key) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (val) + (set! res val)) + db + (conc "SELECT " key " FROM runs WHERE id=?;") + run-id) + res)) ;; keys list to key1,key2,key3 ... (define (runs:get-std-run-fields keys remfields) - (let* ((header (append (map key:get-fieldname keys) - remfields)) + (let* ((header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (list keystr header))) ;; make a query (fieldname like 'patt1' OR fieldname @@ -545,22 +566,22 @@ patts)) comparator))) ;; register a test run with the db -(define (db:register-run db keys keyvallst runname state status user) - (debug:print 3 "runs:register-run, keys: " keys " keyvallst: " keyvallst " runname: " runname " state: " state " status: " status " user: " user) - (let* ((keystr (keys->keystr keys)) +(define (db:register-run db keyvals runname state status user) + (debug:print 3 "runs:register-run runname: " runname " state: " state " status: " status " user: " user) + (let* ((keys (map car keyvals)) + (keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... - (keyvals (map cadr keyvallst)) - (allvals (append (list runname state status user) keyvals)) - (qryvals (append (list runname) keyvals)) - (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND "))) - (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals) - (debug:print 2 "NOTE: using target " (string-intersperse keyvals "/") " for this run") + (allvals (append (list runname state status user) (map cadr keyvals))) + (qryvals (append (list runname) (map cadr keyvals))) + (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) + (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) + (debug:print 2 "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (let ((res #f)) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) (apply sqlite3:for-each-row @@ -586,12 +607,11 @@ (define (db:get-runs db runpatt count offset keypatts) (let* ((res '()) (keys (db:get-keys db)) (runpattstr (db:patt->like "runname" runpatt)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) - (header (append (map key:get-fieldname keys) - remfields)) + (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ","))) (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " ;; Generate: " AND x LIKE 'keypatt' ..." (if (null? keypatts) "" @@ -637,12 +657,11 @@ ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) (let* ((res #f) (keys (db:get-keys db)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) - (header (append (map key:get-fieldname keys) - remfields)) + (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (sqlite3:for-each-row (lambda (a . x) @@ -685,20 +704,20 @@ ;;====================================================================== ;; get key val pairs for a given run-id ;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) (define (db:get-key-val-pairs db run-id) - (let* ((keys (get-keys db)) + (let* ((keys (db:get-keys db)) (res '())) (debug:print-info 11 "db:get-key-val-pairs START keys: " keys " run-id: " run-id) (for-each (lambda (key) - (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) + (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (debug:print 0 "qry: " qry) (sqlite3:for-each-row (lambda (key-val) - (set! res (cons (list (key:get-fieldname key) key-val) res))) + (set! res (cons (list key key-val) res))) db qry run-id))) keys) (debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id) (reverse res))) @@ -705,16 +724,16 @@ ;; get key vals for a given run-id (define (db:get-key-vals db run-id) (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) (if mykeyvals mykeyvals - (let* ((keys (get-keys db)) + (let* ((keys (db:get-keys db)) (res '())) (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id) (for-each (lambda (key) - (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) + (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (debug:print 0 "qry: " qry) (sqlite3:for-each-row (lambda (key-val) (set! res (cons key-val res))) db qry run-id))) @@ -1327,12 +1346,12 @@ (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path)) (define (cdb:flush-queue serverdat) (cdb:client-call serverdat 'flush #f *default-numtries*)) -(define (cdb:kill-server serverdat) - (cdb:client-call serverdat 'killserver #t *default-numtries*)) +(define (cdb:kill-server serverdat pid) + (cdb:client-call serverdat 'killserver #t *default-numtries* pid)) (define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status) (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status)) (define (cdb:get-test-info serverdat run-id test-name item-path) @@ -1564,18 +1583,24 @@ (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))))) ((flush sync) (server:reply return-address qry-sig #t 1)) ;; (length data))) ((set-verbosity) (set! *verbosity* (car params)) - (server:reply return-address qry-sig #t '(#t *verbosity*))) + (server:reply return-address qry-sig #t (list #t *verbosity*))) ((killserver) - (debug:print 0 "WARNING: Server going down in 15 seconds by user request!") - (open-run-close tasks:server-deregister tasks:open-db - (car *runremote*) - pullport: (cadr *runremote*)) - (thread-start! (make-thread (lambda ()(thread-sleep! 15)(exit)))) - (server:reply return-address qry-sig #t '(#t "exit process started"))) + (let ((hostname (car *runremote*)) + (port (cadr *runremote*)) + (pid (car params))) + (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!") + (debug:print-info 1 "current pid=" (current-process-id)) + (open-run-close tasks:server-deregister tasks:open-db + hostname + port: port) + (set! *server-run* #f) + (thread-sleep! 3) + (process-signal pid signal/kill) + (server:reply return-address qry-sig #t '(#t "exit process started")))) (else ;; not a command, i.e. is a query (debug:print 0 "ERROR: Unrecognised query/command " stmt-key) (server:reply return-address qry-sig #f 'failed))))) (else (debug:print-info 11 "Executing " stmt-key " for " params) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -13,11 +13,13 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) (import (prefix sqlite3 sqlite3:)) (use spiffy uri-common intarweb http-client spiffy-request-vars) +;; Configurations for server (tcp-buffer-size 2048) +(max-connections 2048) (declare (unit http-transport)) (declare (uses common)) (declare (uses db)) @@ -32,11 +34,11 @@ (define (http-transport:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) -(define *server-loop-heart-beat* (current-seconds)) +(define *server-loop-heart-beat* (current-seconds)) (define *heartbeat-mutex* (make-mutex)) ;;====================================================================== ;; S E R V E R ;;====================================================================== @@ -271,14 +273,15 @@ ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access (mutex-lock! *heartbeat-mutex*) (set! last-access *last-db-access*) (mutex-unlock! *heartbeat-mutex*) ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout) - (if (> (+ last-access server-timeout) - (current-seconds)) + (if (and *server-run* + (> (+ last-access server-timeout) + (current-seconds))) (begin - (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) + (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) (loop 0)) (begin (debug:print-info 0 "Starting to shutdown the server.") ;; need to delete only *my* server entry (future use) (set! *time-to-exit* #t) Index: key_records.scm ================================================================== --- key_records.scm +++ key_records.scm @@ -7,19 +7,15 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(define-inline (key:get-fieldname key)(vector-ref key 0)) -(define-inline (key:get-fieldtype key)(vector-ref key 1)) - (define-inline (keys->valslots keys) ;; => ?,?,? .... (string-intersperse (map (lambda (x) "?") keys) ",")) (define-inline (keys->key/field keys . additional) - (string-join (map (lambda (k)(conc (key:get-fieldname k) " " - (key:get-fieldtype k))) + (string-join (map (lambda (k)(conc k " TEXT")) (append keys additional)) ",")) (define-inline (item-list->path itemdat) (if (list? itemdat) (string-intersperse (map cadr itemdat) "/") Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -19,103 +19,52 @@ (declare (uses common)) (include "key_records.scm") (include "common_records.scm") -(define (get-keys db) - (let ((keys '())) ;; keys are vectors - (sqlite3:for-each-row (lambda (fieldname fieldtype) - (set! keys (cons (vector fieldname fieldtype) keys))) - db - "SELECT fieldname,fieldtype FROM keys ORDER BY id ASC;") - (reverse keys))) ;; could just sort desc? - (define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... - (string-intersperse (map key:get-fieldname keys) ",")) + (string-intersperse keys ",")) (define (args:usage . a) #f) -;; keys->vallist is called several times (quite unnecessarily), use this hash to suppress multiple -;; reporting of missing keys on the command line. -(define keys:warning-suppress-hash (make-hash-table)) - ;;====================================================================== ;; key <=> target routines ;;====================================================================== -;; this now invalidates using "/" in item names +;; This invalidates using "/" in item names. Every key will be +;; available via args:get-arg as :keyfield. Since this only needs to +;; be called once let's use it to set the environment vars +;; +;; The setting of :keyfield in args should be turned off ASAP +;; (define (keys:target-set-args keys target ht) (let ((vals (string-split target "/"))) (if (eq? (length vals)(length keys)) (for-each (lambda (key val) - (hash-table-set! ht (conc ":" (vector-ref key 0)) val)) + (setenv key val) + (hash-table-set! ht (conc ":" key) val)) keys vals) (debug:print 0 "ERROR: wrong number of values in " target ", should match " keys)) vals)) -;; given the keys (a list of vectors ) and a target return a keyval list +;; given the keys (a list of vectors or a list of keys) and a target return a keyval list ;; keyval list ( (key1 val1) (key2 val2) ...) (define (keys:target->keyval keys target) (let* ((targlist (string-split target "/")) (numkeys (length keys)) (numtarg (length targlist)) (targtweaked (if (> numkeys numtarg) (append targlist (make-list (- numkeys numtarg) "")) targlist))) (map (lambda (key targ) - (list (vector-ref key 0) targ)) - keys targtweaked))) - - -;;====================================================================== -;; key <=> args routines -;;====================================================================== - -;; Using the keys pulled from the database (initially set from the megatest.config file) -;; look for the equivalent value on the command line and add it to a list, or #f if not found. -;; default => (val1 val2 val3 ...) -;; withkey => (:key1 val1 :key2 val2 :key3 val3 ...) -(define (keys->vallist keys . withkey) ;; ORDERING IS VERY IMPORTANT, KEEP PROPER ORDER HERE! - (let* ((keynames (map key:get-fieldname keys)) - (argkeys (map (lambda (k)(conc ":" k)) keynames)) - (withkey (not (null? withkey))) - (newremargs (args:get-args - (cons "blah" remargs) ;; the cons blah works around a bug in args [args assumes ("calling-prog-name" .... ) ] - argkeys - '() - args:arg-hash - 0))) - ;;(debug:print 0 "remargs: " remargs " newremargs: " newremargs) - (apply append (map (lambda (x) - (let ((val (args:get-arg x))) - ;; (debug:print 0 "x: " x " val: " val) - (if (not val) - (begin - (if (not (hash-table-ref/default keys:warning-suppress-hash x #f)) - (begin - (debug:print 0 "WARNING: missing key " x ". Specified in database but not on command line, using \"unk\"") - (hash-table-set! keys:warning-suppress-hash x #t))) - (set! val "default"))) - (if withkey (list x val) (list val)))) - argkeys)))) - -;; Given a list of keys (list of vectors) return an alist ((key argval) ...) -(define (keys->alist keys defaultval) - (let* ((keynames (map key:get-fieldname keys)) - (newremargs (args:get-args (cons "blah" remargs) (map (lambda (k)(conc ":" k)) keynames) '() args:arg-hash 0))) ;; the cons blah works around a bug in args - (map (lambda (key) - (let ((val (args:get-arg (conc ":" key)))) - (list key (if val val defaultval)))) - keynames))) - -(define (keystring->keys keystring) - (map (lambda (x) - (let ((xlst (string-split x ":"))) - (list->vector (if (> (length xlst) 1) xlst (append (car xlst)(list "TEXT")))))) - (delete-duplicates (string-split keystring ",")))) - -(define (config-get-fields confdat) - (let ((fields (hash-table-ref/default confdat "fields" '()))) - (map (lambda (x)(vector (car x)(cadr x))) - fields))) + (list key targ)) + keys targtweaked))) + +;;====================================================================== +;; config file related routines +;;====================================================================== + +(define (keys:config-get-fields confdat) + (let ((fields (hash-table-ref/default confdat "fields" '()))) + (map car fields))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -91,11 +91,11 @@ ;; Setup the *runremote* global var (if *runremote* (debug:print 2 "ERROR: I'm not expecting *runremote* to be set at this time")) ;; (set! *runremote* runremote) (set! *transport-type* (string->symbol transport)) (set! keys (cdb:remote-run db:get-keys #f)) - (set! keyvals (if run-id (cdb:remote-run db:get-key-vals #f run-id) #f)) + (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 "varpairs: " varpairs) @@ -126,11 +126,11 @@ (change-directory *toppath*) (set-megatest-env-vars run-id) ;; these may be needed by the launching process (change-directory work-area) - (set-run-config-vars run-id keys keyvals target) ;; (db:get-target db run-id)) + (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") @@ -406,17 +406,17 @@ ;; ;; All log file links should be stored relative to the top of link path ;; ;; - [ - ] ;; -(define (create-work-area run-id run-info key-vals test-id test-src-path disk-path testname itemdat) +(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat) (let* ((item-path (item-list->path itemdat)) (runname (db:get-value-by-header (db:get-row run-info) (db:get-header run-info) "runname")) ;; convert back to db: from rdb: - this is always run at server end - (target (string-intersperse key-vals "/")) + (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)) @@ -554,11 +554,11 @@ ;; 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 key-vals runname test-conf keyvallst test-name test-path itemdat params) +(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) (change-directory *toppath*) (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (list ;; (list "MT_TEST_RUN_DIR" work-area) (list "MT_RUN_AREA_HOME" *toppath*) (list "MT_TEST_NAME" test-name) @@ -595,11 +595,11 @@ (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) (item-path (item-list->path itemdat)) ;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) (testinfo (cdb:get-test-info-by-id *runremote* test-id)) - (mt_target (string-intersperse (map cadr keyvallst) "/")) + (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 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")) @@ -606,11 +606,11 @@ (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 - (let ((dat (create-work-area run-id run-info key-vals test-id test-path diskpath test-name itemdat))) + (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 "Using work area " work-area)) (begin (set! work-area (conc test-path "/tmp_run")) @@ -634,11 +634,11 @@ (list 'ezsteps ezsteps) (list 'target mt_target) (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))))))) ;; (string-intersperse keyvallst " ")))) + (list 'mt-bindir-path mt-bindir-path))))))) ;; clean out step records from previous run if they exist ;; (debug:print-info 4 "FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?") ;; (open-run-close db:delete-test-step-records db test-id) (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir (tests:test-set-status! test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.5421) +(define megatest-version 1.5422) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -8,11 +8,11 @@ ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") -(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json) ;; (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client) ;; (srfi 18) extras) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) ;; (use zmq) @@ -30,42 +30,17 @@ (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") +(include "run_records.scm") (include "megatest-fossil-hash.scm") -;; (use trace dot-locking) -;; (trace -;; tests:match) -;; db:teststep-set-status! -;; db:open-test-db-by-test-id -;; db:test-get-rundir-from-test-id -;; cdb:tests-register-test -;; cdb:tests-update-uname-host -;; cdb:tests-update-run-duration -;; ;; cdb:client-call -;; ;; cdb:remote-run -;; ) -;; cdb:test-set-status-state -;; change-directory -;; db:process-queue-item -;; db:test-get-logfile-info -;; db:teststep-set-status! -;; nice-path -;; obtain-dot-lock -;; open-run-close -;; read-config -;; runs:can-run-more-tests -;; sqlite3:execute -;; sqlite3:for-each-row -;; tests:check-waiver-eligibility -;; tests:summarize-items -;; tests:test-set-status! -;; thread-sleep! -;;) - +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2012 @@ -410,20 +385,32 @@ (for-each (lambda (x) ;; (print "[" x "]")) (print x)) targets) (set! *didsomething* #t))) + +(define (full-runconfigs-read) + (let* ((keys (cdb:remote-run get-keys #f)) + (target (if (args:get-arg "-reqtarg") + (args:get-arg "-reqtarg") + (if (args:get-arg "-target") + (args:get-arg "-target") + #f))) + (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 "runconfigs.config" #f #t sections: sections)))) + data)) + (if (args:get-arg "-show-runconfig") - (let* ((target (if (args:get-arg "-reqtarg") - (args:get-arg "-reqtarg") - (if (args:get-arg "-target") - (args:get-arg "-target") - #f))) - (sections (if target (list "default" target) #f)) - (data (read-config "runconfigs.config" #f #t sections: sections))) - + (let ((data (full-runconfigs-read))) ;; keep this one local (cond ((not (args:get-arg "-dumpmode")) (pp (hash-table->alist data))) ((string=? (args:get-arg "-dumpmode") "json") @@ -456,43 +443,50 @@ ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first (define (operate-on action) - (cond - ((not (args:get-arg ":runname")) - (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with :runname patt") - (exit 2)) - ((not (args:get-arg "-testpatt")) - (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") - (exit 3)) - (else - (if (not (car *configinfo*)) - (begin - (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") - (exit 1)) - ;; put test parameters into convenient variables - (runs:operate-on action - (args:get-arg ":runname") - (args:get-arg "-testpatt") - state: (args:get-arg ":state") - status: (args:get-arg ":status") - new-state-status: (args:get-arg "-set-state-status"))) - (set! *didsomething* #t)))) + (let* ((runrec (runs:runrec-make-record)) + (target (or (args:get-arg "-reqtarg") + (args:get-arg "-target")))) + (cond + ((not target) + (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg") + (exit 1)) + ((not (args:get-arg ":runname")) + (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with :runname patt") + (exit 2)) + ((not (args:get-arg "-testpatt")) + (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") + (exit 3)) + (else + (if (not (car *configinfo*)) + (begin + (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") + (exit 1)) + ;; put test parameters into convenient variables + (runs:operate-on action + target + (args:get-arg ":runname") + (args:get-arg "-testpatt") + state: (args:get-arg ":state") + status: (args:get-arg ":status") + new-state-status: (args:get-arg "-set-state-status"))) + (set! *didsomething* #t))))) (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (operate-on 'remove-runs)))) (if (args:get-arg "-set-state-status") (general-run-call "-set-state-status" "set state and status" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (operate-on 'set-state-status)))) ;;====================================================================== ;; Query runs ;;====================================================================== @@ -507,19 +501,18 @@ "%")) (runsdat (cdb:remote-run db:get-runs #f runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) (keys (cdb:remote-run db:get-keys #f)) - (keynames (map key:get-fieldname keys)) (db-targets (args:get-arg "-list-db-targets")) (seen (make-hash-table))) ;; Each run (for-each (lambda (run) (let ((targetstr (string-intersperse (map (lambda (x) (db:get-value-by-header run header x)) - keynames) "/"))) + keys) "/"))) (if db-targets (if (not (hash-table-ref/default seen targetstr #f)) (begin (hash-table-set! seen targetstr #t) ;; (print "[" targetstr "]")))) @@ -589,14 +582,13 @@ ;; run all tests are are Not COMPLETED and PASS or CHECK (if (args:get-arg "-runall") (general-run-call "-runall" "run all tests" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (runs:run-tests target runname - "%" (args:get-arg "-testpatt") user args:arg-hash)))) ;;====================================================================== @@ -618,45 +610,40 @@ (if (args:get-arg "-runtests") (general-run-call "-runtests" "run a test" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (runs:run-tests target runname (args:get-arg "-runtests") - (or (args:get-arg "-testpatt") - (args:get-arg "-runtests")) user args:arg-hash)))) ;;====================================================================== ;; Rollup into a run ;;====================================================================== (if (args:get-arg "-rollup") - (begin - (debug:print 0 "ERROR: Rollup is currently not working. If you need it please submit a ticket at http://www.kiatoa.com/fossils/megatest") - (exit 4))) -;; (general-run-call -;; "-rollup" -;; "rollup tests" -;; (lambda (target runname keys keynames keyvallst) -;; (runs:rollup-run keys -;; (keys->alist keys "na") -;; (args:get-arg ":runname") -;; user)))) + (general-run-call + "-rollup" + "rollup tests" + (lambda (target runname keys keyvals) + (runs:rollup-run keys + keyvals + (args:get-arg ":runname") + user)))) ;;====================================================================== ;; Lock or unlock a run ;;====================================================================== (if (or (args:get-arg "-lock")(args:get-arg "-unlock")) (general-run-call (if (args:get-arg "-lock") "-lock" "-unlock") "lock/unlock tests" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (runs:handle-locking target keys (args:get-arg ":runname") (args:get-arg "-lock") @@ -695,25 +682,24 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) (let* ((keys (cdb:remote-run db:get-keys db)) - (keynames (map key:get-fieldname keys)) ;; db:test-get-paths must not be run remote - (paths (db:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) + (paths (db:test-get-paths-matching db keys target (args:get-arg "-test-files")))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call (general-run-call "-test-files" "Get paths to test" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (let* ((db #f) ;; DO NOT run remote - (paths (db:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) + (paths (db:test-get-paths-matching db keys target (args:get-arg "-test-files")))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -747,25 +733,24 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -archive, exiting") (exit 1))) (let* ((keys (cdb:remote-run db:get-keys db)) - (keynames (map key:get-fieldname keys)) ;; DO NOT run remote - (paths (db:test-get-paths-matching db keynames target))) + (paths (db:test-get-paths-matching db keys target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call (general-run-call "-test-paths" "Get paths to tests" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (let* ((db #f) ;; DO NOT run remote - (paths (db:test-get-paths-matching db keynames target))) + (paths (db:test-get-paths-matching db keys target))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -774,17 +759,17 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (let ((db #f) (outputfile (args:get-arg "-extract-ods")) (runspatt (args:get-arg ":runname")) - (pathmod (args:get-arg "-pathmod")) - (keyvalalist (keys->alist keys "%"))) - (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvalalist: " keyvalalist) + (pathmod (args:get-arg "-pathmod"))) + ;; (keyvalalist (keys->alist keys "%"))) + (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvalalist: " keyvals) (cdb:remote-run db:extract-ods-file db outputfile keyvalalist (if runspatt runspatt "%") pathmod))))) ;;====================================================================== ;; execute the test ;; - gets called on remote host @@ -978,11 +963,11 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! keys (cbd:remote-run db:get-keys db)) - (debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", ")) + (debug:print 1 "Keys: " (string-intersperse keys ", ")) (if db (sqlite3:finalize! db)) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin @@ -1056,10 +1041,12 @@ (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== + +(if *runremote* (close-all-connections!)) ;; this is the socket if we are a client ;; (if (and *runremote* ;; (socket? *runremote*)) ;; (close-socket *runremote*)) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -776,11 +776,11 @@ ;; ;; Each run is unique on its keys and runname or run-id, store in hash on colnum (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) - (map key:get-fieldname keys))) + keys)) (run-name (db:get-value-by-header run-record header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name)))) (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) (iup:attribute-set! (dboard:data-get-runs-matrix *data*) Index: run-tests-queue-classic.scm ================================================================== --- run-tests-queue-classic.scm +++ run-tests-queue-classic.scm @@ -1,13 +1,12 @@ ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > -(define (runs:run-tests-queue-classic run-id runname test-records keyvallst flags test-patts) +(define (runs:run-tests-queue-classic run-id runname test-records keyvals flags test-patts required-tests) ;; 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 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags)) + (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) (let ((run-info (cdb:remote-run db:get-run-info #f run-id)) - (key-vals (cdb:remote-run db:get-key-vals #f run-id)) (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 (config-lookup *configdat* "setup" "maxretries")) @@ -52,13 +51,13 @@ (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) (cond ;; OUTER COND ((not items) ;; when false the test is ok to be handed off to launch (but not before) - (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path)) + (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) reruns)) + (loop (car newtal)(cdr newtal) reruns)) (let* ((run-limits-info (runs:can-run-more-tests test-record 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)) @@ -78,11 +77,11 @@ ;; 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 "run-limits-info = " run-limits-info) (cond ;; INNER COND #1 for a launchable test ;; Check item path against item-patts - ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path)) ;; This test/itempath is not to be run + ((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 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) ;; (thread-sleep! *global-delta*) (if (not (null? tal)) @@ -132,11 +131,11 @@ (loop (car newtal)(cdr newtal) reruns)) ((and have-resources (or (null? prereqs-not-met) (and (eq? testmode 'toplevel) (null? non-completed)))) - (run:test run-id run-info key-vals runname keyvallst test-record flags #f) + (run:test run-id run-info keyvals runname test-record flags #f) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (not (null? tal)) (loop (car tal)(cdr tal) reruns))) @@ -178,11 +177,11 @@ (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))) - (if (tests:match test-patts hed my-item-path) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! + (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! (let ((newtestname (runs:make-full-test-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) @@ -222,11 +221,11 @@ (and (eq? testmode 'toplevel) (null? non-completed))) (let ((test-name (tests:testqueue-get-testname test-record))) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars run-id) ;; these may be needed by the launching process + (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 (tests:testqueue-set-items! test-record items-list) ;; (thread-sleep! *global-delta*) Index: run-tests-queue-new.scm ================================================================== --- run-tests-queue-new.scm +++ run-tests-queue-new.scm @@ -1,11 +1,11 @@ ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > -(define (runs:run-tests-queue-new run-id runname test-records keyvallst flags test-patts reglen) +(define (runs:run-tests-queue-new run-id runname test-records keyvallst flags test-patts required-tests reglen) ;; 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 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags)) + (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) (let ((run-info (cdb:remote-run db:get-run-info #f run-id)) (key-vals (cdb:remote-run db:get-key-vals #f run-id)) (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registry (make-hash-table)) (registry-mutex (make-mutex)) @@ -148,11 +148,11 @@ (loop (car newtal)(cdr newtal) reg reruns)) ((and have-resources (or (null? prereqs-not-met) (and (eq? testmode 'toplevel) (null? non-completed)))) - (run:test run-id run-info key-vals runname keyvallst test-record flags #f) + (run:test run-id run-info key-vals runname test-record flags #f) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (not (null? tal)) (loop (runs:queue-next-hed tal reg reglen regfull) Index: run_records.scm ================================================================== --- run_records.scm +++ run_records.scm @@ -7,10 +7,25 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== +(define-inline (runs:runrec-make-record) (make-vector 13)) +(define-inline (runs:runrec-get-target vec)(vector-ref vec 0)) ;; a/b/c +(define-inline (runs:runrec-get-runname vec)(vector-ref vec 1)) ;; string +(define-inline (runs:runrec-testpatt vec)(vector-ref vec 2)) ;; a,b/c,d% +(define-inline (runs:runrec-keys vec)(vector-ref vec 3)) ;; (key1 key2 ...) +(define-inline (runs:runrec-keyvals vec)(vector-ref vec 4)) ;; ((key1 val1)(key2 val2) ...) +(define-inline (runs:runrec-environment vec)(vector-ref vec 5)) ;; environment, alist key val +(define-inline (runs:runrec-mconfig vec)(vector-ref vec 6)) ;; megatest.config +(define-inline (runs:runrec-runconfig vec)(vector-ref vec 7)) ;; runconfigs.config +(define-inline (runs:runrec-serverdat vec)(vector-ref vec 8)) ;; (host port) +(define-inline (runs:runrec-transport vec)(vector-ref vec 9)) ;; 'http +(define-inline (runs:runrec-db vec)(vector-ref vec 10)) ;; (if 'fs) +(define-inline (runs:runrec-top-path vec)(vector-ref vec 11)) ;; *toppath* +(define-inline (runs:runrec-run_id vec)(vector-ref vec 12)) ;; run-id + (define-inline (test:get-id vec) (vector-ref vec 0)) (define-inline (test:get-run_id vec) (vector-ref vec 1)) (define-inline (test:get-test-name vec)(vector-ref vec 2)) (define-inline (test:get-state vec) (vector-ref vec 3)) (define-inline (test:get-status vec) (vector-ref vec 4)) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -8,24 +8,19 @@ (declare (unit runconfig)) (declare (uses common)) (include "common_records.scm") - - -;; (define (setup-env-defaults db fname run-id already-seen #!key (environ-patt #f)(change-env #t)) -(define (setup-env-defaults fname run-id already-seen keys keyvals #!key (environ-patt #f)(change-env #t)) - (let* (;; (keys (db:get-keys db)) - ;; (keyvals (if run-id (db:get-key-vals db run-id) #f)) - (thekey (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/") - (if (args:get-arg "-reqtarg") - (args:get-arg "-reqtarg") - (if (args:get-arg "-target") - (args:get-arg "-target") - (begin - (debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") - "nothing matches this I hope"))))) +(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 (args:get-arg "-reqtarg") + (args:get-arg "-target") + (get-environment-variable "MT_TARGET") + (begin + (debug:print 0 "ERROR: 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 (read-config fname #f #t environ-patt: environ-patt sections: (list "default" thekey))) (whatfound (make-hash-table)) (finaldat (make-hash-table)) @@ -32,14 +27,14 @@ (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 "Using key=\"" thekey "\"") (if change-env - (for-each - (lambda (key val) - (setenv (vector-ref key 0) val)) - keys keyvals)) + (for-each ;; NB// This can be simplified with new content of keyvals having all that is needed. + (lambda (keyval) + (setenv (car keyval)(cadr keyval))) + keyvals)) (for-each (lambda (section) (let ((section-dat (hash-table-ref/default confdat section #f))) (if section-dat @@ -59,20 +54,21 @@ sections) (debug:print 2 "---") (set! *already-seen-runconfig-info* #t))) finaldat)) -(define (set-run-config-vars run-id keys keyvals targ-from-db) - (push-directory *toppath*) +(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 (args:get-arg "-target") (args:get-arg "-reqtarg") - targ-from-db))) + targ-from-db + (get-environment-variable "MT_TARGET")))) (pop-directory) (if (file-exists? runconfigf) - (setup-env-defaults runconfigf run-id #t keys keyvals + (setup-env-defaults runconfigf run-id #t keyvals environ-patt: (conc "(default" (if targ (conc "|" targ ")") ")"))) (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -32,30 +32,30 @@ ;; register a test run with the db ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) ;; to extract info from the structure returned ;; -(define (runs:get-runs-by-patt db keys runnamepatt) ;; test-name) - (let* ((keyvallst (keys->vallist keys)) - (tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) +(define (runs:get-runs-by-patt db keys runnamepatt targpatt) ;; test-name) + (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) (keystr (car tmp)) (header (cadr tmp)) (res '()) (key-patt "") (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) - (qry-str #f)) + (qry-str #f) + (keyvals (keys:target->keyval keys targpatt))) (for-each (lambda (keyval) - (let* ((key (vector-ref keyval 0)) + (let* ((key (car keyval)) + (patt (cadr keyval)) (fulkey (conc ":" key)) - (patt (args:get-arg fulkey)) (wildtype (if (substring-index "%" patt) "like" "glob"))) (if patt (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) (begin (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) (exit 6))))) - keys) + keyvals) (set! qry-str (conc "SELECT " keystr " FROM runs WHERE runname " runwildtype " ? " key-patt ";")) (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (sqlite3:for-each-row (lambda (a . r) (set! res (cons (list->vector (cons a r)) res))) @@ -67,53 +67,99 @@ (define (runs:test-get-full-path test) (let* ((testname (db:test-get-testname test)) (itempath (db:test-get-item-path test))) (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) -(define (db:get-run-key-val db run-id key) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (val) - (set! res val)) - db - (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;") - run-id) - res)) - -(define (db:get-run-name-from-id db run-id) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (runname) - (set! res runname)) - db - "SELECT runname FROM runs WHERE id=?;" - run-id) - res)) - -(define (set-megatest-env-vars run-id) - (let ((keys (cdb:remote-run db:get-keys #f)) - (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))) +;; This is the *new* methodology. One record to inform them and in the chaos, organise them. +;; +(define (runs:create-run-record) + (let* ((mconfig (if *configdat* + *configdat* + (if (setup-for-run) + *configdat* + (begin + (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting") + (exit 1))))) + (runrec (runs:runrec-make-record)) + (target (or (args:get-arg "-reqtarg") + (args:get-arg "-target"))) + (runname (or (args:get-arg ":runname") + (args:get-arg "-runname"))) + (testpatt (or (args:get-arg "-testpatt") + (args:get-arg "-runtests"))) + (keys (keys:config-get-fields mconfig)) + (keyvals (keys:target->keyval keys target)) + (toppath *toppath*) + (envdat keyvals) ;; initial values start with keyvals + (runconfig #f) + (serverdat (if (args:get-arg "-server") + *runremote* + #f)) ;; to be used later + (transport (or (args:get-arg "-transport") 'http)) + (db (if (and mconfig + (or (args:get-arg "-server") + (eq? transport 'fs))) + (open-db) + #f)) + (run-id #f)) + ;; Set all the environment vars we know so far, start with keys + (for-each (lambda (keyval) + (setenv (car keyval)(cadr keyval))) + keyvals) + ;; Set up various and sundry known vars here + (setenv "MT_RUN_AREA_HOME" toppath) + (setenv "MT_RUNNAME" runname) + (setenv "MT_TARGET" target) + (set! envdat (append + envdat + (list (list "MT_RUN_AREA_HOME" toppath) + (list "MT_RUNNAME" runname) + (list "MT_TARGET" target)))) + ;; Now can read the runconfigs file + ;; + (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))) + (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)) + (begin + (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) + (if db (sqlite3:finalize! db)) + (exit 1))) + ;; Now have runconfigs data loaded, set environment vars + (for-each (lambda (section) + (for-each (lambda (varval) + (set! envdat (append envdat (list varval))) + (setenv (car varval)(cadr varval))) + (configf:get-section runconfig section))) + (list "default" target)) + (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id))) + + +(define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) + (let* ((target (or (args:get-arg "-reqtarg") + (args:get-arg "-target") + (get-environment-variable "MT_TARGET"))) + (keys (if inkeys inkeys (cdb:remote-run db:get-keys #f))) + (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) + (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))) ;; get the info from the db and put it in the cache (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 key (cdb:remote-run db:get-run-key-val #f run-id key))) - keys))) + (hash-table-set! vals (car key) (cadr key))) ;; (cdb:remote-run db:get-run-key-val #f run-id (car key)))) + keyvals))) ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) - (debug:print 2 "setenv " (key:get-fieldname key) " " val) - (setenv (key:get-fieldname key) val))) + (debug:print 2 "setenv " key " " val) + (setenv key val))) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment - (setenv "MT_RUNNAME" (cdb:remote-run db:get-run-name-from-id #f run-id)) - (setenv "MT_RUN_AREA_HOME" *toppath*) - )) + (setenv "MT_RUNNAME" (if inrunname inrunname (cdb:remote-run db:get-run-name-from-id #f run-id))) + (setenv "MT_RUN_AREA_HOME" *toppath*))) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) @@ -173,34 +219,34 @@ ;; ;; 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 ;; -(define (runs:run-tests target runname test-names test-patts user flags) +(define (runs:run-tests target runname test-patts user flags) ;; test-names (common:clear-caches) ;; clear all caches (let* ((db #f) - (keys (cdb:remote-run db:get-keys #f)) - (keyvallst (keys:target->keyval keys target)) - (run-id (cdb:remote-run db:register-run #f keys keyvallst runname "new" "n/a" user)) ;; test-name))) - (keyvals (if run-id (cdb:remote-run db:get-key-vals #f run-id) #f)) + (keys (keys:config-get-fields *configdat*)) + (keyvals (keys:target->keyval keys target)) + (run-id (cdb:remote-run db:register-run #f keyvals runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause ;; keepgoing is the defacto modality now, will add hit-n-run a bit later ;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '()) - (test-records (make-hash-table))) + (test-records (make-hash-table)) + (all-test-names (tests:get-valid-tests *toppath* "%"))) ;; we need a list of all valid tests to check waiton names - (set-megatest-env-vars run-id) ;; these may be needed by the launching process + (set-megatest-env-vars run-id inkeys: keys) ;; these may be needed by the launching process (if (file-exists? runconfigf) - (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars") + (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) - (set! test-names (tests:get-valid-tests *toppath* test-names)) + (set! test-names (tests:get-valid-tests *toppath* test-patts)) (set! test-names (delete-duplicates test-names)) (debug:print-info 0 "test names " test-names) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if @@ -218,28 +264,35 @@ ;; (sqlite3:finalize! db) ;; now add non-directly referenced dependencies (i.e. waiton) (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 "hed=" hed " at top of loop") (let* ((config (tests:get-testconfig hed 'return-procs)) (waitons (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print 0 "ERROR: non-existent required test \"" hed "\"") (if db (sqlite3:finalize! db)) (exit 1))))) (debug:print-info 8 "waitons string is " instr) - (string-split (cond - ((procedure? instr) - (let ((res (instr))) - (debug:print-info 8 "waiton procedure results in string " res " for test " hed) - res)) - ((string? instr) instr) - (else - ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed) - "")))))) + (let ((newwaitons + (string-split (cond + ((procedure? instr) + (let ((res (instr))) + (debug:print-info 8 "waiton procedure results in string " res " for test " hed) + res)) + ((string? instr) instr) + (else + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed) + ""))))) + (filter (lambda (x) + (if (member x all-test-names) + #t + (begin + (debug:print 0 "ERROR: test " hed " has unrecognised waiton testname " x) + #f))) + newwaitons))))) (debug:print-info 8 "waitons: " waitons) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member hed waitons) (begin @@ -272,11 +325,11 @@ (append (if (list? items) items '()) (if (list? itemstable) itemstable '()))) 'have-procedure) ((or (list? items)(list? itemstable)) ;; calc now (debug:print-info 4 "items and itemstable are lists, calc now\n" - " items: " items " itemstable: " itemstable) + " items: " items " itemstable: " itemstable) (items:get-items-from-config config)) (else #f))) ;; not iterated #f ;; itemsdat 5 #f ;; spare - used for item-path ))) @@ -295,12 +348,12 @@ (debug:print-info 1 "Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 "test-records=" (hash-table->alist test-records)) (let ((reglen (any->number (configf:lookup *configdat* "setup" "runqueue")))) (if reglen - (runs:run-tests-queue-new run-id runname test-records keyvallst flags test-patts reglen) - (runs:run-tests-queue-classic run-id runname test-records keyvallst flags test-patts))) + (runs:run-tests-queue-new run-id runname test-records keyvals flags test-patts required-tests reglen) + (runs:run-tests-queue-classic run-id runname test-records keyvals flags test-patts required-tests))) (debug:print-info 4 "All done by here"))) (define (runs:calc-fails prereqs-not-met) (filter (lambda (test) (and (vector? test) ;; not (string? test)) @@ -351,11 +404,11 @@ (include "run-tests-queue-classic.scm") (include "run-tests-queue-new.scm") ;; 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 key-vals runname keyvallst test-record flags parent-test) +(define (run:test run-id run-info keyvals runname test-record flags parent-test) ;; All these vars might be referenced by the testconfig file reader (let* ((test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (test-conf (tests:testqueue-get-testconfig test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) @@ -373,11 +426,11 @@ (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) (debug:print 2 "Attempting to launch test " test-name (if (equal? item-path "/") "/" item-path)) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars run-id) ;; these may be needed by the launching process + (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process (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? (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) @@ -406,10 +459,12 @@ (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) (cdb:tests-register-test *runremote* run-id test-name item-path) (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)))) (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") (set! testdat (cdb:get-test-info-by-id *runremote* test-id)))) + (if (not testdat) ;; should NOT happen + (debug:print 0 "ERROR: failed to get test record for test-id " test-id)) (set! test-id (db:test-get-id testdat)) (change-directory test-path) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat @@ -455,11 +510,11 @@ "\" 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 - (if (not (launch-test test-id run-id run-info key-vals runname test-conf keyvallst test-name test-path itemdat flags)) + (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)))))) ((KILLED) @@ -490,15 +545,15 @@ ;; 'remove-runs ;; 'set-state-status ;; ;; NB// should pass in keys? ;; -(define (runs:operate-on action runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)) +(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)) (common:clear-caches) ;; clear all caches (let* ((db #f) (keys (open-run-close db:get-keys db)) - (rundat (open-run-close runs:get-runs-by-patt db keys runnamepatt)) + (rundat (open-run-close runs:get-runs-by-patt db 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)))) @@ -508,11 +563,11 @@ (debug:print 0 "ERROR: 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 (vector-ref k 0))) keys) "/")) + (db:get-value-by-header run header k)) keys) "/")) (dirs-to-remove (make-hash-table))) (let* ((run-id (db:get-value-by-header run header "id")) (run-state (db:get-value-by-header run header "state")) (tests (if (not (equal? run-state "locked")) (open-run-close db:get-tests-for-run db run-id @@ -621,39 +676,38 @@ ;; this wrapper is used to reduce the replication of code (define (general-run-call switchname action-desc proc) (let ((runname (args:get-arg ":runname")) (target (if (args:get-arg "-target") (args:get-arg "-target") - (args:get-arg "-reqtarg"))) - (th1 #f)) + (args:get-arg "-reqtarg")))) + ;; (th1 #f)) (cond ((not target) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") (exit 3)) ((not runname) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname") (exit 3)) (else (let ((db #f) - (keys #f)) + (keys #f) + (target (or (args:get-arg "-reqtarg") + (args:get-arg "-target")))) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - (if (args:get-arg "-server") - (open-run-close server:start db (args:get-arg "-server"))) - ;; (if (not (or (args:get-arg "-runall") ;; runall and runtests are allowed to be servers - ;; (args:get-arg "-runtests"))) - ;; (client:setup) ;; This is a duplicate startup!!!??? BUG? - ;; )) - (set! keys (open-run-close db:get-keys db)) + ;; (if (args:get-arg "-server") + ;; (open-run-close server:start db (args:get-arg "-server"))) + (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))) + (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 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) (if db (sqlite3:finalize! db)) (exit 1)))) (if (args:get-arg "-target") @@ -662,24 +716,22 @@ (begin (debug:print 0 "ERROR: 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* ((keynames (map key:get-fieldname keys)) - (keyvallst (keys->vallist keys #t))) - (proc target runname keys keynames keyvallst))) - (if th1 (thread-join! th1)) + (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 (open-run-close runs:get-runs-by-patt db keys runname)) + (rundat (open-run-close runs:get-runs-by-patt db 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"))) (if (or lock @@ -726,14 +778,14 @@ ;; use the open-run-close instead of passing in db (runs:update-test_meta test-name test-conf))) test-names))) ;; This could probably be refactored into one complex query ... -(define (runs:rollup-run keys keyvallst runname user) ;; was target, now keyvallst - (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user) - (let* ((db #f) ;; (keyvalllst (keys:target->keyval keys target)) - (new-run-id (cdb:remote-run db:register-run #f keys keyvallst runname "new" "n/a" user)) +(define (runs:rollup-run keys runname user keyvals) + (debug:print 4 "runs:rollup-run, keys: " keys " :runname " runname " user: " user) + (let* ((db #f) + (new-run-id (cdb:remote-run db:register-run #f keyvals runname "new" "n/a" user)) (prev-tests (open-run-close test:get-matching-previous-test-run-records db new-run-id "%" "%")) (curr-tests (open-run-close db:get-tests-for-run db new-run-id "%/%" '() '())) (curr-tests-hash (make-hash-table))) (open-run-close db:update-run-event_time db new-run-id) ;; index the already saved tests by testname and itemdat in curr-tests-hash @@ -751,11 +803,11 @@ (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 (open-run-close db:get-steps-for-test db (db:test-get-id testdat))) + (test-steps (open-run-close db:get-steps-for-test db (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) " Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -103,20 +103,20 @@ pubport transport )) ;; NB// two servers with same pid on different hosts will be removed from the list if pid: is used! -(define (tasks:server-deregister mdb hostname #!key (port #f)(pid #f)(action 'markdead)) +(define (tasks:server-deregister mdb hostname #!key (port #f)(pid #f)(action 'delete)) (debug:print-info 11 "server-deregister " hostname ", port " port ", pid " pid) (if pid (case action ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE pid=?;" pid)) (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE pid=?;" pid))) (if port (case action - ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE hostname=? AND port=?;" hostname port)) - (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE hostname=? AND port=?;" hostname port))) + ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE (interface=? or hostname=?) AND port=?;" hostname hostname port)) + (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE (interface=? or hostname=?) AND port=?;" hostname hostname port))) (debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified")))) (define (tasks:server-deregister-self mdb hostname) (tasks:server-deregister mdb hostname pid: (current-process-id))) @@ -141,11 +141,11 @@ "SELECT id FROM servers WHERE pid=-999;"))) (if hostname hostname iface)(if pid pid port)) res)) (define (tasks:server-update-heartbeat mdb server-id) - (debug:print-info 0 "Heart beat update of server id=" server-id) + (debug:print-info 1 "Heart beat update of server id=" server-id) (sqlite3:execute mdb "UPDATE servers SET heartbeat=strftime('%s','now') WHERE id=?;" server-id)) ;; alive servers keep the heartbeat field upto date with seconds every 6 or so seconds (define (tasks:server-alive? mdb server-id #!key (iface #f)(hostname #f)(port #f)(pid #f)) (let* ((server-id (if server-id @@ -250,17 +250,17 @@ (process-signal pid signal/term) (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill ;;(process-signal pid signal/kill) ) ;; local machine, send sig term (begin - (debug:print-info 1 "Stopping remote servers not yet supported.")))) - ;; (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide") - ;; (let ((serverdat (list hostname port))) - ;; (case (string->symbol transport) - ;; ((http)(http-transport:client-connect hostname port)) - ;; (else (debug:print "ERROR: remote stopping servers of type " transport " not supported yet"))) - ;; (cdb:kill-server serverdat))))) ;; remote machine, try telling server to commit suicide + ;;(debug:print-info 1 "Stopping remote servers not yet supported.")))) + (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide") + (let ((serverdat (list hostname port))) + (case (if (string? transport) (string->symbol transport) transport) + ((http)(http-transport:client-connect hostname port)) + (else (debug:print "ERROR: remote stopping servers of type " transport " not supported yet"))) + (cdb:kill-server serverdat pid))))) ;; remote machine, try telling server to commit suicide (begin (if status (if (equal? hostname (get-host-name)) (begin (debug:print-info 1 "Sending signal/term to " pid " on " hostname) @@ -531,15 +531,15 @@ (tasks:set-state mdb (tasks:task-get-id task) "waiting"))) (define (tasks:rollup-runs db mdb task) (let* ((flags (make-hash-table)) (keys (db:get-keys db)) - (keyvallst (keys:target->keyval keys (tasks:task-get-target task)))) + (keyvals (keys:target-keyval keys (tasks:task-get-target task)))) ;; (hash-table-set! flags "-rerun" "NOT_STARTED") (print "Starting rollup " task) ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY (runs:rollup-run db keys - keyvallst + keyvals (tasks:task-get-name task) (tasks:task-get-owner task)) (tasks:set-state mdb (tasks:task-get-id task) "waiting"))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -51,13 +51,13 @@ (set! res (string-match (regexp finpatt (if like #t #f)) str)) (if notpatt (not res) res)))) ;; if itempath is #f then look only at the testname part ;; -(define (tests:match patterns testname itempath) +(define (tests:match patterns testname itempath #!key (required '())) (if (string? patterns) - (let ((patts (string-split patterns ","))) + (let ((patts (append (string-split patterns ",") required))) (if (null? patts) ;;; no pattern(s) means no match #f (let loop ((patt (car patts)) (tal (cdr patts))) ;; (print "loop: patt: " patt ", tal " tal) @@ -107,12 +107,12 @@ ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found (define (test:get-previous-test-run-record db run-id test-name item-path) (let* ((keys (cdb:remote-run db:get-keys #f)) - (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) - (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) + (selstr (string-intersperse keys ",")) + (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) (keyvals #f)) ;; first look up the key values from the run selected by run-id (sqlite3:for-each-row (lambda (a . b) (set! keyvals (cons a b))) Index: tests/fdktestqa/testqa/Makefile ================================================================== --- tests/fdktestqa/testqa/Makefile +++ tests/fdktestqa/testqa/Makefile @@ -1,3 +1,25 @@ - +BINDIR=$(PWD)/../../../bin +MEGATEST=$(BINDIR)/megatest +DASHBOARD=$(BINDIR)/dashboard all : - megatest -runtests % -target a/b :runname c + $(MEGATEST) -runtests % -target a/b :runname c + +bigbig : + for tn in a b c d;do \ + ($(MEGATEST) -runtests % -target a/b :runname $tn & ) ; \ + done + +bigrun : + $(MEGATEST) -runtests bigrun -target a/bigrun :runname a + +bigrun2 : + $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a + +dashboard : + $(DASHBOARD) -rows 20 & + +compile : + (cd ../../..;make && make install) + +clean : + rm -rf ../simple*/*/* megatest.db Index: tests/fdktestqa/testqa/tests/bigrun2/step1.sh ================================================================== --- tests/fdktestqa/testqa/tests/bigrun2/step1.sh +++ tests/fdktestqa/testqa/tests/bigrun2/step1.sh @@ -1,7 +1,9 @@ #!/bin/sh -prev_test=`$MT_MEGATEST -test-paths -target $MT_TARGET :runname $MT_RUNNAME -testpatt bigrun/$NUMBER` -if [ -e $prev_test/testconfig ]; then - exit 0 -else - exit 1 -fi +# prev_test=`$MT_MEGATEST -test-paths -target $MT_TARGET :runname $MT_RUNNAME -testpatt bigrun/$NUMBER` +# if [ -e $prev_test/testconfig ]; then +# exit 0 +# else +# exit 1 +# fi + +exit 0 Index: tests/fdktestqa/testqa/tests/bigrun2/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun2/testconfig +++ tests/fdktestqa/testqa/tests/bigrun2/testconfig @@ -2,18 +2,18 @@ [ezsteps] step1 step1.sh # Test requirements are specified here [requirements] -waiton bigrun +# waiton bigrun priority 0 mode itemmatch # Iteration for your tests are controlled by the items section [items] -NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (< a 150)(loop (+ a 1)(cons a res)) res)) >)) " ")} +NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (< a 1500)(loop (+ a 1)(cons a res)) res)) >)) " ")} # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt ADDED tests/fullrun/afs.config Index: tests/fullrun/afs.config ================================================================== --- /dev/null +++ tests/fullrun/afs.config @@ -0,0 +1,1 @@ +TESTSTORUN priority_6 sqlitespeed/ag ADDED tests/fullrun/nfs.config Index: tests/fullrun/nfs.config ================================================================== --- /dev/null +++ tests/fullrun/nfs.config @@ -0,0 +1,1 @@ +TESTSTORUN priority_4 test_mt_vars Index: tests/fullrun/runconfigs.config ================================================================== --- tests/fullrun/runconfigs.config +++ tests/fullrun/runconfigs.config @@ -1,12 +1,16 @@ [default] SOMEVAR This should show up in SOMEVAR3 + +# target based getting of config file, look at afs.config and nfs.config +[include #{getenv fsname}.config] [include #{getenv MT_RUN_AREA_HOME}/common_runconfigs.config] # #{system echo 'VACKYVAR #{shell pwd}' > $MT_RUN_AREA_HOME/config/$USER.config} [include ./config/#{getenv USER}.config] + WACKYVAR0 #{get ubuntu/nfs/none CURRENT} WACKYVAR1 #{scheme (args:get-arg "-target")} [default/ubuntu/nfs] ADDED tests/fullrun/tests/special/testconfig Index: tests/fullrun/tests/special/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/special/testconfig @@ -0,0 +1,8 @@ +[ezsteps] +# calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET + +[requirements] +waiton #{rget TESTSTORUN} + +# This is a "toplevel" test, it does not require waitons to be non-FAIL to run +mode toplevel Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -79,36 +79,35 @@ (test "setup for run" #t (begin (setup-for-run) (string? (getenv "MT_RUN_AREA_HOME")))) (test "server-register, get-best-server" #t (let ((res #f)) - (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live) + (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) (set! res (open-run-close tasks:get-best-server tasks:open-db)) - (number? (cadddr res)))) + (number? (vector-ref res 3)))) -(test "de-register server" #t (let ((res #f)) - (open-run-close tasks:server-deregister tasks:open-db "bob" pullport: 1234) - (list? (open-run-close tasks:get-best-server tasks:open-db)))) +(test "de-register server" #f (let ((res #f)) + (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) + (open-run-close tasks:get-best-server tasks:open-db))) -(define hostinfo #f) +(define server-pid #f) +(test "launch server" #t (let ((pid (process-fork (lambda () + ;; (daemon:ize) + (server:launch 'http))))) + (set! server-pid pid) + (number? pid))) + +(thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed. (test "get-best-server" #t (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) - (set! hostinfo dat) ;; host ip pullport pubport - (and (string? (car dat)) - (number? (caddr dat))))) - -(test #f #t (let ((zmq-socket (server:client-connect - (cadr hostinfo) - (caddr hostinfo) - ;; (cadddr hostinfo) - ))) - (set! *runremote* zmq-socket) - (string? (car *runremote*)))) - -(test #f #t (let ((res (server:client-login *runremote*))) + (set! *runremote* (list (vector-ref dat 1)(vector-ref dat 2))) ;; host ip pullport pubport + (and (string? (car *runremote*)) + (number? (cadr *runremote*))))) + +(test #f #t (car (cdb:login *runremote* *toppath* *my-client-signature*))) +(test #f #t (let ((res (client:login *runremote*))) (car res))) -(test #f #t (car (cdb:login *runremote* *toppath* *my-client-signature*))) ;;====================================================================== ;; C O N F I G F I L E S ;;====================================================================== @@ -169,26 +168,26 @@ ;; (cdb:set-verbosity *runremote* *verbosity*) (test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?)) -(test "get-keys" "SYSTEM" (vector-ref (car (db:get-keys *db*)) 0));; (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0))))))) +(test "get-keys" "SYSTEM" (car (db:get-keys *db*))) (define remargs (args:get-args '("bar" "foo" ":runname" "bob" ":SYSTEM" "ubuntu" ":RELEASE" "v1.2" ":datapath" "blah/foo" "nada") (list ":runname" ":state" ":status") (list "-h") args:arg-hash 0)) -(test "register-run" #t (number? (runs:register-run *db* - (db:get-keys *db*) - '(("SYSTEM" "key1")("RELEASE" "key2")) - "myrun" - "new" - "n/a" - "bob"))) +(test "register-run" #t (number? + (db:register-run *db* + '(("SYSTEM" "key1")("RELEASE" "key2")) + "myrun" + "new" + "n/a" + "bob"))) (test #f #t (cdb:tests-register-test *runremote* 1 "nada" "")) (test #f 1 (cdb:remote-run db:get-test-id #f 1 "nada" "")) (test #f "NOT_STARTED" (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3)) (test #f "NOT_STARTED" (vector-ref (cdb:get-test-info *runremote* 1 "nada" "") 3)) @@ -198,12 +197,12 @@ ;;====================================================================== ;; D B ;;====================================================================== (test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def")) -(test #f (vector '("SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time") '()) - (runs:get-runs-by-patt db keys "%")) +(test #f "key2" (vector-ref (car (vector-ref (runs:get-runs-by-patt *db* '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1)) + (test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))) (test #f #t (runs:operate-on 'print "%" "%" "%")) ;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada" (setenv "BLAHFOO" "1234") @@ -236,10 +235,13 @@ (hash-table-set! args:arg-hash "-testpatt" "%") (hash-table-set! args:arg-hash "-target" "ubuntu/r1.2") (test "Setup for a run" #t (begin (setup-for-run) #t)) (define *tdb* #f) +(define keyvals #f) +(test "target->keyval" #t (let ((kv (keys:target->keyval keys (args:get-arg "-target")))) + (set! keyvals kv)(list? keyvals))) (define testdbpath (conc "/tmp/" (getenv "USER") "/megatest_testing")) (system (conc "rm -f " testdbpath "/testdat.db;mkdir -p " testdbpath)) (print "Using " testdbpath " for test db") @@ -252,37 +254,88 @@ (define tconfig #f) (test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" 'return-procs))) (set! tconfig tconf) (hash-table? tconf))) (db:clean-all-caches) -;; (set! *verbosity* 20) + +(test "set-megatest-env-vars" + "ubuntu" + (begin + (set-megatest-env-vars 1 inkeys: keys) + (get-environment-variable "SYSTEM"))) +(test "setup-env-defaults" + "see this variable" + (begin + (setup-env-defaults "runconfigs.config" 1 *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars") + (get-environment-variable "ALLTESTS"))) + +(test #f "ubuntu" (car (keys:target-set-args keys (args:get-arg "-target") args:arg-hash))) + +(define rinfo #f) +(test "get-run-info" #f (vector? (vector-ref (let ((rinf (cdb:remote-run db:get-run-info #f 1))) + (set! rinfo rinf) + rinf) 0))) +(test "get-key-vals" "key1" (car (cdb:remote-run db:get-key-vals #f 1))) +(test "tests:sort-by" '() (tests:sort-by-priority-and-waiton (make-hash-table))) + +(test "update-test_meta" "test1" (begin + (runs:update-test_meta "test1" tconfig) + (let ((dat (cdb:remote-run db:testmeta-get-record #f "test1"))) + (vector-ref dat 1)))) + +(define test-path "tests/test1") +(define disk-path #f) +(test "get-best-disk" #t (string? (file-exists? (let ((d (get-best-disk *configdat*))) + (set! disk-path d) + d)))) +(test "create-work-area" #t (symbolic-link? (car (create-work-area 1 rinfo keyvals 1 test-path disk-path "test1" '())))) +(test #f "" (item-list->path '())) + +(test "launch-test" #t (string? (file-exists? (launch-test 1 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table))))) + + (test "Run a test" #t (general-run-call "-runtests" "run a test" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvallst) (let ((test-patts "test%")) ;; (runs:run-tests target runname test-patts user (make-hash-table)) + ;; (run:test run-id run-info key-vals runname test-record flags parent-test) + ;; (set! *verbosity* 22) ;; (list 0 1 2)) (run:test 1 ;; run-id - (args:get-arg ":runname") - (keys:target->keyval keys target) - (vector + #f ;; run-info is yet only a dream + keyvallst ;; (keys:target->keyval keys target) + "run1" ;; runname + (vector ;; test_records.scm tests:testqueue "test1" ;; testname tconfig ;; testconfig '() ;; waitons 0 ;; priority #f ;; items #f ;; itemsdat - #f ;; spare + "" ;; itempath ) args:arg-hash ;; flags (e.g. -itemspatt) - #f))))) + #f) + ;; (set! *verbosity* 0) + )))) + + + + + +(test "server stop" #f (let ((hostname (car *runremote*)) + (port (cadr *runremote*))) + (tasks:kill-server #t hostname port server-pid 'http) + (open-run-close tasks:get-best-server tasks:open-db))) -(test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2)) - (non-cached (db:get-test-info-not-cached-by-id db 2))) - (print "\nCached: " cached-info) - (print "Noncached: " non-cached) - (equal? cached-info non-cached))) +(exit 1) +;; (test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2)) +;; (non-cached (db:get-test-info-not-cached-by-id db 2))) +;; (print "\nCached: " cached-info) +;; (print "Noncached: " non-cached) +;; (equal? cached-info non-cached))) (change-directory test-work-dir) (test "Add a step" #t (begin (db:teststep-set-status! db 2 "step1" "start" 0 "This is a comment" "mylogfile.html") @@ -390,11 +443,16 @@ (hash-table-set! args:arg-hash ":runname" "%") (test "Remove the rollup run" #t (begin (operate-on 'remove-runs))) (print "Waiting for server to be done, should be about 20 seconds") -(cdb:kill-server *runremote*) +(test "server stop" #f (let ((hostname (car *runremote*)) + (port (cadr *runremote*))) + (tasks:kill-server #t hostname port server-pid 'http) + (open-run-close tasks:get-best-server tasks:open-db))) + +;; (cdb:kill-server *runremote*) ;; (thread-join! th1 th2 th3) ;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal) ;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '())