Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -6,11 +6,13 @@ 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 filedb.scm \ + rmt.scm api.scm tdb.scm \ + ezsteps.scm lock-queue.scm GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) @@ -59,12 +61,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 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: 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) @@ -92,14 +97,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)) 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: 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") @@ -208,21 +209,21 @@ (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) + (rmt:test-set-state-status-by-id test-id #f #f b) (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) + (rmt:test-set-state-status-by-id test-id state #f #f) (db:test-set-state! testdat state))))) btn)) *common:std-states*))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) @@ -238,11 +239,11 @@ (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) + (rmt:test-set-state-status-by-id test-id #f status #f) (db:test-set-status! testdat status))))) btn)) *common:std-statuses*))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) @@ -286,16 +287,105 @@ ;; (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) + (string (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds request-update)) (newtestdat (if need-update (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)) + (rmt:get-test-info-by-id 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 test-id work-area: rundir)) (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 @@ -536,22 +627,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 +694,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 "%"))) + (rmt: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" @@ -90,12 +92,14 @@ (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 + (if (args:get-arg "-transport") + (begin + (set! *transport-type* (string->symbol (args:get-arg "-transport"))) ;; 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*) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -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,53 +42,108 @@ (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:set-sync db) - (let* ((syncval (config-lookup *configdat* "setup" "synchronous")) - (val (cond ;; 0 | OFF | 1 | NORMAL | 2 | FULL; - ((not syncval) #f) - ((string->number syncval) - (let ((val (string->number syncval))) - (if (member val '(0 1 2)) val #f))) - ((string-match (regexp "yes" #t) syncval) 1) - ((string-match (regexp "no" #t) syncval) 0) - ((string-match (regexp "(off|normal|full)" #t) syncval) syncval) - (else - (debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval) - #f)))) - (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*))) + +(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)))) + +;;====================================================================== +;; 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)) (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 + (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 (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 (not dbexists) - (db:initialize db)) - (db:set-sync db) + (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))) + ;; 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) @@ -110,39 +166,18 @@ (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,12 +187,10 @@ (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 @@ -170,53 +203,12 @@ "event_time TIMESTAMP," "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 +216,81 @@ 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, + testname TEXT, + host TEXT DEFAULT 'n/a', + cpuload REAL DEFAULT -1, + diskfree INTEGER DEFAULT -1, + uname TEXT DEFAULT 'n/a', + rundir_id INTEGER, + realdir_id INTEGER, + 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 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, + 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 +308,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,93 +321,12 @@ (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 ;;====================================================================== -(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)))))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -471,26 +335,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) @@ -501,30 +369,30 @@ (debug:print-info 0 "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) (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 +401,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 +442,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 +484,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))) @@ -657,13 +521,14 @@ ;; 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 +560,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 +574,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 "") @@ -782,121 +660,117 @@ ";")) (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)) + (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) + ;; (common:clear-caches) ;; don't trust caches after doing any deletion ;; 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))) ;;====================================================================== ;; 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,11 +779,11 @@ ;; 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 +(define (db:get-tests-for-run dbstruct 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")) (res '()) @@ -939,11 +813,11 @@ (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' " + " 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 ")) @@ -959,372 +833,310 @@ ))) (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)) + (db:get-db dbstruct run-id) + qry) + 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)) ;; 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-step-records dbstruct run-id test-id) + (let ((db (db:get-db dbstruct run-id))) + (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) + (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id))) ;; -(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_timesqlqry 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;"))) (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) 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! 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)))))))))) +;; NEVER FINISHED? ;; look through tests from matching runs for a file +;; NEVER FINISHED? (define (db:test-get-first-path-matching dbstruct keynames target fname) +;; NEVER FINISHED? ;; [refpaths] is the section where references to other megatest databases are stored +;; NEVER FINISHED? ;; +;; NEVER FINISHED? ;; NEED TO REVISIT THIS!!! BUGGISHNESS +;; NEVER FINISHED? ;; +;; NEVER FINISHED? (let ((mt-paths (configf:get-section "refpaths")) +;; NEVER FINISHED? (res (db:test-get-paths-matching dbstruct keynames target fname))) +;; NEVER FINISHED? (let loop ((pathdat (if (null? paths) #f (car mt-paths))) +;; NEVER FINISHED? (tal (if (null? paths) '()(cdr mt-paths)))) +;; NEVER FINISHED? (if (not (null? res)) +;; NEVER FINISHED? (car res) ;; return first found +;; NEVER FINISHED? (if path +;; NEVER FINISHED? (let* ((db (open-db path: (cadr pathdat))) +;; NEVER FINISHED? (newres (db:test-get-paths-matching db keynames target fname))) +;; NEVER FINISHED? (debug:print-info 4 "Trying " (car pathdat) " at " (cadr pathdat)) +;; NEVER FINISHED? (sqlite3:finalize! db) +;; NEVER FINISHED? (if (not (null? newres)) +;; NEVER FINISHED? (car newres) +;; NEVER FINISHED? (if (null? tal) +;; NEVER FINISHED? #f +;; NEVER FINISHED? (loop (car tal)(cdr tal)))))))))) ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS ;;====================================================================== @@ -1454,217 +1270,227 @@ ;; 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*)) +;; (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)))))) + +;; NOT NEEDED FOR NOW (define (cdb:set-verbosity serverdat val) +;; NOT NEEDED FOR NOW (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val)) +;; NOT NEEDED FOR NOW +;; NOT NEEDED FOR NOW (define (cdb:login serverdat keyval signature) +;; NOT NEEDED FOR NOW (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature)) +;; NOT NEEDED FOR NOW +;; NOT NEEDED FOR NOW (define (cdb:logout serverdat keyval signature) +;; NOT NEEDED FOR NOW (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature)) +;; NOT NEEDED FOR NOW +;; NOT NEEDED FOR NOW (define (cdb:num-clients serverdat) +;; NOT NEEDED FOR NOW (cdb:client-call serverdat 'numclients #t *default-numtries*)) +;; NOT NEEDED FOR NOW ;; 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) +(define (db:test-set-status-state dbstruct run-id test-id status state msg-id) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) - (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id)) + (sqlite3:execute (db:get-db dbstruct run-id) 'set-test-start-time 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)) + (sqlite3:execute (db:get-db dbstruct run-id) 'state-status-msg state status msg-id test-id) + (sqlite3:execute (db:get-db dbstruct run-id) 'state-status state status test-id))) + +(define (db:test-rollup-test_data-pass-fail dbstruct run-id test-id) + (sqlite3:execute (db:get-db dbstruct run-id) 'test_data-pf-rollup test-id test-id test-id test-id)) +;; (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id)) + + +(define (db:pass-fail-counts dbstruct run-id test-id fail-count pass-count) + (sqlite3:execute (db:get-db dbstruct run-id) 'pass-fail-counts fail-count pass-count test-id)) + +(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)) ;; 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 (db:update-pass-fail-counts dbstruct run-id test-name) + (sqlite3:execute (db:get-db dbstruct run-id) 'update-fail-pass-counts test-name test-name test-name)) + +(define (db:top-test-set-running dbstruct run-id test-name) + (sqlite3:execute (db:get-db dbstruct run-id) 'top-test-set-running test-name)) + +(define (db:top-test-set-per-pf-counts dbstruct run-id test-name) + (sqlite3:execute (db:get-db dbstruct run-id) 'top-test-set-per-pf-counts test-name test-name 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) +;; NOT NEEDED FOR NOW (define (cdb:flush-queue serverdat) +;; NOT NEEDED FOR NOW (cdb:client-call serverdat 'flush #f *default-numtries*)) +;; NOT NEEDED FOR NOW +;; NOT NEEDED FOR NOW (define (cdb:kill-server serverdat pid) +;; NOT NEEDED FOR NOW (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 (db: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 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 '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") ;; DONE ;; 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 fail_count=?,pass_count=? WHERE id=?;") ;; DONE ;; 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-run-duration "UPDATE tests SET run_duration=? 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='';") + 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 )) + +(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 @@ -1676,365 +1502,334 @@ )) ;; 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) +;; DISABLING FOR NOW (define (db:process-cached-writes db) +;; DISABLING FOR NOW (let ((queries (make-hash-table)) +;; DISABLING FOR NOW (data #f)) +;; DISABLING FOR NOW (mutex-lock! *incoming-mutex*) +;; DISABLING FOR NOW ;; data is a list of query packets (length data) 0) +;; DISABLING FOR NOW ;; Process if we have data +;; DISABLING FOR NOW (begin +;; DISABLING FOR NOW (debug:print-info 7 "Writing cached data " data) +;; DISABLING FOR NOW +;; DISABLING FOR NOW ;; Prepare the needed sql statements +;; DISABLING FOR NOW ;; +;; DISABLING FOR NOW (for-each (lambda (request-item) +;; DISABLING FOR NOW (let ((stmt-key (vector-ref request-item 0)) +;; DISABLING FOR NOW (query (vector-ref request-item 1))) +;; DISABLING FOR NOW (hash-table-set! queries stmt-key (sqlite3:prepare db query)))) +;; DISABLING FOR NOW data) +;; DISABLING FOR NOW +;; DISABLING FOR NOW ;; No outer loop needed. Single loop for write items only. Reads trigger flush of queue +;; DISABLING FOR NOW ;; and then are executed. +;; DISABLING FOR NOW (sqlite3:with-transaction +;; DISABLING FOR NOW db +;; DISABLING FOR NOW (lambda () +;; DISABLING FOR NOW (for-each +;; DISABLING FOR NOW (lambda (hed) +;; DISABLING FOR NOW (let* ((params (vector-ref hed 2)) +;; DISABLING FOR NOW (stmt-key (vector-ref hed 0)) +;; DISABLING FOR NOW (stmt (hash-table-ref/default queries stmt-key #f))) +;; DISABLING FOR NOW (if stmt +;; DISABLING FOR NOW (apply sqlite3:execute stmt params) +;; DISABLING FOR NOW (debug:print 0 "ERROR: Problem Executing " stmt-key " for " params)))) +;; DISABLING FOR NOW data))) +;; DISABLING FOR NOW +;; DISABLING FOR NOW ;; let all the waiting calls know all is done +;; DISABLING FOR NOW (mutex-lock! *completed-mutex*) +;; DISABLING FOR NOW (for-each (lambda (item) +;; DISABLING FOR NOW (let ((qry-sig (cdb:packet-get-client-sig item))) +;; DISABLING FOR NOW (debug:print-info 7 "Registering query " qry-sig " as done") +;; DISABLING FOR NOW (hash-table-set! *completed-writes* qry-sig #t))) +;; DISABLING FOR NOW data) +;; DISABLING FOR NOW (mutex-unlock! *completed-mutex*) +;; DISABLING FOR NOW +;; DISABLING FOR NOW ;; Finalize the statements. Should this be done inside the mutex above? +;; DISABLING FOR NOW ;; I think sqlite3 mutexes will keep the data safe +;; DISABLING FOR NOW (for-each (lambda (stmt-key) +;; DISABLING FOR NOW (sqlite3:finalize! (hash-table-ref queries stmt-key))) +;; DISABLING FOR NOW (hash-table-keys queries)) +;; DISABLING FOR NOW +;; DISABLING FOR NOW ;; Do a little record keeping +;; DISABLING FOR NOW (let ((cache-size (length data))) +;; DISABLING FOR NOW (if (> cache-size *max-cache-size*) +;; DISABLING FOR NOW (set! *max-cache-size* cache-size))) +;; DISABLING FOR NOW #t) +;; DISABLING FOR NOW #f))) +;; DISABLING FOR NOW +;; DISABLING FOR NOW (define *db:process-queue-mutex* (make-mutex)) +;; 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 +;; DISABLING FOR NOW ;; values to be applied +;; DISABLING FOR NOW ;; +;; DISABLING FOR NOW (define (db:queue-write-and-wait db qry-sig query params) +;; DISABLING FOR NOW (let ((queue-len 0) +;; DISABLING FOR NOW (res #f) +;; DISABLING FOR NOW (got-it #f) +;; DISABLING FOR NOW (qry-pkt (vector qry-sig query params)) +;; DISABLING FOR NOW (start-time (current-milliseconds)) +;; DISABLING FOR NOW (timeout (+ 10 (current-seconds)))) ;; set the time out to 10 secs in future +;; DISABLING FOR NOW +;; DISABLING FOR NOW ;; Put the item in the queue *incoming-writes* +;; DISABLING FOR NOW (mutex-lock! *incoming-mutex*) +;; DISABLING FOR NOW (set! *incoming-writes* (cons qry-pkt *incoming-writes*)) +;; DISABLING FOR NOW (set! queue-len (length *incoming-writes*)) +;; DISABLING FOR NOW (mutex-unlock! *incoming-mutex*) +;; DISABLING FOR NOW +;; DISABLING FOR NOW (debug:print-info 7 "Current write queue length is " queue-len) +;; DISABLING FOR NOW +;; DISABLING FOR NOW ;; poll for the write to complete, timeout after 10 seconds +;; DISABLING FOR NOW ;; periodic flushing of the queue is taken care of by +;; DISABLING FOR NOW ;; db:flush-queue +;; DISABLING FOR NOW (let loop () +;; DISABLING FOR NOW (thread-sleep! 0.001) +;; DISABLING FOR NOW (mutex-lock! *completed-mutex*) +;; DISABLING FOR NOW (if (hash-table-ref/default *completed-writes* qry-sig #f) +;; DISABLING FOR NOW (begin +;; DISABLING FOR NOW (hash-table-delete! *completed-writes* qry-sig) +;; DISABLING FOR NOW (set! got-it #t))) +;; DISABLING FOR NOW (mutex-unlock! *completed-mutex*) +;; DISABLING FOR NOW (if (and (not got-it) +;; DISABLING FOR NOW (< (current-seconds) timeout)) +;; DISABLING FOR NOW (begin +;; DISABLING FOR NOW (thread-sleep! 0.01) +;; DISABLING FOR NOW (loop)))) +;; DISABLING FOR NOW (set! *number-of-writes* (+ *number-of-writes* 1)) +;; DISABLING FOR NOW (set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time))) +;; DISABLING FOR NOW got-it)) +;; DISABLING FOR NOW +;; DISABLING FOR NOW (define (db:process-queue-item db item) +;; DISABLING FOR NOW (let* ((stmt-key (cdb:packet-get-qtype item)) +;; DISABLING FOR NOW (qry-sig (cdb:packet-get-query-sig item)) +;; DISABLING FOR NOW (return-address (cdb:packet-get-client-sig item)) +;; DISABLING FOR NOW (params (cdb:packet-get-params item)) +;; DISABLING FOR NOW (query (let ((q (alist-ref stmt-key db:queries))) +;; DISABLING FOR NOW (if q (car q) #f)))) +;; DISABLING FOR NOW (debug:print-info 11 "Special queries/requests stmt-key=" stmt-key ", return-address=" return-address ", query=" query ", params=" params) +;; DISABLING FOR NOW (if query +;; DISABLING FOR NOW ;; hand queries off to the write queue +;; DISABLING FOR NOW (let ((response (case *transport-type* +;; DISABLING FOR NOW ((http) +;; DISABLING FOR NOW (debug:print-info 7 "Queuing item " item " for wrapped write") +;; DISABLING FOR NOW (db:queue-write-and-wait db qry-sig query params)) +;; DISABLING FOR NOW (else +;; DISABLING FOR NOW (apply sqlite3:execute db query params) +;; DISABLING FOR NOW #t)))) +;; DISABLING FOR NOW (debug:print-info 7 "Received " response " from wrapped write") +;; DISABLING FOR NOW (server:reply return-address qry-sig response response)) +;; DISABLING FOR NOW ;; otherwise if appropriate flush the queue (this is a read or complex query) +;; DISABLING FOR NOW (begin +;; DISABLING FOR NOW (cond +;; DISABLING FOR NOW ((member stmt-key db:special-queries) +;; DISABLING FOR NOW (let ((starttime (current-milliseconds))) +;; DISABLING FOR NOW (debug:print-info 9 "Handling special statement " stmt-key) +;; DISABLING FOR NOW (case stmt-key +;; DISABLING FOR NOW ((immediate) +;; DISABLING FOR NOW ;; This is a read or mixed read-write query, must clear the cache +;; DISABLING FOR NOW (case *transport-type* +;; DISABLING FOR NOW ((http) +;; DISABLING FOR NOW (mutex-lock! *db:process-queue-mutex*) +;; DISABLING FOR NOW (db:process-cached-writes db) +;; DISABLING FOR NOW (mutex-unlock! *db:process-queue-mutex*))) +;; DISABLING FOR NOW (let* ((proc (car params)) +;; DISABLING FOR NOW (remparams (cdr params)) +;; DISABLING FOR NOW ;; we are being handed a procedure so call it +;; DISABLING FOR NOW ;; (debug:print-info 11 "Running (apply " proc " " remparams ")") +;; DISABLING FOR NOW (result (server:reply return-address qry-sig #t (apply proc remparams)))) +;; DISABLING FOR NOW (set! *total-non-write-delay* (+ *total-non-write-delay* (- (current-milliseconds) starttime))) +;; DISABLING FOR NOW (set! *number-non-write-queries* (+ *number-non-write-queries* 1)) +;; DISABLING FOR NOW result)) +;; DISABLING FOR NOW ((login) +;; DISABLING FOR NOW (if (< (length params) 3) ;; should get toppath, version and signature +;; DISABLING FOR NOW (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params +;; DISABLING FOR NOW (let ((calling-path (car params)) +;; DISABLING FOR NOW (calling-vers (cadr params)) +;; DISABLING FOR NOW (client-key (caddr params))) +;; DISABLING FOR NOW (if (and (equal? calling-path *toppath*) +;; DISABLING FOR NOW (equal? megatest-version calling-vers)) +;; DISABLING FOR NOW (begin +;; DISABLING FOR NOW (hash-table-set! *logged-in-clients* client-key (current-seconds)) +;; DISABLING FOR NOW (server:reply return-address qry-sig #t '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ... +;; DISABLING FOR NOW (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))))) +;; DISABLING FOR NOW ((flush sync) +;; DISABLING FOR NOW (server:reply return-address qry-sig #t 1)) ;; (length data))) +;; DISABLING FOR NOW ((set-verbosity) +;; DISABLING FOR NOW (set! *verbosity* (car params)) +;; DISABLING FOR NOW (server:reply return-address qry-sig #t (list #t *verbosity*))) +;; DISABLING FOR NOW ((killserver) +;; DISABLING FOR NOW (let ((hostname (car *runremote*)) +;; DISABLING FOR NOW (port (cadr *runremote*)) +;; DISABLING FOR NOW (pid (car params))) +;; DISABLING FOR NOW (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!") +;; DISABLING FOR NOW (debug:print-info 1 "current pid=" (current-process-id)) +;; DISABLING FOR NOW (open-run-close tasks:server-deregister tasks:open-db +;; DISABLING FOR NOW hostname +;; DISABLING FOR NOW port: port) +;; DISABLING FOR NOW (set! *server-run* #f) +;; DISABLING FOR NOW (thread-sleep! 3) +;; DISABLING FOR NOW (process-signal pid signal/kill) +;; DISABLING FOR NOW (server:reply return-address qry-sig #t '(#t "exit process started")))) +;; DISABLING FOR NOW (else ;; not a command, i.e. is a query +;; DISABLING FOR NOW (debug:print 0 "ERROR: Unrecognised query/command " stmt-key) +;; DISABLING FOR NOW (server:reply return-address qry-sig #f 'failed))))) +;; DISABLING FOR NOW (else +;; DISABLING FOR NOW (debug:print-info 11 "Executing " stmt-key " for " params) +;; DISABLING FOR NOW (apply sqlite3:execute (hash-table-ref queries stmt-key) params) +;; DISABLING FOR NOW (server:reply return-address qry-sig #t #t))))))) +;; DISABLING FOR NOW + +(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)) +(define (db:testmeta-update-field dbstruct testname field value) + (sqlite3:execute (db:get-db dbstruct #f) (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)) - '()))) - +(define (db:csv->test-data dbstruct run-id test-id 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)(db:get-prev-tol-for-test dbstruct run-id 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:get-db dbstruct run-id) "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))) + +(define (db:read-test-data dbstruct run-id 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))) + (db:get-db dbstruct run-id) + "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) + (reverse res))) ;; NOTE: Run this local with #f for db !!! -(define (db:load-test-data db test-id #!key (work-area #f)) +(define (db:load-test-data dbstruct run-id test-id) (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) + (db:csv->test-data dbstruct run-id test-id lin) (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)) + (db:test-data-rollup dbstruct run-id test-id #f)) ;; 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) +(define (db:test-data-rollup dbstruct run-id test-id status) + (let ((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, + (sqlite3:for-each-row + (lambda (fcount pcount) + (set! fail-count fcount) + (set! pass-count pcount)) + (db:get-db dbstruct run-id) + "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) + test-id test-id) + + ;; Now rollup the counts to the central megatest.db + (cdb:pass-fail-counts *runremote* test-id fail-count pass-count) + ;; 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))) + +(define (db:get-prev-tol-for-test dbstruct run-id test-id category variable) ;; Finish me? (values #f #f #f)) ;;====================================================================== ;; S T E P S @@ -2041,174 +1836,107 @@ ;;====================================================================== (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) - (stringsymbol (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 dbstruct run-id test-id) + (let ((comprsteps (open-run-close db:get-steps-table (db:get-db dbstruct run-id) test-id))) + (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) + (stringstring (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 @@ -98,10 +98,17 @@ (if (not db)(set! db (open-db))) (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,52 @@ ;;====================================================================== ;; 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*))) ;; (system "megatest -list-servers | grep alive || megatest -server - -daemonize && sleep 4") ;; ;; @@ -209,17 +258,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,15 +305,95 @@ (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))) + (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! login-res (client:login serverdat)) (if (and (not (null? login-res)) (car login-res)) (begin (debug:print-info 2 "Logged in and connected to " iface ":" port) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -141,10 +141,11 @@ ;; (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 @@ -700,10 +701,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.5513) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -25,10 +25,12 @@ (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) (declare (uses daemon)) (declare (uses db)) +(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") Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -38,12 +38,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 (db:get-runs-by-patt dbstruct keys runnamepatt targpatt 0 500)) (res '()) (offset 0) (limit 500)) ;; (print "runsdat: " runsdat) (let* ((header (vector-ref runsdat 0)) @@ -51,11 +51,11 @@ (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 (db:get-runs-by-patt dbstruct 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 @@ -64,31 +64,51 @@ ;;====================================================================== ;; 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)) +(define (mt:get-tests-for-run dbstruct run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)) + (let loop ((testsdat (db:get-tests-for-run dbstruct run-id testpatt states status 0 500 not-in sort-by sort-order qryvals: 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 (db:get-tests-for-run dbstruct run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals: 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:get-run-stats) - (cdb:remote-run db:get-run-stats #f)) +(define (mt:get-run-stats dbstruct run-id) + (db:get-run-stats dbstruct run-id)) + +(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 ;;====================================================================== @@ -122,34 +142,34 @@ ;;====================================================================== ;; 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) +(define (mt:roll-up-pass-fail-counts dbstruct 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) + (db:update-pass-fail-counts dbstruct 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)) + (db:top-test-set-running dbstruct run-id test-name) + (db:top-test-set-per-pf-counts dbstruct 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)))) - (mt:process-triggers test-id newstate newstatus) - #t) +;; ;; 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) +;; (sqlite3: '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)))) +;; (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))) (if (and tdat (< (current-seconds)(+ (vector-ref tdat 0) 10))) 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 @@ -367,11 +367,11 @@ '() 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)) (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 " @@ -450,18 +450,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) @@ -874,11 +877,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)))) 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)) 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 @@ -26,10 +26,11 @@ (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*)))) @@ -132,12 +133,12 @@ ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found ;; ;; Run this server-side ;; -(define (test:get-previous-test-run-record db run-id test-name item-path) - (let* ((keys (db:get-keys db)) +(define (test:get-previous-test-run-record dbstruct run-id test-name item-path) + (let* ((keys (db:get-keys dbstruct)) (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 @@ -157,11 +158,11 @@ ;; 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))) + (let ((results (db:get-tests-for-run dbstruct run-id 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 @@ -171,12 +172,12 @@ ;; 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)) +(define (test:get-matching-previous-test-run-records dbstruct run-id test-name item-path) + (let* ((keys (db:get-keys dbstruct)) (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 @@ -198,11 +199,11 @@ (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))) + (let ((results (db:get-tests-for-run dbstruct run-id 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) @@ -278,33 +279,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) + (test:get-previous-test-run-record dbstruct 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 +324,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))) + (db:test-set-status-state dbstruct run-id 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)) + (db:test-data-rollup dbstruct run-id 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 +365,36 @@ 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)) + (mt:roll-up-pass-fail-counts dbstruct 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) + (db:test-set-comment dbstruct run-id test-id (db:save-string dbstruct cmt)))))) + +(define (tests:test-set-toplog! dbstruct run-id test-name logf) + (sqlite3:execute (db:get-db dbstruct run-id) + (db:get-query 'tests:test-set-toplog) + (db:save-string dbstruct logf) + test-name)) + +(define (tests:summarize-items dbstruct 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 (db:test-get-logfile-info dbstruct 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 ... @@ -411,16 +411,16 @@ (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)) (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 (db:test-get-records-for-index-file dbstruct run-id test-name))) (with-output-to-port oup (lambda () (set! outtxt (conc outtxt "Summary: " test-name "

Summary for " test-name "

")) @@ -472,11 +472,11 @@ (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! dbstruct run-id test-name outputfilename) ))))))) ;;====================================================================== ;; Gather data from test/task specifications ;;====================================================================== @@ -545,22 +545,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 (db:get-test-id dbstruct run-id test-name item-path)) + (tdat (db:get-test-info-by-id dbstruct run-id 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 +572,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 (db:get-test-id dbstruct run-id waiton "")) + (wtdat (db:get-test-info-by-id dbstruct run-id 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,58 +679,56 @@ ;; 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 (db:get-test-info-by-id run-id test-id))) ;; run-id test-name item-path))) (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) +(define (tests:update-central-meta-info dbstruct run-id 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) + (db:tests-update-cpuload-diskfree dbstruct run-id test-id cpuload diskfree) (if minutes - (cdb:tests-update-run-duration *runremote* test-id minutes)) + (db:tests-update-run-duration dbstruct run-id test-id minutes)) (if (and uname hostname) - (cdb:tests-update-uname-host *runremote* test-id uname hostname))) + (db:tests-update-uname-host dbstruct run-id test-id uname hostname))) -(define (tests:set-full-meta-info db test-id run-id minutes work-area) - ;; DOES cdb:remote-run under the hood! +;; OPTIMIZE THESE!!! They are redundant!! + +(define (tests:set-full-meta-info dbstruct test-id run-id minutes work-area) (let* ((num-records 0) ;; (test:tdb-get-rundat-count tdb)) (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))) + ;; (tests:update-testdat-meta-info dbstruct run-id 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 db test-id run-id minutes work-area) - ;; DOES cdb:remote-run under the hood! +(define (tests:set-partial-meta-info dbstruct 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))) +(define (tests:update-testdat-meta-info dbstruct run-id test-id work-area cpuload diskfree minutes) + (sqlite3:execute (db:get-db dbstruct run-id "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" + cpuload diskfree minutes))) ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -1,5 +1,6 @@ +# # run some tests BINPATH=$(shell readlink -m $(PWD)/../bin) MEGATEST=$(BINPATH)/megatest PATH := $(BINPATH):$(PATH) @@ -99,11 +100,11 @@ 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) @@ -117,10 +118,14 @@ test9d : @echo Run an itemized test with no items 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 \ (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done 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 +