Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -6,11 +6,12 @@ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ fs-transport.scm http-transport.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ - tree.scm ezsteps.scm lock-queue.scm + tree.scm ezsteps.scm lock-queue.scm sdb.scm filedb.scm \ + rmt.scm api.scm tdb.scm GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) @@ -59,12 +60,13 @@ # Special dependencies for the includes tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o megatest.o : db_records.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm -runs.o : test_records.scm +runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm +filedb.o : fdb_records.scm # Temporary while transitioning to new routine # runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm Index: NOTES ================================================================== --- NOTES +++ NOTES @@ -1,5 +1,79 @@ +====================================================================== +Try writing to in-memory db and every 2-5 seconds syncing to megatest.db +====================================================================== + +First, how much time will it take to write back the changes: + +1. Get the run table + +(define (get-all db)(let ((res '()))(for-each-row (lambda (a . b)(set! res (cons (apply vector a b) res))) db "SELECT * FROM tests;") res)) +(define tdata (let ((start (current-milliseconds))(res (get-all *db*)))(print (- (current-milliseconds) start))res)) + +Result ranges from 34ms to 89ms but mostly around 40ms for 623 records on moosefs + +Projecting to 15000 records: + + Slow 2 seconds to read all + Median 1 second to read all + +This seems like it would work with an update period of 2-5 seconds + +TODO +---- + +1. open-db opens in-memory db and megatest.db, put handles in *memdb* and *db*, *memdb* is < run-id dbh > +2. Server is part of runtests + a. server start cycle - adapt to per run-id + i. states; starting, started, stopping, stopped + b. turn off write coalesing +3. Calls to -runtests, -remove-runs etc. + a. Might talk to running server if run specific + b. Can talk to megatest.db but not a generally good idea + c. Can start a runserver +4. Dashboard is fine except for writes? + +====================================================================== +Routines to convert for runs.scm + +cdb:remote-run db:register-run + +cdb:delete-tests-in-state *runremote* +cdb:get-test-info-by-id *runremote* +cdb:remote-run db:delete-old-deleted-test-records +cdb:remote-run db:delete-run +cdb:remote-run db:delete-test-records +cdb:remote-run db:delete-tests-for-run +cdb:remote-run db:find-and-mark-incomplete +cdb:remote-run db:get-count-tests-running +cdb:remote-run db:get-count-tests-running-in-jobgroup +cdb:remote-run db:get-keys +cdb:remote-run db:get-run-info +cdb:remote-run db:get-run-key-val +cdb:remote-run db:get-run-name-from-id +cdb:remote-run db:get-steps-for-test +cdb:remote-run db:get-test-id-cached +cdb:remote-run db:get-tests-for-runs-mindata +cdb:remote-run db:lock/unlock-run +cdb:remote-run db:set-sync +cdb:remote-run db:set-tests-state-status +cdb:remote-run db:set-var +cdb:remote-run db:testmeta-add-record +cdb:remote-run db:testmeta-get-record +cdb:remote-run db:testmeta-update-field +cdb:remote-run db:update-run-event_time +cdb:remote-run instead +cdb:remote-run server:start +cdb:remote-run test:get-matching-previous-test-run-records +cdb:tests-register-test *runremote* +(define (runs:shrink-can-run-more-tests-count) ;; the db is a dummy var so we can use cdb:remote-run + +====================================================================== + +[87cbe68f31] +[be405e8e2e] + # FROM andyjpg on #chicken (let ((original-exit (exit-handler))) (exit-handler (lambda (#!optional (exit-code 0)) (printf "Preparing to exit...\n" exit-code) ADDED api.scm Index: api.scm ================================================================== --- /dev/null +++ api.scm @@ -0,0 +1,55 @@ +;;====================================================================== +;; Copyright 2006-2013, 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. +;;====================================================================== + +(declare (unit api)) +(declare (uses rmt)) +(declare (uses db)) + +;; These are called by the server on recipt of /api calls + +(define (api:execute-requests db cmd params) + (debug:print-info 1 "api:execute-requests cmd=" cmd " params=" params) + (db:process-cached-writes db) + (case (string->symbol cmd) + ;; KEYS + ((get-key-val-pairs) (apply db:get-key-val-pairs db params)) + ;; TESTS + ;; json doesn't do vectors, convert to list + ((get-test-info-by-id) (vector->list (apply db:get-test-info-by-id db params))) + ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id db params)) + ((testmeta-get-record) (vector->list (apply db:testmeta-get-record db params))) + ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id db params)) + ;; RUNS + ((get-run-info) (let ((res (apply db:get-run-info db params))) + (list (vector-ref res 0) + (vector->list (vector-ref res 1))))) + (else + (list "ERROR" 0)))) + +;; http-server send-response +;; api:process-request +;; db:* +;; +;; NB// Runs on the server as part of the server loop +;; +(define (api:process-request db $) ;; the $ is the request vars proc + (let* ((cmd ($ 'cmd)) + (paramsj ($ 'params)) + (params (rmt:json-str->dat paramsj)) + (res (api:execute-requests db cmd params))) + (rmt:dat->json-str + (if (or (string? res) + (list? res) + (number? res) + (boolean? res)) + res + (list "ERROR" 1 cmd params res))))) + Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -35,14 +35,10 @@ (if *my-client-signature* *my-client-signature* (let ((sig (conc (get-host-name) " " (current-process-id)))) (set! *my-client-signature* sig) *my-client-signature*))) -;; client:login serverdat -(define (client:login serverdat) - (cdb:login serverdat *toppath* (client:get-signature))) - ;; Not currently used! But, I think it *should* be used!!! (define (client:logout serverdat) (let ((ok (and (socket? serverdat) (cdb:logout serverdat *toppath* (client:get-signature))))) ok)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -27,20 +27,25 @@ (define getenv get-environment-variable) (define home (getenv "HOME")) (define user (getenv "USER")) -;; global gletches +;; GLOBAL GLETCHES (define *db-keys* #f) (define *configinfo* #f) (define *configdat* #f) (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar +(define *global-delta* 0) +(define *last-global-delta-printed* 0) + +;; DATABASE +(define *open-dbs* (vector #f (make-hash-table))) ;; megatestdb run-id-dbs ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'fs) (define *megatest-db* #f) @@ -55,11 +60,11 @@ (define *time-to-exit* #f) (define *received-response* #f) (define *default-numtries* 10) (define *server-run* #t) (define *db-write-access* #t) - +(define *inmemdb* #f) (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 @@ -75,10 +80,14 @@ ;; Testconfig and runconfig caches. (define *testconfigs* (make-hash-table)) ;; test-name => testconfig (define *runconfigs* (make-hash-table)) ;; target => runconfig +;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than +;; five seconds ago +(define *pre-reqs-met-cache* (make-hash-table)) + (define (common:clear-caches) (set! *target* (make-hash-table)) (set! *keys* (make-hash-table)) (set! *keyvals* (make-hash-table)) (set! *toptest-paths* (make-hash-table)) @@ -92,14 +101,29 @@ ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== (define *common:std-states* - (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ" "STUCK")) + '((0 "COMPLETED") + (1 "NOT_STARTED") + (2 "RUNNING") + (3 "REMOTEHOSTSTART") + (4 "LAUNCHED") + (5 "KILLED") + (6 "KILLREQ") + (7 "STUCK"))) (define *common:std-statuses* - (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")) + '((0 "PASS") + (1 "WARN") + (2 "FAIL") + (3 "CHECK") + (4 "n/a") + (5 "WAIVED") + (6 "SKIP") + (7 "DELETED") + (8 "STUCK/DEAD"))) ;; These are stopping conditions that prevent a test from being run (define *common:cant-run-states-sym* '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) @@ -370,13 +394,25 @@ (define (seconds->time-string sec) (time->string (seconds->local-time sec) "%H:%M:%S")) +(define (seconds->work-week/day-time sec) + (time->string + (seconds->local-time sec) "ww%V.%u %H:%M")) + (define (seconds->work-week/day sec) (time->string - (seconds->local-time sec) "%V.%u")) + (seconds->local-time sec) "ww%V.%u")) + +(define (seconds->year-work-week/day sec) + (time->string + (seconds->local-time sec) "%yww%V.%w")) + +(define (seconds->year-work-week/day-time sec) + (time->string + (seconds->local-time sec) "%yww%V.%w %H:%M")) ;;====================================================================== ;; Colors ;;====================================================================== Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -44,11 +44,10 @@ (not (getenv "MT_DEBUG_MODE"))) (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) (string-intersperse (map conc *verbosity*) ",") (conc *verbosity*)))))) - (define (debug:print n . params) (if (debug:debug-mode n) (with-output-to-port (current-error-port) (lambda () (if *logging* Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -118,20 +118,24 @@ (configf:lookup config "default" var)) (configf:lookup config "default" var)))) (define-inline (configf:read-line p ht allow-processing) (let loop ((inl (read-line p))) - (if (and (string? inl) - (not (string-null? inl)) - (equal? "\\" (string-take-right inl 1))) ;; last character is \ - (let ((nextl (read-line p))) - (if (not (eof-object? nextl)) - (loop (string-append inl nextl)))) - (if (and allow-processing - (not (eq? allow-processing 'return-string))) - (configf:process-line inl ht) - inl)))) + (let ((cont-line (and (string? inl) + (not (string-null? inl)) + (equal? "\\" (string-take-right inl 1))))) + (if cont-line ;; last character is \ + (let ((nextl (read-line p))) + (if (not (eof-object? nextl)) + (loop (string-append (if cont-line + (string-take inl (- (string-length inl) 1)) + inl) + nextl)))) + (if (and allow-processing + (not (eq? allow-processing 'return-string))) + (configf:process-line inl ht) + inl))))) ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -24,10 +24,11 @@ (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) (declare (uses gutils)) +(declare (uses rmt)) (declare (uses ezsteps)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -43,11 +44,12 @@ (list "Testname: " "Item path: " "Current state: " "Current status: " "Test comment: " - "Test id: ")) + "Test id: " + "Test date: ")) (list (iup:label "" #:expand "VERTICAL")))) (apply iup:vbox ; #:expand "YES" (list (store-label "testname" (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") @@ -78,10 +80,15 @@ (store-label "testid" (iup:label "TestId " #:expand "HORIZONTAL") (lambda (testdat) (db:test-get-id testdat))) + (store-label "testdate" + (iup:label "TestDate " + #:expand "HORIZONTAL") + (lambda (testdat) + (seconds->work-week/day-time (db:test-get-event_time testdat)))) ))))) ;;====================================================================== ;; Test meta panel ;;====================================================================== @@ -126,27 +133,35 @@ ;;====================================================================== ;; Run info panel ;;====================================================================== -(define (run-info-panel keydat testdat runname) - (iup:frame - #:title "Megatest Run Info" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" - (append (map (lambda (keyval) - (iup:label (conc (car keyval) " ") ; #:expand "HORIZONTAL" - )) - keydat) - (list (iup:label "runname ")(iup:label "run-id")))) - (apply iup:vbox - (append (map (lambda (keyval) - (iup:label (cadr keyval) #:expand "HORIZONTAL")) - keydat) - (list (iup:label runname) - (iup:label (conc (db:test-get-run_id testdat))) - (iup:label "" #:expand "VERTICAL"))))))) +(define (run-info-panel db keydat testdat runname) + (let* ((run-id (db:test-get-run_id testdat)) + (rundat (db:get-run-info db run-id)) + (header (db:get-header rundat)) + (event_time (db:get-value-by-header (db:get-row rundat) + (db:get-header rundat) + "event_time"))) + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (keyval) + (iup:label (conc (car keyval) " "))) + keydat) + (list (iup:label "runname ") + (iup:label "run-id") + (iup:label "run-date")))) + (apply iup:vbox + (append (map (lambda (keyval) + (iup:label (cadr keyval) #:expand "HORIZONTAL")) + keydat) + (list (iup:label runname) + (iup:label (conc run-id)) + (iup:label (seconds->year-work-week/day-time event_time)) + (iup:label "" #:expand "VERTICAL")))))))) ;;====================================================================== ;; Host info panel ;;====================================================================== (define (host-info-panel testdat store-label) @@ -199,33 +214,34 @@ (define *dashboard-test-db* #t) ;;====================================================================== ;; Set fields ;;====================================================================== -(define (set-fields-panel test-id testdat #!key (db #f)) +(define (set-fields-panel db test-id testdat #!key (db #f)) (let ((newcomment #f) (newstatus #f) (newstate #f)) (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (iup:textbox #:action (lambda (val a b) - (open-run-close db:test-set-state-status-by-id db test-id #f #f b) + (db:test-set-state-status-by-id db test-id #f #f b) + ;; IDEA: Just set a variable with the proc to call? (set! newcomment b)) #:value (db:test-get-comment testdat) #:expand "HORIZONTAL")) (apply iup:hbox (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (open-run-close db:test-set-state-status-by-id db test-id state #f #f) + (db:test-set-state-status-by-id db test-id state #f #f) (db:test-set-state! testdat state))))) btn)) - *common:std-states*))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) + (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) @@ -238,14 +254,19 @@ (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (open-run-close db:test-set-state-status-by-id db test-id #f status #f) - (db:test-set-status! testdat status))))) + (let ((t (iup:attribute x "TITLE"))) + (if (equal? t "WAIVED") + (iup:show (dashboard-tests:waiver testdat (lambda (c) + (set! newcomment c)))) + (begin + (open-run-close db:test-set-state-status-by-id db test-id #f status #f) + (db:test-set-status! testdat status)))))))) btn)) - *common:std-statuses*))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) + (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) @@ -286,41 +307,262 @@ ;; (iup:button "Refresh test data" ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) +;; get a pretty table to summarize steps +;; +(define (dashboard-tests:process-steps-table steps);; db test-id #!key (work-area #f)) +;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) + ;; organise the steps for better readability + (let ((res (make-hash-table))) + (for-each + (lambda (step) + (debug:print 6 "step=" step) + (let ((record (hash-table-ref/default + res + (db:step-get-stepname step) + ;; stepname start end status Duration Logfile + (vector (db:step-get-stepname step) "" "" "" "" "")))) + (debug:print 6 "record(before) = " record + "\nid: " (db:step-get-id step) + "\nstepname: " (db:step-get-stepname step) + "\nstate: " (db:step-get-state step) + "\nstatus: " (db:step-get-status step) + "\ntime: " (db:step-get-event_time step)) + (case (string->symbol (db:step-get-state step)) + ((start)(vector-set! record 1 (db:step-get-event_time step)) + (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (db:step-get-status step))) + (if (> (string-length (db:step-get-logfile step)) + 0) + (vector-set! record 5 (db:step-get-logfile step)))) + ((end) + (vector-set! record 2 (any->number (db:step-get-event_time step))) + (vector-set! record 3 (db:step-get-status step)) + (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) + (endt (any->number (vector-ref record 2)))) + (debug:print 4 "record[1]=" (vector-ref record 1) + ", startt=" startt ", endt=" endt + ", get-status: " (db:step-get-status step)) + (if (and (number? startt)(number? endt)) + (seconds->hr-min-sec (- endt startt)) "-1"))) + (if (> (string-length (db:step-get-logfile step)) + 0) + (vector-set! record 5 (db:step-get-logfile step)))) + (else + (vector-set! record 2 (db:step-get-state step)) + (vector-set! record 3 (db:step-get-status step)) + (vector-set! record 4 (db:step-get-event_time step)))) + (hash-table-set! res (db:step-get-stepname step) record) + (debug:print 6 "record(after) = " record + "\nid: " (db:step-get-id step) + "\nstepname: " (db:step-get-stepname step) + "\nstate: " (db:step-get-state step) + "\nstatus: " (db:step-get-status step) + "\ntime: " (db:step-get-event_time step)))) + ;; (else (vector-set! record 1 (db:step-get-event_time step))) + (sort steps (lambda (a b) + (cond + ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t) + ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) + (< (db:step-get-id a) (db:step-get-id b))) + (else #f))))) + res)) + +(define (dashboard-tests:get-compressed-steps test-id #!key (work-area #f)) + (if (or (not work-area) + (file-exists? (conc work-area "/testdat.db"))) + (let* ((steps-data (rmt:get-steps-for-test test-id work-area)) + (comprsteps (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) + (map (lambda (x) + ;; take advantage of the \n on time->string + (vector + (vector-ref x 0) + (let ((s (vector-ref x 1))) + (if (number? s)(seconds->time-string s) s)) + (let ((s (vector-ref x 2))) + (if (number? s)(seconds->time-string s) s)) + (vector-ref x 3) ;; status + (vector-ref x 4) + (vector-ref x 5))) ;; time delta + (sort (hash-table-values comprsteps) + (lambda (a b) + (let ((time-a (vector-ref a 1)) + (time-b (vector-ref b 1))) + (if (and (number? time-a)(number? time-b)) + (if (< time-a time-b) + #t + (if (eq? time-a time-b) + (stringsymbol (tdb:step-get-state step)) + ((start)(vector-set! record 1 (tdb:step-get-event_time step)) + (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (tdb:step-get-status step))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + ((end) + (vector-set! record 2 (any->number (tdb:step-get-event_time step))) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) + (endt (any->number (vector-ref record 2)))) + (debug:print 4 "record[1]=" (vector-ref record 1) + ", startt=" startt ", endt=" endt + ", get-status: " (tdb:step-get-status step)) + (if (and (number? startt)(number? endt)) + (seconds->hr-min-sec (- endt startt)) "-1"))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + (else + (vector-set! record 2 (tdb:step-get-state step)) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (tdb:step-get-event_time step)))) + (hash-table-set! res (tdb:step-get-stepname step) record) + (debug:print 6 "record(after) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)))) + ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) + (sort steps (lambda (a b) + (cond + ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) + ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) + (< (tdb:step-get-id a) (tdb:step-get-id b))) + (else #f))))) + res)) + +(define (dashboard-tests:get-compressed-steps db test-id) + (let* ((steps-data (db:get-steps-for-test db test-id)) + (comprsteps (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) + (map (lambda (x) + ;; take advantage of the \n on time->string + (vector + (vector-ref x 0) + (let ((s (vector-ref x 1))) + (if (number? s)(seconds->time-string s) s)) + (let ((s (vector-ref x 2))) + (if (number? s)(seconds->time-string s) s)) + (vector-ref x 3) ;; status + (vector-ref x 4) + (vector-ref x 5))) ;; time delta + (sort (hash-table-values comprsteps) + (lambda (a b) + (let ((time-a (vector-ref a 1)) + (time-b (vector-ref b 1))) + (if (and (number? time-a)(number? time-b)) + (if (< time-a time-b) + #t + (if (eq? time-a time-b) + (string= curr-mod-time db-mod-time) (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds request-update)) (newtestdat (if need-update + ;; NOTE: BUG HIDER, try to eliminate this exception handler (handle-exceptions exn - (debug:print-info 2 "test db access issue: " ((condition-property-accessor 'exn 'message) exn)) - (open-run-close db:get-test-info-by-id db test-id ))))) + (debug:print-info 0 "test db access issue: " ((condition-property-accessor 'exn 'message) exn)) + (db:get-test-info-by-id db test-id ))))) + ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) - (set! teststeps (db:get-compressed-steps test-id work-area: rundir)) + (set! teststeps (dashboard-tests:get-compressed-steps db test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir (db:test-get-rundir testdat)) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) - (if (eq? curr-mod-time db-mod-time) ;; do only once if same - (set! db-mod-time (+ curr-mod-time 1)) + + ;; I don't see why this was implemented this way. Please comment it ... + ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same + ;; (set! db-mod-time (+ curr-mod-time 1)) + ;; (set! db-mod-time curr-mod-time)) + + (if (not (eq? curr-mod-time db-mod-time)) (set! db-mod-time curr-mod-time)) (set! last-update (current-milliseconds)) (set! request-update #f) ;; met the need ... ) (need-update ;; if this was true and yet there is no data .... @@ -477,11 +726,11 @@ (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" #:title testfullname (iup:vbox ; #:expand "YES" ;; The run and test info (iup:hbox ; #:expand "YES" - (run-info-panel keydat testdat runname) + (run-info-panel db keydat testdat runname) (test-info-panel testdat store-label widgets) (test-meta-panel testmeta store-meta)) (host-info-panel testdat store-label) ;; The controls (iup:frame #:title "Actions" @@ -495,11 +744,11 @@ (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x") (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) (apply iup:hbox (list command-text-box command-launch-button)))) - (set-fields-panel test-id testdat) + (set-fields-panel db test-id testdat) (let ((tabs (iup:tabs ;; Replace here with matrix (let ((steps-matrix (iup:matrix #:font "Courier New, -8" @@ -536,22 +785,22 @@ ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) (let ((max-row 0)) - (if (not (null? teststeps)) - (let loop ((hed (car teststeps)) - (tal (cdr teststeps)) - (rownum 1) - (colnum 1)) + (if (not (null? teststeps)) + (let loop ((hed (car teststeps)) + (tal (cdr teststeps)) + (rownum 1) + (colnum 1)) (if (> rownum max-row)(set! max-row rownum)) - (let ((val (vector-ref hed (- colnum 1))) - (mtrx-rc (conc rownum ":" colnum))) - (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) - (if (< colnum 6) - (loop hed tal rownum (+ colnum 1)) - (if (not (null? tal)) + (let ((val (vector-ref hed (- colnum 1))) + (mtrx-rc (conc rownum ":" colnum))) + (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) + (if (< colnum 6) + (loop hed tal rownum (+ colnum 1)) + (if (not (null? tal)) (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) (if (> max-row 0) (begin ;; we are going to speculatively clear rows until we find a row that is already cleared (let loop ((rownum (+ max-row 1)) @@ -603,11 +852,11 @@ (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) - (open-run-close db:read-test-data db test-id "%"))) + (tdb:open-run-close-db-by-test-id-local test-id #f tdb:read-test-data test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data)) ;;(dashboard:run-controls) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -39,10 +39,11 @@ (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") +(include "megatest-fossil-hash.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2013 @@ -63,10 +64,11 @@ (list "-rows" "-run" "-test" "-debug" "-host" + "-transport" ) (list "-h" "-use-server" "-guimonitor" "-main" @@ -84,29 +86,30 @@ (if (not (setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *db* #f) ;; (open-db)) - -(if (args:get-arg "-host") - (begin - (set! *runremote* (string-split (args:get-arg "-host" ":"))) - (client:launch)) - (if (not (args:get-arg "-use-server")) - (set! *transport-type* 'fs) ;; force fs access - (client:launch))) +(define *db* (open-db)) + +;; (if (args:get-arg "-host") +;; (begin +;; (set! *runremote* (string-split (args:get-arg "-host" ":"))) +;; (client:launch)) +;; (if (not (args:get-arg "-use-server")) +;; (set! *transport-type* 'fs) ;; force fs access +;; (client:launch))) +;; (client:launch)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db")))) ;; (client:setup *db*) (define toplevel #f) (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 *keys* (cdb:remote-run db:get-keys #f)) ;; (define *keys* (db:get-keys *db*)) (define *dbkeys* (append *keys* (list "runname"))) (define *header* #f) @@ -116,11 +119,11 @@ (define *buttondat* (make-hash-table)) ;; (define *alltestnamelst* '()) (define *searchpatts* (make-hash-table)) (define *num-runs* 8) -(define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%")) +(define *tot-run-count* (db:get-num-runs *db* "%")) ;; (define *tot-run-count* (db:get-num-runs *db* "%")) ;; Update management ;; (define *last-update* (current-seconds)) @@ -203,11 +206,11 @@ (null? (filter (lambda (x)(> x 3)) delta)))) ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat runnamepatt numruns testnamepatt keypatts) (let* ((referenced-run-ids '()) - (allruns (cdb:remote-run db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + (allruns (db:get-runs *db* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) *start-run-offset* keypatts)) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) (maxtests 0) @@ -222,17 +225,21 @@ ;; ;; trim runs to only those that are changing often here ;; (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (mt:get-tests-for-run run-id testnamepatt states statuses - not-in: *hide-not-hide* - sort-by: sort-by - sort-order: sort-order)) + (tests (db:get-tests-for-run *db* run-id testnamepatt states statuses + #f #f + *hide-not-hide* + sort-by + sort-order + 'shortlist)) ;; NOTE: bubble-up also sets the global *all-item-test-names* ;; (tests (bubble-up tmptests priority: bubble-type)) - (key-vals (cdb:remote-run db:get-key-vals #f run-id))) + (key-vals (db:get-key-vals *db* run-id))) + ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. + ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? (set! referenced-run-ids (cons run-id referenced-run-ids)) (if (> (length tests) maxtests) (set! maxtests (length tests))) (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set @@ -459,11 +466,11 @@ (testname (db:test-get-testname test)) (itempath (db:test-get-item-path test)) (testfullname (test:test-get-fullname test)) (teststatus (db:test-get-status test)) (teststate (db:test-get-state test)) - (teststart (db:test-get-event_time test)) + ;;(teststart (db:test-get-event_time test)) (runtime (db:test-get-run_duration test)) (buttontxt (if (equal? teststate "COMPLETED") teststatus teststate)) (button (vector-ref columndat rown)) (color (car (gutils:get-color-for-state-status teststate teststatus))) (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) @@ -553,11 +560,11 @@ (iup:attribute-set! lb "VALUE" newval) newval)))))) (define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) (let* ((runconf-targs (common:get-runconfig-targets)) - (db-target-dat (open-run-close db:get-targets #f)) + (db-target-dat (db:get-targets *db*)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (all-targets (append db-targets (map (lambda (x) (list->vector @@ -818,11 +825,11 @@ (iup:attribute-set! tb "VALUE" val) (dboard:data-set-run-name! *data* val) (dashboard:update-run-command)))) (refresh-runs-list (lambda () (let* ((target (dboard:data-get-target-string *data*)) - (runs-for-targ (mt:get-runs-by-patt *keys* "%" target)) + (runs-for-targ (db:get-runs-by-patt *db* *keys* "%" target #f #f)) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) @@ -867,19 +874,19 @@ ;; Text box for STATES (iup:frame #:title "States" (dashboard:text-list-toggle-box ;; Move these definitions to common and find the other useages and replace! - *common:std-states* ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") + (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") (lambda (all) (dboard:data-set-states! *data* all) (dashboard:update-run-command)))) ;; Text box for STATES (iup:frame #:title "Statuses" (dashboard:text-list-toggle-box - *common:std-statuses* ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") + (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") (lambda (all) (dboard:data-set-statuses! *data* all) (dashboard:update-run-command)))))))) (iup:frame @@ -978,11 +985,11 @@ ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area -(define (dashboard:summary) +(define (dashboard:summary db) (let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string))) (iup:vbox (iup:split ;; #:value 500 (iup:frame @@ -1003,11 +1010,11 @@ ;; (iup:frame ;; #:title "Disks Areas" (dcommon:section-matrix rawconfig "disks" "Disk area" "Path")))) (iup:frame #:title "Run statistics" - (dcommon:run-stats))))) + (dcommon:run-stats db))))) ;;====================================================================== ;; R U N ;;====================================================================== ;; @@ -1019,11 +1026,11 @@ #f)) (define dashboard:update-run-summary-tab #f) ;; (define (tests window-id) -(define (dashboard:one-run) +(define (dashboard:one-run db) (let* ((tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" @@ -1039,19 +1046,21 @@ ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) )))) (run-matrix (iup:matrix #:expand "YES")) (updater (lambda () - (let* ((runs-dat (mt:get-runs-by-patt *keys* "%" #f)) + (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:data-get-curr-run-id *data*)) - (tests-dat (let ((tdat (mt:get-tests-for-run run-id + (tests-dat (let ((tdat (db:get-tests-for-run db run-id (hash-table-ref/default *searchpatts* "test-name" "%/%") (hash-table-keys *state-ignore-hash*) ;; '() (hash-table-keys *status-ignore-hash*) ;; '() - not-in: *hide-not-hide* - qryvals: "id,testname,item_path,state,status"))) ;; get 'em all + #f #f + *hide-not-hide* + #f #f + "id,testname,item_path,state,status"))) ;; get 'em all (sort tdat (lambda (a b) (let* ((aval (vector-ref a 2)) (bval (vector-ref b 2)) (anum (string->number aval)) (bnum (string->number bval))) @@ -1164,11 +1173,11 @@ ;;====================================================================== ;; R U N S ;;====================================================================== -(define (make-dashboard-buttons nruns ntests keynames) +(define (make-dashboard-buttons db nruns ntests keynames) (let* ((nkeys (length keynames)) (runsvec (make-vector nruns)) (header (make-vector nruns)) (lftcol (make-vector ntests)) (keycol (make-vector ntests)) @@ -1238,21 +1247,21 @@ (mark-for-update) (if (eq? val 1) (hash-table-set! *status-ignore-hash* status #t) (hash-table-delete! *status-ignore-hash* status)) (set-bg-on-filter)))) - *common:std-statuses*)) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) + (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) (apply iup:hbox (map (lambda (state) (iup:toggle state #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) (hash-table-set! *state-ignore-hash* state #t) (hash-table-delete! *state-ignore-hash* state)) (set-bg-on-filter)))) - *common:std-states*)) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) + (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) (oldmax (string->number (iup:attribute obj "MAX"))) (maxruns *tot-run-count*)) (set! *start-run-offset* val) @@ -1375,13 +1384,13 @@ controls)) (tabs (iup:tabs #:tabchangepos-cb (lambda (obj curr prev) (set! *please-update-buttons* #t) (set! *current-tab-number* curr)) - (dashboard:summary) + (dashboard:summary db) runs-view - (dashboard:one-run) + (dashboard:one-run db) (dashboard:run-controls) ))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") @@ -1420,11 +1429,11 @@ (or please-update-buttons (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) (> modtime last-db-update-time) (> (current-seconds)(+ last-db-update-time 1))))) -(define *monitor-db-path* (conc *toppath* "/monitor.db")) +(define *monitor-db-path* (conc *toppath* "/db/monitor.db")) (define *last-monitor-update-time* 0) ;; Force creation of the db in case it isn't already there. (let ((db (tasks:open-db))) (sqlite3:finalize! db)) @@ -1481,11 +1490,11 @@ (if runid (begin (lambda (x) (on-exit (lambda () (if *db* (sqlite3:finalize! *db*)))) - (cdb:remote-run examine-run *db* runid))) + (examine-run *db* runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) ((args:get-arg "-test") (let ((testid (string->number (args:get-arg "-test")))) @@ -1496,11 +1505,11 @@ (debug:print 3 "INFO: tried to open test with invalid test-id. " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") (gui-monitor *db*)) (else - (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*)) + (set! uidat (make-dashboard-buttons *db* *num-runs* *num-tests* *dbkeys*)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) (let ((update-is-running #f)) (mutex-lock! *update-mutex*) @@ -1515,5 +1524,6 @@ (set! *update-is-running* #f) (mutex-unlock! *update-mutex*)))) 1)))) (iup:main-loop) +(sqlite3:finalize! *db*) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -14,11 +14,11 @@ ;;====================================================================== (require-extension (srfi 18) extras tcp) ;; rpc) ;; (import (prefix rpc rpc:)) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) ;; Note, try to remove this dependency ;; (use zmq) @@ -28,10 +28,11 @@ (declare (uses keys)) (declare (uses ods)) (declare (uses fs-transport)) (declare (uses client)) (declare (uses mt)) +(declare (uses filedb)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") @@ -41,12 +42,23 @@ (define *incoming-writes* '()) (define *completed-writes* (make-hash-table)) (define *incoming-last-time* (current-seconds)) (define *incoming-mutex* (make-mutex)) (define *completed-mutex* (make-mutex)) -(define *cache-on* #f) +(define (db:get-db dbstruct run-id) + (let ((db (if run-id + (hash-table-ref/default (vector-ref dbstruct 1) run-id #f) + (vector-ref dbstruct 0)))) + (if db + db + (let ((db (open-db run-id))) + (if run-id + (hash-table-set! (vector-ref dbstruct 1) run-id db) + (vector-set! dbstruct 0 db)) + db)))) + (define (db:set-sync db) (let* ((syncval (config-lookup *configdat* "setup" "synchronous")) (val (cond ;; 0 | OFF | 1 | NORMAL | 2 | FULL; ((not syncval) #f) ((string->number syncval) @@ -61,88 +73,399 @@ (if val (begin (debug:print-info 9 "db:set-sync, setting pragma synchronous to " val) (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';")))))) -(define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) +;;====================================================================== +;; K E E P F I L E D B I N dbstruct +;;====================================================================== + +(define (db:get-filedb dbstruct) + (let ((db (vector-ref dbstruct 2))) + (if db + db + (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db")))) + (vector-set! dbstruct 2 fdb) + fdb)))) + +;; Can also be used to save arbitrary strings +;; +(define (db:save-path dbstruct path) + (let ((fdb (db:get-filedb dbstruct))) + (filedb:register-path fdb path))) + +;; Use to get a path. To get an arbitrary string see next define +;; +(define (db:get-path dbstruct id) + (let ((fdb (db:get-filedb dbstruct))) + (filedb:get-path db id))) + +;;====================================================================== +;; U S E F I L E D B T O S T O R E S T R I N G S +;; +;; N O T E ! ! T H I S C L O B B E R S M U L T I P L E //// T O / +;; +;; Replace with something proper! +;; +;;====================================================================== + +;; Use to save a stored string, pad with _ to deal with trimming the prepending of / +;; +(define (db:save-string dbstruct str) + (let ((fdb (db:get-filedb dbstruct))) + (filedb:register-path fdb (conc "_" str)))) + +;; Use to get a stored string +;; +(define (db:get-string dbstruct id) + (let ((fdb (db:get-filedb dbstruct))) + (string-drop (filedb:get-path fdb id) 2))) + +;; This routine creates the db. It is only called if the db is not already opened +;; +(define (open-db dbstruct run-id) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (if (not *toppath*) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") (exit)))) - (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) - (dbexists (file-exists? dbpath)) + (let* ((dbpath (if run-id + (conc *toppath* "/db/" run-id ".db") + (let ((dbdir (conc *toppath* "/db"))) ;; use this opportunity to create our db dir + (if (not (directory-exists? dbdir)) + (create-direcory dbdir)) + (conc *toppath* "/megatest.db")))) + (dbexists (file-exists? dbpath)) + (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (write-access (file-write-access? dbpath)) - (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) ;; 136000))) ;; 136000 = 2.2 minutes + (handler (make-busy-timeout (if (args:get-arg "-override-timeout") + (string->number (args:get-arg "-override-timeout")) + 136000)))) ;; 136000))) ;; 136000 = 2.2 minutes (if (and dbexists (not write-access)) (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv)) - (sqlite3:set-busy-handler! db handler) + (if write-access (sqlite3:set-busy-handler! db handler)) (if (not dbexists) + (if (not run-id) ;; do the megatest.db + (db:initialize-megatest-db db) + (db:initialize-run-id-db db run-id))) + (sqlite3:execute db "PRAGMA synchronous = 0;") + db)) + +;; close all opened run-id dbs +(define (db:close-all-db) + (for-each + (lambda (db) + (finalize! db)) + (hash-table-values (vector-ref *open-dbs* 1))) + (finalize! (vector-ref *open-dbs* 0))) + +(define (open-in-mem-db) + (let* ((path (configf:lookup *configdat* "setup" "tmpdb")) + (fname (if path (conc path "/temp-megatest.db") #f)) + (exists (and path (file-exists? fname))) + (db (if path + (begin + (create-directory path #t) + (sqlite3:open-database fname)) + (sqlite3:open-database ":memory:"))) + (handler (make-busy-timeout 3600))) + (if (or (not path) + (not exists)) (db:initialize db)) - (db:set-sync db) + (sqlite3:set-busy-handler! db handler) db)) +;; (define (db:sync-table tblname fields fromdb todb) + +(define (db:tbls db) + (let ((keys (db:get-keys db))) + (list + (list "keys" + '("id" #f) + '("fieldname" #f) + '("fieldtype" #f)) + (list "metadat" '("var" #f) '("val" #f)) + (append (list "runs" + '("id" #f)) + (map (lambda (k)(list k #f)) + (append keys + (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))) + (list "tests" + '("id" #f) + '("run_id" #f) + '("testname" #f) + '("host" #f) + '("cpuload" #f) + '("diskfree" #f) + '("uname" #f) + '("rundir" #f) + '("shortdir" #f) + '("item_path" #f) + '("state" #f) + '("status" #f) + '("attemptnum" #f) + '("final_logf" #f) + '("logdat" #f) + '("run_duration" #f) + '("comment" #f) + '("event_time" #f) + '("fail_count" #f) + '("pass_count" #f) + '("archived" #f)) + (list "test_steps" + '("id" #f) + '("test_id" #f) + '("stepname" #f) + '("state" #f) + '("status" #f) + '("event_time" #f) + '("comment" #f) + '("logfile" #f)) + (list "test_meta" + '("id" #f) + '("testname" #f) + '("owner" #f) + '("description" #f) + '("reviewed" #f) + '("iterated" #f) + '("avg_runtime" #f) + '("avg_disk" #f) + '("tags" #f) + '("jobgroup" #f))))) + +;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) +(define (db:sync-tables tbls fromdb todb) + (let ((stmts (make-hash-table)) ;; table-field => stmt + (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) + (numrecs (make-hash-table)) + (start-time (current-milliseconds))) + (for-each ;; table + (lambda (tabledat) + (let* ((tablename (car tabledat)) + (fields (cdr tabledat)) + (num-fields (length fields)) + (field->num (make-hash-table)) + (num->field (apply vector (map car fields))) + (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") + " FROM " tablename ";")) + (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " + " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) + (fromdat '()) + (todat (make-hash-table)) + (count 0)) + + ;; set up the field->num table + (for-each + (lambda (field) + (hash-table-set! field->num field count) + (set! count (+ count 1))) + fields) + + ;; read the source table + (sqlite3:for-each-row + (lambda (a . b) + (set! fromdat (cons (apply vector a b) fromdat))) + fromdb + full-sel) + + ;; read the target table + (sqlite3:for-each-row + (lambda (a . b) + (hash-table-set! todat a (apply vector a b))) + todb + full-sel) + + ;; first pass implementation, just insert all changed rows + (let ((stmth (sqlite3:prepare todb full-ins))) + (sqlite3:with-transaction + todb + (lambda () + (for-each ;; + (lambda (fromrow) + (let* ((a (vector-ref fromrow 0)) + (curr (hash-table-ref/default todat a #f)) + (same #t)) + (let loop ((i 0)) + (if (or (not curr) + (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) + (set! same #f)) + (if (and same + (< i (- num-fields 1))) + (loop (+ i 1)))) + (if (not same) + (begin + (apply sqlite3:execute stmth (vector->list fromrow)) + (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) + fromdat))) + (sqlite3:finalize! stmth)))) + tbls) + (let ((runtime (- (current-milliseconds) start-time))) + (debug:print 0 "INFO: db sync, total run time " runtime " ms") + (for-each + (lambda (dat) + (let ((tblname (car dat)) + (count (cdr dat))) + (if (> count 0) + (debug:print 0 (format #f " ~10a ~5a" tblname count))))) + (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))))) + +;; (define (db:sync-to fromdb todb) +;; ;; strategy +;; ;; 1. Get all run-ids +;; ;; 2. For each run-id +;; ;; a. Sync that run in a transaction +;; (let ((trecchgd 0) +;; (rrecchgd 0) +;; (tmrecchgd 0)) +;; +;; ;; First sync test_meta data +;; (let ((tmgetstmt (sqlite3:prepare todb "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE id=?;")) +;; (tmputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO test_meta (id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup) +;; VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);")) +;; (tmdats (db:testmeta-get-all fromdb))) +;; ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) +;; (for-each +;; (lambda (tmdat) ;; iterate over tests +;; (let ((testm-id (vector-ref tmdat 0))) +;; (sqlite3:with-transaction +;; todb +;; (lambda () +;; (let ((curr-tmdat #f)) +;; (sqlite3:for-each-row +;; (lambda (a . b) +;; (set! curr-tmdat (apply vector a b))) +;; tmgetstmt testm-id) +;; (if (not (equal? curr-tmdat tmdat)) ;; something changed +;; (begin +;; (debug:print 0 " test-id: " testm-id +;; "\ncurr-tdat: " curr-tmdat +;; "\n tdat: " tmdat) +;; (apply sqlite3:execute tmputstmt (vector->list tmdat)) +;; (set! tmrecchgd (+ tmrecchgd 1))))))))) +;; tmdats) +;; (sqlite3:finalize! tmgetstmt) +;; (sqlite3:finalize! tmputstmt)) +;; +;; ;; First sync tests data +;; (let ((run-ids (db:get-all-run-ids fromdb)) +;; (tgetstmt (sqlite3:prepare todb "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;")) +;; (tputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO tests (id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) +;; VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );"))) +;; (for-each +;; (lambda (run-id) +;; (let ((tdats (db:get-all-tests-info-by-run-id fromdb run-id))) +;; ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) +;; (for-each +;; (lambda (tdat) ;; iterate over tests +;; (let ((test-id (vector-ref tdat 0))) +;; (sqlite3:with-transaction +;; todb +;; (lambda () +;; (let ((curr-tdat #f)) +;; (sqlite3:for-each-row +;; (lambda (a . b) +;; (set! curr-tdat (apply vector a b))) +;; tgetstmt +;; test-id) +;; (if (not (equal? curr-tdat tdat)) ;; something changed +;; (begin +;; (debug:print 0 " test-id: " test-id +;; "\ncurr-tdat: " curr-tdat +;; "\n tdat: " tdat) +;; (apply sqlite3:execute tputstmt (vector->list tdat)) +;; (set! trecchgd (+ trecchgd 1))))))))) +;; tdats))) +;; run-ids) +;; (sqlite3:finalize! tgetstmt) +;; (sqlite3:finalize! tputstmt)) +;; +;; ;; Next sync runs table +;; (let* ((rdats '()) +;; (keys (db:get-keys fromdb)) +;; (rstdfields (conc "id," (string-intersperse keys ",") ",runname,state,status,owner,event_time,comment,fail_count,pass_count")) +;; (rnumfields (length (string-split rstdfields ","))) +;; (runslots (string-intersperse (make-list rnumfields "?") ",")) +;; (rgetstmt (sqlite3:prepare todb (conc "SELECT " rstdfields " FROM runs WHERE id=?;"))) +;; (rputstmt (sqlite3:prepare todb (conc "INSERT OR REPLACE INTO runs (" rstdfields ") VALUES ( " runslots " );")))) +;; ;; first collect all the source run data +;; (sqlite3:for-each-row +;; (lambda (a . b) +;; (set! rdats (cons (apply vector a b) rdats))) +;; fromdb +;; (conc "SELECT " rstdfields " FROM runs;")) +;; (sqlite3:with-transaction +;; todb +;; (lambda () +;; (for-each +;; (lambda (rdat) +;; (let ((run-id (vector-ref rdat 0)) +;; (curr-rdat #f)) +;; ;; first get the current value of the equivalent row from the target +;; ;; read, then insert/overwrite if different +;; (sqlite3:for-each-row +;; (lambda (a . b) +;; (set! curr-rdat (apply vector a b))) +;; rgetstmt +;; run-id) +;; (if (not (equal? curr-rdat rdat)) +;; (begin +;; (debug:print 0 " run-id: " run-id +;; "\ncurr-rdat: " curr-rdat +;; "\n rdat: " rdat) +;; (set! rrecchgd (+ rrecchgd 1)) +;; (apply sqlite3:execute rputstmt (vector->list rdat)))))) +;; rdats))) +;; (sqlite3:finalize! rgetstmt) +;; (sqlite3:finalize! rputstmt)) +;; +;; (if (> rrecchgd 0) (debug:print 0 "synced " rrecchgd " changed records in runs table")) +;; (if (> trecchgd 0) (debug:print 0 "synced " trecchgd " changed records in tests table")) +;; (if (> tmrecchgd 0) (debug:print 0 "sync'd " tmrecchgd " changed records in test_meta table")) +;; (+ rrecchgd trecchgd tmrecchgd))) + +(define (db:sync-back) + (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) + ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) - (let* ((db (if idb - (if (procedure? idb) - (idb) - idb) - (open-db))) - (res #f)) - (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! db)) - (debug:print-info 11 "open-run-close-no-exception-handling END" ) - res)) + (if (or *db-write-access* + (not (member proc *db:all-write-procs*))) + (let* ((db (cond + ((sqlite3:database? idb) idb) + ((not idb) (open-db)) + ((procedure? idb) (idb)) + (else (open-db)))) + (res #f)) + (set! res (apply proc db params)) + (if (not idb)(sqlite3:finalize! db)) + (debug:print-info 11 "open-run-close-no-exception-handling END" ) + res) + #f)) (define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn (begin - (debug:print 0 "EXCEPTION: database probably overloaded?") + (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") (debug:print 0 " " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain) (thread-sleep! (random 120)) (debug:print-info 0 "trying db call one more time....") (apply open-run-close-no-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) -;; (define open-run-close open-run-close-exception-handling) -(define open-run-close open-run-close-no-exception-handling) - -(define *global-delta* 0) -(define *last-global-delta-printed* 0) - -(define (open-run-close-measure proc idb . params) - (debug:print-info 11 "open-run-close-measure START, idb=" idb ", params=" params) - (let* ((start-ms (current-milliseconds)) - (db (if idb idb (open-db))) - (throttle (string->number (config-lookup *configdat* "setup" "throttle")))) - ;; (db:set-sync db) - (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! db)) - ;; scale by 10, average with current value. - (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) - (if throttle throttle 0.01))) - 2)) - (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit - (begin - (debug:print-info 1 "launch throttle factor=" *global-delta*) - (set! *last-global-delta-printed* *global-delta*))) - (debug:print-info 11 "open-run-close-measure END" ) - res)) - -(define (db:initialize db) - (debug:print-info 11 "db:initialize START") +;; (define open-run-close +(define open-run-close (if (debug:debug-mode 2) + open-run-close-no-exception-handling + open-run-close-exception-handling)) + +(define (db:initialize-megatest-db db) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... - (keys (keys:config-get-fields configdat)) + (keys (keys:configq-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys))) (for-each (lambda (key) (let ((keyn key)) @@ -152,71 +475,28 @@ (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table") (system (conc "rm -f " dbpath)) (exit 1))))) 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 "TEXT")) keys) (sqlite3:execute db (conc "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " fieldstr (if havekeys "," "") - "runname TEXT," - "state TEXT DEFAULT ''," - "status TEXT DEFAULT ''," - "owner TEXT DEFAULT ''," - "event_time TIMESTAMP," - "comment TEXT DEFAULT ''," + "runname TEXT DEFAULT 'norun'," + "state TEXT DEFAULT ''," + "status TEXT DEFAULT ''," + "owner TEXT DEFAULT ''," + "event_time TIMESTAMP DEFAULT (strftime('%s','now'))," + "comment TEXT DEFAULT ''," "fail_count INTEGER DEFAULT 0," "pass_count INTEGER DEFAULT 0," "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) - (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");")) - (sqlite3:execute db - "CREATE TABLE IF NOT EXISTS tests - (id INTEGER PRIMARY KEY, - run_id INTEGER, - testname TEXT, - host TEXT DEFAULT 'n/a', - cpuload REAL DEFAULT -1, - diskfree INTEGER DEFAULT -1, - uname TEXT DEFAULT 'n/a', - rundir TEXT DEFAULT 'n/a', - shortdir TEXT DEFAULT '', - item_path TEXT DEFAULT '', - state TEXT DEFAULT 'NOT_STARTED', - status TEXT DEFAULT 'FAIL', - attemptnum INTEGER DEFAULT 0, - final_logf TEXT DEFAULT 'logs/final.log', - logdat BLOB, - run_duration INTEGER DEFAULT 0, - comment TEXT DEFAULT '', - event_time TIMESTAMP, - fail_count INTEGER DEFAULT 0, - pass_count INTEGER DEFAULT 0, - archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes - CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path) - );") - (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname, item_path);") - (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps - (id INTEGER PRIMARY KEY, - test_id INTEGER, - stepname TEXT, - state TEXT DEFAULT 'NOT_STARTED', - status TEXT DEFAULT 'n/a', - event_time TIMESTAMP, - comment TEXT DEFAULT '', - logfile TEXT DEFAULT '', - CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY, + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( + id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', description TEXT DEFAULT '', reviewed TIMESTAMP, @@ -224,125 +504,84 @@ avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, - test_id INTEGER, - category TEXT DEFAULT '', - variable TEXT, - value REAL, - expected REAL, - tol REAL, - units TEXT, - comment TEXT DEFAULT '', - status TEXT DEFAULT 'n/a', - type TEXT DEFAULT '', - CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") + (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");")) + ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, + CONSTRAINT metadat_constraint UNIQUE (var));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. (db:set-var db "MEGATEST_VERSION" megatest-version) - (debug:print-info 11 "db:initialize END") - )) - -;;====================================================================== -;; T E S T S P E C I F I C D B -;;====================================================================== - -;; Create the sqlite db for the individual test(s) -(define (open-test-db work-area) - (debug:print-info 11 "open-test-db " work-area) - (if (and work-area - (directory? work-area) - (file-read-access? work-area)) - (let* ((dbpath (conc work-area "/testdat.db")) - (dbexists (file-exists? dbpath)) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) - (handle-exceptions - exn - (begin - (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" - ((condition-property-accessor 'exn 'message) exn)) - (set! db (sqlite3:open-database ":memory:"))) ;; open an in-memory db to allow readonly access - (set! db (sqlite3:open-database dbpath))) - (sqlite3:set-busy-handler! db handler) - (if (not dbexists) - (begin - (sqlite3:execute db "PRAGMA synchronous = FULL;") - (debug:print-info 11 "Initialized test database " dbpath) - (db:testdb-initialize db))) - ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - (debug:print-info 11 "open-test-db END (sucessful)" work-area) - ;; now let's test that everything is correct - (handle-exceptions - exn - (begin - (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" - ((condition-property-accessor 'exn 'message) exn)) - #f) - ;; Is there a cheaper single line operation that will check for existance of a table - ;; and raise an exception ? - (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) - db) - (begin - (debug:print-info 11 "open-test-db END (unsucessful)" work-area) - #f))) - -;; find and open the testdat.db file for an existing test -(define (db:open-test-db-by-test-id db test-id #!key (work-area #f)) - (let* ((test-path (if work-area - work-area - (cdb:remote-run db:test-get-rundir-from-test-id db test-id)))) - (debug:print 3 "TEST PATH: " test-path) - (open-test-db test-path))) - -(define (db:testdb-initialize db) - (debug:print 11 "db:testdb-initialize START") - (for-each - (lambda (sqlcmd) - (sqlite3:execute db sqlcmd)) - (list "CREATE TABLE IF NOT EXISTS test_rundat ( - id INTEGER PRIMARY KEY, - update_time TIMESTAMP, - cpuload INTEGER DEFAULT -1, - diskfree INTEGER DEFAULT -1, - diskusage INTGER DEFAULT -1, - run_duration INTEGER DEFAULT 0);" - "CREATE TABLE IF NOT EXISTS test_data ( - id INTEGER PRIMARY KEY, - test_id INTEGER, - category TEXT DEFAULT '', - variable TEXT, - value REAL, - expected REAL, - tol REAL, - units TEXT, - comment TEXT DEFAULT '', - status TEXT DEFAULT 'n/a', - type TEXT DEFAULT '', - CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));" - "CREATE TABLE IF NOT EXISTS test_steps ( - id INTEGER PRIMARY KEY, - test_id INTEGER, - stepname TEXT, - state TEXT DEFAULT 'NOT_STARTED', - status TEXT DEFAULT 'n/a', - event_time TIMESTAMP, - comment TEXT DEFAULT '', - logfile TEXT DEFAULT '', - CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));" - ;; test_meta can be used for handing commands to the test - ;; e.g. KILLREQ - ;; the ackstate is set to 1 once the command has been completed - "CREATE TABLE IF NOT EXISTS test_meta ( - id INTEGER PRIMARY KEY, - var TEXT, - val TEXT, - ackstate INTEGER DEFAULT 0, - CONSTRAINT metadat_constraint UNIQUE (var));")) - (debug:print 11 "db:testdb-initialize END")) + (debug:print-info 11 "db:initialize END"))) + +;;====================================================================== +;; R U N S P E C I F I C D B +;;====================================================================== + +(define (db:initialized-run-id-db db run-id) + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests + (id INTEGER PRIMARY KEY, + run_id INTEGER DEFAULT -1, + testname TEXT DEFAULT 'noname', + host TEXT DEFAULT 'n/a', + cpuload REAL DEFAULT -1, + diskfree INTEGER DEFAULT -1, + uname TEXT DEFAULT 'n/a', + rundir TEXT DEFAULT 'n/a', + shortdir TEXT DEFAULT '', + item_path TEXT DEFAULT '', + state TEXT DEFAULT 'NOT_STARTED', + status TEXT DEFAULT 'FAIL', + attemptnum INTEGER DEFAULT 0, + final_logf TEXT DEFAULT 'logs/final.log', + logdat TEXT DEFAULT '', + run_duration INTEGER DEFAULT 0, + comment TEXT DEFAULT '', + event_time TIMESTAMP DEFAULT (strftime('%s','now')), + fail_count INTEGER DEFAULT 0, + pass_count INTEGER DEFAULT 0, + archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes + CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") + (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname, item_path);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps + (id INTEGER PRIMARY KEY, + test_id INTEGER, + stepname TEXT, + state TEXT DEFAULT 'NOT_STARTED', + status TEXT DEFAULT 'n/a', + event_time TIMESTAMP, + comment TEXT DEFAULT '', + logfile TEXT DEFAULT '', + CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data + (id INTEGER PRIMARY KEY, + reviewed TIMESTAMP DEFAULT (strftime('%s','now')), + avg_runtime REAL DEFAULT -1, + avg_disk REAL DEFAULT -1, + test_id INTEGER, + category TEXT DEFAULT '', + variable TEXT, + value REAL, + expected REAL, + tol REAL, + units TEXT, + comment TEXT DEFAULT '', + status TEXT DEFAULT 'n/a', + type TEXT DEFAULT '', + CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + update_time TIMESTAMP, + cpuload INTEGER DEFAULT -1, + diskfree INTEGER DEFAULT -1, + diskusage INTGER DEFAULT -1, + run_duration INTEGER DEFAULT 0);") + db) ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== @@ -360,13 +599,10 @@ (sqlite3:execute db (conc "PRAGMA synchronous = 0;")))) db)) (define (db:log-local-event . loglst) (let ((logline (apply conc loglst))) - ;; (pwd (current-directory)) - ;; (cmdline (string-intersperse (argv) " ")) - ;; (pid (current-process-id))) (db:log-event logline))) (define (db:log-event logline) (let ((db (open-logging-db))) (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" @@ -376,94 +612,72 @@ (current-process-id)) (sqlite3:finalize! db) logline)) ;;====================================================================== -;; TODO: -;; put deltas into an assoc list with version numbers -;; apply all from last to current +;; D B U T I L S +;;====================================================================== + +;;====================================================================== +;; M A I N T E N A N C E ;;====================================================================== -(define (patch-db db) - (handle-exceptions - exn - (begin - (print "Exception: " exn) - (print "ERROR: Possible out of date schema, attempting to add table metadata...") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (if (not (db:get-var db "MEGATEST_VERSION")) - (db:set-var db "MEGATEST_VERSION" 1.17))) - (let ((mver (db:get-var db "MEGATEST_VERSION")) - (test-meta-def "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY, - testname TEXT DEFAULT '', - author TEXT DEFAULT '', - owner TEXT DEFAULT '', - description TEXT DEFAULT '', - reviewed TIMESTAMP, - iterated TEXT DEFAULT '', - avg_runtime REAL, - avg_disk REAL, - tags TEXT DEFAULT '', - CONSTRAINT test_meta_constraint UNIQUE (testname));")) - (print "Current schema version: " mver " current megatest version: " megatest-version) - (cond - ((not mver) - (print "Adding megatest-version to metadata") ;; Need to recreate the table - (sqlite3:execute db "DROP TABLE IF EXISTS metadat;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (db:set-var db "MEGATEST_VERSION" 1.17) - (patch-db)) - ((< mver 1.21) - (sqlite3:execute db "DROP TABLE IF EXISTS metadat;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (db:set-var db "MEGATEST_VERSION" 1.21) ;; set before, just in case the changes are already applied - (sqlite3:execute db test-meta-def) - ;(for-each - ; (lambda (stmt) - ; (sqlite3:execute db stmt)) - ; (list - ; "ALTER TABLE tests ADD COLUMN first_err TEXT;" - ; "ALTER TABLE tests ADD COLUMN first_warn TEXT;" - ; )) - (patch-db)) - ((< mver 1.24) - (db:set-var db "MEGATEST_VERSION" 1.24) - (sqlite3:execute db "DROP TABLE IF EXISTS test_data;") - (sqlite3:execute db "DROP TABLE IF EXISTS test_meta;") - (sqlite3:execute db test-meta-def) - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, - test_id INTEGER, - category TEXT DEFAULT '', - variable TEXT, - value REAL, - expected REAL, - tol REAL, - units TEXT, - comment TEXT DEFAULT '', - status TEXT DEFAULT 'n/a', - CONSTRAINT test_data UNIQUE (test_id,category,variable));") - (print "WARNING: Table test_data and test_meta were recreated. Please do megatest -update-meta") - (patch-db)) - ((< mver 1.27) - (db:set-var db "MEGATEST_VERSION" 1.27) - (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT '';") - (patch-db)) - ((< mver 1.29) - (db:set-var db "MEGATEST_VERSION" 1.29) - (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';") - (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';")) - ((< mver 1.36) - (db:set-var db "MEGATEST_VERSION" 1.36) - (sqlite3:execute db "ALTER TABLE test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';")) - ((< mver 1.37) - (db:set-var db "MEGATEST_VERSION" 1.37) - (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;")) - ((< mver megatest-version) - (db:set-var db "MEGATEST_VERSION" megatest-version)))))) - + +;; select end_time-now from +;; (select testname,item_path,event_time+run_duration as +;; end_time,strftime('%s','now') as now from tests where state in +;; ('RUNNING','REMOTEHOSTSTART','LAUNCED')); + + +(define (db:find-and-mark-incomplete db #!key (ovr-deadtime #f)) + (let* ((incompleted '()) + (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) + (deadtime (if (and deadtime-str + (string->number deadtime-str)) + (string->number deadtime-str) + 7200)) ;; two hours + (run-ids (db:get-run-ids db))) ;; iterate over runs to divy up the calls + (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) + (for-each + (lambda (run-id) + + ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes + ;; + ;; THIS CANNOT WORK. The run_duration is not updated in the central db due to performance concerns. + ;; The testdat.db file must be consulted. + ;; + ;; HOWEVER: this code in run:test seems to work fine + ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) + ;; (db:test-get-run_duration testdat))) + ;; 600) + (sqlite3:for-each-row + (lambda (test-id) + (set! incompleted (cons test-id incompleted))) + db + "SELECT id FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time - run_duration) > ? AND state IN ('RUNNING','REMOTEHOSTSTART');" + run-id deadtime) + + ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config + ;; + (sqlite3:for-each-row + (lambda (test-id) + (set! incompleted (cons test-id incompleted))) + db + "SELECT id FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time - run_duration) > ? AND state IN ('LAUNCHED');" + run-id (* 60 60 24))) + run-ids) + + ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. + ;; + (if (> (length incompleted) 0) + (begin + (debug:print 0 "WARNING: Marking test(s); " (string-intersperse (map conc incompleted) ", ") " as INCOMPLETE") + (sqlite3:execute + db + (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" + (string-intersperse (map conc incompleted) ",") + ");")))))) + ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; ;; 1. Look at test records either deleted or part of deleted run: @@ -471,26 +685,30 @@ ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; -(define (db:clean-up db) - (let ((count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) - (statements - (map (lambda (stmt) - (sqlite3:prepare db stmt)) - (list - ;; delete all tests that belong to runs that are 'deleted' - "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');" - ;; delete all tests that are 'DELETED' - "DELETE FROM tests WHERE state='DELETED';" - ;; delete all tests that have no run - "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);" - ;; delete all runs that are state='deleted' - "DELETE FROM runs WHERE state='deleted';" - ;; delete empty runs - "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" +(define (db:clean-up dbstruct) + + (debug:print 0 "ERROR: db clean up not ported yet") + + (let* ((db (db:get-db dbstruct #f)) + (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) + (statements + (map (lambda (stmt) + (sqlite3:prepare db stmt)) + (list + ;; delete all tests that belong to runs that are 'deleted' + "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');" + ;; delete all tests that are 'DELETED' + "DELETE FROM tests WHERE state='DELETED';" + ;; delete all tests that have no run + "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);" + ;; delete all runs that are state='deleted' + "DELETE FROM runs WHERE state='deleted';" + ;; delete empty runs + "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" )))) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) @@ -500,31 +718,32 @@ (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) + (db:find-and-mark-incomplete db) (sqlite3:execute db "VACUUM;"))) - -;; (define (db:report-junk-records db) - ;;====================================================================== -;; meta get and set vars +;; M E T A G E T A N D S E T V A R S ;;====================================================================== ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* -(define (db:get-var db var) - (debug:print-info 11 "db:get-var START " var) +;; +;; Operates on megatestdb +;; +(define (db:get-var dbstruct var) (let* ((start-ms (current-milliseconds)) (throttle (let ((t (config-lookup *configdat* "setup" "throttle"))) (if t (string->number t) t))) (res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) - db "SELECT val FROM metadat WHERE var=?;" var) + (db:get-db dbstruct #f) + "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) (if valnum (set! res valnum)))) ;; scale by 10, average with current value. @@ -533,37 +752,32 @@ 2)) (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit (begin (debug:print-info 4 "launch throttle factor=" *global-delta*) (set! *last-global-delta-printed* *global-delta*))) - (debug:print-info 11 "db:get-var END " var " val=" res) res)) -(define (db:set-var db var val) - (debug:print-info 11 "db:set-var START " var " " val) - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val) - (debug:print-info 11 "db:set-var END " var " " val)) - -(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)) +(define (db:set-var dbstruct var val) + (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)) + +(define (db:del-var dbstruct var) + (sqlite3:execute (db:get-db dbstruct #f) "DELETE FROM metadat WHERE var=?;" 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 ;; why get the keys from the db? why not get from the *configdat* ;; using keys:config-get-fields? -(define (db:get-keys db) +(define (db:get-keys dbstruct) (if *db-keys* *db-keys* (let ((res '())) (sqlite3:for-each-row (lambda (key) (set! res (cons key res))) - db + (db:get-db dbstruct #f) "SELECT fieldname FROM keys ORDER BY id DESC;") (set! *db-keys* res) res))) ;; @@ -579,26 +793,26 @@ ;;====================================================================== ;; R U N S ;;====================================================================== -(define (db:get-run-name-from-id db run-id) +(define (db:get-run-name-from-id dbstruct run-id) (let ((res #f)) (sqlite3:for-each-row (lambda (runname) (set! res runname)) - db + (db:get-db dbstruct #f) "SELECT runname FROM runs WHERE id=?;" run-id) res)) -(define (db:get-run-key-val db run-id key) +(define (db:get-run-key-val dbstruct run-id key) (let ((res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) - db + (db:get-db dbstruct #f) (conc "SELECT " key " FROM runs WHERE id=?;") run-id) res)) ;; keys list to key1,key2,key3 ... @@ -621,13 +835,14 @@ patts)) comparator))) ;; register a test run with the db -(define (db:register-run db keyvals runname state status user) +(define (db:register-run dbstruct keyvals runname state status user) (debug:print 3 "runs:register-run runname: " runname " state: " state " status: " status " user: " user) - (let* ((keys (map car keyvals)) + (let* ((db (db:get-db dbstruct #f)) + (keys (map car keyvals)) (keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (allvals (append (list runname state status user) (map cadr keyvals))) @@ -651,19 +866,28 @@ res) (begin (debug:print 0 "ERROR: Called without all necessary keys") #f)))) +(define (db:get-all-run-ids db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (run-id) + (set! res (cons run-id res))) + db + "SELECT DISTINCT run_id FROM tests;") + res)) ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... ;; -(define (db:get-runs db runpatt count offset keypatts) - (let* ((res '()) - (keys (db:get-keys db)) +(define (db:get-runs dbstruct runpatt count offset keypatts) + (let* ((db (db:get-db dbstruct #f)) + (res '()) + (keys (db:get-keys dbstruct)) (runpattstr (db:patt->like "runname" runpatt)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ","))) @@ -695,13 +919,13 @@ (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) ;; Get all targets from the db ;; -(define (db:get-targets db) +(define (db:get-targets dbstruct) (let* ((res '()) - (keys (db:get-keys db)) + (keys (db:get-keys dbstruct)) (header keys) ;; (map key:get-fieldname keys)) (keystr (keys->keystr keys)) (qrystr (conc "SELECT " keystr " FROM runs;")) (seen (make-hash-table))) (sqlite3:for-each-row @@ -709,56 +933,69 @@ (let ((targ (cons a x))) (if (not (hash-table-ref/default seen targ #f)) (begin (hash-table-set! seen targ #t) (set! res (cons (apply vector targ) res)))))) - db + (db:get-db dbstruct #f) qrystr) (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) (vector header res))) ;; just get count of runs -(define (db:get-num-runs db runpatt) +(define (db:get-num-runs dbstruct runpatt) (let ((numruns 0)) (debug:print-info 11 "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) (set! numruns count)) - db + (db:get-db dbstruct #f) "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) (debug:print-info 11 "db:get-num-runs END " runpatt) numruns)) ;; get some basic run stats ;; ;; ( (runname (( state count ) ... )) ;; ( ... -(define (db:get-run-stats db) +(define (db:get-run-stats dbstruct) (let ((totals (make-hash-table)) - (res '())) + (res '()) + (runs-info '())) + ;; First get all the runname/run-ids (sqlite3:for-each-row - (lambda (runname state count) - (let* ((stateparts (string-split state "|")) - (newstate (conc (car stateparts) "\n" (cadr stateparts)))) - (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count)) - (set! res (cons (list runname newstate count) res)))) - db - "SELECT runname,t.state||'|'||t.status AS s,count(t.id) FROM runs AS r INNER JOIN tests AS t ON r.id=t.run_id GROUP BY s,runname ORDER BY r.event_time,s DESC;" ) - ;; (set! res (reverse res)) - (for-each (lambda (state) - (set! res (cons (list "Totals" state (hash-table-ref totals state)) res))) - (sort (hash-table-keys totals) string>=)) + (lambda (run-id runname) + (set! runs-info (cons (list runname run-id) runs-info))) + (db:get-db dbstruct #f) + "SELECT id,runname FROM runs;") + ;; for each run get stats data + (for-each + (lambda (run-info) + (let ((run-name (cadr run-info)) + (run-id (car run-info))) + (sqlite3:for-each-row + (lambda (state count) + (let* ((stateparts (string-split state "|")) + (newstate (conc (car stateparts) "\n" (cadr stateparts)))) + (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count)) + (set! res (cons (list runname newstate count) res)))) + (db:get-db dbstruct run-id) + "SELECT state||'|'||status AS s,count(id) FROM tests AS t ON ORDER BY s DESC;" ) + ;; (set! res (reverse res)) + (for-each (lambda (state) + (set! res (cons (list "Totals" state (hash-table-ref totals state)) res))) + (sort (hash-table-keys totals) string>=)))) + runs-info) res)) ;; db:get-runs-by-patt ;; get runs by list of criteria ;; 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 (db:get-runs-by-patt db keys runnamepatt targpatt offset limit) ;; test-name) +(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; 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 "") @@ -774,129 +1011,132 @@ (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))))) keyvals) - (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time" + (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) (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))) - db + (db:get-db dbstruct #f) qry-str runnamepatt) (vector header res))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) -(define (db:get-run-info db run-id) +(define (db:get-run-info dbstruct run-id) ;;(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)) + (let* ((res (vector #f #f #f #f)) + (keys (db:get-keys dbstruct)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (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) (set! res (apply vector a x))) - db + (db:get-db dbstruct #f) (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") run-id) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) -(define (db:set-comment-for-run db run-id comment) - (debug:print-info 11 "db:set-comment-for-run START run-id: " run-id " comment: " comment) - (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id) - (debug:print-info 11 "db:set-comment-for-run END run-id: " run-id " comment: " comment)) +(define (db:set-comment-for-run dbstruct run-id comment) + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET comment=? WHERE id=?;" comment run-id)) ;; does not (obviously!) removed dependent data. But why not!!? -(define (db:delete-run db run-id) - (common:clear-caches) ;; don't trust caches after doing any deletion +(define (db:delete-run dbstruct run-id) ;; First set any related tests to DELETED - (let ((stmt1 (sqlite3:prepare db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;")) - (stmt2 (sqlite3:prepare db "UPDATE runs SET state='deleted',comment='' WHERE id=?;"))) - (sqlite3:with-transaction - db (lambda () - (sqlite3:execute stmt1 run-id) - (sqlite3:execute stmt2 run-id))) - (sqlite3:finalize! stmt1) - (sqlite3:finalize! stmt2))) -;; (sqlite3:execute db "DELETE FROM runs WHERE id=?;" run-id)) - -(define (db:update-run-event_time db run-id) - (debug:print-info 11 "db:update-run-event_time START run-id: " run-id) - (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id) - (debug:print-info 11 "db:update-run-event_time END run-id: " run-id)) - -(define (db:lock/unlock-run db run-id lock unlock user) + (let ((db (db:get-db dbstruct run-id))) + (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='';") + (sqlite3:execute db "DELETE FROM test_steps;") + (sqlite3:execute db "DELETE FROM test_data;") + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))) + +(define (db:update-run-event_time dbstruct run-id) + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)) + +(define (db:lock/unlock-run dbstruct run-id lock unlock user) (let ((newlockval (if lock "locked" (if unlock "unlocked" "locked")))) ;; semi-failsafe - (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) - (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) + (sqlite3:execute (db:get-db dbstruct #f) "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 "" newlockval " run number " run-id))) + +(define (db:get-all-run-ids dbstruct) + (let ((res '())) + (sqlite3:for-each-row + (lambda (run-id) + (set! res (cons run-id res))) + (db:get-db dbstruct #f) + "SELECT id FROM runs;") + (reverse res))) + +(define (db:get-run-ids db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id) + (set! res (cons id res))) + db + "SELECT id FROM runs;"))) ;;====================================================================== ;; K E Y S ;;====================================================================== ;; get key val pairs for a given run-id ;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) -(define (db:get-key-val-pairs db run-id) - (let* ((keys (db:get-keys db)) +(define (db:get-key-val-pairs dbstruct run-id) + (let* ((keys (db:get-keys dbstruct)) (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 " FROM runs WHERE id=?;"))) ;; (debug:print 0 "qry: " qry) (sqlite3:for-each-row (lambda (key-val) (set! res (cons (list key key-val) res))) - db qry run-id))) + (db:get-db dbstruct #f) qry run-id))) keys) - (debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id) (reverse res))) ;; get key vals for a given run-id -(define (db:get-key-vals db run-id) +(define (db:get-key-vals dbstruct run-id) (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) - (if mykeyvals - mykeyvals - (let* ((keys (db:get-keys db)) + (if mykeyvals + mykeyvals + (let* ((keys (db:get-keys dbstruct)) (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 " 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))) + (db:get-db dbstruct #f) qry run-id))) keys) - (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id) - (let ((final-res (reverse res))) - (hash-table-set! *keyvals* run-id final-res) - final-res))))) + (let ((final-res (reverse res))) + (hash-table-set! *keyvals* run-id final-res) + final-res))))) ;; The target is keyval1/keyval2..., cached in *target* as it is used often -(define (db:get-target db run-id) +(define (db:get-target dbstruct run-id) (let ((mytarg (hash-table-ref/default *target* run-id #f))) (if mytarg mytarg - (let* ((keyvals (db:get-key-vals db run-id)) + (let* ((keyvals (db:get-key-vals dbstruct run-id)) (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) (hash-table-set! *target* run-id thekey) thekey)))) ;;====================================================================== @@ -905,15 +1145,15 @@ ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match -(define (db:get-tests-for-run db run-id testpatt states statuses offset limit not-in sort-by sort-order - #!key - (qryvals #f) - ) - (let* ((qryvals (if qryvals qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) +(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) + (let* ((qryvalstr (case qryvals + ((shortlist) "id,run_id,testname,item_path,state,status") + ((#f) "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") + (else qryvals))) (res '()) ;; if states or statuses are null then assume match all when not-in is false (states-qry (if (null? states) #f (conc " state " @@ -938,397 +1178,452 @@ (conc " AND " states-qry)) (statuses-qry (conc " AND " statuses-qry)) (else ""))) (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvals - " FROM tests WHERE run_id=? AND state != 'DELETED' " + (qry (conc "SELECT " qryvalstr + " FROM tests WHERE AND state != 'DELETED' " states-statuses-qry (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") (case sort-by ((rundir) " ORDER BY length(rundir) ") ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) ((event_time) " ORDER BY event_time ") (else (if (string? sort-by) - (conc " ORDER BY " sort-by) - ""))) - (if sort-order sort-order "") - (if limit (conc " LIMIT " limit) "") - (if offset (conc " OFFSET " offset) "") + (conc " ORDER BY " sort-by " ") + " "))) + (if sort-order sort-order " ") + (if limit (conc " LIMIT " limit) " ") + (if offset (conc " OFFSET " offset) " ") ";" ))) (debug:print-info 8 "db:get-tests-for-run qry=" qry) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) - db - qry - run-id - ) - res)) - -;; get a useful subset of the tests data (used in dashboard -;; use db:mintests-get-{id ,run_id,testname ...} -(define (db:get-tests-for-runs-mindata db run-ids testpatt states status not-in) - (db:get-tests-for-runs db run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) - -;; NB // This is get tests for "runs" (note the plural!!) -;; -;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN -;; i.e. these lists define what to NOT show. -;; states and statuses are required to be lists, empty is ok -;; not-in #t = above behaviour, #f = must match -;; run-ids is a list of run-ids or a single number or #f for all runs -(define (db:get-tests-for-runs db run-ids testpatt states statuses - #!key (not-in #t) - (sort-by #f) - (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time - (let* ((res '()) - ;; if states or statuses are null then assume match all when not-in is false - (states-qry (if (null? states) - #f - (conc " state " - (if not-in "NOT" "") - " IN ('" - (string-intersperse states "','") - "')"))) - (statuses-qry (if (null? statuses) - #f - (conc " status " - (if not-in "NOT" "") - " IN ('" - (string-intersperse statuses "','") - "')"))) - (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvals - " FROM tests WHERE state != 'DELETED' " - (if run-ids - (if (list? run-ids) - (conc "AND run_id IN (" (string-intersperse (map conc run-ids) ",") ") ") - (conc "AND run_id=" run-ids " ")) - " ") ;; #f => run-ids don't filter on run-ids - (if states-qry (conc " AND " states-qry) "") - (if statuses-qry (conc " AND " statuses-qry) "") - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (case sort-by - ((rundir) " ORDER BY length(rundir) DESC;") - ((event_time) " ORDER BY event_time ASC;") - (else ";")) - ))) - (debug:print-info 8 "db:get-tests-for-runs qry=" qry) - (sqlite3:for-each-row - (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) - (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) - db - qry - ) - res)) - -;; this one is a bit broken BUG FIXME -(define (db:delete-test-step-records db test-id #!key (work-area #f)) - ;; Breaking it into two queries for better file access interleaving - (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) - ;; test db's can go away - must check every time - (if tdb - (begin - (sqlite3:execute tdb "DELETE FROM test_steps;") - (sqlite3:execute tdb "DELETE FROM test_data;") - (sqlite3:finalize! tdb))))) - -;; -(define (db:delete-test-records db tdb test-id #!key (force #f)) - (common:clear-caches) - (if tdb - (begin - (sqlite3:execute tdb "DELETE FROM test_steps;") - (sqlite3:execute tdb "DELETE FROM test_data;"))) - ;; (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)) - (if db - (begin - (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) - (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id) - (if force - (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id) - (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))) - -(define (db:delete-tests-for-run db run-id) - (common:clear-caches) - (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id)) - -(define (db:delete-old-deleted-test-records db) - (common:clear-caches) - (let ((targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past - (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_timenorm res)) + ((#f) res) + (else res)))) + +(define (db:test-short-record->norm inrec) + ;; "id,run_id,testname,item_path,state,status" + ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (vector (vector-ref inrec 0) ;; id + (vector-ref inrec 1) ;; run_id + (vector-ref inrec 2) ;; testname + (vector-ref inrec 4) ;; state + (vector-ref inrec 5) ;; status + -1 "" -1 -1 "" "-" + (vector-ref inrec 3) ;; item-path + -1 "-" "-")) + + +(define (db:get-tests-for-run-state-status db run-id testpatt) + (let* ((res '()) + (tests-match-qry (tests:match->sqlqry testpatt)) + (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) + (debug:print-info 8 "db:get-tests-for-run qry=" qry) + (sqlite3:for-each-row + (lambda (id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) + db + qry + run-id) + res)) + +(define (db:get-testinfo-state-status db test-id) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (run-id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) + db + "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" + test-id) + res)) + + +;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs +;; + +;; ;; ;; get a useful subset of the tests data (used in dashboard +;; ;; ;; use db:mintests-get-{id ,run_id,testname ...} +;; ;; (define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states status not-in) +;; ;; (db:get-tests-for-runs dbstruct run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) +;; ;; +;; ;; ;; NB // This is get tests for "runs" (note the plural!!) +;; ;; ;; +;; ;; ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN +;; ;; ;; i.e. these lists define what to NOT show. +;; ;; ;; states and statuses are required to be lists, empty is ok +;; ;; ;; not-in #t = above behaviour, #f = must match +;; ;; ;; run-ids is a list of run-ids or a single number or #f for all runs +;; ;; (define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses +;; ;; #!key (not-in #t) +;; ;; (sort-by #f) +;; ;; (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time +;; ;; (let* ((res '()) +;; ;; ;; if states or statuses are null then assume match all when not-in is false +;; ;; (states-qry (if (null? states) +;; ;; #f +;; ;; (conc " state " +;; ;; (if not-in "NOT" "") +;; ;; " IN ('" +;; ;; (string-intersperse states "','") +;; ;; "')"))) +;; ;; (statuses-qry (if (null? statuses) +;; ;; #f +;; ;; (conc " status " +;; ;; (if not-in "NOT" "") +;; ;; " IN ('" +;; ;; (string-intersperse statuses "','") +;; ;; "')"))) +;; ;; (tests-match-qry (tests:match->sqlqry testpatt)) +;; ;; (qry (conc "SELECT " qryvals +;; ;; " FROM tests WHERE state != 'DELETED' " +;; ;; (if run-ids +;; ;; (if (list? run-ids) +;; ;; (conc "AND run_id IN (" (string-intersperse (map conc run-ids) ",") ") ") +;; ;; (conc "AND run_id=" run-ids " ")) +;; ;; " ") ;; #f => run-ids don't filter on run-ids +;; ;; (if states-qry (conc " AND " states-qry) "") +;; ;; (if statuses-qry (conc " AND " statuses-qry) "") +;; ;; (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") +;; ;; (case sort-by +;; ;; ((rundir) " ORDER BY length(rundir) DESC;") +;; ;; ((event_time) " ORDER BY event_time ASC;") +;; ;; (else ";")) +;; ;; ))) +;; ;; (debug:print-info 8 "db:get-tests-for-runs qry=" qry) +;; ;; (sqlite3:for-each-row +;; ;; (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) +;; ;; (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) +;; ;; db +;; ;; qry +;; ;; ) +;; ;; res)) + +(define (db:delete-test-records dbstruct run-id test-id) +;; (define (db:delete-test-step-records dbstruct run-id test-id) + (let ((db (db:get-db dbstruct run-id))) + (db:general-call db 'delete-test-step-records (list test-id)) + (db:general-call db 'delete-test-data-records (list test-id)) + (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)) + +(define (db:delete-tests-for-run dbstruct run-id) + (let ((db (db:get-db dbstruct run-id))) + (sqlite3:execute db "DELETE FROM tests;"))) + +(define (db:delete-old-deleted-test-records dbstruct) + (let ((run-ids (db:get-all-run-ids dbstruct)) + (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past + (for-each + (lambda (run-id) + (sqlite3:execute (db:get-db dbstruct run-id) "DELETE FROM tests WHERE state='DELETED' AND event_timetest-data db test-id csvdata) + (debug:print 4 "test-id " test-id ", csvdata: " csvdata) + (let ((csvlist (csv->list (make-csv-reader + (open-input-string csvdata) + '((strip-leading-whitespace? #t) + (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata))) + (for-each + (lambda (csvrow) + (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) + (category (list-ref padded-row 0)) + (variable (list-ref padded-row 1)) + (value (any->number-if-possible (list-ref padded-row 2))) + (expected (any->number-if-possible (list-ref padded-row 3))) + (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number + (units (list-ref padded-row 5)) + (comment (list-ref padded-row 6)) + (status (let ((s (list-ref padded-row 7))) + (if (and (string? s)(or (string-match (regexp "^\\s*$") s) + (string-match (regexp "^n/a$") s))) + #f + s))) ;; if specified on the input then use, else calculate + (type (list-ref padded-row 8))) + ;; look up expected,tol,units from previous best fit test if they are all either #f or '' + (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) + + (if (and (or (not expected)(equal? expected "")) + (or (not tol) (equal? expected "")) + (or (not units) (equal? expected ""))) + (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test tdb test-id category variable))) + (set! expected new-expected) + (set! tol new-tol) + (set! units new-units))) + + (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) + ;; calculate status if NOT specified + (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers + (if (number? tol) ;; if tol is a number then we do the standard comparison + (let* ((max-val (+ expected tol)) + (min-val (- expected tol)) + (result (and (>= value min-val)(<= value max-val)))) + (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result) + (set! status (if result "pass" "fail"))) + (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. + (case (string->symbol tol) ;; tol should be >, <, >=, <= + ((>) (if (> value expected) "pass" "fail")) + ((<) (if (< value expected) "pass" "fail")) + ((>=) (if (>= value expected) "pass" "fail")) + ((<=) (if (<= value expected) "pass" "fail")) + (else (conc "ERROR: bad tol comparator " tol)))))) + (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) + (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" + test-id category variable value expected tol units (if comment comment "") status type))) + csvlist))) ;;====================================================================== ;; Misc. test related queries ;;====================================================================== ;; MUST BE CALLED local! -(define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '())) +;; +(define (db:test-get-paths-matching dbstruct keynames target fnamepatt #!key (res '())) ;; BUG: Move the values derived from args to parameters and push to megatest.scm (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) - (paths-from-db (cdb:remote-run db:test-get-paths-matching-keynames-target-new db keynames target res - testpatt: testpatt - statepatt: statepatt - statuspatt: statuspatt - runname: runname))) + (paths-from-db (rmt:test-get-paths-matching-keynames-target-new keynames target res + testpatt + statepatt + statuspatt + runname))) (if fnamepatt (apply append (map (lambda (p) (if (directory-exists? p) (glob (conc p "/" fnamepatt)) @@ -1358,80 +1653,56 @@ (set! res (cons p res))) db qrystr) res)) -(define (db:test-get-paths-matching-keynames-target-new db keynames target res - #!key - (testpatt "%") - (statepatt "%") - (statuspatt "%") - (runname "%")) +(define (db:test-get-paths-matching-keynames-target-new dbstruct keynames target res testpatt statepatt statuspatt runname) (let* ((row-ids '()) (keystr (string-intersperse (map (lambda (key val) (conc key " like '" val "'")) keynames (string-split target "/")) " AND ")) (testqry (tests:match->sqlqry testpatt)) - (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))) - (tstsqry (sqlite3:prepare db (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))) + (runsqry (sqlite3:prepare (db:get-db dbstruct #f)(conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))) + (tstsqry (conc "SELECT rundir_id FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) + (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstqry=" tstqry) (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) + (sqlite3:finalize! runsqry) (for-each (lambda (rid) (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) - tstsqry rid)) + (db:get-db dbstruct rid) + tstsqry)) row-ids) - (sqlite3:finalize! tstsqry) - (sqlite3:finalize! runsqry) res)) -;; look through tests from matching runs for a file -(define (db:test-get-first-path-matching db keynames target fname) - ;; [refpaths] is the section where references to other megatest databases are stored - (let ((mt-paths (configf:get-section "refpaths")) - (res (db:test-get-paths-matching db keynames target fname))) - (let loop ((pathdat (if (null? paths) #f (car mt-paths))) - (tal (if (null? paths) '()(cdr mt-paths)))) - (if (not (null? res)) - (car res) ;; return first found - (if path - (let* ((db (open-db path: (cadr pathdat))) - (newres (db:test-get-paths-matching db keynames target fname))) - (debug:print-info 4 "Trying " (car pathdat) " at " (cadr pathdat)) - (sqlite3:finalize! db) - (if (not (null? newres)) - (car newres) - (if (null? tal) - #f - (loop (car tal)(cdr tal)))))))))) - ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS ;;====================================================================== ;; NOTE: Can remove the regex and base64 encoding for zmq (define (db:obj->string obj) (case *transport-type* - ((fs) obj) - ((http) + ;; ((fs) obj) + ((http fs) (string-substitute (regexp "=") "_" (base64:base64-encode (with-output-to-string (lambda ()(serialize obj)))) #t)) ((zmq)(with-output-to-string (lambda ()(serialize obj)))) (else obj))) (define (db:string->obj msg) (case *transport-type* - ((fs) msg) - ((http) + ;; ((fs) msg) + ((http fs) (if (string? msg) (with-input-from-string (base64:base64-decode (string-substitute (regexp "_") "=" msg #t)) @@ -1438,233 +1709,116 @@ (lambda ()(deserialize))) (vector #f #f #f))) ;; crude reply for when things go awry ((zmq)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) -(define (cdb:use-non-blocking-mode proc) - (set! *client-non-blocking-mode* #t) - (let ((res (proc))) - (set! *client-non-blocking-mode* #f) - res)) - -;; params = 'target cached remparams -;; -;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime -;; -;; cdb:client-call is the unified interface to all the transports. It dispatches the -;; query to a server routine (e.g. server:client-send-recieve) that -;; transports the data to the server where it is passed to db:process-queue-item -;; which either returns the data to the calling server routine or -;; directly calls the returning procedure (e.g. zmq). -;; -(define (cdb:client-call serverdat qtype immediate numretries . params) - (debug:print-info 11 "cdb:client-call serverdat=" serverdat ", qtype=" qtype ", immediate=" immediate ", numretries=" numretries ", params=" params) - (case *transport-type* - ((fs) - (let ((packet (vector "na" qtype immediate "na" params 0))) - (fs:process-queue-item packet))) - ((http) - (let* ((client-sig (client:get-signature)) - (query-sig (message-digest-string (md5-primitive) (conc qtype immediate params))) - (zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds))))) ;; (with-output-to-string (lambda ()(serialize params)))) - (debug:print-info 11 "zdat=" zdat) - (let* ((res #f) - (rawdat (http-transport:client-send-receive serverdat zdat)) - (tmp #f)) - (debug:print-info 11 "Sent " zdat ", received " rawdat) - (if rawdat - (begin - (set! tmp (db:string->obj rawdat)) - (vector-ref tmp 2)) - (begin - (debug:print 0 "ERROR: Communication with the server failed. Exiting if possible") - (exit 1)))))) - ((zmq) - (handle-exceptions - exn - (begin - (debug:print-info 0 "cdb:client-call timeout or error. Trying again in 5 seconds") - (thread-sleep! 5) - (if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params))) - (let* ((push-socket (vector-ref serverdat 0)) - (sub-socket (vector-ref serverdat 1)) - (client-sig (client:get-signature)) - (query-sig (message-digest-string (md5-primitive) (conc qtype immediate params))) - (zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds)))) ;; (with-output-to-string (lambda ()(serialize params)))) - (res #f) - (send-receive (lambda () - (debug:print-info 11 "sending message") - (send-message push-socket zdat) - (debug:print-info 11 "message sent") - (let loop () - ;; get the sender info - ;; this should match (client:get-signature) - ;; we will need to process "all" messages here some day - (receive-message* sub-socket) - ;; now get the actual message - (let ((myres (db:string->obj (receive-message* sub-socket)))) - (if (equal? query-sig (vector-ref myres 1)) - (set! res (vector-ref myres 2)) - (loop))))))) - ;; (timeout (lambda () - ;; (let loop ((n numretries)) - ;; (thread-sleep! 15) - ;; (if (not res) - ;; (if (> numretries 0) - ;; (begin - ;; (debug:print 2 "WARNING: no reply to query " params ", trying resend") - ;; (debug:print-info 11 "re-sending message") - ;; (send-message push-socket zdat) - ;; (debug:print-info 11 "message re-sent") - ;; (loop (- n 1))) - ;; ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params)) - ;; (begin - ;; (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.") - ;; (exit 5)))))))) - (debug:print-info 11 "Starting threads") - (let ((th1 (make-thread send-receive "send receive")) - ;; (th2 (make-thread timeout "timeout")) - ) - (thread-start! th1) - ;; (thread-start! th2) - (thread-join! th1) - (debug:print-info 11 "cdb:client-call returning res=" res) - res)))))) - -(define (cdb:set-verbosity serverdat val) - (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val)) - -(define (cdb:login serverdat keyval signature) - (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature)) - -(define (cdb:logout serverdat keyval signature) - (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature)) - -(define (cdb:num-clients serverdat) - (cdb:client-call serverdat 'numclients #t *default-numtries*)) - -;; I think this would be more efficient if executed on client side FIXME??? -(define (cdb:test-set-status-state serverdat test-id status state msg) - (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) - (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id)) - (if msg - (cdb:client-call serverdat 'state-status-msg #t *default-numtries* state status msg test-id) - (cdb:client-call serverdat 'state-status #t *default-numtries* state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) - -(define (cdb:test-rollup-test_data-pass-fail serverdat test-id) - (cdb:client-call serverdat 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id)) - -(define (cdb:pass-fail-counts serverdat test-id fail-count pass-count) - (cdb:client-call serverdat 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id)) - -(define (cdb:tests-register-test serverdat run-id test-name item-path) - (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path)) - -;; more transactioned calls, these for roll-up-pass-fail stuff -(define (cdb:update-pass-fail-counts serverdat run-id test-name) - (cdb:client-call serverdat 'update-fail-pass-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name)) - -(define (cdb:top-test-set-running serverdat run-id test-name) - (cdb:client-call serverdat 'top-test-set-running #t *default-numtries* run-id test-name)) - -(define (cdb:top-test-set-per-pf-counts serverdat run-id test-name) - (cdb:client-call serverdat 'top-test-set-per-pf-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name)) - -;;= - -(define (cdb:flush-queue serverdat) - (cdb:client-call serverdat 'flush #f *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) - (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path)) - -(define (cdb:get-test-info-by-id serverdat test-id) - (let ((test-dat (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id))) - (hash-table-set! *test-info* test-id (vector (current-seconds) test-dat)) ;; cached for use where up-to-date info is not needed - test-dat)) - -;; db should be db open proc or #f -(define (cdb:remote-run proc db . params) - (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)) - -(define (db:test-get-logfile-info db run-id test-name) +(define (db:test-set-status-state dbstruct run-id test-id status state msg) + (let ((db (db:get-db dbstruct rid))) + (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) + (db:general-call db 'set-test-start-time (list test-id))) + (if msg + (db:general-call db 'state-status-msg (list state status msg test-id)) + (db:general-call db 'state-status (list state status test-id))))) + +(define (db:roll-up-pass-fail-counts db run-id test-name item-path status) + (if (and (not (equal? item-path "")) + (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP"))) + (let ((db (db:get-db dbstruct rid))) + (handle-exceptions + exn + (begin + (debug:print 0 "Problem with call to cdb:remote-run, database may be locked and read-only, waiting and trying again ...") + (thread-sleep! 10) + (apply cdb:remote-run proc db params)) + (apply cdb:remote-run proc db params))))) + +(define (db:tests-register-test dbstruct run-id test-name item-path) + (sqlite3:execute (db:get-db dbstruct run-id) 'register-test run-id test-name item-path)) + +(define (db:test-get-logfile-info dbstruct run-id test-name) (let ((res #f)) (sqlite3:for-each-row - (lambda (path final_logf) - (set! logf final_logf) - (set! res (list path final_logf)) - (if (directory? path) - (debug:print 2 "Found path: " path) - (debug:print 2 "No such path: " path))) - db - "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name) + (lambda (path-id final_logf-id) + (let ((path (db:get-path dbstruct path-id)) + (final_logf (db:get-string dbstruct final_logf-id))) + (set! logf final_logf) + (set! res (list path final_logf)) + (if (directory? path) + (debug:print 2 "Found path: " path) + (debug:print 2 "No such path: " path)))) + (db:get-db dbstruct run-id) + "SELECT rundir_id,final_logf_id FROM tests WHERE testname=? AND item_path='';" + test-name) res)) ;;====================================================================== ;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S ;;====================================================================== (define db:queries - (list '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") + (list '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;") + + ;; TESTS + '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") ;; Test state and status '(set-test-state "UPDATE tests SET state=? WHERE id=?;") '(set-test-status "UPDATE tests SET state=? WHERE id=?;") - '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") - '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") + '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; DONE + '(state-status-msg "UPDATE tests SET state=?,status=?,comment_id=? WHERE id=?;") ;; DONE ;; Test comment - '(set-test-comment "UPDATE tests SET comment=? WHERE id=?;") - '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") - '(pass-fail-counts "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;") + '(set-test-comment "UPDATE tests SET comment_id=? WHERE id=?;") + '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE + '(pass-fail-counts "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;") ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps '(test_data-pf-rollup "UPDATE tests SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 THEN 'FAIL' WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') THEN 'PASS' ELSE status - END WHERE id=?;") - '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") - '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") - '(test-set-rundir "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;") - '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;") + END WHERE id=?;") ;; DONE + '(test-set-log "UPDATE tests SET final_logf_id=? WHERE id=?;") ;; DONE + '(test-set-rundir-by-test-id "UPDATE tests SET rundir_id=? WHERE id=?") ;; DONE + '(test-set-rundir "UPDATE tests SET rundir_id=? AND testname=? AND item_path=?;") ;; DONE + '(delete-tests-in-state "DELETE FROM tests WHERE state=?;") ;; DONE '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") - '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") - '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;") - '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") + '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE + '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") ;; stuff for roll-up-pass-fail-counts - '(update-fail-pass-counts "UPDATE tests - SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), - pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) - WHERE run_id=? AND testname=? AND item_path='';") - '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE run_id=? AND testname=? AND item_path='';") + '(update-pass-fail-counts "UPDATE tests + SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), + pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) + WHERE testname=? AND item_path='';") ;; DONE + '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE '(top-test-set-per-pf-counts "UPDATE tests SET state=CASE WHEN (SELECT count(id) FROM tests - WHERE run_id=? AND testname=? + WHERE testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' ELSE 'COMPLETED' END, status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' WHEN (SELECT count(id) FROM tests - WHERE run_id=? AND testname=? + WHERE testname=? AND item_path != '' AND status = 'SKIP') > 0 THEN 'SKIP' ELSE 'UNKNOWN' END - WHERE run_id=? AND testname=? AND item_path='';") + WHERE testname=? AND item_path='';") ;; DONE + + ;; STEPS + '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE id=?;") + '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE id=?;") ;; using status since no state field )) + +(define (db:lookup-query qry-name) + (let ((q (alist-ref qry-name db:queries))) + (if q (car q) #f))) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail ;; db:roll-up-pass-fail-counts ;; WHY NOT!? login @@ -1673,542 +1827,176 @@ sync set-verbosity killserver )) -;; not used, intended to indicate to run in calling process -(define db:run-local-queries '()) ;; rollup-tests-pass-fail)) - -(define (db:process-cached-writes db) - (let ((queries (make-hash-table)) - (data #f)) - (mutex-lock! *incoming-mutex*) - ;; data is a list of query packets (length data) 0) - ;; Process if we have data - (begin - (debug:print-info 7 "Writing cached data " data) - - ;; Prepare the needed sql statements - ;; - (for-each (lambda (request-item) - (let ((stmt-key (vector-ref request-item 0)) - (query (vector-ref request-item 1))) - (hash-table-set! queries stmt-key (sqlite3:prepare db query)))) - data) - - ;; No outer loop needed. Single loop for write items only. Reads trigger flush of queue - ;; and then are executed. - (sqlite3:with-transaction - db - (lambda () - (for-each - (lambda (hed) - (let* ((params (vector-ref hed 2)) - (stmt-key (vector-ref hed 0)) - (stmt (hash-table-ref/default queries stmt-key #f))) - (if stmt - (apply sqlite3:execute stmt params) - (debug:print 0 "ERROR: Problem Executing " stmt-key " for " params)))) - data))) - - ;; let all the waiting calls know all is done - (mutex-lock! *completed-mutex*) - (for-each (lambda (item) - (let ((qry-sig (cdb:packet-get-client-sig item))) - (debug:print-info 7 "Registering query " qry-sig " as done") - (hash-table-set! *completed-writes* qry-sig #t))) - data) - (mutex-unlock! *completed-mutex*) - - ;; Finalize the statements. Should this be done inside the mutex above? - ;; I think sqlite3 mutexes will keep the data safe - (for-each (lambda (stmt-key) - (sqlite3:finalize! (hash-table-ref queries stmt-key))) - (hash-table-keys queries)) - - ;; Do a little record keeping - (let ((cache-size (length data))) - (if (> cache-size *max-cache-size*) - (set! *max-cache-size* cache-size))) - #t) - #f))) - -(define *db:process-queue-mutex* (make-mutex)) - -(define *number-of-writes* 0) -(define *writes-total-delay* 0) -(define *total-non-write-delay* 0) -(define *number-non-write-queries* 0) - -;; The queue is a list of vectors where the zeroth slot indicates the type of query to -;; apply and the second slot is the time of the query and the third entry is a list of -;; values to be applied -;; -(define (db:queue-write-and-wait db qry-sig query params) - (let ((queue-len 0) - (res #f) - (got-it #f) - (qry-pkt (vector qry-sig query params)) - (start-time (current-milliseconds)) - (timeout (+ 10 (current-seconds)))) ;; set the time out to 10 secs in future - - ;; Put the item in the queue *incoming-writes* - (mutex-lock! *incoming-mutex*) - (set! *incoming-writes* (cons qry-pkt *incoming-writes*)) - (set! queue-len (length *incoming-writes*)) - (mutex-unlock! *incoming-mutex*) - - (debug:print-info 7 "Current write queue length is " queue-len) - - ;; poll for the write to complete, timeout after 10 seconds - ;; periodic flushing of the queue is taken care of by - ;; db:flush-queue - (let loop () - (thread-sleep! 0.001) - (mutex-lock! *completed-mutex*) - (if (hash-table-ref/default *completed-writes* qry-sig #f) - (begin - (hash-table-delete! *completed-writes* qry-sig) - (set! got-it #t))) - (mutex-unlock! *completed-mutex*) - (if (and (not got-it) - (< (current-seconds) timeout)) - (begin - (thread-sleep! 0.01) - (loop)))) - (set! *number-of-writes* (+ *number-of-writes* 1)) - (set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time))) - got-it)) - -(define (db:process-queue-item db item) - (let* ((stmt-key (cdb:packet-get-qtype item)) - (qry-sig (cdb:packet-get-query-sig item)) - (return-address (cdb:packet-get-client-sig item)) - (params (cdb:packet-get-params item)) - (query (let ((q (alist-ref stmt-key db:queries))) - (if q (car q) #f)))) - (debug:print-info 11 "Special queries/requests stmt-key=" stmt-key ", return-address=" return-address ", query=" query ", params=" params) - (if query - ;; hand queries off to the write queue - (let ((response (case *transport-type* - ((http) - (debug:print-info 7 "Queuing item " item " for wrapped write") - (db:queue-write-and-wait db qry-sig query params)) - (else - (apply sqlite3:execute db query params) - #t)))) - (debug:print-info 7 "Received " response " from wrapped write") - (server:reply return-address qry-sig response response)) - ;; otherwise if appropriate flush the queue (this is a read or complex query) - (begin - (cond - ((member stmt-key db:special-queries) - (let ((starttime (current-milliseconds))) - (debug:print-info 9 "Handling special statement " stmt-key) - (case stmt-key - ((immediate) - ;; This is a read or mixed read-write query, must clear the cache - (case *transport-type* - ((http) - (mutex-lock! *db:process-queue-mutex*) - (db:process-cached-writes db) - (mutex-unlock! *db:process-queue-mutex*))) - (let* ((proc (car params)) - (remparams (cdr params)) - ;; we are being handed a procedure so call it - ;; (debug:print-info 11 "Running (apply " proc " " remparams ")") - (result (server:reply return-address qry-sig #t (apply proc remparams)))) - (set! *total-non-write-delay* (+ *total-non-write-delay* (- (current-milliseconds) starttime))) - (set! *number-non-write-queries* (+ *number-non-write-queries* 1)) - result)) - ((login) - (if (< (length params) 3) ;; should get toppath, version and signature - (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params - (let ((calling-path (car params)) - (calling-vers (cadr params)) - (client-key (caddr params))) - (if (and (equal? calling-path *toppath*) - (equal? megatest-version calling-vers)) - (begin - (hash-table-set! *logged-in-clients* client-key (current-seconds)) - (server:reply return-address qry-sig #t '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ... - (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 (list #t *verbosity*))) - ((killserver) - (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) - (apply sqlite3:execute (hash-table-ref queries stmt-key) params) - (server:reply return-address qry-sig #t #t))))))) - -(define (db:test-get-records-for-index-file db run-id test-name) +(define (db:login db calling-path calling-version client-signature) + (if (and (equal? calling-path *toppath*) + (equal? megatest-version calling-version)) + (begin + (hash-table-set! *logged-in-clients* client-signature (current-seconds)) + '(#t "successful login")) ;; path matches - pass! Should vet the caller at this time ... + (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))) + +(define (db:process-write db request-item) + (let ((stmt-key (vector-ref request-item 0)) + (query (vector-ref request-item 1)) + (params (vector-ref request-item 2)) + (queryh (sqlite3:prepare db query))) + (apply sqlite3:execute stmt params) + #f)) +;; DISABLING FOR NOW +;; DISABLING FOR NOW (define *number-of-writes* 0) +;; DISABLING FOR NOW (define *writes-total-delay* 0) +;; DISABLING FOR NOW (define *total-non-write-delay* 0) +;; DISABLING FOR NOW (define *number-non-write-queries* 0) +;; DISABLING FOR NOW +;; DISABLING FOR NOW ;; The queue is a list of vectors where the zeroth slot indicates the type of query to +;; DISABLING FOR NOW ;; apply and the second slot is the time of the query and the third entry is a list of +(define (db:general-call db stmtname params) + (let ((query (let ((q (alist-ref (if (string? stmtname) + (string->symbol stmtname) + stmtname) + db:queries))) + (if q (car q) #f)))) + (apply sqlite3:execute db query params) + #t)) + +;; 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 +;; +;; Run this server-side +;; +(define (db:get-previous-test-run-record db run-id test-name item-path) + (let* ((keys (db:get-keys db)) + (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))) + db + (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) + (if (not keyvals) + #f + (let ((prev-run-ids '())) + (apply sqlite3:for-each-row + (lambda (id) + (set! prev-run-ids (cons id prev-run-ids))) + db + (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) + ;; for each run starting with the most recent look to see if there is a matching test + ;; if found then return that matching test record + (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) + (if (null? prev-run-ids) #f + (let loop ((hed (car prev-run-ids)) + (tal (cdr prev-run-ids))) + (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) + (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) + (if (and (null? results) + (not (null? tal))) + (loop (car tal)(cdr tal)) + (if (null? results) #f + (car results)))))))))) + +;; get the previous records for when these tests were run where all keys match but runname +;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests +;; can use wildcards. Also can likely be factored in with get test paths? +;; +;; Run this remotely!! +;; +(define (db:get-matching-previous-test-run-records db run-id test-name item-path) + (let* ((keys (db:get-keys db)) + (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) + (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) + (keyvals #f) + (tests-hash (make-hash-table))) + ;; 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))) + db + (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) + (if (not keyvals) + '() + (let ((prev-run-ids '())) + (apply sqlite3:for-each-row + (lambda (id) + (set! prev-run-ids (cons id prev-run-ids))) + db + (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) + ;; collect all matching tests for the runs then + ;; extract the most recent test and return that. + (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals + ", previous run ids found: " prev-run-ids) + (if (null? prev-run-ids) '() ;; no previous runs? return null + (let loop ((hed (car prev-run-ids)) + (tal (cdr prev-run-ids))) + (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) + (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name + ", item-path " item-path " results: " (intersperse results "\n")) + ;; Keep only the youngest of any test/item combination + (for-each + (lambda (testdat) + (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) + (stored-test (hash-table-ref/default tests-hash full-testname #f))) + (if (or (not stored-test) + (and stored-test + (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test)))) + ;; this test is younger, store it in the hash + (hash-table-set! tests-hash full-testname testdat)))) + results) + (if (null? tal) + (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests + (loop (car tal)(cdr tal)))))))))) + +(define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) (sqlite3:for-each-row - (lambda (id itempath state status run_duration logf comment) - (set! res (cons (vector id itempath state status run_duration logf comment) res))) - db - "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';" - run-id test-name) - res)) + (lambda (id itempath state status run_duration logf-id comment-id) + (let ((logf (db:get-string dbstruct logf-id)) + (comment (db:get-string dbstruct comment-id))) + (set! res (cons (vector id itempath state status run_duration logf comment) res))) + (db:get-db dbstruct run-id) + "SELECT id,item_path,state,status,run_duration,final_logf_id,comment_id FROM tests WHERE testname=? AND item_path != '';" + test-name) + res))) ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; read the record given a testname -(define (db:testmeta-get-record db testname) +(define (db:testmeta-get-record dbstruct testname) (let ((res #f)) (sqlite3:for-each-row (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags) (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags))) - db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags FROM test_meta WHERE testname=?;" + (db:get-db dbstruct #f) + "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags FROM test_meta WHERE testname=?;" testname) res)) ;; create a new record for a given testname -(define (db:testmeta-add-record db testname) - (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)) +(define (db:testmeta-add-record dbstruct testname) + (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)) ;; update one of the testmeta fields -(define (db:testmeta-update-field db testname field value) - (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) - -;;====================================================================== -;; T E S T D A T A -;;====================================================================== - -(define (db:csv->test-data db test-id csvdata #!key (work-area #f)) - (debug:print 4 "test-id " test-id ", csvdata: " csvdata) - (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) - (if tdb - (let ((csvlist (csv->list (make-csv-reader - (open-input-string csvdata) - '((strip-leading-whitespace? #t) - (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata))) - (for-each - (lambda (csvrow) - (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) - (category (list-ref padded-row 0)) - (variable (list-ref padded-row 1)) - (value (any->number-if-possible (list-ref padded-row 2))) - (expected (any->number-if-possible (list-ref padded-row 3))) - (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number - (units (list-ref padded-row 5)) - (comment (list-ref padded-row 6)) - (status (let ((s (list-ref padded-row 7))) - (if (and (string? s)(or (string-match (regexp "^\\s*$") s) - (string-match (regexp "^n/a$") s))) - #f - s))) ;; if specified on the input then use, else calculate - (type (list-ref padded-row 8))) - ;; look up expected,tol,units from previous best fit test if they are all either #f or '' - (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) - - (if (and (or (not expected)(equal? expected "")) - (or (not tol) (equal? expected "")) - (or (not units) (equal? expected ""))) - (let-values (((new-expected new-tol new-units)(db:get-prev-tol-for-test db test-id category variable))) - (set! expected new-expected) - (set! tol new-tol) - (set! units new-units))) - - (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - ;; calculate status if NOT specified - (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers - (if (number? tol) ;; if tol is a number then we do the standard comparison - (let* ((max-val (+ expected tol)) - (min-val (- expected tol)) - (result (and (>= value min-val)(<= value max-val)))) - (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result) - (set! status (if result "pass" "fail"))) - (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. - (case (string->symbol tol) ;; tol should be >, <, >=, <= - ((>) (if (> value expected) "pass" "fail")) - ((<) (if (< value expected) "pass" "fail")) - ((>=) (if (>= value expected) "pass" "fail")) - ((<=) (if (<= value expected) "pass" "fail")) - (else (conc "ERROR: bad tol comparator " tol)))))) - (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - (sqlite3:execute tdb "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" - test-id category variable value expected tol units (if comment comment "") status type))) - csvlist) - (sqlite3:finalize! tdb))))) - -;; get a list of test_data records matching categorypatt -(define (db:read-test-data db test-id categorypatt #!key (work-area #f)) - (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) - (if tdb - (let ((res '())) - (sqlite3:for-each-row - (lambda (id test_id category variable value expected tol units comment status type) - (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) - tdb - "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) - (sqlite3:finalize! tdb) - (reverse res)) - '()))) - -;; NOTE: Run this local with #f for db !!! -(define (db:load-test-data db test-id #!key (work-area #f)) - (let loop ((lin (read-line))) - (if (not (eof-object? lin)) - (begin - (debug:print 4 lin) - (db:csv->test-data db test-id lin work-area: work-area) - (loop (read-line))))) - ;; roll up the current results. - ;; FIXME: Add the status to - (db:test-data-rollup db test-id #f work-area: work-area)) - -;; WARNING: Do NOT call this for the parent test on an iterated test -;; Roll up test_data pass/fail results -;; look at the test_data status field, -;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. -;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored -(define (db:test-data-rollup db test-id status #!key (work-area #f)) - (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) - (fail-count 0) - (pass-count 0)) - (if tdb - (begin - (sqlite3:for-each-row - (lambda (fcount pcount) - (set! fail-count fcount) - (set! pass-count pcount)) - tdb - "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, - (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" - test-id test-id) - (sqlite3:finalize! tdb) - - ;; Now rollup the counts to the central megatest.db - (cdb:pass-fail-counts *runremote* test-id fail-count pass-count) - ;; (sqlite3:execute db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;" - ;; fail-count pass-count test-id) - - ;; The flush is not needed with the transaction based write agregation enabled. Remove these commented lines - ;; next time you read this! - ;; - ;; (cdb:flush-queue *runremote*) - ;; (thread-sleep! 1) ;; play nice with the queue by ensuring the rollup is at least 10ms later than the set - - ;; if the test is not FAIL then set status based on the fail and pass counts. - (cdb:test-rollup-test_data-pass-fail *runremote* test-id) - ;; (sqlite3:execute - ;; db ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME - ;; "UPDATE tests - ;; SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 - ;; THEN 'FAIL' - ;; WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND - ;; (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') - ;; THEN 'PASS' - ;; ELSE status - ;; END WHERE id=?;" - ;; test-id test-id test-id test-id) - )))) - -(define (db:get-prev-tol-for-test db test-id category variable) - ;; Finish me? - (values #f #f #f)) - -;;====================================================================== -;; S T E P S -;;====================================================================== - -(define (db:step-get-time-as-string vec) - (seconds->time-string (db:step-get-event_time vec))) - -;; db-get-test-steps-for-run -(define (db:get-steps-for-test db test-id #!key (work-area #f)) - (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) - (res '())) - (if tdb - (begin - (sqlite3:for-each-row - (lambda (id test-id stepname state status event-time logfile) - (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) - tdb - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (sqlite3:finalize! tdb) - (reverse res)) - '()))) - -;; get a pretty table to summarize steps -;; -(define (db:get-steps-table db test-id #!key (work-area #f)) - (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) - ;; organise the steps for better readability - (let ((res (make-hash-table))) - (for-each - (lambda (step) - (debug:print 6 "step=" step) - (let ((record (hash-table-ref/default - res - (db:step-get-stepname step) - ;; stepname start end status Duration Logfile - (vector (db:step-get-stepname step) "" "" "" "" "")))) - (debug:print 6 "record(before) = " record - "\nid: " (db:step-get-id step) - "\nstepname: " (db:step-get-stepname step) - "\nstate: " (db:step-get-state step) - "\nstatus: " (db:step-get-status step) - "\ntime: " (db:step-get-event_time step)) - (case (string->symbol (db:step-get-state step)) - ((start)(vector-set! record 1 (db:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") - (db:step-get-status step))) - (if (> (string-length (db:step-get-logfile step)) - 0) - (vector-set! record 5 (db:step-get-logfile step)))) - ((end) - (vector-set! record 2 (any->number (db:step-get-event_time step))) - (vector-set! record 3 (db:step-get-status step)) - (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) - (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) - ", startt=" startt ", endt=" endt - ", get-status: " (db:step-get-status step)) - (if (and (number? startt)(number? endt)) - (seconds->hr-min-sec (- endt startt)) "-1"))) - (if (> (string-length (db:step-get-logfile step)) - 0) - (vector-set! record 5 (db:step-get-logfile step)))) - (else - (vector-set! record 2 (db:step-get-state step)) - (vector-set! record 3 (db:step-get-status step)) - (vector-set! record 4 (db:step-get-event_time step)))) - (hash-table-set! res (db:step-get-stepname step) record) - (debug:print 6 "record(after) = " record - "\nid: " (db:step-get-id step) - "\nstepname: " (db:step-get-stepname step) - "\nstate: " (db:step-get-state step) - "\nstatus: " (db:step-get-status step) - "\ntime: " (db:step-get-event_time step)))) - ;; (else (vector-set! record 1 (db:step-get-event_time step))) - (sort steps (lambda (a b) - (cond - ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t) - ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) - (< (db:step-get-id a) (db:step-get-id b))) - (else #f))))) - res))) - -;; get a pretty table to summarize steps -;; -(define (db:get-steps-table-list db test-id #!key (work-area #f)) - (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) - ;; organise the steps for better readability - (let ((res (make-hash-table))) - (for-each - (lambda (step) - (debug:print 6 "step=" step) - (let ((record (hash-table-ref/default - res - (db:step-get-stepname step) - ;; stepname start end status - (vector (db:step-get-stepname step) "" "" "" "" "")))) - (debug:print 6 "record(before) = " record - "\nid: " (db:step-get-id step) - "\nstepname: " (db:step-get-stepname step) - "\nstate: " (db:step-get-state step) - "\nstatus: " (db:step-get-status step) - "\ntime: " (db:step-get-event_time step)) - (case (string->symbol (db:step-get-state step)) - ((start)(vector-set! record 1 (db:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") - (db:step-get-status step))) - (if (> (string-length (db:step-get-logfile step)) - 0) - (vector-set! record 5 (db:step-get-logfile step)))) - ((end) - (vector-set! record 2 (any->number (db:step-get-event_time step))) - (vector-set! record 3 (db:step-get-status step)) - (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) - (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) - ", startt=" startt ", endt=" endt - ", get-status: " (db:step-get-status step)) - (if (and (number? startt)(number? endt)) - (seconds->hr-min-sec (- endt startt)) "-1"))) - (if (> (string-length (db:step-get-logfile step)) - 0) - (vector-set! record 5 (db:step-get-logfile step)))) - (else - (vector-set! record 2 (db:step-get-state step)) - (vector-set! record 3 (db:step-get-status step)) - (vector-set! record 4 (db:step-get-event_time step)))) - (hash-table-set! res (db:step-get-stepname step) record) - (debug:print 6 "record(after) = " record - "\nid: " (db:step-get-id step) - "\nstepname: " (db:step-get-stepname step) - "\nstate: " (db:step-get-state step) - "\nstatus: " (db:step-get-status step) - "\ntime: " (db:step-get-event_time step)))) - ;; (else (vector-set! record 1 (db:step-get-event_time step))) - (sort steps (lambda (a b) - (cond - ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t) - ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) - (< (db:step-get-id a) (db:step-get-id b))) - (else #f))))) - res))) - -(define (db:get-compressed-steps test-id #!key (work-area #f)(tdb #f)) - (if (or (not work-area) - (file-exists? (conc work-area "/testdat.db"))) - (let* ((comprsteps (open-run-close db:get-steps-table tdb test-id work-area: work-area))) - (map (lambda (x) - ;; take advantage of the \n on time->string - (vector - (vector-ref x 0) - (let ((s (vector-ref x 1))) - (if (number? s)(seconds->time-string s) s)) - (let ((s (vector-ref x 2))) - (if (number? s)(seconds->time-string s) s)) - (vector-ref x 3) ;; status - (vector-ref x 4) - (vector-ref x 5))) ;; time delta - (sort (hash-table-values comprsteps) - (lambda (a b) - (let ((time-a (vector-ref a 1)) - (time-b (vector-ref b 1))) - (if (and (number? time-a)(number? time-b)) - (if (< time-a time-b) - #t - (if (eq? time-a time-b) - (stringtest-data +;; )) + Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -1,6 +1,6 @@ -(define (make-db:test)(make-vector 6)) +(define (make-db:test)(make-vector 20)) (define-inline (db:test-get-id vec) (vector-ref vec 0)) (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) (define-inline (db:test-get-testname vec) (vector-ref vec 2)) (define-inline (db:test-get-state vec) (vector-ref vec 3)) (define-inline (db:test-get-status vec) (vector-ref vec 4)) @@ -12,10 +12,12 @@ (define-inline (db:test-get-rundir vec) (vector-ref vec 10)) (define-inline (db:test-get-item-path vec) (vector-ref vec 11)) (define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) (define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) (define-inline (db:test-get-comment vec) (vector-ref vec 14)) +(define-inline (db:test-get-pass_count vec) (vector-ref vec 15)) +(define-inline (db:test-get-fail_count vec) (vector-ref vec 16)) (define-inline (db:test-get-fullname vec) (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) (define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) (define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) @@ -97,38 +99,38 @@ ;; S T E P S ;;====================================================================== ;; Run steps ;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time (define (make-db:step)(make-vector 7)) -(define-inline (db:step-get-id vec) (vector-ref vec 0)) -(define-inline (db:step-get-test_id vec) (vector-ref vec 1)) -(define-inline (db:step-get-stepname vec) (vector-ref vec 2)) -(define-inline (db:step-get-state vec) (vector-ref vec 3)) -(define-inline (db:step-get-status vec) (vector-ref vec 4)) -(define-inline (db:step-get-event_time vec) (vector-ref vec 5)) -(define-inline (db:step-get-logfile vec) (vector-ref vec 6)) -(define-inline (db:step-set-id! vec val)(vector-set! vec 0 val)) -(define-inline (db:step-set-test_id! vec val)(vector-set! vec 1 val)) -(define-inline (db:step-set-stepname! vec val)(vector-set! vec 2 val)) -(define-inline (db:step-set-state! vec val)(vector-set! vec 3 val)) -(define-inline (db:step-set-status! vec val)(vector-set! vec 4 val)) -(define-inline (db:step-set-event_time! vec val)(vector-set! vec 5 val)) -(define-inline (db:step-set-logfile! vec val)(vector-set! vec 6 val)) +(define-inline (tdb:step-get-id vec) (vector-ref vec 0)) +(define-inline (tdb:step-get-test_id vec) (vector-ref vec 1)) +(define-inline (tdb:step-get-stepname vec) (vector-ref vec 2)) +(define-inline (tdb:step-get-state vec) (vector-ref vec 3)) +(define-inline (tdb:step-get-status vec) (vector-ref vec 4)) +(define-inline (tdb:step-get-event_time vec) (vector-ref vec 5)) +(define-inline (tdb:step-get-logfile vec) (vector-ref vec 6)) +(define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val)) +(define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) +(define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) +(define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val)) +(define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val)) +(define-inline (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) +(define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) ;; The steps table (define (make-db:steps-table)(make-vector 5)) -(define-inline (db:steps-table-get-stepname vec) (vector-ref vec 0)) -(define-inline (db:steps-table-get-start vec) (vector-ref vec 1)) -(define-inline (db:steps-table-get-end vec) (vector-ref vec 2)) -(define-inline (db:steps-table-get-status vec) (vector-ref vec 3)) -(define-inline (db:steps-table-get-runtime vec) (vector-ref vec 4)) -(define-inline (db:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) -(define-inline (db:step-stable-set-start! vec val)(vector-set! vec 1 val)) -(define-inline (db:step-stable-set-end! vec val)(vector-set! vec 2 val)) -(define-inline (db:step-stable-set-status! vec val)(vector-set! vec 3 val)) -(define-inline (db:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) +(define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) +(define-inline (tdb:steps-table-get-start vec) (vector-ref vec 1)) +(define-inline (tdb:steps-table-get-end vec) (vector-ref vec 2)) +(define-inline (tdb:steps-table-get-status vec) (vector-ref vec 3)) +(define-inline (tdb:steps-table-get-runtime vec) (vector-ref vec 4)) +(define-inline (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) +(define-inline (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val)) +(define-inline (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val)) +(define-inline (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val)) +(define-inline (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) ;; use this one for db-get-run-info (define-inline (db:get-row vec)(vector-ref vec 1)) ;; The data structure for handing off requests via wire Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -375,15 +375,15 @@ (iup:attribute-set! general-matrix "3:0" "Version") (iup:attribute-set! general-matrix "3:1" megatest-version) general-matrix)) -(define (dcommon:run-stats) +(define (dcommon:run-stats db) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) (updater (lambda () - (let* ((run-stats (mt:get-run-stats)) + (let* ((run-stats (db:get-run-stats db)) (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) (row-indices (car indices)) (col-indices (cadr indices)) (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 Index: docs/megatest-training.odp ================================================================== --- docs/megatest-training.odp +++ docs/megatest-training.odp cannot compute difference between binary files Index: docs/megatest-training.pdf ================================================================== --- docs/megatest-training.pdf +++ docs/megatest-training.pdf cannot compute difference between binary files Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -77,12 +77,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - ;; DO NOT remote - (db:teststep-set-status! #f test-id stepname "start" "-" #f #f work-area: test-run-dir) + (rmt:teststep-set-status! #f test-id stepname "start" "-" #f #f) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! run-mutex) @@ -95,14 +94,13 @@ (thread-sleep! 1) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) - ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) - (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: test-run-dir)) + (rmt:teststep-set-status! #f test-id stepname "end" exinfo #f logfna)) (if logpro-used - (cdb:test-set-log! *runremote* test-id (conc stepname ".html"))) + (rmt:test-set-log! test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) ((eq? (vector-ref exit-info 2) 0) 'pass) (else 'fail))) ADDED fdb_records.scm Index: fdb_records.scm ================================================================== --- /dev/null +++ fdb_records.scm @@ -0,0 +1,19 @@ +;; Single record for managing a filedb +;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache +;; Filedb record +(define (make-filedb:fdb)(make-vector 5)) +(define-inline (filedb:fdb-get-db vec) (vector-ref vec 0)) +(define-inline (filedb:fdb-get-dbpath vec) (vector-ref vec 1)) +(define-inline (filedb:fdb-get-pathcache vec) (vector-ref vec 2)) +(define-inline (filedb:fdb-get-idcache vec) (vector-ref vec 3)) +(define-inline (filedb:fdb-get-partcache vec) (vector-ref vec 4)) +(define-inline (filedb:fdb-set-db! vec val)(vector-set! vec 0 val)) +(define-inline (filedb:fdb-set-dbpath! vec val)(vector-set! vec 1 val)) +(define-inline (filedb:fdb-set-pathcache! vec val)(vector-set! vec 2 val)) +(define-inline (filedb:fdb-set-idcache! vec val)(vector-set! vec 3 val)) +(define-inline (filedb:fdb-set-partcache! vec val)(vector-set! vec 4 val)) + +;; children records, should have use something other than "child" +(define-inline (filedb:child-get-id vec) (vector-ref vec 0)) +(define-inline (filedb:child-get-path vec) (vector-ref vec 1)) +(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2)) ADDED filedb.scm Index: filedb.scm ================================================================== --- /dev/null +++ filedb.scm @@ -0,0 +1,230 @@ +;; 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. + +;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex) +(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit filedb)) + +(include "fdb_records.scm") +;; (include "settings.scm") + +(define (filedb:open-db dbpath) + (let* ((fdb (make-filedb:fdb)) + (dbexists (file-exists? dbpath)) + (db (sqlite3:open-database dbpath))) + (filedb:fdb-set-db! fdb db) + (filedb:fdb-set-dbpath! fdb dbpath) + (filedb:fdb-set-pathcache! fdb (make-hash-table)) + (filedb:fdb-set-idcache! fdb (make-hash-table)) + (filedb:fdb-set-partcache! fdb (make-hash-table)) + ;(sqlite3:set-busy-timeout! db 1000000) + (if (not dbexists) + (begin + (sqlite3:execute db "PRAGMA synchronous = OFF;") + (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id + (sqlite3:execute db "CREATE INDEX name_index ON names (name);") + ;; NB// We store a useful subset of file attributes but do not attempt to store all + (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY, + path TEXT, + parent_id INTEGER, + mode INTEGER DEFAULT -1, + uid INTEGER DEFAULT -1, + gid INTEGER DEFAULT -1, + size INTEGER DEFAULT -1, + mtime INTEGER DEFAULT -1);") + (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);") + (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) + fdb)) + +(define (filedb:get-current-time-string) + (string-chomp (time->string (seconds->local-time (current-seconds))))) + +(define (filedb:get-base-id db path) + (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;")) + (id-num #f)) + (sqlite3:for-each-row + (lambda (num) (set! id-num num)) stmt path) + (sqlite3:finalize! stmt) + id-num)) + +(define (filedb:get-path-id db path parent) + (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;")) + (id-num #f)) + (sqlite3:for-each-row + (lambda (num) (set! id-num num)) stmt path parent) + (sqlite3:finalize! stmt) + id-num)) + +(define (filedb:add-base db path) + (let ((existing (filedb:get-base-id db path))) + (if existing #f + (begin + (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string)))))) + +;; index value field notes +;; 0 inode number st_ino +;; 1 mode st_mode bitfield combining file permissions and file type +;; 2 number of hard links st_nlink +;; 3 UID of owner st_uid as with file-owner +;; 4 GID of owner st_gid +;; 5 size st_size as with file-size +;; 6 access time st_atime as with file-access-time +;; 7 change time st_ctime as with file-change-time +;; 8 modification time st_mtime as with file-modification-time +;; 9 parent device ID st_dev ID of device on which this file resides +;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number) +;; 11 block size st_blksize +;; 12 number of blocks allocated st_blocks + +(define (filedb:add-path-stat db path parent statinfo) + (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);"))) + (sqlite3:execute stmt + path + parent + (vector-ref statinfo 1) ;; mode + (vector-ref statinfo 3) ;; uid + (vector-ref statinfo 4) ;; gid + (vector-ref statinfo 5) ;; size + (vector-ref statinfo 8) ;; mtime + ))) ;; (filedb:get-current-time-string)))) + +(define (filedb:add-path db path parent) + (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);"))) + (sqlite3:execute stmt path parent))) + +(define (filedb:register-path fdb path #!key (save-stat #f)) + (let* ((db (filedb:fdb-get-db fdb)) + (pathcache (filedb:fdb-get-pathcache fdb)) + (stat (if save-stat (file-stat path #t))) + (id (hash-table-ref/default pathcache path #f))) + (if id id + (let ((plist (string-split path "/"))) + (let loop ((head (car plist)) + (tail (cdr plist)) + (parent 0)) + (let ((id (filedb:get-path-id db head parent)) + (done (null? tail))) + (if id ;; we'll have a id if the path is already registered + (if done + (begin + (hash-table-set! pathcache path id) + id) ;; return the last path id for a result + (loop (car tail)(cdr tail) id)) + (begin ;; add the path and then repeat the loop with the same data + (if save-stat + (filedb:add-path-stat db head parent stat) + (filedb:add-path db head parent)) + (loop head tail parent))))))))) + +(define (filedb:update-recursively fdb path #!key (save-stat #f)) + (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path)))) + (print "processed 0 files...") + (let loop ((l (read-line p)) + (lc 0)) ;; line count + (if (eof-object? l) + (begin + (print " " lc " files") + (close-input-port p)) + (begin + (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info + (if (= (modulo lc 100) 0) + (print " " lc " files")) + (loop (read-line p)(+ lc 1))))))) + +(define (filedb:update fdb path #!key (save-stat #f)) + ;; first get the realpath and add it to the bases table + (let ((real-path path) ;; (filedb:get-real-path path)) + (db (filedb:fdb-get-db fdb))) + (filedb:add-base db real-path) + (filedb:update-recursively fdb path save-stat: save-stat))) + +;; not used and broken +;; +(define (filedb:get-real-path path) + (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path)))) + (pth (read-line p))) + (if (eof-object? pth) path + (begin + (close-input-port p) + pth)))) + +(define (filedb:drop-base fdb path) + (print "Sorry, I don't do anything yet")) + +(define (filedb:find-all fdb pattern action) + (let* ((db (filedb:fdb-get-db fdb)) + (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;")) + (result '())) + (sqlite3:for-each-row + (lambda (num) + (action num) + (set! result (cons num result))) stmt pattern) + (sqlite3:finalize! stmt) + result)) + +(define (filedb:get-path-record fdb id) + (let* ((db (filedb:fdb-get-db fdb)) + (partcache (filedb:fdb-get-partcache fdb)) + (dat (hash-table-ref/default partcache id #f))) + (if dat dat + (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;")) + (result #f)) + (sqlite3:for-each-row + (lambda (path parent_id)(set! result (list path parent_id))) stmt id) + (hash-table-set! partcache id result) + result)))) + +(define (filedb:get-children fdb parent-id) + (let* ((db (filedb:fdb-get-db fdb)) + (res '())) + (sqlite3:for-each-row + (lambda (id path parent-id) + (set! res (cons (vector id path parent-id) res))) + db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;" + parent-id) + res)) + +;; retrieve all that have children and those without +;; children that match patt +(define (filedb:get-children-patt fdb parent-id search-patt) + (let* ((db (filedb:fdb-get-db fdb)) + (res '())) + ;; first get the children that have no children + (sqlite3:for-each-row + (lambda (id path parent-id) + (set! res (cons (vector id path parent-id) res))) + db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND + (id IN (SELECT parent_id FROM paths) OR path LIKE ?);" + parent-id search-patt) + res)) + +(define (filedb:get-path fdb id) + (let* ((db (filedb:fdb-get-db fdb)) + (idcache (filedb:fdb-get-idcache fdb)) + (path (hash-table-ref/default idcache id #f))) + (if path path + (let loop ((curr-id id) + (path "")) + (let ((path-record (filedb:get-path-record fdb curr-id))) + (if (not path-record) #f ;; this id has no path + (let* ((parent-id (list-ref path-record 1)) + (pname (list-ref path-record 0)) + (newpath (string-append "/" pname path))) + (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0 + (begin + (hash-table-set! idcache id newpath) + newpath) + (loop parent-id newpath))))))))) + +(define (filedb:search db pattern) + (let ((action (lambda (id)(print (filedb:get-path db id))))) + (filedb:find-all db pattern action))) + Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -74,34 +74,41 @@ (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) #f))) - (if ipstr ipstr hostn))) ;; hostname))) + (if ipstr ipstr hostn))) ;; hostname))) (start-port (if (and (args:get-arg "-port") (string->number (args:get-arg "-port"))) (string->number (args:get-arg "-port")) (if (and (config-lookup *configdat* "server" "port") (string->number (config-lookup *configdat* "server" "port"))) (string->number (config-lookup *configdat* "server" "port")) (+ 5000 (random 1001))))) (link-tree-path (config-lookup *configdat* "setup" "linktree"))) - (set! *cache-on* #t) + (set! db *inmemdb*) (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! (handle-directory spiffy-directory-listing) ;; http-transport:handle-directory) ;; simple-directory-handler) ;; Setup the web server and a /ctrl interface ;; (vhost-map `(((* any) . ,(lambda (continue) ;; open the db on the first call - (if (not db)(set! db (open-db))) + ;; This is were we set up the database connections (let* (($ (request-vars source: 'both)) (dat ($ 'dat)) (res #f)) (cond + ((equal? (uri-path (request-uri (current-request))) + '(/ "api")) + (send-response body: (api:process-request db $) ;; the $ is the request vars proc + headers: '((content-type text/plain))) + (mutex-lock! *heartbeat-mutex*) + (set! *last-db-access* (current-seconds)) + (mutex-unlock! *heartbeat-mutex*)) ;; This is the /ctrl path where data is handed to the server and ;; responses ((equal? (uri-path (request-uri (current-request))) '(/ "ctrl")) (let* ((packet (db:string->obj dat)) @@ -174,10 +181,96 @@ ;;====================================================================== ;; C L I E N T S ;;====================================================================== (define *http-mutex* (make-mutex)) +(define *http-requests-in-progress* 0) +(define *http-connections-next-cleanup* (current-seconds)) + +(define (http-transport:get-time-to-cleanup) + (let ((res #f)) + (mutex-lock! *http-mutex*) + (set! res (> (current-seconds) *http-connections-next-cleanup*)) + (mutex-unlock! *http-mutex*) + res)) + +(define (http-transport:inc-requests-count) + (mutex-lock! *http-mutex*) + (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)) + ;; Use this opportunity to slow things down iff there are too many requests in flight + (if (> *http-requests-in-progress* 5) + (begin + (debug:print-info 0 "Whoa there buddy, ease up...") + (thread-sleep! 1))) + (mutex-unlock! *http-mutex*)) + +(define (http-transport:dec-requests-count proc) + (mutex-lock! *http-mutex*) + (proc) + (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) + (mutex-unlock! *http-mutex*)) + +(define (http-transport:dec-requests-count-and-close-all-connections) + (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) + (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds + (if (> *http-requests-in-progress* 0) + (if (> etime (current-seconds)) + (begin + (thread-sleep! 0.05) + (loop etime)) + (debug:print 0 "ERROR: requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) + (close-all-connections!))) + (set! *http-connections-next-cleanup* (+ (current-seconds) 10)) + (mutex-unlock! *http-mutex*)) + +(define (http-transport:inc-requests-and-prep-to-close-all-connections) + (mutex-lock! *http-mutex*) + (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))) + +;; This next block all imported en-mass from the api branch +(define *http-requests-in-progress* 0) +(define *http-connections-next-cleanup* (current-seconds)) + +(define (http-transport:get-time-to-cleanup) + (let ((res #f)) + (mutex-lock! *http-mutex*) + (set! res (> (current-seconds) *http-connections-next-cleanup*)) + (mutex-unlock! *http-mutex*) + res)) + +(define (http-transport:inc-requests-count) + (mutex-lock! *http-mutex*) + (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)) + ;; Use this opportunity to slow things down iff there are too many requests in flight + (if (> *http-requests-in-progress* 5) + (begin + (debug:print-info 0 "Whoa there buddy, ease up...") + (thread-sleep! 1))) + (mutex-unlock! *http-mutex*)) + +(define (http-transport:dec-requests-count proc) + (mutex-lock! *http-mutex*) + (proc) + (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) + (mutex-unlock! *http-mutex*)) + +(define (http-transport:dec-requests-count-and-close-all-connections) + (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) + (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds + (if (> *http-requests-in-progress* 0) + (if (> etime (current-seconds)) + (begin + (thread-sleep! 0.05) + (loop etime)) + (debug:print 0 "ERROR: requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) + (close-all-connections!))) + (set! *http-connections-next-cleanup* (+ (current-seconds) 10)) + (mutex-unlock! *http-mutex*)) + +(define (http-transport:inc-requests-and-prep-to-close-all-connections) + (mutex-lock! *http-mutex*) + (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))) ;; (system "megatest -list-servers | grep alive || megatest -server - -daemonize && sleep 4") ;; ;; @@ -209,17 +302,34 @@ ;; #t)) ;; send the data and get the response ;; extract the needed info from the http data and ;; process and return it. (let* ((send-recieve (lambda () - (mutex-lock! *http-mutex*) - (set! res (with-input-from-request - fullurl - (list (cons 'dat msg)) - read-string)) - (close-all-connections!) - (mutex-unlock! *http-mutex*))) + ;; (let ((dat #f) + ;; (cleanup (http-transport:get-time-to-cleanup))) + ;; (if cleanup + ;; (begin + ;; (debug:print-info 0 "Running cleanup mode") + ;; (http-transport:inc-requests-and-prep-to-close-all-connections)) + ;; (http-transport:inc-requests-count)) + ;; ;; Do the actual data transfer + (mutex-lock! *http-mutex*) ;; Hypothesis is that this was *not* the bottleneck + (set! res (with-input-from-request ;; was set! dat + fullurl + (list (cons 'dat msg)) + read-string)) + (close-all-connections!) + (mutex-unlock! *http-mutex*) + )) + ;;(if cleanup + ;; ;; mutex already set + ;; (begin + ;; (set! res dat) + ;; (http-transport:dec-requests-count-and-close-all-connections)) + ;; (http-transport:dec-requests-count + ;; (lambda () + ;; (set! res dat))))))) (time-out (lambda () (thread-sleep! 45) (if (not res) (begin (debug:print 0 "WARNING: communication with the server timed out.") @@ -239,17 +349,98 @@ (let ((match (string-search (regexp "(.*)<.body>") res))) (debug:print-info 11 "match=" match) (let ((final (cadr match))) (debug:print-info 11 "final=" final) final))))))) + +;; Send "cmd" with json payload "params" to serverdat and receive result +;; +(define (http-transport:client-api-send-receive serverdat cmd params #!key (numretries 30)) + (let* ((fullurl (if (list? serverdat) + (cadddr serverdat) ;; this is the uri for /api + (begin + (debug:print 0 "FATAL ERROR: http-transport:client-send-receive called with no server info") + (exit 1)))) + (res #f)) + (handle-exceptions + exn + (begin + ;; TODO: Send this output to a log file so it isn't lost when running as daemon + (print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 2) + (if (> numretries 0) + (http-transport:client-api-send-receive serverdat cmd params numretries: (- numretries 1)))) + (begin + (debug:print-info 11 "fullurl=" fullurl "\n") + ;; set up the http-client here + (max-retry-attempts 5) + ;; consider all requests indempotent + (retry-request? (lambda (request) + #t)) ;; (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10)) + ;; (set! numretries (- numretries 1)) + ;; #t)) + ;; send the data and get the response + ;; extract the needed info from the http data and + ;; process and return it. + + ;; (with-input-from-request "http://localhost/echo-service" + ;; '((test . "value")) read-string) + + (let* ((send-recieve (lambda () + ;; (let ((dat #f) + ;; (cleanup (http-transport:get-time-to-cleanup))) + ;; (if cleanup + ;; (http-transport:inc-requests-and-prep-to-close-all-connections) + ;; (http-transport:inc-requests-count)) + ;; ;; Do the actual data transfer NB// KEPP THIS IN SYNC WITH http-transport:client-send-receive + (mutex-lock! *http-mutex*) + (set! res (with-input-from-request ;; was dat + fullurl + (list (cons 'key "thekey") + (cons 'cmd cmd) + (cons 'params params)) + read-string)) + ;; Shouldn't this be a call to the managed call-all-connections stuff above? + (close-all-connections!) + (mutex-unlock! *http-mutex*) + )) + ;; (if cleanup + ;; ;; mutex already set + ;; (begin + ;; (set! res dat) + ;; (http-transport:dec-requests-count-and-close-all-connections)) + ;; (http-transport:dec-requests-count + ;; (lambda () + ;; (set! res dat))))))) + (time-out (lambda () + (thread-sleep! 45) + (if (not res) + (begin + (debug:print 0 "WARNING: communication with the server timed out.") + (mutex-unlock! *http-mutex*) + (http-transport:client-api-send-receive serverdat cmd params numretries: (- numretries 1)) + (if (< numretries 3) ;; on last try just exit + (begin + (debug:print 0 "ERROR: communication with the server timed out. Giving up.") + (exit 1))))))) + (th1 (make-thread send-recieve "with-input-from-request")) + (th2 (make-thread time-out "time out"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + (thread-terminate! th2) + (debug:print-info 11 "got res=" res) + res))))) (define (http-transport:client-connect iface port) (let* ((login-res #f) (uri-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl")))) - (serverdat (list iface port uri-dat))) - (set! login-res (client:login serverdat)) - (if (and (not (null? login-res)) + (uri-api-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/api")))) + (serverdat (list iface port uri-dat uri-api-dat))) + (set! *runremote* serverdat) ;; may or may not be good ... + (set! login-res (rmt:login)) + (if (and (list? login-res) (car login-res)) (begin (debug:print-info 2 "Logged in and connected to " iface ":" port) (set! *runremote* serverdat) serverdat) @@ -290,68 +481,79 @@ (* 60 60 (string->number tmo)) ;; default to three days (* 3 24 60 60))))) (debug:print-info 2 "server-timeout: " server-timeout ", server pid: " spid " on " iface ":" port) (let loop ((count 0)) - (thread-sleep! 4) ;; no need to do this very often - ;; NB// sync currently does NOT return queue-length - (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1))) - ;; (print "Server running, count is " count) - (if (< count 1) ;; 3x3 = 9 secs aprox - (loop (+ count 1))) - - ;; Check that iface and port have not changed (can happen if server port collides) - (mutex-lock! *heartbeat-mutex*) - (set! sdat *runremote*) - (mutex-unlock! *heartbeat-mutex*) - - (if (or (not (equal? sdat (list iface port))) - (not spid)) - (begin - (debug:print-info 0 "interface changed, refreshing iface and port info") - (set! iface (car sdat)) - (set! port (cadr sdat)) - (set! spid (tasks:server-get-server-id tdb #f iface port #f)))) - - ;; NOTE: Get rid of this mechanism! It really is not needed... - ;; (open-run-close tasks:server-update-heartbeat tasks:open-db spid) - (tasks:server-update-heartbeat tdb spid) - - ;; (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 (and *server-run* - (> (+ last-access server-timeout) - (current-seconds))) - (begin - (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) - (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name)) - (thread-sleep! 1) - (debug:print-info 0 "Max cached queries was " *max-cache-size*) - (debug:print-info 0 "Number of cached writes " *number-of-writes*) - (debug:print-info 0 "Average cached write time " - (if (eq? *number-of-writes* 0) - "n/a (no writes)" - (/ *writes-total-delay* - *number-of-writes*)) - " ms") - (debug:print-info 0 "Number non-cached queries " *number-non-write-queries*) - (debug:print-info 0 "Average non-cached time " - (if (eq? *number-non-write-queries* 0) - "n/a (no queries)" - (/ *total-non-write-delay* - *number-non-write-queries*)) - " ms") - (debug:print-info 0 "Server shutdown complete. Exiting") - (exit))))))) + ;; Use this opportunity to sync the inmemdb to db + (let ((start-time (current-milliseconds)) + (sync-time #f) + (rem-time #f)) + (if *inmemdb* (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) + (set! sync-time (- (current-milliseconds) start-time)) + (debug:print 0 "SYNC: time= " sync-time) + (set! rem-time (quotient (- 4000 sync-time) 1000)) + (if (and (< rem-time 4) + (> rem-time 0)) + (thread-sleep! rem-time))) + + ;; (thread-sleep! 4) ;; no need to do this very often + + (if (< count 1) ;; 3x3 = 9 secs aprox + (loop (+ count 1))) + + ;; Check that iface and port have not changed (can happen if server port collides) + (mutex-lock! *heartbeat-mutex*) + (set! sdat *runremote*) + (mutex-unlock! *heartbeat-mutex*) + + (if (or (not (equal? sdat (list iface port))) + (not spid)) + (begin + (debug:print-info 0 "interface changed, refreshing iface and port info") + (set! iface (car sdat)) + (set! port (cadr sdat)) + (set! spid (tasks:server-get-server-id tdb #f iface port #f)))) + + ;; NOTE: Get rid of this mechanism! It really is not needed... + ;; (open-run-close tasks:server-update-heartbeat tasks:open-db spid) + (tasks:server-update-heartbeat tdb spid) + + ;; (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 (and *server-run* + (> (+ last-access server-timeout) + (current-seconds))) + (begin + (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) + (if *inmemdb* (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) + (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name)) + (thread-sleep! 1) + (debug:print-info 0 "Max cached queries was " *max-cache-size*) + (debug:print-info 0 "Number of cached writes " *number-of-writes*) + (debug:print-info 0 "Average cached write time " + (if (eq? *number-of-writes* 0) + "n/a (no writes)" + (/ *writes-total-delay* + *number-of-writes*)) + " ms") + (debug:print-info 0 "Number non-cached queries " *number-non-write-queries*) + (debug:print-info 0 "Average non-cached time " + (if (eq? *number-non-write-queries* 0) + "n/a (no queries)" + (/ *total-non-write-delay* + *number-non-write-queries*)) + " ms") + (debug:print-info 0 "Server shutdown complete. Exiting") + (exit)))))) ;; all routes though here end in exit ... (define (http-transport:launch) (if (not *toppath*) (if (not (setup-for-run)) @@ -370,15 +572,20 @@ (let* ((th2 (make-thread (lambda () (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-"))) "Server run")) - (th3 (make-thread http-transport:keep-running "Keep running")) - (th1 (make-thread server:write-queue-handler "write queue"))) + (th3 (make-thread http-transport:keep-running "Keep running"))) +;; (th1 (make-thread server:write-queue-handler "write queue"))) + (set! *cache-on* #t) + (set! *db* (open-db)) + (set! *inmemdb* (open-in-mem-db)) + (db:sync-tables (db:tbls *db*) *db* *inmemdb*) ;; (db:sync-to *db* *inmemdb*) + (thread-start! th2) (thread-start! th3) - (thread-start! th1) + ;; (thread-start! th1) (set! *didsomething* #t) (thread-join! th2)) (debug:print 0 "ERROR: Failed to setup for megatest"))) (exit))) Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -69,13 +69,18 @@ (debug:print 6 "item-assoc->item-list x: " x) (if (< (length x) 2) (begin (debug:print 0 "ERROR: malformed items spec " (string-intersperse x " ")) (list (car x)'())) - (let ((name (car x)) - (items (cadr x))) - (list name (string-split items))))) + (let* ((name (car x)) + (items (cadr x)) + (ilist (list name (if (string? items) + (string-split items) + '())))) + (if (null? ilist) + (debug:print 0 "ERROR: No items specified for " name)) + ilist))) itemsdat)))) (let ((debuglevel 5)) (debug:print 5 "item-assoc->item-list: itemsdat => itemlst ") (if (debug:debug-mode 5) (begin @@ -131,12 +136,13 @@ (if (member item valid-values) item #f) item))) (define (items:get-items-from-config tconfig) - (let* (;; db is always at *toppath*/db/megatest.db - (items (hash-table-ref/default tconfig "items" '())) + (let* ((have-items (hash-table-ref/default tconfig "items" #f)) + (have-itable (hash-table-ref/default tconfig "itemstable" #f)) + (items (hash-table-ref/default tconfig "items" '())) (itemstable (hash-table-ref/default tconfig "itemstable" '()))) (debug:print 5 "items: " items " itemstable: " itemstable) (set! items (map (lambda (item) (if (procedure? (cadr item)) (list (car item)((cadr item))) @@ -145,14 +151,16 @@ (set! itemstable (map (lambda (item) (if (procedure? (cadr item)) (list (car item)((cadr item))) item)) itemstable)) + (if (and have-items (null? items)) (debug:print 0 "ERROR: [items] section in testconfig but no entries defined")) + (if (and have-itable (null? itemstable))(debug:print 0 "ERROR: [itemstable] section in testconfig but no entries defined")) (if (or (not (null? items))(not (null? itemstable))) (append (item-assoc->item-list items) (item-table->item-list itemstable)) '(())))) ;; (pp (item-assoc->item-list itemdat)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -19,10 +19,11 @@ (declare (unit launch)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) +(declare (uses tdb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -91,11 +92,11 @@ (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) ;; 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! keys (rmt:get-keys)) (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 ","))) @@ -106,17 +107,27 @@ (let ((var (car varval)) (val (cadr varval))) (debug:print 1 "Adding pre-var/val " var " = " val " to the environment") (setenv var val))))) varpairs))) - (setenv "MT_TEST_RUN_DIR" work-area) - (setenv "MT_TEST_NAME" test-name) - (setenv "MT_ITEM_INFO" (conc itemdat)) - (setenv "MT_RUNNAME" runname) - (setenv "MT_MEGATEST" megatest) - (setenv "MT_TARGET" target) - (setenv "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree")) + (for-each + (lambda (varval) + (let ((var (car varval)) + (val (cadr varval))) + (if val + (setenv var val) + (begin + (debug:print 0 "ERROR: required variable " var " does not have a valid value. Exiting") + (exit))))) + (list + (list "MT_TEST_RUN_DIR" work-area) + (list "MT_TEST_NAME" test-name) + (list "MT_ITEM_INFO" (conc itemdat)) + (list "MT_RUNNAME" runname) + (list "MT_MEGATEST" megatest) + (list "MT_TARGET" target) + (list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree")))) (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;; (change-directory top-path) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") @@ -125,26 +136,27 @@ (exit 1))) ;; Can setup as client for server mode now ;; (client:setup) (change-directory *toppath*) - (set-megatest-env-vars run-id) ;; these may be needed by the launching process + (set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process (change-directory work-area) (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-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info - (tests:set-full-meta-info #f test-id run-id 0 work-area) + (tests:set-full-meta-info test-id run-id 0 work-area) ;; (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) (tests:test-force-state-status! test-id "REMOTEHOSTSTART" "n/a") (thread-sleep! 0.3) ;; NFS slowness has caused grief here + ;; (cdb:set-test-start-time! *runremote* test-id) (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test @@ -224,12 +236,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - ;; DO NOT remote - (db:teststep-set-status! #f test-id stepname "start" "-" #f #f work-area: work-area) + (rmt:teststep-set-status! test-id stepname "start" "-" #f #f) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) @@ -242,14 +253,13 @@ (thread-sleep! 2) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) - ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) - (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: work-area)) + (rmt:teststep-set-status! test-id stepname "end" exinfo #f logfna)) (if logpro-used - (cdb:test-set-log! *runremote* test-id (conc stepname ".html"))) + (rmt:test-set-log! test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) ((eq? (vector-ref exit-info 2) 0) 'pass) (else 'fail))) @@ -260,15 +270,15 @@ (next-status (cond ((eq? overall-status 'pass) this-step-status) ((eq? overall-status 'warn) (if (eq? this-step-status 'fail) 'fail 'warn)) (else 'fail))) - (next-state "RUNNING") - ;; (cond - ;; ((null? tal) ;; more to run? - ;; "COMPLETED") - ;; (else "RUNNING")) + (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ?? + (cond + ((null? tal) ;; more to run? + "COMPLETED") + (else "RUNNING"))) ) (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " next-status: " next-status " rollup-status: " rollup-status) (case next-status @@ -279,12 +289,12 @@ (if (eq? this-step-status 'warn) "Logpro warning found" #f) #f)) ((pass) (tests:test-set-status! test-id next-state "PASS" #f #f)) (else ;; 'fail - (set! rollup-status 1) ;; force fail - (tests:test-set-status! test-id next-state "FAIL" (conc "Failed at step " stepname) #f) + (set! rollup-status 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" + (tests:test-set-status! test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) )))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (loop (car tal) (cdr tal) stepname))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) @@ -295,11 +305,11 @@ (round (- (current-seconds) start-seconds))))) (kill-tries 0)) - (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) + (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) (let loop ((minutes (calc-minutes))) (begin (set! kill-job? (or (test-get-kill-request test-id) ;; run-id test-name itemdat)) (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) (time-exceeded (> run-seconds runtlim))) @@ -307,11 +317,11 @@ (begin (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) #t) #f))))) ;; open-run-close not needed for test-set-meta-info - (tests:set-partial-meta-info #f test-id run-id minutes work-area) + (tests:set-partial-meta-info test-id run-id minutes work-area) (if kill-job? (begin (mutex-lock! m) ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this ;; section and the runit section? Or add a loop that tries three times with a 1/4 second @@ -336,34 +346,33 @@ ;; (system (conc "kill -9 -" pid)))) (begin (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") (tests:test-set-status! test-id "KILLED" "FAIL" (args:get-arg "-m") #f) - (sqlite3:finalize! tdb) - (exit 1)))) + (exit 1) ;; IS THIS NECESSARY OR WISE??? + ))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) - ;; (sqlite3:finalize! db) (if keep-going (begin (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses (if keep-going - (loop (calc-minutes)))))))))) ;; NOTE: Checking twice for keep-going is intentional + (loop (calc-minutes))))))) + (tests:update-central-meta-info test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional (th1 (make-thread monitorjob "monitor job")) (th2 (make-thread runit "run job"))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) (set! keep-going #f) (thread-join! th1) - ;; (thread-sleep! 1) - ;; (thread-terminate! th1) ;; Not sure if this is a good idea (thread-sleep! 1) ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) - (testinfo (cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path))) + ;; only state and status needed - use lazy routine + (testinfo (rmt:get-testinfo-state-status test-id))) ;;;(cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path))) ;; Am I completed? (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test @@ -390,11 +399,11 @@ ;; (thread-sleep! 0.1) ;; give other processes an opportunity to access the db as rollup is lower priority ;; (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status))) )) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) - (tests:summarize-items #f run-id test-id test-name #f))) ;; don't force - just update if no + (tests:summarize-items run-id test-id test-name #f))) ;; don't force - just update if no (mutex-unlock! m) (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") (if (not (vector-ref exit-info 1)) (exit 4))))))) @@ -413,11 +422,16 @@ given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") pathenvvar: "MT_RUN_AREA_HOME")) (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) (if *toppath* - (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated + (let ((dbdir (conc *toppath* "/db"))) + (handle-exceptions + exn + (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files") + (if (not (directory-exists? dbdir))(create-directory dbdir))) + (setenv "MT_RUN_AREA_HOME" *toppath*)) (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")))) *toppath*) (define (get-best-disk confdat) (let* ((disks (hash-table-ref/default confdat "disks" #f)) @@ -484,11 +498,11 @@ (lnkbase (conc linktree "/" target "/" runname)) (lnkpath (conc lnkbase "/" testname)) (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path))) ;; Update the rundir path in the test record for all - (cdb:test-set-rundir-by-test-id *runremote* test-id lnkpathf) + (rmt:general-call 'test-set-rundir-by-test-id lnkpathf test-id) (debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) (if (not (file-exists? linktree)) (begin (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree) @@ -504,15 +518,15 @@ ;; again. ;; NB - This is not working right - some top tests are not getting the path set!!! (if (not (hash-table-ref/default *toptest-paths* testname #f)) - (let* ((testinfo (cdb:get-test-info-by-id *runremote* test-id)) ;; run-id testname item-path)) + (let* ((testinfo (rmt:get-test-info-by-id test-id)) ;; run-id testname item-path)) (curr-test-path (if testinfo (db:test-get-rundir testinfo) #f))) (hash-table-set! *toptest-paths* testname curr-test-path) ;; NB// Was this for the test or for the parent in an iterated test? - (cdb:test-set-rundir! *runremote* run-id testname "" lnkpath) ;; toptest-path) + (rmt:general-call 'test-set-rundir lnkpath run-id testname "") ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) (begin (debug:print-info 2 "Creating " toptest-path " and link " lnkpath) (create-directory toptest-path #t) @@ -572,19 +586,10 @@ (debug:print 0 "ERROR: Failed to re-create link " linktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit)) (if (symbolic-link? lnktarget) (delete-file lnktarget)) (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget))))) - ;; I suspect this section was deleting test directories under some - ;; wierd sitations? This doesn't make sense - reenabling the rm -f - ;; I honestly don't remember *why* this chunk was needed... - ;; (let ((testlink (conc lnkpath "/" testname))) - ;; (if (and (file-exists? testlink) - ;; (or (regular-file? testlink) - ;; (symbolic-link? testlink))) - ;; (system (conc "rm -f " testlink))) - ;; (system (conc "ln -sf " test-path " " testlink))) (if (directory? test-path) (begin (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd"))) (if cmd ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH @@ -629,11 +634,12 @@ (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big (diskspace (config-lookup test-conf "requirements" "diskspace")) (memory (config-lookup test-conf "requirements" "memory")) (hosts (config-lookup *configdat* "jobtools" "workhosts")) (remote-megatest (config-lookup *configdat* "setup" "executable")) - (run-time-limit (configf:lookup test-conf "requirements" "runtimelim")) + (run-time-limit (or (configf:lookup test-conf "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 (let* ((lm (car (argv))) @@ -652,11 +658,11 @@ (cmdparms #f) (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)) + (testinfo (rmt:get-test-info-by-id test-id)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '())))) (setenv "MT_ITEMPATH" item-path) (if hosts (set! hosts (string-split hosts))) @@ -700,10 +706,11 @@ ;; 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")) + ;; (cdb:set-test-start-time! *runremote* test-id) (cond ((and launcher hosts) ;; must be using ssh hostname (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) (launcher 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.5512) +(define megatest-version 1.5514) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -25,10 +25,13 @@ (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) (declare (uses daemon)) (declare (uses db)) +(declare (uses tdb)) +(declare (uses mt)) +(declare (uses api)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") @@ -122,10 +125,11 @@ -list-servers : list the servers -stop-server id : stop server specified by id (see output of -list-servers), use 0 to kill all -repl : start a repl (useful for extending megatest) -load file.scm : load and run file.scm + -mark-incompletes : find and mark incomplete tests Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database -pathmod path : insert path, i.e. path/runame/itempath/logfile.html will clear the field if no rundir/testname/itempath/logfile @@ -233,10 +237,11 @@ "-rebuild-db" "-cleanup-db" "-rollup" "-update-meta" "-gen-megatest-area" + "-mark-incompletes" "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only ) @@ -464,11 +469,11 @@ (print x)) targets) (set! *didsomething* #t))) (define (full-runconfigs-read) - (let* ((keys (cdb:remote-run db:get-keys #f)) + (let* ((keys (rmt:get-keys)) (target (if (args:get-arg "-reqtarg") (args:get-arg "-reqtarg") (if (args:get-arg "-target") (args:get-arg "-target") #f))) @@ -569,22 +574,24 @@ ;;====================================================================== ;; Query runs ;;====================================================================== +;; NOTE: list-runs and list-db-targets operate on local db!!! +;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (setup-for-run) - (let* ((db #f) + (let* ((db (open-db)) (runpatt (args:get-arg "-list-runs")) (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) - (runsdat (cdb:remote-run db:get-runs #f runpatt #f #f '())) + (runsdat (db:get-runs db runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) - (keys (cdb:remote-run db:get-keys #f)) + (keys (db:get-keys db)) (db-targets (args:get-arg "-list-db-targets")) (seen (make-hash-table))) ;; Each run (for-each (lambda (run) @@ -597,11 +604,11 @@ (hash-table-set! seen targetstr #t) ;; (print "[" targetstr "]")))) (print targetstr)))) (if (not db-targets) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (mt:get-tests-for-run run-id testpatt '() '()))) + (tests (db:get-tests-for-run db run-id testpatt '() '() #f #f #f 'testname 'asc #f))) (print "Run: " targetstr "/" (db:get-value-by-header run header "runname") " status: " (db:get-value-by-header run header "state") " run-id: " run-id ", number tests: " (length tests)) (for-each (lambda (test) @@ -615,29 +622,29 @@ (db:test-get-status test) (db:test-get-run_duration test) (db:test-get-event_time test) (db:test-get-host test)) (if (not (or (equal? (db:test-get-status test) "PASS") - (equal? (db:test-get-status test) "WARN") + (equal? (db:test-get-status test) "WARN") (equal? (db:test-get-state test) "NOT_STARTED"))) (begin - (print " cpuload: " (db:test-get-cpuload test) + (print " cpuload: " (db:test-get-cpuload test) "\n diskfree: " (db:test-get-diskfree test) "\n uname: " (db:test-get-uname test) "\n rundir: " (db:test-get-rundir test) ) ;; Each test ;; DO NOT remote run - (let ((steps (db:get-steps-for-test #f (db:test-get-id test)))) + (let ((steps (db:get-steps-for-test db (db:test-get-id test)))) (for-each (lambda (step) (format #t " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" - (db:step-get-stepname step) - (db:step-get-state step) - (db:step-get-status step) - (db:step-get-event_time step))) + (tdb:step-get-stepname step) + (tdb:step-get-state step) + (tdb:step-get-status step) + (tdb:step-get-event_time step))) steps))))) tests))))) runs) (set! *didsomething* #t)))) @@ -761,11 +768,11 @@ (exit 1))) (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)) + (let* ((keys (rmt:get-keys)) ;; db:test-get-paths must not be run remote (paths (db:test-get-paths-matching db keys target (args:get-arg "-test-files")))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) @@ -797,11 +804,11 @@ (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) - (db #f) + (db (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target"))) (change-directory testpath) ;; (set! *runremote* runremote) @@ -812,28 +819,30 @@ (exit 1))) (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)) + (let* ((keys (db:get-keys db)) ;; DO NOT run remote (paths (db:test-get-paths-matching db keys target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) - paths))) + paths)) + (if (sqlite3:database? db)(sqlite3:finalize! db))) ;; else do a general-run-call (general-run-call "-test-paths" "Get paths to tests" (lambda (target runname keys keyvals) - (let* ((db #f) + (let* ((db (open-db)) ;; DO NOT run remote (paths (db:test-get-paths-matching db keys target))) (for-each (lambda (path) (print path)) - paths)))))) + paths) + (sqlite3:finalize! db)))))) ;;====================================================================== ;; Extract a spreadsheet from the runs database ;;====================================================================== @@ -840,17 +849,19 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" (lambda (target runname keys keyvals) - (let ((db #f) + (let ((db (open-db)) (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 " keyvals: " keyvals) - (cdb:remote-run db:extract-ods-file db outputfile keyvals (if runspatt runspatt "%") pathmod))))) + (db:extract-ods-file db outputfile keyvals (if runspatt runspatt "%") pathmod) + (sqlite3:finalize! db) + (set! *didsomething* #t))))) ;;====================================================================== ;; execute the test ;; - gets called on remote host ;; - receives info from the -execute param @@ -891,12 +902,11 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) - ;; DO NOT remote run, makes calls to the testdat.db test db. - (db:teststep-set-status! db test-id step state status msg logfile work-area: work-area) + (rmt:teststep-set-status! test-id step state status msg logfile) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") @@ -951,17 +961,17 @@ ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: ;; DO NOT put this one into either cdb:remote-run or open-run-close - (db:load-test-data db test-id work-area: work-area)) + (tdb:load-test-data test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) - (cdb:test-set-log! *runremote* test-id logfname))) + (rmt:test-set-log! test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote - (tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) + (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") ;; DO NOT run remote (tests:summarize-items db run-id test-id test-name #t)) ;; do force here (if (args:get-arg "-runstep") (if (null? remargs) @@ -982,16 +992,15 @@ (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test - ;; DO NOT run remote - (db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile work-area: work-area) + (rmt:teststep-set-status! test-id stepname "start" "n/a" (args:get-arg "-m") logfile) ;; run the test step (debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir) (change-directory startingdir) - (set! exitstat (system fullcmd)) ;; cmd params)) + (set! exitstat (system fullcmd)) (set! *globalexitstatus* exitstat) ;; (change-directory testpath) ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) (if logprofile (let* ((htmllogfile (conc stepname ".html")) @@ -1000,14 +1009,13 @@ (debug:print-info 2 "running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) - (cdb:test-set-log! *runremote* test-id htmllogfile))) + (rmt:test-set-log! test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) - ;; DO NOT run remote - (db:teststep-set-status! db test-id stepname "end" exitstat msg logfile work-area: work-area)) + (rmt:teststep-set-status! test-id stepname "end" exitstat msg logfile)) ))) (if (or (args:get-arg "-test-status") (args:get-arg "-set-values")) (let ((newstatus (cond ((number? status) (if (equal? status 0) "PASS" "FAIL")) @@ -1025,17 +1033,17 @@ (if (and (args:get-arg "-test-status") (or (not state) (not status))) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) - ;; (sqlite3:finalize! db) + (if (sqlite3:database? db)(sqlite3:finalize! db)) (exit 6))) (let* ((msg (args:get-arg "-m")) (numoth (length (hash-table-keys otherdata)))) ;; Convert to rpc inside the tests:test-set-status! call, not here (tests:test-set-status! test-id state newstatus msg otherdata work-area: work-area)))) - (if db (sqlite3:finalize! db)) + (if (sqlite3:database? db)(sqlite3:finalize! db)) (set! *didsomething* #t)))) ;;====================================================================== ;; Various helper commands can go below here ;;====================================================================== @@ -1048,11 +1056,11 @@ (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! keys (cdb:remote-run db:get-keys db)) (debug:print 1 "Keys: " (string-intersperse keys ", ")) - (if db (sqlite3:finalize! db)) + (if (sqlite3:database? db)(sqlite3:finalize! db)) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin (debug:print 0 "Look at the dashboard for now") @@ -1090,10 +1098,19 @@ (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; keep this one local (open-run-close db:clean-up #f) (set! *didsomething* #t))) + +(if (args:get-arg "-mark-incompletes") + (begin + (if (not (setup-for-run)) + (begin + (debug:print 0 "Failed to setup, exiting") + (exit 1))) + (open-run-close db:find-and-mark-incomplete #f) + (set! *didsomething* #t))) ;;====================================================================== ;; Wait on a run to complete ;;====================================================================== @@ -1116,11 +1133,11 @@ (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db ;; keep this one local - (open-run-close runs:update-all-test_meta db) + (open-run-close runs:update-all-test_meta #f) (set! *didsomething* #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -17,10 +17,11 @@ (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses runs)) +(declare (uses rmt)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -38,12 +39,12 @@ ;; 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 (mt:get-runs-by-patt keys runnamepatt targpatt) - (let loop ((runsdat (cdb:remote-run db:get-runs-by-patt #f keys runnamepatt targpatt 0 500)) +(define (mt:get-runs-by-patt dbstruct keys runnamepatt targpatt) + (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500)) (res '()) (offset 0) (limit 500)) ;; (print "runsdat: " runsdat) (let* ((header (vector-ref runsdat 0)) @@ -51,51 +52,84 @@ (full-list (append res runslst)) (have-more (eq? (length runslst) limit))) ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more) (if have-more (let ((new-offset (+ offset limit)) - (next-batch (cdb:remote-run db:get-runs-by-patt #f keys runnamepatt targpatt offset limit))) + (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit))) (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.") (debug:print-info 0 "next-batch: " next-batch) (loop next-batch full-list new-offset limit)) - (vector header full-list))))) + (vector header full-list))))) ;;====================================================================== ;; T E S T S ;;====================================================================== (define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)) - (let loop ((testsdat (cdb:remote-run db:get-tests-for-run #f run-id testpatt states status 0 500 not-in sort-by sort-order qryvals: qryvals)) + (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals)) (res '()) (offset 0) (limit 500)) (let* ((full-list (append res testsdat)) (have-more (eq? (length testsdat) limit))) (if have-more (let ((new-offset (+ offset limit))) (debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.") - (loop (cdb:remote-run db:get-tests-for-run #f run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals: qryvals) + (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals) full-list new-offset limit)) full-list)))) -(define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) - (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode)) +(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) + (let* ((key (list run-id waitons ref-item-path mode)) + (res (hash-table-ref/default *pre-reqs-met-cache* key #f)) + (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) + (if last-time + (< (current-seconds)(+ last-time 5)) + #f)))) + (if useres + (let ((result (vector-ref res 1))) + (debug:print 4 "Using lazy value res: " result) + result) + (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode))) + (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) + newres)))) + +(define (mt:get-run-stats dbstruct run-id) +;; Get run stats from local access, move this ... but where? + (db:get-run-stats dbstruct run-id)) -(define (mt:get-run-stats) - (cdb:remote-run db:get-run-stats #f)) +(define (mt:discard-blocked-tests run-id failed-test tests test-records) + (if (null? tests) + tests + (begin + (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test) + (let loop ((testn (car tests)) + (remt (cdr tests)) + (res '())) + (let ((waitons (vector-ref (hash-table-ref/default test-records testn (vector #f #f '())) 2))) + ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons) + (if (null? remt) + (let ((new-res (reverse res))) + ;; (print " new-res: " new-res) + new-res) + (loop (car remt) + (cdr remt) + (if (member failed-test waitons) + res + (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S ;;====================================================================== (define (mt:process-triggers test-id newstate newstatus) - (let* ((test-dat (mt:lazy-get-test-info-by-id test-id)) + (let* ((test-dat (rmt:get-test-info-by-id test-id)) (test-rundir (db:test-get-rundir test-dat)) (test-name (db:test-get-testname test-dat)) (tconfig #f) (state (if newstate newstate (db:test-get-state test-dat))) (status (if newstatus newstatus (db:test-get-status test-dat)))) @@ -122,32 +156,21 @@ ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== -(define (mt:roll-up-pass-fail-counts run-id test-name item-path status) - (if (and (not (equal? item-path "")) - (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP"))) - (begin - (cdb:update-pass-fail-counts *runremote* run-id test-name) - (if (equal? status "RUNNING") - (cdb:top-test-set-running *runremote* run-id test-name) - (cdb:top-test-set-per-pf-counts *runremote* run-id test-name)) - #f) - #f)) - -;; speed up for common cases with a little logic -(define (mt:test-set-state-status-by-id test-id newstate newstatus newcomment) - (cond - ((and newstate newstatus newcomment) - (cdb:client-call *runremote* 'state-status-msg #t *default-numtries* newstate newstatus newcomment test-id)) - ((and newstate newstatus) - (cdb:client-call *runremote* 'state-status #t *default-numtries* newstate newstatus test-id)) - (else - (if newstate (cdb:client-call *runremote* 'set-test-state #t *default-numtries* newstate test-id)) - (if newstatus (cdb:client-call *runremote* 'set-test-status #t *default-numtries* newstatus test-id)) - (if newcomment (cdb:client-call *runremote* 'set-test-comment #t *default-numtries* newcomment test-id)))) +;; ;; speed up for common cases with a little logic +(define (mt:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment) + (cond + ((and newstate newstatus newcomment) + (rmt:general-call 'state-status-msg newstate newstatus newcomment test-id)) + ((and newstate newstatus) + (rmt:general-call 'state-status newstate newstatus test-id)) + (else + (if newstate (rmt:general-call 'set-test-state newstate test-id)) + (if newstatus (rmt:general-call 'set-test-status newstatus test-id)) + (if newcomment (rmt:general-call 'set-test-comment newcomment test-id)))) (mt:process-triggers test-id newstate newstatus) #t) (define (mt:lazy-get-test-info-by-id test-id) (let* ((tdat (hash-table-ref/default *test-info* test-id #f))) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -568,13 +568,13 @@ (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") tabtop))) (define *current-window-id* 0) -(define (newdashboard) +(define (newdashboard dbstruct) (let* ((data (make-hash-table)) - (keys (cdb:remote-run db:get-keys #f)) + (keys (db:get-keys dbstruct)) (runname "%") (testpatt "%") (keypatts (map (lambda (k)(list k "%")) keys)) (states '()) (statuses '()) ADDED rmt.scm Index: rmt.scm ================================================================== --- /dev/null +++ rmt.scm @@ -0,0 +1,134 @@ +;;====================================================================== +;; Copyright 2006-2013, 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. +;;====================================================================== + +(use json) + +(declare (unit rmt)) +(declare (uses api)) +(declare (uses tdb)) +(declare (uses http-transport)) + +;; +;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! +;; + +;;====================================================================== +;; S U P P O R T F U N C T I O N S +;;====================================================================== + +;; cmd is a symbol +;; vars is a json string encoding the parameters for the call +;; +(define (rmt:send-receive cmd params) + (case *transport-type* + ((fs) + (debug:print 0 "ERROR: Not yet (re)supported") + (exit 1)) + ((http) + (let* ((jparams (rmt:dat->json-str params)) + (res (http-transport:client-api-send-receive *runremote* cmd jparams))) + (if res + (rmt:json-str->dat res) + (begin + (debug:print 0 "ERROR: Bad value from http-transport:client-api-send-receive " res) + #f)) + )) + (else + (debug:print 0 "ERROR: Transport not yet (re)supported") + (exit 1)))) + +;; Wrap json library for strings (why the ports crap in the first place?) +(define (rmt:dat->json-str dat) + (with-output-to-string + (lambda () + (json-write dat)))) + +(define (rmt:json-str->dat json-str) + (with-input-from-string json-str + (lambda () + (json-read)))) + +;;====================================================================== +;; +;; A C T U A L A P I C A L L S +;; +;;====================================================================== + +;;====================================================================== +;; K E Y S +;;====================================================================== + +(define (rmt:get-key-val-pairs run-id) + (rmt:send-receive 'get-key-val-pairs (list run-id))) + +;;====================================================================== +;; T E S T S +;;====================================================================== + +(define (rmt:get-test-info-by-id test-id) + (list->vector + (rmt:send-receive 'get-test-info-by-id (list test-id)))) + +(define (rmt:test-get-rundir-from-test-id test-id) + (rmt:send-receive 'test-get-rundir-from-test-id (list test-id))) + +(define (rmt:open-test-db-by-test-id test-id #!key (work-area #f)) + (let* ((test-path (if (string? work-area) + work-area + (rmt:test-get-rundir-from-test-id test-id)))) + (debug:print 3 "TEST PATH: " test-path) + (open-test-db test-path))) + +(define (rmt:testmeta-get-record testname) + (list->vector + (rmt:send-receive 'testmeta-get-record (list testname)))) + +;; WARNING: This currently bypasses the transaction wrapped writes system +(define (rmt:test-set-state-status-by-id test-id newstate newstatus newcomment) + (rmt:send-receive 'test-set-state-status-by-id (list test-id newstate newstatus newcomment))) + +;;====================================================================== +;; R U N S +;;====================================================================== + +(define (rmt:get-run-info run-id) + (let ((res (rmt:send-receive 'get-run-info (list run-id)))) + (vector (car res) + (list->vector (cadr res))))) + +;;====================================================================== +;; S T E P S +;;====================================================================== + +;; Getting steps is more complicated. +;; +;; If given work area +;; 1. Find the testdat.db file +;; 2. Open the testdat.db file and do the query +;; If not given the work area +;; 1. Do a remote call to get the test path +;; 2. Continue as above +;; +(define (rmt:get-steps-for-test test-id #!key (work-area #f)) + (let* ((tdb (rmt:open-test-db-by-test-id test-id work-area: work-area))) + (if tdb + (tdb:get-steps-data tdb test-id) + '()))) + +;;====================================================================== +;; T E S T D A T A +;;====================================================================== + +(define (rmt:read-test-data test-id categorypatt #!key (work-area #f)) + (let ((tdb (rmt:open-test-db-by-test-id test-id work-area: work-area))) + (if tdb + (tdb:read-test-data tdb test-id categorypatt) + '()))) ADDED rmtdb.scm Index: rmtdb.scm ================================================================== --- /dev/null +++ rmtdb.scm @@ -0,0 +1,11 @@ +;;====================================================================== +;; Copyright 2006-2013, 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. +;;====================================================================== + Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -97,32 +97,38 @@ (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))) + (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))) ;; 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 (car key) (cadr key))) ;; (cdb:remote-run db:get-run-key-val #f run-id (car key)))) + (hash-table-set! vals (car key) (cadr key))) keyvals))) ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) (debug:print 2 "setenv " key " " val) - (setenv key val))) + (if (and (string? key) + (string? val)) + (setenv key val) + (debug:print 0 "ERROR: Malformed environment variable definition: var=" var ", val=" val)))) (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) (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" (if inrunname inrunname (cdb:remote-run db:get-run-name-from-id #f run-id))) + (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) + (if runname + (setenv "MT_RUNNAME" runname) + (debug:print 0 "ERROR: no value for runname for id " 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)) @@ -133,19 +139,20 @@ ;; ;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine ;; (define *last-num-running-tests* 0) (define *runs:can-run-more-tests-count* 0) -(define (runs:shrink-can-run-more-tests-count) ;; the db is a dummy var so we can use cdb:remote-run +(define (runs:shrink-can-run-more-tests-count) (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2))) ;; Temporary globals. Move these into the logic or into common ;; (define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run (define (runs:inc-cant-run-tests testname) (hash-table-set! *seen-cant-run-tests* testname (+ (hash-table-ref/default *seen-cant-run-tests* testname 0) 1))) + (define (runs:can-keep-running? testname n) (< (hash-table-ref/default *seen-cant-run-tests* testname 0) n)) (define *runs:denoise* (make-hash-table)) ;; key => last-time-ran @@ -160,12 +167,12 @@ (define (runs:can-run-more-tests jobgroup max-concurrent-jobs) (thread-sleep! (cond ((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while (else 0))) - (let* ((num-running (cdb:remote-run db:get-count-tests-running #f)) - (num-running-in-jobgroup (cdb:remote-run db:get-count-tests-running-in-jobgroup #f jobgroup)) + (let* ((num-running (rmt:get-count-tests-running)) + (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup jobgroup)) (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) (if (> (+ num-running num-running-in-jobgroup) 0) (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) (if (not (eq? *last-num-running-tests* num-running)) (begin @@ -197,19 +204,23 @@ ;; (define (runs:run-tests target runname test-patts user flags) ;; test-names (common:clear-caches) ;; clear all caches (let* ((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))) + (run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '()) (test-records (make-hash-table)) (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names (hash-table-keys all-tests-registry)) (test-names (tests:filter-test-names all-test-names test-patts))) - (set-megatest-env-vars run-id inkeys: keys) ;; these may be needed by the launching process + + ;; Update the synchronous setting in the db based on the default or what is set by the user + ;; This is done once here on a call to run tests rather than on every call to open-db + + (set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process (if (file-exists? runconfigf) (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 @@ -224,12 +235,15 @@ (begin ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. - (cdb:delete-tests-in-state *runremote* run-id "NOT_STARTED") - (cdb:remote-run db:set-tests-state-status #f run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) + (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED") + (rmt:set-tests-state-status run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) + + ;; Ensure all tests are registered in the test_meta table + (runs:update-all-test_meta #f) ;; now add non-directly referenced dependencies (i.e. waiton) ;;====================================================================== ;; refactoring this block into tests:get-full-data ;; @@ -238,10 +252,11 @@ ;;====================================================================== (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 (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. + (setenv "MT_TEST_NAME" hed) ;; (let* ((config (tests:get-testconfig hed all-tests-registry '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 "\"") @@ -367,13 +382,13 @@ '() reg))) (define runs:nothing-left-in-queue-count 0) -(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry) +(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records) (let* ((loop-list (list hed tal reg reruns)) - (prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) + (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode)) ;; (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met))) (debug:print-info 4 "START OF INNER COND #2 " "\n can-run-more: " can-run-more "\n testname: " hed @@ -388,11 +403,11 @@ "\n can-run-more: " can-run-more) (cond ;; all prereqs met, fire off the test ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch - + ((member (hash-table-ref/default test-registry (runs:make-full-test-name hed item-path) 'n/a) '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (runs:make-full-test-name hed item-path)) "\". Removing it from the queue") (if (or (not (null? tal)) (not (null? reg))) @@ -425,11 +440,11 @@ (if (list? items-list) (begin (tests:testqueue-set-items! test-record items-list) (list hed tal reg reruns)) (begin - (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") + (debug:print 0 "ERROR: The proc from reading the items table did not yield a list - please report this") (exit 1)))))) ((and (null? fails) (not (null? non-completed))) (let* ((allinqueue (map (lambda (x)(if (string? x) x (db:test-get-testname x))) @@ -450,18 +465,21 @@ (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN) (set! give-up #t))) prereqstrs) (if (and give-up (not (and (null? tal)(null? reg)))) - (begin - (debug:print 1 "WARNING: test " hed " has no discarded prerequisites, removing it from the queue") - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns)) - (list (car newtal)(append (cdr newtal) reg) '() reruns)))) - + (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) + (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) + (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue") + (if (and (null? trimmed-tal) + (null? trimmed-reg)) + #f + (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull) + (runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull) + (runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull) + reruns))) + (list (car newtal)(append (cdr newtal) reg) '() reruns)))) ;; (debug:print-info 1 "allinqueue: " allinqueue) ;; (debug:print-info 1 "prereqstrs: " prereqstrs) ;; (debug:print-info 1 "notinqueue: " notinqueue) ;; (debug:print-info 1 "tal: " tal) @@ -571,11 +589,11 @@ (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup (list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) - (prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) + (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode)) ;; (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) (loop-list (list hed tal reg reruns))) (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" (string-intersperse @@ -611,20 +629,20 @@ ;; ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) (if (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs (begin - (cdb:tests-register-test *runremote* run-id test-name item-path) + (rmt:general-call 'register-test run-id test-name item-path) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done)) (let ((th (make-thread (lambda () (mutex-lock! registry-mutex) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start) (mutex-unlock! registry-mutex) ;; If haven't done it before register a top level test if this is an itemized test (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) - (cdb:tests-register-test *runremote* run-id test-name "")) - (cdb:tests-register-test *runremote* run-id test-name item-path) + (rmt:general-call 'register-test run-id test-name "")) + (rmt:general-call 'register-test run-id test-name item-path) (mutex-lock! registry-mutex) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) (mutex-unlock! registry-mutex)) (conc test-name "/" item-path)))) (thread-start! th))) @@ -668,10 +686,14 @@ ;; ((and have-resources (or (null? prereqs-not-met) (and (eq? testmode 'toplevel) (null? non-completed)))) + ;; (hash-table-delete! *max-tries-hash* (runs:make-full-test-name test-name item-path)) + ;; we are going to reset all the counters for test retries by setting a new hash table + ;; this means they will increment only when nothing can be run + (set! *max-tries-hash* (make-hash-table)) (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) (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 (or (not (null? tal))(not (null? reg))) @@ -685,13 +707,15 @@ ;; (else (debug:print 4 "FAILS: " fails) ;; If one or more of the prereqs-not-met are FAIL then we can issue ;; a message and drop hed from the items to be processed. - + ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) (if (not (null? prereqs-not-met)) - (debug:print-info 1 "waiting on tests; " (string-intersperse prereqs-not-met ", "))) + (debug:print-info 1 "waiting on tests; " (string-intersperse + (runs:mixed-list-testname-and-testrec->list-of-strings + prereqs-not-met) ", "))) (if (null? fails) (begin ;; couldn't run, take a breather (debug:print-info 0 "Waiting for more work to do...") @@ -714,17 +738,27 @@ (debug:print 0 "WARNING: Test not processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (list hed tal reg reruns) (list (car newtal)(cdr newtal) reg reruns) )))))))) + +;; every time though the loop increment the test/itempatt val. +;; when the min is > max-allowed and none running then force exit +;; +(define *max-tries-hash* (make-hash-table)) ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > (define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) - (let ((run-info (cdb:remote-run db:get-run-info #f run-id)) + + ;; Do mark-and-find clean up of db before starting runing of quue + ;; + ;; (cdb:remote-run db:find-and-mark-incomplete #f) + + (let ((run-info (rmt:get-run-info run-id)) (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registry (make-hash-table)) (registry-mutex (make-mutex)) (num-retries 0) @@ -731,11 +765,13 @@ (max-retries (config-lookup *configdat* "setup" "maxretries")) (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) (if (and mcj (string->number mcj)) (string->number mcj) 1))) ;; length of the register queue ahead - (reglen (if (number? reglen-in) reglen-in 1))) + (reglen (if (number? reglen-in) reglen-in 1)) + (last-time-incomplete (current-seconds)) + (last-time-some-running (current-seconds))) ;; Initialize the test-registery hash with tests that already have a record ;; convert state to symbol and use that as the hash value (for-each (lambda (trec) (let ((id (db:test-get-id trec)) @@ -750,10 +786,16 @@ (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) (reg '()) ;; registered, put these at the head of tal (reruns '())) (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) + + ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes + ;; (if (> (current-seconds)(+ last-time-incomplete 900)) + ;; (begin + ;; (set! last-time-incomplete (current-seconds)) + ;; (cdb:remote-run db:find-and-mark-incomplete #f))) ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) (let* ((test-record (hash-table-ref test-records hed)) (test-name (tests:testqueue-get-testname test-record)) (tconfig (tests:testqueue-get-testconfig test-record)) @@ -765,17 +807,25 @@ (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f (items (tests:testqueue-get-items test-record)) (item-path (item-list->path itemdat)) (tfullname (runs:make-full-test-name test-name item-path)) (newtal (append tal (list hed))) - (regfull (>= (length reg) reglen))) + (regfull (>= (length reg) reglen)) + (num-running (rmt:get-count-tests-running-for-run-id run-id))) + + (if (> num-running 0) + (set! last-time-some-running (current-seconds))) + + (if (> (current-seconds)(+ last-time-some-running 60)) + (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) + ;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*)) ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. (if (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f)) (begin - (cdb:tests-register-test *runremote* run-id test-name "") + (rmt:general-call 'register-test run-id test-name "") (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done))) ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( ;; (if (member (hash-table-ref/default test-registry tfullname #f) @@ -811,10 +861,26 @@ (begin (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 + + ;; We want to catch tests that have waitons that are NOT in the queue and discard them IFF + ;; they have been through the wringer 10 or more times + ((and (list? waitons) + (not (null? waitons)) + (> (hash-table-ref/default *max-tries-hash* tfullname 0) 10) + (not (null? (filter + number? + (map (lambda (waiton) + (if (and (not (member waiton tal)) ;; this waiton is not in the list to be tried to run + (not (member waiton reruns))) + 1 + #f)) + waitons))))) ;; could do this more elegantly with a marker.... + (debug:print 0 "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.") + (hash-table-set! test-registry tfullname 'removed)) ;; items is #f then the test is ok to be handed off to launch (but not before) ;; ((not items) (debug:print-info 4 "OUTER COND: (not items)") @@ -874,11 +940,11 @@ ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) (let ((can-run-more (runs:can-run-more-tests jobgroup max-concurrent-jobs))) (if (and (list? can-run-more) (car can-run-more)) - (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry))) + (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records))) (if loop-list (apply loop loop-list))) ;; if can't run more just loop with next possible test (loop (car newtal)(cdr newtal) reg reruns)))) @@ -965,19 +1031,24 @@ (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? + ;; + ;; There is now a single call to runs:update-all-test_meta and this + ;; per-test call is not needed. Given the delicacy of the move to + ;; v1.55 this code is being left in place for the time being. + ;; (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) (begin (hash-table-set! *test-meta-updated* test-name #t) (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) - (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) - (testdat (cdb:get-test-info-by-id *runremote* test-id))) + (test-id (rmt:get-test-id run-id test-name item-path)) + (testdat (if test-id (rmt:get-test-info-by-id test-id) #f))) (if (not testdat) (let loop () ;; ensure that the path exists before registering the test ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... ;; (system (conc "mkdir -p " new-test-path)) @@ -984,18 +1055,18 @@ ;; ;; (open-run-close tests:register-test db run-id test-name item-path) ;; ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; - (set! test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) + (if (not test-id)(set! test-id (rmt:get-test-id-cached run-id test-name item-path))) (if (not test-id) (begin (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 (cdb:remote-run db:get-test-id #f run-id test-name item-path)))) + (rmt:general-call 'register-test run-id test-name item-path) + (set! test-id (rmt:get-test-id run-id test-name item-path)))) (debug:print-info 4 "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)) + (set! testdat (rmt:get-test-info-by-id test-id)) (if (not testdat) (begin (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") (thread-sleep! 1) (loop))))) @@ -1061,11 +1132,11 @@ (cond ;; Have to check for skip conditions. This one skips if there are same-named tests ;; currently running ((and skip-check (configf:lookup test-conf "skip" "prevrunning")) - (let ((running-tests (cdb:remote-run db:get-tests-for-runs-mindata #f #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) + (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) (if (not (null? running-tests)) ;; have to skip (set! skip-test "Skipping due to previous tests running")))) ((and skip-check (configf:lookup test-conf "skip" "fileexists")) (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) @@ -1141,11 +1212,11 @@ ;; NB// should pass in keys? ;; (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 (cdb:remote-run db:get-keys db)) + (keys (rmt:get-keys)) (rundat (mt:get-runs-by-patt keys runnamepatt target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1)) (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) @@ -1196,11 +1267,11 @@ (test-retry-time (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em (let loop ((test (car sorted-tests)) (tal (cdr sorted-tests))) (let* ((test-id (db:test-get-id test)) - (new-test-dat (cdb:get-test-info-by-id *runremote* test-id))) + (new-test-dat (rmt:get-test-info-by-id test-id))) (if (not new-test-dat) (begin (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) @@ -1267,11 +1338,11 @@ (if run-dir (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) )) ;; Only delete the records *after* removing the directory. If things fail we have a record - (cdb:remote-run db:delete-test-records db #f (db:test-get-id test)) + (rmt:delete-test-records (db:test-get-id test)) (if (not (null? tal)) (loop (car tal)(cdr tal)))))) ((set-state-status) (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) (mt:test-set-state-status-by-id (db:test-get-id test) (car state-status)(cadr state-status) #f) @@ -1292,15 +1363,13 @@ (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") - (cdb:remote-run db:delete-run db run-id) - ;; This is a pretty good place to purge old DELETED tests - (cdb:remote-run db:delete-tests-for-run db run-id) - (cdb:remote-run db:delete-old-deleted-test-records db) - (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds)) + (rmt:delete-run run-id) + (rmt:delete-old-deleted-test-records) + ;; (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (debug:print 1 "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) @@ -1378,55 +1447,56 @@ (if (or lock (and unlock (begin (print "Do you really wish to unlock run " run-id "?\n y/n: ") (equal? "y" (read-line))))) - (cdb:remote-run db:lock/unlock-run db run-id lock unlock user) + (rmt:lock/unlock-run run-id lock unlock user) (debug:print-info 0 "Skipping lock/unlock on " run-id)))) runs))) ;;====================================================================== ;; Rollup runs ;;====================================================================== ;; Update the test_meta table for this test (define (runs:update-test_meta test-name test-conf) - (let ((currrecord (cdb:remote-run db:testmeta-get-record #f test-name))) + (let ((currrecord (rmt:testmeta-get-record test-name))) (if (not currrecord) (begin (set! currrecord (make-vector 10 #f)) - (cdb:remote-run db:testmeta-add-record #f test-name))) + (rmt:testmeta-add-record test-name))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) - (cdb:remote-run db:testmeta-update-field #f test-name fld val))))) + (rmt:testmeta-update-field test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) - (let ((test-names (tests:get-valid-tests))) + (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) (for-each (lambda (test-name) (let* ((test-conf (mt:lazy-read-test-config test-name))) - ;; use the cdb:remote-run instead of passing in db (if test-conf (runs:update-test_meta test-name test-conf)))) - test-names))) + (hash-table-keys test-names)))) ;; This could probably be refactored into one complex query ... +;; NOT PORTED - DO NOT USE YET +;; (define (runs:rollup-run keys runname user keyvals) (debug:print 4 "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 (cdb:remote-run test:get-matching-previous-test-run-records db new-run-id "%" "%")) + (new-run-id (rmt:register-run keyvals runname "new" "n/a" user)) + (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '())) (curr-tests-hash (make-hash-table))) - (cdb:remote-run db:update-run-event_time db new-run-id) + (rmt:update-run-event_time new-run-id) ;; index the already saved tests by testname and itemdat in curr-tests-hash (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) @@ -1440,11 +1510,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 (cdb:remote-run db:get-steps-for-test db (db:test-get-id testdat))) + (test-steps (rmt:get-steps-for-test (db:test-get-id testdat))) (new-test-record #f)) ;; replace these with insert ... select (apply sqlite3:execute db (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " ADDED sdb.scm Index: sdb.scm ================================================================== --- /dev/null +++ sdb.scm @@ -0,0 +1,102 @@ +;;====================================================================== +;; Copyright 2006-2013, 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. +;;====================================================================== + +;;====================================================================== +;; Simple persistant strings lookup table. Keep out of the main db +;; so writes/reads don't slow down central access. +;;====================================================================== + +(require-extension (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +(import (prefix sqlite3 sqlite3:)) +(import (prefix base64 base64:)) + +(declare (unit sdb)) + +;; +(define (sdb:open) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) + (if (not *toppath*) + (if (not (setup-for-run)) + (begin + (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") + (exit)))) + (let* ((dbpath (conc *toppath* "/db/sdb.db")) ;; fname) + (dbexists (let ((fe (file-exists? dbpath))) + (if fe + fe + (begin + (create-directory (conc *toppath* "/db") #t) + #f)))) + (sdb (sqlite3:open-database dbpath)) + (handler (make-busy-timeout (if (args:get-arg "-override-timeout") + (string->number (args:get-arg "-override-timeout")) + 136000)))) + (sqlite3:set-busy-handler! sdb handler) + (if (not dbexists) + (sdb:initialize sdb)) + (sqlite3:execute sdb "PRAGMA synchronous = 1;") + sdb)) + +(define (sdb:initialize sdb) + (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs + (id INTEGER PRIMARY KEY, + str TEXT, + CONSTRAINT str UNIQUE (str));") + (sqlite3:execute sdb "CREATE INDEX strindx ON strs (str);")) + +;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a))) + +(define (sdb:register-string sdb str) + (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) + +(define (sdb:string->id sdb str-cache str) + (let ((id (hash-table-ref/default str-cache str #f))) + (if (not id) + (sqlite3:for-each-row + (lambda (sid) + (set! id sid) + (hash-table-set! str-cache str id)) + sdb + "SELECT id FROM strs WHERE str=?;" str)) + id)) + +(define (sdb:id->string sdb id-cache id) + (let ((str (hash-table-ref/default id-cache id #f))) + (if (not str) + (sqlite3:for-each-row + (lambda (istr) + (set! str istr) + (hash-table-set! id-cache id str)) + sdb + "SELECT str FROM strs WHERE id=?;" id)) + str)) + +(define sdb:qry + (let ((sdb #f) + (scache (make-hash-table)) + (icache (make-hash-table))) + (lambda (cmd var) + (if (not sdb)(set! sdb (sdb:open))) + (case cmd + ((init) (if (not sdb)(set! sdb (sdb:open)))) + ((finalize!) (if sdb (sqlite3:finalize! sdb))) + ((getid) (let ((id (sdb:string->id sdb scache var))) + (if id + id + (begin + (sdb:register-string sdb var) + (sdb:string->id sdb scache var))))) + ((getstr) (if (or (number? var) + (string->number var)) + (sdb:id->string sdb icache var) + var)) + (else #f))))) + Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -67,28 +67,28 @@ ;; We don't want to flush the queue if it was just flushed (define *server:last-write-flush* (current-milliseconds)) ;; Flush the queue every third of a second. Can we assume that setup-for-run ;; has already been done? -(define (server:write-queue-handler) - (if (setup-for-run) - (let ((db (open-db))) - (let loop () - (let ((last-write-flush-time #f)) - (mutex-lock! *incoming-mutex*) - (set! last-write-flush-time *server:last-write-flush*) - (mutex-unlock! *incoming-mutex*) - (if (> (- (current-milliseconds) last-write-flush-time) 10) - (begin - (mutex-lock! *db:process-queue-mutex*) - (db:process-cached-writes db) - (mutex-unlock! *db:process-queue-mutex*) - (thread-sleep! 0.005)))) - (loop))) - (begin - (debug:print 0 "ERROR: failed to setup for Megatest in server:write-queue-handler") - (exit 1)))) +;; (define (server:write-queue-handler) +;; (if (setup-for-run) +;; (let ((db (open-db))) +;; (let loop () +;; (let ((last-write-flush-time #f)) +;; (mutex-lock! *incoming-mutex*) +;; (set! last-write-flush-time *server:last-write-flush*) +;; (mutex-unlock! *incoming-mutex*) +;; (if (> (- (current-milliseconds) last-write-flush-time) 10) +;; (begin +;; (mutex-lock! *db:process-queue-mutex*) +;; (db:process-cached-writes db) +;; (mutex-unlock! *db:process-queue-mutex*) +;; (thread-sleep! 0.005)))) +;; (loop))) +;; (begin +;; (debug:print 0 "ERROR: failed to setup for Megatest in server:write-queue-handler") +;; (exit 1)))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== Index: synchash.scm ================================================================== --- synchash.scm +++ synchash.scm @@ -55,14 +55,14 @@ orig-keys) (list changed deleted) ;; (list indat '()) ;; just for debugging )) -;; (cdb:remote-run db:get-keys #f) -;; (cdb:remote-run db:get-num-runs #f "%") -;; (cdb:remote-run db:get-runs #f runnamepatt numruns *start-run-offset* keypatts) -;; +;; (c?db:remote-run db:get-keys #f) +;; (c?db:remote-run db:get-num-runs #f "%") +;; (c?db:remote-run db:get-runs #f runnamepatt numruns *start-run-offset* keypatts) +;; ;; keynum => the field to use as the unique key (usually 0 but can be other field) ;; (define (synchash:client-get proc synckey keynum synchash . params) (let* ((data (apply cdb:remote-run synchash:server-get #f proc synckey keynum params)) (newdat (car data)) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -21,11 +21,11 @@ ;;====================================================================== ;; Tasks db ;;====================================================================== (define (tasks:open-db) - (let* ((dbpath (conc *toppath* "/monitor.db")) + (let* ((dbpath (conc *toppath* "/db/monitor.db")) (exists (file-exists? dbpath)) (write-access (file-write-access? dbpath)) (mdb (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout 36000))) (if (and exists @@ -64,10 +64,11 @@ priority INTEGER, state TEXT, mt_version TEXT, heartbeat TIMESTAMP, transport TEXT, + run_id INTEGER, CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));") (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, server_id INTEGER, pid INTEGER, hostname TEXT, @@ -425,11 +426,11 @@ ;; (define (tasks:start-monitor db mdb) (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more (debug:print-info 1 "Not starting monitor, already have more than two running") (let* ((megatestdb (conc *toppath* "/megatest.db")) - (monitordbf (conc *toppath* "/monitor.db")) + (monitordbf (conc *toppath* "/db/monitor.db")) (last-db-update 0)) ;; (file-modification-time megatestdb))) (task:register-monitor mdb) (let loop ((count 0) (next-touch 0)) ;; next-touch is the time where we need to update last_update ;; if the db has been modified we'd best look at the task queue ADDED tdb.scm Index: tdb.scm ================================================================== --- /dev/null +++ tdb.scm @@ -0,0 +1,64 @@ +;;====================================================================== +;; Copyright 2006-2013, 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. +;;====================================================================== + +;;====================================================================== +;; Database access +;;====================================================================== + +(require-extension (srfi 18) extras tcp) ;; rpc) +;; (import (prefix rpc rpc:)) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +(import (prefix sqlite3 sqlite3:)) +(import (prefix base64 base64:)) + +;; Note, try to remove this dependency +;; (use zmq) + +(declare (unit tdb)) +(declare (uses common)) +(declare (uses keys)) +(declare (uses ods)) +(declare (uses fs-transport)) +(declare (uses client)) +(declare (uses mt)) + +(include "common_records.scm") +(include "db_records.scm") +(include "key_records.scm") +(include "run_records.scm") + +;;====================================================================== +;; +;; T E S T D A T A B A S E S +;; +;;====================================================================== + +(define (tdb:get-steps-data tdb test-id) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id test-id stepname state status event-time logfile) + (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) + tdb + "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-id) + (sqlite3:finalize! tdb) + (reverse res))) + +(define (tdb:read-test-data tdb test-id categorypatt) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id test_id category variable value expected tol units comment status type) + (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) + tdb + "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) + (sqlite3:finalize! tdb) + (reverse res))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -17,19 +17,21 @@ (import (prefix sqlite3 sqlite3:)) (declare (unit tests)) (declare (uses lock-queue)) (declare (uses db)) +(declare (uses tdb)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") + ;; Call this one to do all the work and get a standardized list of tests (define (tests:get-all) (let* ((test-search-path (cons (conc *toppath* "/tests") ;; the default (tests:get-tests-search-path *configdat*)))) @@ -127,99 +129,10 @@ (if (null? tal) (string-intersperse (append (reverse res)(list qry)) " OR ") (loop (car tal)(cdr tal)(cons qry res))))))) #f)) -;; 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 -;; -;; Run this server-side -;; -(define (test:get-previous-test-run-record db run-id test-name item-path) - (let* ((keys (db:get-keys db)) - (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))) - db - (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) - (if (not keyvals) - #f - (let ((prev-run-ids '())) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) - db - (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) - ;; for each run starting with the most recent look to see if there is a matching test - ;; if found then return that matching test record - (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) - (if (null? prev-run-ids) #f - (let loop ((hed (car prev-run-ids)) - (tal (cdr prev-run-ids))) - (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path)'() '() #f #f #f #f #f))) - (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) - (if (and (null? results) - (not (null? tal))) - (loop (car tal)(cdr tal)) - (if (null? results) #f - (car results)))))))))) - -;; get the previous records for when these tests were run where all keys match but runname -;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests -;; can use wildcards. Also can likely be factored in with get test paths? -;; -;; Run this remotely!! -;; -(define (test:get-matching-previous-test-run-records db run-id test-name item-path) - (let* ((keys (db:get-keys db)) - (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) - (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) - (keyvals #f) - (tests-hash (make-hash-table))) - ;; 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))) - db - (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) - (if (not keyvals) - '() - (let ((prev-run-ids '())) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) - db - (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) - ;; collect all matching tests for the runs then - ;; extract the most recent test and return that. - (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals - ", previous run ids found: " prev-run-ids) - (if (null? prev-run-ids) '() ;; no previous runs? return null - (let loop ((hed (car prev-run-ids)) - (tal (cdr prev-run-ids))) - (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f))) - (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name - ", item-path " item-path " results: " (intersperse results "\n")) - ;; Keep only the youngest of any test/item combination - (for-each - (lambda (testdat) - (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) - (stored-test (hash-table-ref/default tests-hash full-testname #f))) - (if (or (not stored-test) - (and stored-test - (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test)))) - ;; this test is younger, store it in the hash - (hash-table-set! tests-hash full-testname testdat)))) - results) - (if (null? tal) - (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests - (loop (car tal)(cdr tal)))))))))) - ;; Check for waiver eligibility ;; (define (tests:check-waiver-eligibility testdat prev-testdat) (let* ((test-registry (make-hash-table)) (testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f)) @@ -278,33 +191,31 @@ (loop (car tal)(cdr tal))) #f)))))) (pop-directory) result))))) -(define (tests:test-force-state-status! test-id state status) - (cdb:test-set-status-state *runremote* test-id status state #f) +(define (tests:test-force-state-status! dbstruct run-id test-id state status) + (db:test-set-status-state dbstruct run-id test-id status state #f) (mt:process-triggers test-id state status)) ;; Do not rpc this one, do the underlying calls!!! -(define (tests:test-set-status! test-id state status comment dat #!key (work-area #f)) - (debug:print-info 4 "tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat) - (let* ((db #f) - (real-status status) +(define (tests:test-set-status! dbstruct run-id test-id state status comment dat) + (let* ((real-status status) (otherdat (if dat dat (make-hash-table))) - (testdat (cdb:get-test-info-by-id *runremote* test-id)) - (run-id (db:test-get-run_id testdat)) - (test-name (db:test-get-testname testdat)) + (testdat (db:get-test-info-by-id dbstruct run-id test-id)) + (run-id (db:test-get-run_id testdat)) + (test-name (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) ;; before proceeding we must find out if the previous test (where all keys matched except runname) ;; was WAIVED if this test is FAIL ;; NOTES: ;; 1. Is the call to test:get-previous-run-record remotified? ;; 2. Add test for testconfig waiver propagation control here ;; (prev-test (if (equal? status "FAIL") - (cdb:remote-run test:get-previous-test-run-record #f run-id test-name item-path) + (rmt:get-previous-test-run-record run-id test-name item-path) #f)) (waived (if prev-test (if prev-test ;; true if we found a previous test in this run series (let ((prev-status (db:test-get-status prev-test)) (prev-state (db:test-get-state prev-test)) @@ -325,17 +236,17 @@ (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) (begin - (cdb:test-set-status-state *runremote* test-id real-status state (if waived waived comment)) - (mt:process-triggers test-id state real-status))) + (rmt:test-set-status-state test-id real-status state (if waived waived comment)) + (mt:process-triggers dbstruct run-id test-id state real-status))) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, it does remote calls under the hood. (if (and test-id state status (equal? status "AUTO")) - (db:test-data-rollup #f test-id status work-area: work-area)) + (rmt:test-data-rollup test-id status)) ;; add metadata (need to do this way to avoid SQL injection issues) ;; :first_err ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) @@ -366,35 +277,33 @@ tol "," units "," dcomment ",," ;; extra comma for status type ))) ;; This was run remote, don't think that makes sense. - (db:csv->test-data #f test-id + (db:csv->test-data dbstruct run-id test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) - (mt:roll-up-pass-fail-counts run-id test-name item-path status)) + (rmt:roll-up-pass-fail-counts run-id test-name item-path status)) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) - (cdb:remote-run db:test-set-comment #f test-id cmt))) - )) - - -(define (tests:test-set-toplog! db run-id test-name logf) - (cdb:client-call *runremote* 'tests:test-set-toplog #t 2 logf run-id test-name)) - -(define (tests:summarize-items db run-id test-id test-name force) + (rmt:general-call 'set-test-comment cmt test-id))))) + +(define (tests:test-set-toplog! run-id test-name logf) + (rmt:general-call 'tests:test-set-toplog logf run-id test-name)) + +(define (tests:summarize-items run-id test-id test-name force) ;; if not force then only update the record if one of these is true: ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename (let* ((outputfilename (conc "megatest-rollup-" test-name ".html")) (orig-dir (current-directory)) - (logf-info (cdb:remote-run db:test-get-logfile-info #f run-id test-name)) + (logf-info (rmt:test-get-logfile-info run-id test-name)) (logf (if logf-info (cadr logf-info) #f)) (path (if logf-info (car logf-info) #f))) ;; This query finds the path and changes the directory to it for the test (if (and (string? path) (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ... @@ -406,21 +315,20 @@ (debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) (if (or (equal? logf "logs/final.log") (equal? logf outputfilename) force) (begin - (if ;; (not (obtain-dot-lock outputfilename 1 5 7)) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock - (not (lock-queue:wait-turn outputfilename test-id)) + (if (not (lock-queue:wait-turn outputfilename test-id)) (print "Not updating " outputfilename " as another test item has signed up for the job") (begin (print "Obtained lock for " outputfilename) - (let ((oup (open-output-file outputfilename)) - (counts (make-hash-table)) + (let ((oup (open-output-file outputfilename)) + (counts (make-hash-table)) (statecounts (make-hash-table)) (outtxt "") (tot 0) - (testdat (cdb:remote-run db:test-get-records-for-index-file #f run-id test-name))) + (testdat (rmt:test-get-records-for-index-file run-id test-name))) (with-output-to-port oup (lambda () (set! outtxt (conc outtxt "Summary: " test-name "

Summary for " test-name "

")) @@ -467,16 +375,17 @@ (print "") (print "" "" outtxt "
ItemStateStatusComment
") - (release-dot-lock outputfilename))) + ;; (release-dot-lock outputfilename) + )) (close-output-port oup) (lock-queue:release-lock outputfilename test-id) (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... - (tests:test-set-toplog! db run-id test-name outputfilename) + (tests:test-set-toplog! run-id test-name outputfilename) ))))))) ;;====================================================================== ;; Gather data from test/task specifications ;;====================================================================== @@ -545,22 +454,22 @@ #t ;; if a is a higher priority than b then we are good to go #f)))))))) ;; for each test: ;; -(define (tests:filter-non-runnable run-id testkeynames testrecordshash) +(define (tests:filter-non-runnable dbstruct run-id testkeynames testrecordshash) (let ((runnables '())) (for-each (lambda (testkeyname) (let* ((test-record (hash-table-ref testrecordshash testkeyname)) (test-name (tests:testqueue-get-testname test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (item-path (tests:testqueue-get-item_path test-record)) (waitons (tests:testqueue-get-waitons test-record)) (keep-test #t) - (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) - (tdat (cdb:get-test-info-by-id *runremote* test-id))) + (test-id (rmt:get-test-id run-id test-name item-path)) + (tdat (rmt:get-testinfo-state-status test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if tdat (begin ;; Look at the test state and status (if (or (and (member (db:test-get-status tdat) '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) @@ -572,12 +481,12 @@ ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test ;; from the runnable list (if keep-test (for-each (lambda (waiton) ;; for now we are waiting only on the parent test - (let* ((parent-test-id (cdb:remote-run db:get-test-id #f run-id waiton "")) - (wtdat (cdb:get-test-info-by-id *runremote* test-id))) + (let* ((parent-test-id (rmt:get-test-id run-id waiton "")) + (wtdat (rmt:get-testinfo-state-status test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED") (member (db:test-get-status wtdat) '("FAIL"))) (member (db:test-get-status wtdat) '("KILLED")) (member (db:test-get-state wtdat) '("INCOMPETE"))) ;; (if (or (member (db:test-get-status wtdat) @@ -679,59 +588,47 @@ ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here -(define (test-get-kill-request test-id) ;; run-id test-name itemdat) - (let* ((testdat (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path))) +(define (test-get-kill-request dbstruct run-id test-id) ;; run-id test-name itemdat) + (let* ((testdat (rmt:get-test-info-by-id test-id))) (and testdat (equal? (test:get-state testdat) "KILLREQ")))) -(define (test:tdb-get-rundat-count tdb) +(define (test:tdb-get-rundat-count dbstruct run-id) (if tdb (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) - tdb + (db:get-db dbstruct run-id) "SELECT count(id) FROM test_rundat;") res)) 0) -(define (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname) - ;; This is a good candidate for threading the requests to enable - ;; transactionized write at the server - (cdb:tests-update-cpuload-diskfree *runremote* test-id cpuload diskfree) +(define (tests:update-central-meta-info dbstruct run-id test-id cpuload diskfree minutes uname hostname) + (rmt:general-call 'update-cpuload-diskfree cpuload diskfree test-id) (if minutes - (cdb:tests-update-run-duration *runremote* test-id minutes)) + (rmt:general-call 'update-run-duration minutes test-id)) (if (and uname hostname) - (cdb:tests-update-uname-host *runremote* test-id uname hostname))) + (rmt:general-call 'update-uname-host uname hostname test-id))) -(define (tests:set-full-meta-info db test-id run-id minutes work-area) - ;; DOES cdb:remote-run under the hood! - (let* ((num-records 0) ;; (test:tdb-get-rundat-count tdb)) +(define (tests:set-full-meta-info dbstruct test-id run-id minutes work-area) + (let* ((num-records 0) (cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (uname (get-uname "-srvpio")) (hostname (get-host-name))) - (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) - (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname))) - -(define (tests:set-partial-meta-info db test-id run-id minutes work-area) - ;; DOES cdb:remote-run under the hood! + (tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes) + (tests:update-central-meta-info dbstruct run-id test-id cpuload diskfree minutes uname hostname))) + +(define (tests:set-partial-meta-info test-id run-id minutes work-area) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory)))) - (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) - ;; Update central with uname and hostname = #f - (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f))) - -(define (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) - (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) - (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" - cpuload diskfree minutes) - (sqlite3:finalize! tdb))) - + (tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes))) + ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== (define (test:archive db test-id) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -1,9 +1,11 @@ +# # run some tests BINPATH=$(shell readlink -m $(PWD)/../bin) MEGATEST=$(BINPATH)/megatest +DASHBOARD=$(BINPATH)/dashboard PATH := $(BINPATH):$(PATH) RUNNAME := $(shell date +w%V.%u.%H.%M) IPADDR := "-" # Set SERVER to "-server -" SERVER = @@ -20,11 +22,11 @@ all : test1 test2 test3 test4 test5 test6 test7 test8 test9 server : cd ..;make;make install - cd fullrun;../../bin/megatest -server - -debug 22 & + cd fullrun;../../bin/megatest -server - -debug 22 stopserver : cd ..;make && make install cd fullrun;$(MEGATEST) -stop-server 0 @@ -34,15 +36,10 @@ test0 : cleanprep cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG) test1 : cleanprep - rm -f simplerun/megatest.db - rm -rf simplelinks/ simpleruns/ - mkdir -p simplelinks simpleruns - cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm - cd simplerun;echo '(load "../tests.scm")' | $(MEGATEST) -repl -debug $(DEBUG) test2 : fullprep cd fullrun;$(MEGATEST) -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none :runname $(RUNNAME) -debug $(DEBUG) $(LOGGING) cd fullrun;megatest -runtests % -target ubuntu/nfs/none :runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG) cd fullrun;megatest -runtests %/,%/ai -target ubuntu/nfs/none :runname $(RUNAME)_02 -debug $(DEBUG) @@ -49,12 +46,19 @@ cd fullrun;megatest -runtests runfirst/%,%/ai -target ubuntu/nfs/none :runname $(RUNNAME)_02 -debug $(DEBUG) cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none :runname $(RUNNAME)_03 -debug $(DEBUG) sleep 40;cd fullrun;megatest -target ubuntu/nfs/none :runname $(RUNNAME) -set-state-status COMPLETED,FORCED :state COMPLETED :status PASS -testpatt ez_p%s,runfirst/ -debug $(DEBUG) $(LOGGING) -test3 : fullprep - cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -debug 10 +test3 : fullprep test3a test3b + +test3a : + @echo Run runfirst and any waitons. + cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b + +test3b : + @echo Run all_toplevel and all waitons + cd fullrun;$(MEGATEST) -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_c test4 : cleanprep @echo "WARNING: No longer running fullprep, test converage may be lessened" cd fullrun;time $(MEGATEST) -debug $(DEBUG) -runtests % -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) @@ -99,27 +103,31 @@ cd fullrun;$(MEGATEST) -runtests runfirst/fall 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem cd fullrun;$(MEGATEST) -runtests test_mt_vars/2 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem_waiton # Some simple checks for bootstrapping and run loop logic -test9 : minsetup test9a test9b test9c test9d +test9 : minsetup test9a test9b test9c test9d test9e test9a : @echo Run super-simple mintest e, no waitons. - cd mintest;megatest -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + cd mintest;$(MEGATEST) -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9b : @echo Run simple mintest d with one waiton c - cd mintest;megatest -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + cd mintest;$(MEGATEST) -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9c : @echo Run mintest a with full waiton chain a -> b -> c -> d -> e - cd mintest;megatest -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + cd mintest;$(MEGATEST) -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9d : @echo Run an itemized test with no items - cd mintest;megatest -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + cd mintest;$(MEGATEST) -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + +test9e : + @echo Run mintest a1 with full waiton chain with d1fail: a1 -> b1 -> c1 -> d1fail -> e1 + cd mintest;$(MEGATEST) -runtests a1 -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test10 : @echo Run a bunch of different targets simultaneously (cd fullrun;$(MEGATEST) -server - ;sleep 2)& for targ in mint/btrfs/mintdir sunos/sshfs/loc; do \ @@ -134,14 +142,14 @@ cd fullrun;time (for a in 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 ;do (megatest -test-paths -target %/%/% > /dev/null ) & done; wait; ) minsetup : cd ..;make && make install mkdir -p mintest/runs mintest/links - cd mintest;megatest -stop-server 0 - cd mintest;megatest -server - -debug $(DEBUG) > server.log 2> server.log & + cd mintest;$(MEGATEST) -stop-server 0 + cd mintest;$(MEGATEST) -server - -debug $(DEBUG) > server.log 2> server.log & sleep 3 - cd mintest;dashboard -rows 18 & + cd mintest;$(DASHBOARD) -rows 18 & cleanprep : ../*.scm Makefile */*.config mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links cd ..;make;make install rm -f */logging.db @@ -150,29 +158,26 @@ fullprep : cleanprep cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/% cd fullrun;$(BINPATH)/dashboard -rows 15 & dashboard : cleanprep - cd fullrun && $(BINPATH)/dashboard -transport fs -rows 20 & - -dashboard-http : cleanprep - cd fullrun && $(BINPATH)/dashboard -transport http -rows 20 & + cd fullrun && $(BINPATH)/dashboard -rows 20 & remove : cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -itempatt % :sysname % :fsname % :datapath % clean : rm cleanprep kill : killall -v mtest main.sh dboard || true - rm -f */megatest.db */logging.db */monitor.db || true + rm -rf */megatest.db */logging.db */monitor.db fullrun/tmp/mt_*/* || true killall -v mtest dboard || true hardkill : kill - sleep 5;killall -v mtest main.sh dboard -9 + sleep 2;killall -v mtest main.sh dboard -9 listservers : cd fullrun;$(MEGATEST) -list-servers runforever : while(ls); do runname=`date +%F-%R:%S`;(cd fullrun;$(MEGATEST) -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname);done Index: tests/fullrun/config/mt_include_1.config ================================================================== --- tests/fullrun/config/mt_include_1.config +++ tests/fullrun/config/mt_include_1.config @@ -8,11 +8,14 @@ useshell yes # ## launcher launches jobs, the job is managed on the target host ## by megatest, comment out launcher to run local # workhosts localhost hermes # launcher exec nbfake + launcher nbfake +# launcher echo + # launcher nbfind # launcher nodanggood ## use "xterm -e csi -- " as a launcher to examine the launch environment. ## exit with (exit) Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -19,26 +19,36 @@ [setup] # Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding # this may save a few milliseconds on launching tests # launchwait no +waivercommentpatt ^WW\d+ [a-z].* # Use http instead of direct filesystem access -# transport http -transport fs +transport http +# transport fs # If set to "default" the old code is used. Otherwise defaults to 200 or uses # numeric value given. # runqueue 20 +# Default runtimelim 1d 1h 1m 10s +# +runtimelim 20m + +# Deadtime - when to consider tests dead (i.e. haven't heard from them in too long) +# Number in seconds, set to 20 seconds here to trigger a little trouble. Default is +# 1800 +# +deadtime 600 # It is possible (but not recommended) to override the rsync command used # to populate the test directories. For test development the following # example can be useful # -# testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log +testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log # or for hard links # testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. ADDED tests/fullrun/run-each-proc.sh Index: tests/fullrun/run-each-proc.sh ================================================================== --- /dev/null +++ tests/fullrun/run-each-proc.sh @@ -0,0 +1,15 @@ +#!/bin/bash + +for x in `cat all-db-procs.txt`;do + cat > ~/.megatestrc <' '-_g'` + megatest -runtests sqlitespeed,test2,ez% -target ubuntu/nfs/none :runname $fname > $fname.log +done + + ADDED tests/fullrun/tests/all_toplevel/calcresults.logpro Index: tests/fullrun/tests/all_toplevel/calcresults.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/all_toplevel/calcresults.logpro @@ -0,0 +1,133 @@ +;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com +;; +;; License GPL. + +(define logbody "LogFileBody") + +(define pass-specs '( ;; testname num-expected max-runtime + ("exit_0" 1 20) + ("ezlog_fail_then_pass" 1 20) + ("ezlog_pass" 1 20) + ("ez_pass" 1 20) + ("lineitem_pass" 1 20) + ("priority_1" 1 20) + ("priority_10" 1 20) + ("priority_10_waiton_1" 1 20) + ("priority_3" 1 20) + ("priority_4" 1 20) + ("priority_5" 1 20) + ("priority_6" 1 20) + ("priority_7" 1 20) + ("priority_8" 1 20) + ("priority_9" 1 20) + ("runfirst" 7 20) + ("singletest" 1 20) + ("singletest2" 1 20) + ("special" 1 20) + ("sqlitespeed" 10 20) + ("test1" 1 20) + ("test2" 6 20) + ("test_mt_vars" 6 20) + )) + +(define fail-specs '( ;; testname num-expected max-runtime + ("exit_1" 1 20) + ("ez_exit2_fail" 1 20) + ("ez_fail" 1 20) + ("ez_fail_quick" 1 20) + ("ezlog_fail" 1 20) + ("lineitem_fail" 1 20) + ("logpro_required_fail" 1 20) + ("manual_example" 1 20) + ("neverrun" 1 20))) + +(define warn-specs '(("ezlog_warn" 1 20))) +(define nost-specs '(("wait_no_items1" 1 20) + ("wait_no_items2" 1 20) + ("wait_no_items3" 1 20) + ("wait_no_items4" 1 20) + ("no_items" 1 20))) + +(define (check-one-test estate estatus testname count runtime) + (let* ((rxe (regexp (conc "^\\s+Test: " testname "(\\(.*|\\s+)\\s+State: " estate "\\s+Status: " estatus "\\s+Runtime:\\s+(\\d+)s"))) + (msg1 (conc testname " expecting count of " count)) + (msg2 (conc testname " expecting runtime less than " runtime))) + (expect:required in logbody = count msg1 rxe) + ;;(expect:value in logbody count < msg2 rxe) + )) + +;; Special cases +;; +(expect:ignore in logbody >= 0 "all_toplevel may not yet be done" #/Test: all_toplevel/) +(expect:error in logbody = 0 "tests left in RUNNING state" #/State: RUNNING/) +(expect:required in logbody = 1 "priority_2 is KILLED" #/Test: priority_2\s+State: KILLED\s+Status: FAIL/) +(expect:required in logbody = 1 "testxz has 1 NOT_STARTED test" #/Test: testxz\s+State: NOT_STARTED/) +(expect:required in logbody = 29 "blocktestxz has 29 tests" #/Test: blocktestxz/) + +;; General cases +;; +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "PASS" testdat)) + pass-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "FAIL" testdat)) + fail-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "WARN" testdat)) + warn-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "NOT_STARTED" "n/a" testdat)) + nost-specs) + +;; Catch all. +;; +(expect:error in logbody = 0 "Tests not accounted for" #/Test: /) + + +;; ;; define your hooks +;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") +;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") +;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") +;; +;; ;; first ensure your run at least started +;; ;; +;; (trigger "Init" #/This is a header/) +;; (trigger "InitEnd" #/^\s*$/) +;; (section "Init" "Init" "InitEnd") +;; +;; (trigger "Body" #/^.*$/) ;; anything starts the body +;; ;; (trigger "EndBody" #/This had better never match/) +;; +;; (section "Body" "Body" "EndBody") +;; +;; (trigger "Blah2" #/^begin Blah2/) +;; (trigger "Blah2End" #/^end Blah2/) +;; (section "Blah2" "Blah2" "Blah2End") +;; +;; (expect:required in "Init" = 1 "Header" #/This is a header/) +;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) +;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) +;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) +;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) +;; +;; ;; Using match number +;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; ;; Comparison instead of tolerance +;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) +;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) +;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors +;; +;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) Index: tests/fullrun/tests/all_toplevel/testconfig ================================================================== --- tests/fullrun/tests/all_toplevel/testconfig +++ tests/fullrun/tests/all_toplevel/testconfig @@ -1,8 +1,13 @@ [ezsteps] calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET [requirements] -waiton all_toplevel exit_0 exit_1 ez_exit2_fail ez_fail ez_pass ezlog_fail ezlog_fail_then_pass ezlog_pass ezlog_warn lineitem_fail lineitem_pass logpro_required_fail manual_example neverrun priority_1 priority_10 priority_10_waiton_1 priority_2 priority_3 priority_4 priority_5 priority_6 priority_7 priority_8 priority_9 runfirst singletest singletest2 sqlitespeed test_mt_vars +waiton all_toplevel exit_0 exit_1 ez_exit2_fail ez_fail ez_pass ezlog_fail \ + ezlog_fail_then_pass ezlog_pass ezlog_warn lineitem_fail lineitem_pass logpro_required_fail \ + manual_example neverrun priority_1 priority_10 priority_10_waiton_1 priority_2 \ + priority_3 priority_4 priority_5 priority_6 priority_7 priority_8 \ + priority_9 runfirst singletest singletest2 sqlitespeed test_mt_vars \ + ez_fail_quick test1 test2 special blocktestxz # This is a "toplevel" test, it does not require waitons to be non-FAIL to run mode toplevel ADDED tests/fullrun/tests/no_items/testconfig Index: tests/fullrun/tests/no_items/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/no_items/testconfig @@ -0,0 +1,15 @@ +[ezsteps] +listfiles ls + +[items] +FOO + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt Index: tests/fullrun/tests/priority_8/main.sh ================================================================== --- tests/fullrun/tests/priority_8/main.sh +++ tests/fullrun/tests/priority_8/main.sh @@ -1,10 +1,14 @@ #!/bin/bash # a bunch of steps in 2 second increments for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do + echo "start step before $i: `date`" $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html + echo "start step after $i: `date`" sleep 2 + echo "end step before $i: `date`" $MT_MEGATEST -step step$i :state end :status 0 + echo "end step after $i: `date`" done exit 0 Index: tests/fullrun/tests/runfirst/main.sh ================================================================== --- tests/fullrun/tests/runfirst/main.sh +++ tests/fullrun/tests/runfirst/main.sh @@ -30,7 +30,9 @@ if [[ `basename $PWD` == "mustfail" ]];then $MT_MEGATEST -test-status :state COMPLETED :status FAIL else $MT_MEGATEST -test-status :state COMPLETED :status $loadstatus -m "This is a test level comment" :value 10e6 :expected_value 1.1e6 :tol 100e3 :category nada :variable sillyvar :units mFarks :comment "This is the value/expected comment" fi + +env > envfile.txt # $MT_MEGATEST -test-status :state COMPLETED :status FAIL Index: tests/fullrun/tests/sqlitespeed/runscript.rb ================================================================== --- tests/fullrun/tests/sqlitespeed/runscript.rb +++ tests/fullrun/tests/sqlitespeed/runscript.rb @@ -1,8 +1,8 @@ #! /usr/bin/env ruby -require "#{ENV['MT_RUN_AREA_HOME']}/../supportfiles/ruby/librunscript.rb" +require "#{ENV['MT_RUN_AREA_HOME']}/../resources/ruby/librunscript.rb" # run_record(stepname, cmd) - will record in db if exit code of script was zero or not run_and_record('create db',"sqlite3 testing.db << EOF\ncreate table if not exists blah(id INTEGER PRIMARY KEY,name TEXT);\n.q\nEOF","") if (! File.exists?("../../runfirst/I_was_here")) ADDED tests/fullrun/tests/wait_no_items1/testconfig Index: tests/fullrun/tests/wait_no_items1/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items1/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton no_items + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/wait_no_items2/testconfig Index: tests/fullrun/tests/wait_no_items2/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items2/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton wait_no_items1 + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/wait_no_items3/testconfig Index: tests/fullrun/tests/wait_no_items3/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items3/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton wait_no_items2 + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/wait_no_items4/testconfig Index: tests/fullrun/tests/wait_no_items4/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items4/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton wait_no_items3 + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt Index: tests/mintest/megatest.config ================================================================== --- tests/mintest/megatest.config +++ tests/mintest/megatest.config @@ -2,10 +2,11 @@ X TEXT [setup] max_concurrent_jobs 50 linktree #{getenv PWD}/linktree +transport http [server] port 8090 [jobtools] ADDED tests/mintest/tests/a1/testconfig Index: tests/mintest/tests/a1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/a1/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b1 ADDED tests/mintest/tests/b1/testconfig Index: tests/mintest/tests/b1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/b1/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton c1 ADDED tests/mintest/tests/c1/testconfig Index: tests/mintest/tests/c1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/c1/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton d1fail ADDED tests/mintest/tests/d1fail/testconfig Index: tests/mintest/tests/d1fail/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/d1fail/testconfig @@ -0,0 +1,7 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS +step2 exit 123 + +[requirements] +waiton e1 ADDED tests/mintest/tests/e1/testconfig Index: tests/mintest/tests/e1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/e1/testconfig @@ -0,0 +1,4 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + ADDED tests/resources/ruby/librunscript.rb Index: tests/resources/ruby/librunscript.rb ================================================================== --- /dev/null +++ tests/resources/ruby/librunscript.rb @@ -0,0 +1,37 @@ +# This is the library of stuff for megatest + +def run_and_record(stepname, cmd, checks) + system "megatest -step #{stepname} :state start :status n/a" + system cmd + exitcode=$? + if exitcode==0 + exitcode='pass' + else + exitcode='fail' + end + system "megatest -step #{stepname} :state end :status #{exitcode}" +end + +def record_step(stepname,state,status) + system "megatest -step #{stepname} :state #{state} :status #{status}" +end + +def test_status(state,status) + system "megatest -test-status :state #{state} :status #{status}" +end + + +# WARNING: This example is deprecated. Don't use the -test-status command +# unless you know for sure what you are doing. +def file_size_checker(stepname,filename,minsize,maxsize) + fsize=File.size(filename) + if fsize > maxsize or fsize < minsize + system "megatest -test-status :state COMPLETED :status fail" + else + system "megatest -test-status :state COMPLETED :status pass" + end +end + + +def wait_for_step(testname,stepname) +end ADDED tests/rununittest.sh Index: tests/rununittest.sh ================================================================== --- /dev/null +++ tests/rununittest.sh @@ -0,0 +1,14 @@ +#!/bin/bash + +# Usage: rununittest.sh testname debuglevel +# + +# Clean setup +# +rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db +rm -rf simplelinks/ simpleruns/ +mkdir -p simplelinks simpleruns +(cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm) + +# Run the test $1 is the unit test to run +cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1 Index: tests/simplerun/megatest.config ================================================================== --- tests/simplerun/megatest.config +++ tests/simplerun/megatest.config @@ -3,10 +3,15 @@ RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines max_concurrent_jobs 50 + +# Uncomment this to make the in-mem db into a disk based db (slower but good for debug) +# be aware that some unit tests will fail with this due to persistent data +# +# tmpdb /tmp # This is your link path, you can move it but it is generally better to keep it stable linktree #{shell readlink -f #{getenv PWD}/../simplelinks} # Valid values for state and status for steps, NB// It is not recommended you use this ADDED tests/speedtest/megatest.config Index: tests/speedtest/megatest.config ================================================================== --- /dev/null +++ tests/speedtest/megatest.config @@ -0,0 +1,48 @@ +[fields] +sysname TEXT +fsname TEXT +datapath TEXT + +[setup] +transport #{scheme (if (getenv "USEHTTP") "http" "fs")} + +max_concurrent_jobs 50 + +# It is possible (but not recommended) to override the rsync command used +# to populate the test directories. For test development the following +# example can be useful +# +testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log + +# FULL or 2, NORMAL or 1, OFF or 0 +synchronous OFF + +# override the logview command +# +logviewer (%MTCMD%) 2> /dev/null > /dev/null + +# override the html viewer launch command +# +# htmlviewercmd firefox -new-window +htmlviewercmd konqueror + +[jobtools] +launcher nbfake + +[server] + +# If the server can't be started on this port it will try the next port until +# it succeeds +port 8080 + +# This server will keep running this number of hours after last access. +# Three minutes is 0.05 hours +timeout 0.025 + +## disks are: +## name host:/path/to/area +## -or- +## name /path/to/area +[disks] +disk0 #{getenv MT_RUN_AREA_HOME}/tmp_run + ADDED tests/speedtest/runconfigs.config Index: tests/speedtest/runconfigs.config ================================================================== --- /dev/null +++ tests/speedtest/runconfigs.config @@ -0,0 +1,3 @@ +[default] +SOMEVAR This should show up in SOMEVAR3 + ADDED tests/speedtest/tests/speedtest/main.sh Index: tests/speedtest/tests/speedtest/main.sh ================================================================== --- /dev/null +++ tests/speedtest/tests/speedtest/main.sh @@ -0,0 +1,10 @@ +#!/bin/bash + +# a bunch of steps in 2 second increments +for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do + $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html + sleep $TEST_DELAY + $MT_MEGATEST -step step$i :state end :status 0 +done + +exit 0 ADDED tests/speedtest/tests/speedtest/testconfig Index: tests/speedtest/tests/speedtest/testconfig ================================================================== --- /dev/null +++ tests/speedtest/tests/speedtest/testconfig @@ -0,0 +1,18 @@ +[setup] +runscript main.sh + +[requirements] +priority 1 + +[items] +SETLOG 0 1 +TEST_DELAY 0 1 2 3 4 5 6 7 8 9 10 +ITERATIONS 0 1 2 3 4 5 6 7 8 9 10 + +[test_meta] +author matt +owner bob +description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS + +tags first,single +reviewed 09/10/2011, by Matt Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -11,12 +11,12 @@ (require-extension test) (require-extension regex) (require-extension srfi-18) (import srfi-18) -(require-extension zmq) -(import zmq) +;; (require-extension zmq) +;; (import zmq) (define test-work-dir (current-directory)) ;; read in all the _record files (let ((files (glob "*_records.scm"))) @@ -26,433 +26,11 @@ (load file)) files)) (define *runremote* #f) -;;====================================================================== -;; P R O C E S S E S -;;====================================================================== - -(test "cmd-run-with-stderr->list" '("No such file or directory") - (let ((reslst (cmd-run-with-stderr->list "ls" "/tmp/ihadbetternotexist"))) - (string-search (regexp "No such file or directory")(car reslst)))) - -;;====================================================================== -;; T E S T M A T C H I N G -;;====================================================================== - -;; tests:glob-like-match -(test #f '("abc") (tests:glob-like-match "abc" "abc")) -(for-each - (lambda (patt str expected) - (test (conc patt " " str "=>" expected) expected (tests:glob-like-match patt str))) - (list "abc" "~abc" "~abc" "a*c" "a%c") - (list "abc" "abcd" "abc" "ABC" "ABC") - (list '("abc") #t #f #f '("ABC")) - ) - -;; tests:match -(test #f #t (tests:match "abc/def" "abc" "def")) -(for-each - (lambda (patterns testname itempath expected) - (test (conc patterns " " testname "/" itempath "=>" expected) - expected - (tests:match patterns testname itempath))) - (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/") - (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a") - (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b") - (list #t #t #t #f #f #t #t #t #f #t #t #t #f)) - -;; db:patt->like -(test #f "testname LIKE 't%'" (db:patt->like "testname" "t%" comparator: " AND ")) -(test #f "testname LIKE 't%' AND testname LIKE '%t'" (db:patt->like "testname" "t%,%t" comparator: " AND ")) -(test #f "item_path GLOB ''" (db:patt->like "item_path" "")) - -;; test:match->sqlqry -(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')" - (tests:match->sqlqry "a/b,a%,/b%")) -(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')" - (tests:match->sqlqry "a/b,a%,%/b%")) - -;;====================================================================== -;; S E R V E R -;;====================================================================== - -(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 'http) - (set! res (open-run-close tasks:get-best-server tasks:open-db)) - (number? (vector-ref res 3)))) - -(test "de-register server" #t (let ((res #f)) - (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) - (vector? (open-run-close tasks:get-best-server tasks:open-db)))) - -(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! *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))) - - -;;====================================================================== -;; C O N F I G F I L E S -;;====================================================================== - -(define conffile #f) -(test "Read a config" #t (hash-table? (read-config "test.config" #f #f))) -(test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f))) - -(set! conffile (read-config "test.config" #f #f)) -(test "Get available diskspace" #t (number? (get-df "./"))) -(test "Get best dir" #t (let ((bestdir (get-best-disk conffile))) - (or (equal? "./" bestdir) - (equal? "/tmp" bestdir)))) -(test "Multiline variable" 4 (length (string-split (config-lookup conffile "metadata" "description") "\n"))) - -;; db -(define row (vector "a" "b" "c" "blah")) -(define header (list "col1" "col2" "col3" "col4")) -(test "Get row by header" "blah" (db:get-value-by-header row header "col4")) - -;; (define *toppath* "tests") -(define *db* #f) -(test "open-db" #t (begin - (set! *db* (open-db)) - (if *db* #t #f))) - -;; quit wasting time, I'm changing *db* to db -(define db *db*) - -(test "get cpu load" #t (number? (get-cpu-load))) -(test "get uname" #t (string? (get-uname))) - -(test "get validvalues as list" (list "start" "end" "completed") - (string-split (config-lookup *configdat* "validvalues" "state"))) - -(for-each (lambda (item) - (test (conc "get valid items (" item ")") - item (items:check-valid-items "state" item))) - (list "start" "end" "completed")) - -(for-each (lambda (item) - (test (conc "get valid items (" item ")") - item (items:check-valid-items "status" item))) - (list "pass" "fail" "n/a")) - -(test #f #f (items:check-valid-items "state" "blahfool")) - -(test "write env files" "nada.csh" (begin - (save-environment-as-files "nada") - (and (file-exists? "nada.sh") - (file-exists? "nada.csh")))) - -(test #f #t (cdb:client-call *runremote* 'immediate #t 1 (lambda ()(display "Got here eh!?") #t))) - -;; (set! *verbosity* 20) -(test #f *verbosity* (cadr (cdb:set-verbosity *runremote* *verbosity*))) -(test #f #f (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" "PASS")) -;; (set! *verbosity* 1) -;; (cdb:set-verbosity *runremote* *verbosity*) - -(test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?)) - - -(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? - (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)) - -(define keys (db:get-keys *db*)) - -;;====================================================================== -;; D B -;;====================================================================== - -(test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def")) -(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") -(unsetenv "NADAFOO") -(test "env temp overrides" "xyz" (let ((prevvals (alist->env-vars '(("BLAHFOO" 4321)("NADAFOO" xyz)))) - (result (get-environment-variable "NADAFOO"))) - (alist->env-vars prevvals) - result)) - -(test "env restored" "1234" (get-environment-variable "BLAHFOO")) - - -(test "Items assoc" "Elephant" (cadar (cadr (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall")))))) -(set! *verbosity* 6) -(test "Items assoc" '()(item-assoc->item-list '(("a" "a b c d")("b" "c d e")("c" "")("d")))) -(set! *verbosity* -1) -(test "Items assoc empty items" '() (item-assoc->item-list '(("A")))) -(set! *verbosity* 1) -(test "Items table" "SEASON" (caadar (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter"))))) -(test "Items table empty items I" '() (item-table->item-list '(("A")))) -(test "Items table empty items II" '() (item-table->item-list '(("A" "")))) - -;; Test out the steps code - -(define test-id #f) - -;; force keepgoing -; (hash-table-set! args:arg-hash "-keepgoing" #t) -(hash-table-set! args:arg-hash "-itempatt" "%") -(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") -(test #f #t (let ((db (open-test-db testdbpath))) - (set! *tdb* db) - (sqlite3#database? db))) -(sqlite3#finalize! *tdb*) - -;; (test "Remove the rollup run" #t (begin (remove-runs) #t)) -(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) - -(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 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 - #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 - "" ;; itempath - ) - args:arg-hash ;; flags (e.g. -itemspatt) - #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))) - -(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") - (sleep 2) - (db:teststep-set-status! db 2 "step1" "end" "pass" "This is a different comment" "finallogfile.html") - (set! test-id (db:test-get-id (car (cdb:remote-run db:get-tests-for-run #f 1 "test1" '() '())))) - (number? test-id))) - -(test "Get rundir" #t (let ((rundir (cdb:remote-run db:test-get-rundir-from-test-id #f test-id))) - (print "Rundir " rundir) - (system (conc "mkdir -p " rundir)) - (string? rundir))) -(test #f #t (sqlite3#database? (open-test-db "./"))) -(test "Create a test db" "../simpleruns/key1/key2/myrun/test1/testdat.db" - (let ((tdb (open-run-close db:open-test-db-by-test-id db test-id))) - (if tdb (sqlite3#finalize! tdb)) - (file-exists? "../simpleruns/key1/key2/myrun/test1/testdat.db"))) - -(test "Get steps for test" #t (let ((steps (cdb:remote-run db:get-steps-for-test #f test-id))) - (print steps) - (> (length steps) 0))) -(test "Get nice table for steps" "2.0s" - (begin - (vector-ref (hash-table-ref (open-run-close db:get-steps-table #f test-id) "step1") 4))) - -;; (exit) - -(test #f "myrun" (cdb:remote-run db:get-run-name-from-id #f 1)) - -(test #f #f (cdb:remote-run db:roll-up-pass-fail-counts #f 1 "nada" "" "PASS")) - -;;====================================================================== -;; R E M O T E C A L L S -;;====================================================================== - -(define start-wait (current-seconds)) -(print "Starting intensive cache and rpc test") -(for-each (lambda (params) - (print "Intensive: params=" params) - (cdb:tests-register-test *runremote* 1 (conc "test" (random 20)) "") - (apply cdb:test-set-status-state *runremote* test-id params) - (cdb:pass-fail-counts *runremote* test-id (random 100) (random 100)) - (cdb:test-rollup-test_data-pass-fail *runremote* test-id) - (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" (cadr params)) - (thread-sleep! 0.01)) ;; cache ordering granularity is at the second level. Should really be at the ms level - '(("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("KILLED" "UNKNOWN" "More testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("KILLED" "UNKNOWN" "More testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("KILLED" "UNKNOWN" "More testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("KILLED" "UNKNOWN" "More testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("KILLED" "UNKNOWN" "More testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("KILLED" "UNKNOWN" "More testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("KILLED" "UNKNOWN" "More testing") - ("KILLED" "UNKNOWN" "More testing") - )) - -;; now set all tests to completed -(cdb:flush-queue *runremote*) -(let ((tests (cdb:remote-run db:get-tests-for-run #f 1 "%" '() '()))) - (print "Setting " (length tests) " to COMPLETED/PASS") - (for-each - (lambda (test) - (cdb:test-set-status-state *runremote* (db:test-get-id test) "COMPLETED" "PASS" "Forced pass")) - tests)) - -;; (process-wait server-pid) -;; (test "Server wait time" #t (let ((run-delta (- (current-seconds) start-wait))) -;; (print "Server ran for " run-delta " seconds") -;; (> run-delta 20))) - -(test "Rollup the run(s)" #t (begin - (runs:rollup-run keys (keys->alist keys "na") "rollup" "matt") - #t)) - -(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") -(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 '() '()) +(let* ((unit-test-name (list-ref (argv) 4)) + (fname (conc "../unittests/" unit-test-name ".scm"))) + (if (file-exists? fname) + (load fname) + (print "ERROR: Unit test " unit-test-name " not found in unittests directory"))) + ADDED tests/unittests/configfiles.scm Index: tests/unittests/configfiles.scm ================================================================== --- /dev/null +++ tests/unittests/configfiles.scm @@ -0,0 +1,52 @@ +;;====================================================================== +;; C O N F I G F I L E S +;;====================================================================== + +(define conffile #f) +(test "Read a config" #t (hash-table? (read-config "test.config" #f #f))) +(test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f))) + +(set! conffile (read-config "test.config" #f #f)) +(test "Get available diskspace" #t (number? (get-df "./"))) +(test "Get best dir" #t (let ((bestdir (get-best-disk conffile))) + (or (equal? "./" bestdir) + (equal? "/tmp" bestdir)))) +(test "Multiline variable" 4 (length (string-split (config-lookup conffile "metadata" "description") "\n"))) + +;; db +(define row (vector "a" "b" "c" "blah")) +(define header (list "col1" "col2" "col3" "col4")) +(test "Get row by header" "blah" (db:get-value-by-header row header "col4")) + +;; (define *toppath* "tests") +(define *db* #f) +(test "open-db" #t (begin + (set! *db* (open-db)) + (if *db* #t #f))) + +;; quit wasting time, I'm changing *db* to db +(define db *db*) + +(test "get cpu load" #t (number? (get-cpu-load))) +(test "get uname" #t (string? (get-uname))) + +(test "get validvalues as list" (list "start" "end" "completed") + (string-split (config-lookup *configdat* "validvalues" "state"))) + +(for-each (lambda (item) + (test (conc "get valid items (" item ")") + item (items:check-valid-items "state" item))) + (list "start" "end" "completed")) + +(for-each (lambda (item) + (test (conc "get valid items (" item ")") + item (items:check-valid-items "status" item))) + (list "pass" "fail" "n/a")) + +(test #f #f (items:check-valid-items "state" "blahfool")) + +(test "write env files" "nada.csh" (begin + (save-environment-as-files "nada") + (and (file-exists? "nada.sh") + (file-exists? "nada.csh")))) + ADDED tests/unittests/inmemdb.scm Index: tests/unittests/inmemdb.scm ================================================================== --- /dev/null +++ tests/unittests/inmemdb.scm @@ -0,0 +1,44 @@ +;;====================================================================== +;; S E R V E R +;;====================================================================== + +;; Run like this: +;; +;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) + +(set! *transport-type* 'http) + +(system "cp ../fullrun/megatest.db megatest.db") + +(test "open inmem db" 1 (begin (open-in-mem-db) 1)) + +(test "setup for run" #t (begin (setup-for-run) + (string? (getenv "MT_RUN_AREA_HOME")))) + +(system "megatest -server - -debug 0 &") + +(thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed. + +(define *keys* (keys:config-get-fields *configdat*)) +(define *keyvals* (keys:target->keyval *keys* "a/b/c")) + +(test #f #t (string? (car *runremote*))) +(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) + +(define inmem (open-in-mem-db)) + +(define (inmem-test t b) + (test "inmem sync to" t (db:sync-to *db* inmem)) + (test "inmem sync back" b (db:sync-to inmem *db*))) + +(inmem-test 0 0) + +(inmem-test 1 1) + +;;====================================================================== +;; D B +;;====================================================================== + +(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) + + ADDED tests/unittests/misc.scm Index: tests/unittests/misc.scm ================================================================== --- /dev/null +++ tests/unittests/misc.scm @@ -0,0 +1,45 @@ +;;====================================================================== +;; P R O C E S S E S +;;====================================================================== + +(test "cmd-run-with-stderr->list" '("No such file or directory") + (let ((reslst (cmd-run-with-stderr->list "ls" "/tmp/ihadbetternotexist"))) + (string-search (regexp "No such file or directory")(car reslst)))) + +;;====================================================================== +;; T E S T M A T C H I N G +;;====================================================================== + +;; tests:glob-like-match +(test #f '("abc") (tests:glob-like-match "abc" "abc")) +(for-each + (lambda (patt str expected) + (test (conc patt " " str "=>" expected) expected (tests:glob-like-match patt str))) + (list "abc" "~abc" "~abc" "a*c" "a%c") + (list "abc" "abcd" "abc" "ABC" "ABC") + (list '("abc") #t #f #f '("ABC")) + ) + +;; tests:match +(test #f #t (tests:match "abc/def" "abc" "def")) +(for-each + (lambda (patterns testname itempath expected) + (test (conc patterns " " testname "/" itempath "=>" expected) + expected + (tests:match patterns testname itempath))) + (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/") + (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a") + (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b") + (list #t #t #t #f #f #t #t #t #f #t #t #t #f)) + +;; db:patt->like +(test #f "testname LIKE 't%'" (db:patt->like "testname" "t%" comparator: " AND ")) +(test #f "testname LIKE 't%' AND testname LIKE '%t'" (db:patt->like "testname" "t%,%t" comparator: " AND ")) +(test #f "item_path GLOB ''" (db:patt->like "item_path" "")) + +;; test:match->sqlqry +(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')" + (tests:match->sqlqry "a/b,a%,/b%")) +(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')" + (tests:match->sqlqry "a/b,a%,%/b%")) + ADDED tests/unittests/runs.scm Index: tests/unittests/runs.scm ================================================================== --- /dev/null +++ tests/unittests/runs.scm @@ -0,0 +1,275 @@ +(define keys (db:get-keys *db*)) + +(test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?)) + +(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)) + +(test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def")) +(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") +(unsetenv "NADAFOO") +(test "env temp overrides" "xyz" (let ((prevvals (alist->env-vars '(("BLAHFOO" 4321)("NADAFOO" xyz)))) + (result (get-environment-variable "NADAFOO"))) + (alist->env-vars prevvals) + result)) + +(test "env restored" "1234" (get-environment-variable "BLAHFOO")) + + +(test "Items assoc" "Elephant" (cadar (cadr (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall")))))) +(set! *verbosity* 6) +(test "Items assoc" '()(item-assoc->item-list '(("a" "a b c d")("b" "c d e")("c" "")("d")))) +(set! *verbosity* -1) +(test "Items assoc empty items" '() (item-assoc->item-list '(("A")))) +(set! *verbosity* 1) +(test "Items table" "SEASON" (caadar (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter"))))) +(test "Items table empty items I" '() (item-table->item-list '(("A")))) +(test "Items table empty items II" '() (item-table->item-list '(("A" "")))) + +;; Test out the steps code + +(define test-id #f) + +;; force keepgoing +; (hash-table-set! args:arg-hash "-keepgoing" #t) +(hash-table-set! args:arg-hash "-itempatt" "%") +(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") +(test #f #t (let ((db (open-test-db testdbpath))) + (set! *tdb* db) + (sqlite3#database? db))) +(sqlite3#finalize! *tdb*) + +;; (test "Remove the rollup run" #t (begin (remove-runs) #t)) +(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) + +(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 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 + #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 + "" ;; itempath + ) + args:arg-hash ;; flags (e.g. -itemspatt) + #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))) + +(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") + (sleep 2) + (db:teststep-set-status! db 2 "step1" "end" "pass" "This is a different comment" "finallogfile.html") + (set! test-id (db:test-get-id (car (cdb:remote-run db:get-tests-for-run #f 1 "test1" '() '())))) + (number? test-id))) + +(test "Get rundir" #t (let ((rundir (cdb:remote-run db:test-get-rundir-from-test-id #f test-id))) + (print "Rundir " rundir) + (system (conc "mkdir -p " rundir)) + (string? rundir))) +(test #f #t (sqlite3#database? (open-test-db "./"))) +(test "Create a test db" "../simpleruns/key1/key2/myrun/test1/testdat.db" + (let ((tdb (open-run-close db:open-test-db-by-test-id db test-id))) + (if tdb (sqlite3#finalize! tdb)) + (file-exists? "../simpleruns/key1/key2/myrun/test1/testdat.db"))) + +(test "Get steps for test" #t (let ((steps (cdb:remote-run db:get-steps-for-test #f test-id))) + (print steps) + (> (length steps) 0))) +(test "Get nice table for steps" "2.0s" + (begin + (vector-ref (hash-table-ref (open-run-close db:get-steps-table #f test-id) "step1") 4))) + +;; (exit) + +(test #f "myrun" (cdb:remote-run db:get-run-name-from-id #f 1)) + +(test #f #f (cdb:remote-run db:roll-up-pass-fail-counts #f 1 "nada" "" "PASS")) + +;;====================================================================== +;; R E M O T E C A L L S +;;====================================================================== + +(define start-wait (current-seconds)) +(print "Starting intensive cache and rpc test") +(for-each (lambda (params) + (print "Intensive: params=" params) + (cdb:tests-register-test *runremote* 1 (conc "test" (random 20)) "") + (apply cdb:test-set-status-state *runremote* test-id params) + (cdb:pass-fail-counts *runremote* test-id (random 100) (random 100)) + (cdb:test-rollup-test_data-pass-fail *runremote* test-id) + (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" (cadr params)) + (thread-sleep! 0.01)) ;; cache ordering granularity is at the second level. Should really be at the ms level + '(("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("KILLED" "UNKNOWN" "More testing") + )) + +;; now set all tests to completed +(cdb:flush-queue *runremote*) +(let ((tests (cdb:remote-run db:get-tests-for-run #f 1 "%" '() '()))) + (print "Setting " (length tests) " to COMPLETED/PASS") + (for-each + (lambda (test) + (cdb:test-set-status-state *runremote* (db:test-get-id test) "COMPLETED" "PASS" "Forced pass")) + tests)) + +;; (process-wait server-pid) +;; (test "Server wait time" #t (let ((run-delta (- (current-seconds) start-wait))) +;; (print "Server ran for " run-delta " seconds") +;; (> run-delta 20))) + +(test "Rollup the run(s)" #t (begin + (runs:rollup-run keys (keys->alist keys "na") "rollup" "matt") + #t)) + +(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") +(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 '() '()) ADDED tests/unittests/server.scm Index: tests/unittests/server.scm ================================================================== --- /dev/null +++ tests/unittests/server.scm @@ -0,0 +1,114 @@ +;;====================================================================== +;; S E R V E R +;;====================================================================== + +;; Run like this: +;; +;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) + +(set! *transport-type* 'http) + +(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 'http) + (set! res (open-run-close tasks:get-best-server tasks:open-db)) + (number? (vector-ref res 3)))) + +(test "de-register server" #f (let ((res #f)) + (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) + (vector? (open-run-close tasks:get-best-server tasks:open-db)))) + +(define server-pid #f) + +;; Not sure how the following should work, replacing it with system of megatest -server +;; (test "launch server" #t (let ((pid (process-fork (lambda () +;; ;; (daemon:ize) +;; (server:launch 'http))))) +;; (set! server-pid pid) +;; (number? pid))) +(system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") + +(let loop ((n 10)) + (thread-sleep! 1) ;; need to wait for server to start. + (let ((res (open-run-close tasks:get-best-server tasks:open-db))) + (print "tasks:get-best-server returned " res) + (if (and (not res) + (> n 0)) + (loop (- n 1))))) + +(test "get-best-server" #t (begin + (client:launch) + (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) + (vector? dat)))) + +(define *keys* (keys:config-get-fields *configdat*)) +(define *keyvals* (keys:target->keyval *keys* "a/b/c")) + +(test #f #t (string? (car *runremote*))) +(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) + +(test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test + +;; RUNS +(test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) +(test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) + (vector-ref (vector-ref rinfo 1) 3))) +(test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) + +;; TESTS +(test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) +(test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) +(test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) +(test "get test id" 1 (rmt:get-test-id 1 "test1" "")) +(test "sync back" #t (> (rmt:sync-inmem->db) 0)) +(test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) +(test "get keys" #t (list? (rmt:get-keys))) +(test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) +(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) + (db:test-get-comment trec))) + +;; MORE RUNS +(test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) + (header (vector-ref runs 0)) + (data (vector-ref runs 1))) + (and (list? header) + (list? data) + (vector? (car data))))) + +(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) +(test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) + +;;====================================================================== +;; D B +;;====================================================================== + +(test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) +(test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) + (+ (db:test-get-pass_count dat) + (db:test-get-fail_count dat)))) + +(define testregistry (make-hash-table)) +(for-each + (lambda (tname) + (for-each + (lambda (itempath) + (let ((tkey (conc tname "/" itempath)) + (rpass (random 10)) + (rfail (random 10))) + (hash-table-set! testregistry tkey (list tname itempath)) + (rmt:general-call 'register-test 1 tname itempath) + (let* ((tid (rmt:get-test-id 1 tname itempath)) + (tdat (rmt:get-test-info-by-id tid))) + (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) + (let* ((resdat (rmt:get-test-info-by-id tid))) + (test "set/get pass fail counts" (list rpass rfail) + (list (db:test-get-pass_count resdat) + (db:test-get-fail_count resdat))))))) + (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) + (list "test1" "test2" "test3" "test4" "test5")) + + +(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) + ADDED tests/unittests/tests.scm Index: tests/unittests/tests.scm ================================================================== --- /dev/null +++ tests/unittests/tests.scm Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -58,13 +58,14 @@ export KTYPE=26 else echo Using KTYPE=$KTYPE fi -export CHICKEN_VERSION=4.8.0 +export CHICKEN_VERSION=4.8.0.5 +export CHICKEN_BASEVER=4.8.0 if ! [[ -e chicken-${CHICKEN_VERSION}.tar.gz ]]; then - wget http://code.call-cc.org/releases/${CHICKEN_VERSION}/chicken-${CHICKEN_VERSION}.tar.gz + wget http://code.call-cc.org/releases/${CHICKEN_BASEVER}/chicken-${CHICKEN_VERSION}.tar.gz fi BUILDHOME=$PWD DEPLOYTARG=$BUILDHOME/deploy ADDED utils/mtgetfile Index: utils/mtgetfile ================================================================== --- /dev/null +++ utils/mtgetfile @@ -0,0 +1,31 @@ +#!/bin/bash + +fullparams="$@" + +function findfile () { +megatest $fullparams -repl < numargs 0)(car remargs) #f)) + (scriptn (if (> numargs 1)(cadr remargs) #f)) + (keys (cdb:remote-run db: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)) + (errmsg (cond + ((not key-vals) "missing -target") + ((not target) "missing -target") + ((not scriptn) "missing file name to find") + (else #f)))) + (if errmsg + (begin + (print "THEPATH: Missing required switch: " errmsg) + (print "THEPATH: Usage: mtgetfile -target target scriptname [searchpath]") + (exit))) + (print "THEPATH: key-vals=" key-vals " path=" path " scriptn=" scriptn)) +EOF +} + +findfile | egrep "^THEPATH: " | sed -e 's/^THEPATH: //' ADDED utils/mtrunscript Index: utils/mtrunscript ================================================================== --- /dev/null +++ utils/mtrunscript @@ -0,0 +1,203 @@ +#!/usr/bin/env bash + +# Copyright 2012, 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. +# +# VERSION: + +# set -e +# set -u +# set -x + +# Usage: mtrunscript scriptname params +# +# Look for scriptname in this order +# +# $MT_TEST_RUN_DIR/scripts => $MT_RUN_AREA_HOME/scripts +# => $MT_RUN_AREA_HOME/../scripts => $PATH +# +# In each area look for the script with the name like this: +# +# scriptname_$TARGET[1]_$TARGET[2]_...$TARGET[n]_$MT_TESTNAME_$MT_ITEMPATH(s#/#_) +# + +echo "NOT IMPLEMENTED YET!" +exit + +case "x$1" in + # repo + xrep*) + fsl_dbinit + case "x$2" in + xhelp) + fsl_help + exit + ;; + + # repo get + xget) + hook_pre_repo_get "$@" + fsl_repo_get $3 $4 + hook_post_repo_get "$@" + exit + ;; + + xaddarea) + fsl_add_area $3 $4 + exit + ;; + + xdroparea) + fsl_remove_area $3 + exit + ;; + + xdbinit) + fsl_dbinit + exit + ;; + + xls|xlist) + shift + shift + fsl_ls "$@" + exit + ;; + + xcreate) + hook_pre_repo_create + fsl_repo_create $3 $4 $5 $6 + hook_post_repo_create + exit + ;; + + ximport) + fsl_repo_import $3 $4 $5 + exit + ;; + + *) + fsl_help + exit + esac + ;; + + "xmv") + if [ "x$2" = "x-f" ];then + # echo "Force mode" + fsl_force=1 + shift + shift + # change this to exec when happy! + # fsl mv -f f1 [f2 f3...] targ + fsl_mv "$@" + # args=("$@") + # echo $@ -> echo $@ + # use $# variable to print out + # number of arguments passed to the bash script + # echo Number of arguments passed: $# -> echo Number of arguments passed: $# + exit + else + # echo No force + shift + fsl_mv "$@" + exit + fi + ;; + + xtim*) + fsl_fork_find + shift + $FOSSILEXE timeline "$@" | sed -e :a -e '$!N;s/\n / /;ta' -e 'P;D' + exit + ;; + + # leaves output needs to be niceified, no need for a function + xle*) + fsl_fork_find + shift + $FOSSILEXE leaves "$@" | sed -e :a -e '$!N;s/\n / /;ta' -e 'P;D' + exit + ;; + + # changes and status + xcha* | xstat*) + fsl_fork_find + fsl_conflicts "$@" + rm -f $CONFLICT_FLAG_FILE + exit + ;; + + # ci/commit + xci | xcom*) + fsl_conflicts changes "$@" + trap "$FOSSILUTIL releaselock $FSLUTIL_PARAMS" SIGINT + # Set up for remote locking + if [ ! -e $CONFLICT_FLAG_FILE ]; then + rm -f $CONFLICT_FLAG_FILE + read -p "ERROR: Conflicts detected. Type \"yes\" to continue: " -e ANSWER + if [ $ANSWER = "yes" ]; then + $FOSSILUTIL commitlock $FSLUTIL_PARAMS + $FOSSILEXE "$@" + $FOSSILUTIL releaselock $FSLUTIL_PARAMS + else + exit 1 + fi + else + $FOSSILUTIL commitlock $FSLUTIL_PARAMS + $FOSSILEXE "$@" + $FOSSILUTIL releaselock $FSLUTIL_PARAMS + fi + exit + ;; + + xtag) + case "x$2" in + xadd | xcancel) + $FOSSILEXE "$@" + $FOSSILEXE sync + exit + ;; + + *) + $FOSSILEXE "$@" + exit + ;; + esac + ;; + + # add mention of repo to help + "xhelp") + if [ $# -gt 1 ]; then + case "x$2" in + xrepo) + fsl_help + exit + ;; + + *) + $FOSSILEXE "$@" + ;; + + esac + else + $FOSSILEXE help | sed -e 's/sync/sync repo/' + fi + exit + ;; + + xup* | xco) + fsl_fork_find + $FOSSILEXE "$@" + exit + ;; + +esac + +exec $FOSSILEXE "$@"