Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -47,11 +47,12 @@ get-steps-data login testmeta-get-record)) ;; These are called by the server on recipt of /api calls - +;; - keep it simple, only return the actual result of the call, i.e. no meta info here +;; (define (api:execute-requests dbstruct cmd params) (case (string->symbol cmd) ;; SERVERS ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) @@ -90,11 +91,11 @@ ((set-run-status) (apply db:set-run-status dbstruct params)) ((register-run) (apply db:register-run dbstruct params)) ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) ((get-test-id) (apply db:get-test-id dbstruct params)) - ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) + ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) ((delete-run) (apply db:delete-run dbstruct params)) ((get-runs) (apply db:get-runs dbstruct params)) ((get-all-run-ids) (db:get-all-run-ids dbstruct)) ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -1,6 +1,6 @@ -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2014, 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 @@ -13,5 +13,6 @@ (import (prefix sqlite3 sqlite3:)) (declare (unit archive)) (declare (uses db)) (declare (uses common)) + Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -55,73 +55,73 @@ ;; ;; lookup_server, need to remove *runremote* stuff ;; (define (client:setup run-id #!key (remaining-tries 100) (failed-connects 0)) (debug:print-info 2 "client:setup remaining-tries=" remaining-tries) - (if (<= remaining-tries 0) - (begin - (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) - (exit 1)) - (let ((host-info (hash-table-ref/default *runremote* run-id #f))) - (if host-info - (let* ((iface (http-transport:server-dat-get-iface host-info)) - (port (http-transport:server-dat-get-port host-info)) - (start-res (http-transport:client-connect iface port)) - (ping-res (rmt:login-no-auto-client-setup start-res run-id))) - (if ping-res ;; sucessful login? - (begin - (debug:print-info 2 "client:setup, ping is good using host-info=" host-info ", remaining-tries=" remaining-tries) - ;; Why add the close-connections here? - ;; (http-transport:close-connections run-id) - (hash-table-set! *runremote* run-id start-res) - start-res) ;; return the server info - ;; have host info but no ping. shutdown the current connection and try again - (begin ;; login failed - (debug:print-info 1 "client:setup, ping is bad for start-res=" start-res " and *runremote*=" host-info) - (http-transport:close-connections run-id) - (hash-table-delete! *runremote* run-id) - (if (< remaining-tries 8) - (thread-sleep! 5) - (thread-sleep! 1)) - (client:setup run-id remaining-tries: (- remaining-tries 1))))) - ;; YUK: rename server-dat here - (let* ((server-dat (tasks:get-server (tasks:get-db) run-id))) - (debug:print-info 4 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) - (if server-dat - (let* ((iface (tasks:hostinfo-get-interface server-dat)) - (port (tasks:hostinfo-get-port server-dat)) - (start-res (http-transport:client-connect iface port)) - (ping-res (rmt:login-no-auto-client-setup start-res run-id))) - (if (and start-res - ping-res) - (begin - (hash-table-set! *runremote* run-id start-res) - (debug:print-info 2 "connected to " (http-transport:server-dat-make-url start-res)) - start-res) - (begin ;; login failed but have a server record, clean out the record and try again - (debug:print-info 0 "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) - (http-transport:close-connections run-id) - (hash-table-delete! *runremote* run-id) - (tasks:server-force-clean-run-record (tasks:get-db) - run-id - (tasks:hostinfo-get-interface server-dat) - (tasks:hostinfo-get-port server-dat) - " client:setup (server-dat = #t)") - (thread-sleep! 2) - (server:try-running run-id) - (thread-sleep! 10) ;; give server a little time to start up - (client:setup run-id remaining-tries: (- remaining-tries 1))))) - (begin ;; no server registered - (let ((num-available (tasks:num-in-available-state (tasks:get-db) run-id))) - (debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) - (thread-sleep! 2) - (if (< num-available 2) - (begin - ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") - (server:try-running run-id))) - (thread-sleep! 10) ;; give server a little time to start up - (client:setup run-id remaining-tries: (- remaining-tries 1)))))))))) + (let* ((tdbdat (tasks:open-db))) + (if (<= remaining-tries 0) + (begin + (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) + (exit 1)) + (let ((host-info (hash-table-ref/default *runremote* run-id #f))) + (if host-info + (let* ((iface (http-transport:server-dat-get-iface host-info)) + (port (http-transport:server-dat-get-port host-info)) + (start-res (http-transport:client-connect iface port)) + (ping-res (rmt:login-no-auto-client-setup start-res run-id))) + (if ping-res ;; sucessful login? + (begin + (debug:print-info 2 "client:setup, ping is good using host-info=" host-info ", remaining-tries=" remaining-tries) + ;; Why add the close-connections here? + ;; (http-transport:close-connections run-id) + (hash-table-set! *runremote* run-id start-res) + start-res) ;; return the server info + ;; have host info but no ping. shutdown the current connection and try again + (begin ;; login failed + (debug:print-info 1 "client:setup, ping is bad for start-res=" start-res " and *runremote*=" host-info) + (http-transport:close-connections run-id) + (hash-table-delete! *runremote* run-id) + (if (< remaining-tries 8) + (thread-sleep! 5) + (thread-sleep! 1)) + (client:setup run-id remaining-tries: (- remaining-tries 1))))) + ;; YUK: rename server-dat here + (let* ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id))) + (debug:print-info 4 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) + (if server-dat + (let* ((iface (tasks:hostinfo-get-interface server-dat)) + (port (tasks:hostinfo-get-port server-dat)) + (start-res (http-transport:client-connect iface port)) + (ping-res (rmt:login-no-auto-client-setup start-res run-id))) + (if (and start-res + ping-res) + (begin + (hash-table-set! *runremote* run-id start-res) + (debug:print-info 2 "connected to " (http-transport:server-dat-make-url start-res)) + start-res) + (begin ;; login failed but have a server record, clean out the record and try again + (debug:print-info 0 "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) + (http-transport:close-connections run-id) + (hash-table-delete! *runremote* run-id) + (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) + run-id + (tasks:hostinfo-get-interface server-dat) + (tasks:hostinfo-get-port server-dat) + " client:setup (server-dat = #t)") + (thread-sleep! 2) + (server:try-running run-id) + (thread-sleep! 10) ;; give server a little time to start up + (client:setup run-id remaining-tries: (- remaining-tries 1))))) + (begin ;; no server registered + (let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id))) + (debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) + (thread-sleep! 2) + (if (< num-available 2) + (begin + (server:try-running run-id))) + (thread-sleep! 10) ;; give server a little time to start up + (client:setup run-id remaining-tries: (- remaining-tries 1))))))))))) ;; keep this as a function to ease future (define (client:start run-id server-info) (http-transport:client-connect (tasks:hostinfo-get-interface server-info) (tasks:hostinfo-get-port server-info))) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -160,11 +160,11 @@ exn (handle-exceptions exn (begin (debug:print 0 "ERROR: received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain) + (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) ;;====================================================================== @@ -188,15 +188,16 @@ (3 "CHECK") (4 "n/a") (5 "WAIVED") (6 "SKIP") (7 "DELETED") - (8 "STUCK/DEAD"))) + (8 "STUCK/DEAD") + (9 "ABORT"))) ;; These are stopping conditions that prevent a test from being run (define *common:cant-run-states-sym* - '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) + '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE ABORT)) ;;====================================================================== ;; D E B U G G I N G S T U F F ;;====================================================================== @@ -210,12 +211,46 @@ (define (assoc/default key lst . default) (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) (define (common:get-testsuite-name) - (or (configf:lookup *configdat* "server" "testsuite" ) + (or (configf:lookup *configdat* "setup" "testsuite" ) (pathname-file *toppath*))) + +;;====================================================================== +;; E X I T H A N D L I N G +;;====================================================================== + +(define (std-exit-procedure) + (debug:print-info 2 "starting exit process, finalizing databases.") + (rmt:print-db-stats) + (let ((run-ids (hash-table-keys *db-local-sync*))) + (if (and (not (null? run-ids)) + (configf:lookup *configdat* "setup" "megatest-db")) + (db:multi-db-sync run-ids 'new2old))) + (if *dbstruct-db* (db:close-all *dbstruct-db*)) + (if (and *megatest-db* + (sqlite3:database? *megatest-db*)) + (begin + (sqlite3:interrupt! *megatest-db*) + (sqlite3:finalize! *megatest-db* #t) + (set! *megatest-db* #f))) + (if *task-db* (let ((db (cdr *task-db*))) + (if (sqlite3:database? db) + (begin + (sqlite3:interrupt! db) + (sqlite3:finalize! db #t) + (vector-set! *task-db* 0 #f)))))) + +(define (std-signal-handler signum) + (signal-mask! signum) + (debug:print 0 "ERROR: Received signal " signum " exiting promptly") + ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway + (exit)) + +(set-signal-handler! signal/int std-signal-handler) +(set-signal-handler! signal/term std-signal-handler) ;;====================================================================== ;; Misc utils ;;====================================================================== @@ -604,6 +639,7 @@ ((equal? status "FAIL") "red") ((equal? status "WARN") "orange") ((equal? status "KILLED") "orange") ((equal? status "KILLREQ") "purple") ((equal? status "RUNNING") "blue") + ((equal? status "ABORT") "brown") (else "black"))) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -9,10 +9,29 @@ ;; PURPOSE. ;;====================================================================== ;; (use trace) +;; Some of these routines use: +;; +;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html +;; +;; Syntax for defining macros in a simple style similar to function definiton, +;; when there is a single pattern for the argument list and there are no keywords. +;; +;; (define-simple-syntax (name arg ...) body ...) +;; + +(define-syntax define-simple-syntax + (syntax-rules () + ((_ (name arg ...) body ...) + (define-syntax name (syntax-rules () ((name arg ...) (begin body ...))))))) + +(define-syntax common:handle-exceptions + (syntax-rules () + ((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...)))) + (define (debug:calc-verbosity vstr) (cond ((number? vstr) vstr) ((not (string? vstr)) 1) ;; ((string-match "^\\s*$" vstr) 1) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -36,10 +36,12 @@ (include "run_records.scm") ;;====================================================================== ;; C O M M O N ;;====================================================================== + +(define *dashboard-comment-share-slot* #f) (define (dtests:get-pre-command #!key (default-override #f)) (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) (or cfg-ovrd default-override "xterm -geometry 180x20 -e \""))) @@ -291,11 +293,11 @@ (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) (let ((t (iup:attribute x "TITLE"))) (if (equal? t "WAIVED") - (iup:show (dashboard-tests:waiver testdat + (iup:show (dashboard-tests:waiver run-id testdat (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) (lambda (c) (set! newcomment c) (if wtxtbox (begin @@ -351,11 +353,11 @@ ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) -(define (dashboard-tests:waiver testdat ovrdval cmtcmd) +(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) (wregx (if (string? wpatt)(regexp wpatt) #f)) (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) (comnt (iup:textbox #:action (lambda (val a b) (if wpatt @@ -393,98 +395,10 @@ #:expand "HORIZONTAL" #:action (lambda (obj) (iup:destroy! dlog))))))) dlog)) -;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!! -;; -;; 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 - (tdb:step-get-stepname step) - ;; stepname start end status Duration Logfile - (vector (tdb:step-get-stepname step) "" "" "" "" "")))) - (debug:print 6 "record(before) = " record - "\nid: " (tdb:step-get-id step) - "\nstepname: " (tdb:step-get-stepname step) - "\nstate: " (tdb:step-get-state step) - "\nstatus: " (tdb:step-get-status step) - "\ntime: " (tdb:step-get-event_time step)) - (case (string->symbol (tdb:step-get-state step)) - ((start)(vector-set! record 1 (tdb:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") - (tdb:step-get-status step))) - (if (> (string-length (tdb:step-get-logfile step)) - 0) - (vector-set! record 5 (tdb:step-get-logfile step)))) - ((end) - (vector-set! record 2 (any->number (tdb:step-get-event_time step))) - (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) - (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) - ", startt=" startt ", endt=" endt - ", get-status: " (tdb:step-get-status step)) - (if (and (number? startt)(number? endt)) - (seconds->hr-min-sec (- endt startt)) "-1"))) - (if (> (string-length (tdb:step-get-logfile step)) - 0) - (vector-set! record 5 (tdb:step-get-logfile step)))) - (else - (vector-set! record 2 (tdb:step-get-state step)) - (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (tdb:step-get-event_time step)))) - (hash-table-set! res (tdb:step-get-stepname step) record) - (debug:print 6 "record(after) = " record - "\nid: " (tdb:step-get-id step) - "\nstepname: " (tdb:step-get-stepname step) - "\nstate: " (tdb:step-get-state step) - "\nstatus: " (tdb:step-get-status step) - "\ntime: " (tdb:step-get-event_time step)))) - ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) - (sort steps (lambda (a b) - (cond - ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) - ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) - (< (tdb:step-get-id a) (tdb:step-get-id b))) - (else #f))))) - res)) - -(define (dashboard-tests:get-compressed-steps dbstruct run-id test-id) - (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id)) - (comprsteps (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) - (map (lambda (x) - ;; take advantage of the \n on time->string - (vector - (vector-ref x 0) - (let ((s (vector-ref x 1))) - (if (number? s)(seconds->time-string s) s)) - (let ((s (vector-ref x 2))) - (if (number? s)(seconds->time-string s) s)) - (vector-ref x 3) ;; status - (vector-ref x 4) - (vector-ref x 5))) ;; time delta - (sort (hash-table-values comprsteps) - (lambda (a b) - (let ((time-a (vector-ref a 1)) - (time-b (vector-ref b 1))) - (if (and (number? time-a)(number? time-b)) - (if (< time-a time-b) - #t - (if (eq? time-a time-b) - (string 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)) - (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)) - (colnum 0) - (deleted #f)) - ;; (debug:print-info 0 "cleaning " rownum ":" colnum) - (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum)) - (next-col (if (eq? colnum 6) 1 (+ colnum 1))) - (mtrx-rc (conc rownum ":" colnum)) - (curr-val (iup:attribute steps-matrix mtrx-rc))) - ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val) - (if (and (string? curr-val) - (not (equal? curr-val ""))) - (begin - (iup:attribute-set! steps-matrix mtrx-rc "") - (loop next-row next-col #t)) - (if (eq? colnum 6) ;; not done, didn't get a full blank row - (if deleted (loop next-row next-col #f)) ;; exit on this not met - (loop next-row next-col deleted))))) - (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))))) + (dcommon:populate-steps teststeps steps-matrix)))) (hash-table-set! widgets "StepsMatrix" proc) (proc testdat)) steps-matrix) ;; populate the Test Data panel (iup:frame Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1045,11 +1045,11 @@ #:click-cb (lambda (obj lin col status) (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) - (cmd (conc toolpath " -test " test-id "&"))) + (cmd (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&"))) (system cmd))))) (updater (lambda () (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:data-get-curr-run-id *data*)) @@ -1235,11 +1235,13 @@ (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide")) (mark-for-update))))) (set! *hide-not-hide-button* hideit) hideit)) (iup:hbox - (iup:button "Quit" #:action (lambda (obj)(if *dbstruct-local* (db:close-all *dbstruct-local*))(exit))) + (iup:button "Quit" #:action (lambda (obj) + ;; (if *dbstruct-local* (db:close-all *dbstruct-local*)) + (exit))) (iup:button "Refresh" #:action (lambda (obj) (mark-for-update))) (iup:button "Collapse" #:action (lambda (obj) (let ((myname (iup:attribute obj "TITLE"))) (if (equal? myname "Collapse") @@ -1451,12 +1453,11 @@ (define *monitor-db-path* (conc *dbdir* "/monitor.db")) (define *last-monitor-update-time* 0) ;; Force creation of the db in case it isn't already there. -(let ((db (tasks:open-db))) - (sqlite3:finalize! db)) +(tasks:open-db) (define (dashboard:get-youngest-run-db-mod-time) (handle-exceptions exn (begin @@ -1518,12 +1519,11 @@ ((args:get-arg "-run") (let ((runid (string->number (args:get-arg "-run")))) (if runid (begin (lambda (x) - (on-exit (lambda () - (if *dbstruct-local* (db:close-all *dbstruct-local*)))) + (on-exit std-exit-procedure) (examine-run *dbstruct-local* runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) ((args:get-arg "-test") ;; run-id,test-id Index: datashare.scm ================================================================== --- datashare.scm +++ datashare.scm @@ -255,11 +255,11 @@ (else (print "EXCEPTION: database overloaded or unreadable.") (print " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (print " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (print-call-chain) + (print-call-chain (current-error-port)) (thread-sleep! sleep-time) (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) (apply open-run-close-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -32,10 +32,28 @@ (define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's (define *number-of-writes* 0) (define *number-non-write-queries* 0) +;;====================================================================== +;; SQLITE3 HELPERS +;;====================================================================== + +;; convert to -inline +(define (db:first-result-default db stmt default . params) + (handle-exceptions + exn + (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) + ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) + (if (eq? err-status 'done) + default + (begin + (debug:print 0 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) + default))) + (apply sqlite3:first-result db stmt params))) + ;; Get/open a database ;; if run-id => get run specific db ;; if #f => get main db ;; if db already open - return inmem ;; if db not open, open inmem, rundb and sync then return inmem @@ -44,18 +62,28 @@ (define (db:get-db dbstruct run-id) (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through dbstruct (begin (mutex-lock! *rundb-mutex*) - (let ((db (if (or (not run-id) - (eq? run-id 0)) - (db:open-main dbstruct) - (db:open-rundb dbstruct run-id) - ))) + (let ((dbdat (if (or (not run-id) + (eq? run-id 0)) + (db:open-main dbstruct) + (db:open-rundb dbstruct run-id) + ))) ;; db prunning would go here (mutex-unlock! *rundb-mutex*) - db)))) + dbdat)))) + +(define (db:dbdat-get-db dbdat) + (if (pair? dbdat) + (car dbdat) + dbdat)) + +(define (db:dbdat-get-path dbdat) + (if (pair? dbdat) + (cdr dbdat) + #f)) ;; mod-read: ;; 'mod modified data ;; 'read read data ;; @@ -71,22 +99,23 @@ ;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;") ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; (define (db:with-db dbstruct run-id r/w proc . params) - (let* ((db (db:get-db dbstruct run-id)) - ) - ;; (proc2 (lambda () - (let ((res (apply proc db params))) - (db:done-with dbstruct run-id r/w) - res))) -;; (handle-exceptions -;; exn -;; (begin -;; (thread-sleep! 10) -;; (proc2)) -;; (proc2)))) + (let* ((dbdat (if (vector? dbstruct) + (db:get-db dbstruct run-id) + dbstruct)) ;; cheat, allow for passing in a dbdat + (db (db:dbdat-get-db dbdat))) + (db:delay-if-busy dbdat) + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port))) + (let ((res (apply proc db params))) + (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) + res)))) ;;====================================================================== ;; K E E P F I L E D B I N dbstruct ;;====================================================================== @@ -99,11 +128,11 @@ ;; fdb)))) ;; ;; ;; Can also be used to save arbitrary strings ;; ;; ;; (define (db:save-path dbstruct path) -;; (let ((fdb (db:get-filedb dbstruct))) +;; (let ((fdb (db:get-filedb dbstruct)))b ;; (filedb:register-path fdb path))) ;; ;; ;; Use to get a path. To get an arbitrary string see next define ;; ;; ;; (define (db:get-path dbstruct id) @@ -123,57 +152,71 @@ (debug:print 0 "ERROR: Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) (conc dbdir fname))) +(define (db:set-sync db) + (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) + (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) + ;; open an sql database inside a file lock ;; ;; returns: db existed-prior-to-opening ;; (define (db:lock-create-open fname initproc) (if (file-exists? fname) (let ((db (sqlite3:open-database fname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - (sqlite3:execute db "PRAGMA synchronous = 0;") + (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") db) (let* ((parent-dir (pathname-directory fname)) (dir-writable (file-write-access? parent-dir))) (if dir-writable - (let ((lock (obtain-dot-lock fname 1 5 10)) - (exists (file-exists? fname)) + (let ((exists (file-exists? fname)) + (lock (obtain-dot-lock fname 1 5 10)) (db (sqlite3:open-database fname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - (sqlite3:execute db "PRAGMA synchronous = 0;") + (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") (if (not exists)(initproc db)) (release-dot-lock fname) db) (begin (debug:print 0 "ERROR: no such db in non-writable dir " fname) (sqlite3:open-database fname)))))) ;; This routine creates the db. It is only called if the db is not already opened ;; -(define (db:open-rundb dbstruct run-id) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) +(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((local (dbr:dbstruct-get-local dbstruct)) (rdb (if local (dbr:dbstruct-get-localdb dbstruct run-id) (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) - (if rdb + (if (or rdb + do-not-open) rdb (let* ((dbpath (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) (dbexists (file-exists? dbpath)) (inmem (if local #f (db:open-inmem-db))) (refdb (if local #f (db:open-inmem-db))) - (db (db:lock-create-open dbpath + (db (db:lock-create-open dbpath ;; this is the database physically on disk (lambda (db) - (db:initialize-run-id-db db) - (sqlite3:execute - db - "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" - (* run-id 30000) ;; allow for up to 30k tests per run - run-id) - ))) ;; add strings db to rundb, not in use yet + (handle-exceptions + exn + (begin + (release-dot-lock dbpath) + (if (> attemptnum 2) + (debug:print 0 "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) + (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) + (db:initialize-run-id-db db) + (sqlite3:execute + db + "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" + (* run-id 30000) ;; allow for up to 30k tests per run + run-id) + ;; do a dummy query to test that the table exists and the db is truly readable + (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) + )))) ;; add strings db to rundb, not in use yet ;; )) ;; (sqlite3:open-database dbpath)) (olddb (if *megatest-db* *megatest-db* (let ((db (db:open-megatest-db))) (set! *megatest-db* db) @@ -181,23 +224,28 @@ (write-access (file-write-access? dbpath)) ;; (handler (make-busy-timeout 136000)) ) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) ;; only unset so other db's also can use this control - (dbr:dbstruct-set-rundb! dbstruct db) + (dbr:dbstruct-set-rundb! dbstruct (cons db dbpath)) (dbr:dbstruct-set-inuse! dbstruct #t) (dbr:dbstruct-set-olddb! dbstruct olddb) ;; (dbr:dbstruct-set-run-id! dbstruct run-id) (if local (begin (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ... db) (begin (dbr:dbstruct-set-inmem! dbstruct inmem) + (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context (db:sync-tables db:sync-tests-only db inmem) + (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) (dbr:dbstruct-set-refdb! dbstruct refdb) (db:sync-tables db:sync-tests-only db refdb) + ;; sync once more to deal with delays + (db:sync-tables db:sync-tests-only db inmem) + (db:sync-tables db:sync-tests-only db refdb) inmem)))))) ;; This routine creates the db. It is only called if the db is not already ls opened ;; (define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) @@ -206,16 +254,17 @@ mdb (let* ((dbpath (db:dbfile-path 0)) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath db:initialize-main-db)) (olddb (db:open-megatest-db)) - (write-access (file-write-access? dbpath))) + (write-access (file-write-access? dbpath)) + (dbdat (cons db dbpath))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) - (dbr:dbstruct-set-main! dbstruct db) - (dbr:dbstruct-set-olddb! dbstruct olddb) - db)))) + (dbr:dbstruct-set-main! dbstruct dbdat) + (dbr:dbstruct-set-olddb! dbstruct olddb) ;; olddb is already a (cons db path) + dbdat)))) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; (define (db:setup run-id #!key (local #f)) (let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) @@ -232,11 +281,11 @@ (db:initialize-main-db db) (db:initialize-run-id-db db)))) (write-access (file-write-access? dbpath))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) - db)) + (cons db dbpath))) ;; sync run to disk if touched ;; (define (db:sync-touched dbstruct run-id #!key (force-sync #f)) (let ((mtime (dbr:dbstruct-get-mtime dbstruct)) @@ -247,21 +296,25 @@ (refdb (dbr:dbstruct-get-refdb dbstruct)) (olddb (dbr:dbstruct-get-olddb dbstruct)) ;; (runid (dbr:dbstruct-get-run-id dbstruct)) ) (debug:print-info 4 "Syncing for run-id: " run-id) + (mutex-lock! *http-mutex*) (if (eq? run-id 0) ;; runid equal to 0 is main.db (if maindb (if (or (not (number? mtime)) (not (number? stime)) (> mtime stime) force-sync) - (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) - (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) - num-synced) - 0) + (begin + (db:delay-if-busy maindb) + (db:delay-if-busy olddb) + (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) + (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) + num-synced) + 0)) (begin ;; this can occur when using local access (i.e. not in a server) ;; need a flag to turn it off. ;; (debug:print 3 "WARNING: call to sync main.db to megatest.db but main not initialized") @@ -269,54 +322,86 @@ ;; any other runid is a run (if (or (not (number? mtime)) (not (number? stime)) (> mtime stime) force-sync) - (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) - (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) - num-synced) - 0)))) + (begin + (db:delay-if-busy rundb) + (db:delay-if-busy olddb) + (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) + (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) + (mutex-unlock! *http-mutex*) + num-synced) + (begin + (mutex-unlock! *http-mutex*) + 0)))))) + +(define (db:close-main dbstruct) + (let ((maindb (dbr:dbstruct-get-main dbstruct))) + (if maindb + (begin + (sqlite3:finalize! (db:dbdat-get-db maindb)) + (dbr:dbstruct-set-main! dbstruct #f))))) + +(define (db:close-run-db dbstruct run-id) + (let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t))) + (if (and rdb + (sqlite3:database? rdb)) + (begin + (sqlite3:finalize! rdb) + (dbr:dbstruct-set-localdb! dbstruct run-id #f) + (dbr:dbstruct-set-inmem! dbstruct #f))))) ;; close all opened run-id dbs (define (db:close-all dbstruct) ;; finalize main.db (db:sync-touched dbstruct 0 force-sync: #t) ;;(common:db-block-further-queries) ;; (mutex-lock! *db-sync-mutex*) ;; with this perhaps it isn't necessary to use the block-further-queries mechanism? - (sqlite3:finalize! (db:get-db dbstruct #f)) - (let* ((local (dbr:dbstruct-get-local dbstruct)) - (rundb (dbr:dbstruct-get-rundb dbstruct))) - (if local - (for-each - (lambda (db) - (if (sqlite3:database? db) - (begin - (sqlite3:interrupt! db) - (sqlite3:finalize! db #t)))) - (hash-table-values (dbr:dbstruct-get-locdbs dbstruct)))) - (thread-sleep! 3) - (if (and rundb - (sqlite3:database? rundb)) - (handle-exceptions - exn - (begin - (debug:print 0 "WARNING: database files may not have been closed correctly. Consider running -cleanup-db") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 " db: " rundb) - (print-call-chain) - #f) - (sqlite3:interrupt! rundb) - (sqlite3:finalize! rundb #t)))) - ;; (mutex-unlock! *db-sync-mutex*) + + (db:close-main dbstruct) + + (let ((locdbs (dbr:dbstruct-get-locdbs dbstruct))) + (if (hash-table? locdbs) + (for-each (lambda (run-id) + (db:close-run-db dbstruct run-id)) + (hash-table-keys locdbs)))) + + ;; (let* ((local (dbr:dbstruct-get-local dbstruct)) + ;; (rundb (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct)))) + ;; (if local + ;; (for-each + ;; (lambda (dbdat) + ;; (let ((db (db:dbdat-get-db dbdat))) + ;; (if (sqlite3:database? db) + ;; (begin + ;; (sqlite3:interrupt! db) + ;; (sqlite3:finalize! db #t))))) + ;; ;; TODO: Come back to this and rework to delete from hashtable when finalized + ;; (hash-table-values (dbr:dbstruct-get-locdbs dbstruct)))) + ;; (thread-sleep! 3) + ;; (if (and rundb + ;; (sqlite3:database? rundb)) + ;; (handle-exceptions + ;; exn + ;; (begin + ;; (debug:print 0 "WARNING: database files may not have been closed correctly. Consider running -cleanup-db") + ;; (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + ;; (debug:print 0 " db: " rundb) + ;; (print-call-chain (current-error-port)) + ;; #f) + ;; (sqlite3:interrupt! rundb) + ;; (sqlite3:finalize! rundb #t)))) + ;; ;; (mutex-unlock! *db-sync-mutex*) ) (define (db:open-inmem-db) (let* ((db (sqlite3:open-database ":memory:")) (handler (make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) (db:initialize-run-id-db db) - db)) + (cons db #f))) ;; just tests, test_steps and test_data tables (define db:sync-tests-only (list ;; (list "strs" @@ -392,103 +477,134 @@ '("avg_disk" #f) '("tags" #f) '("jobgroup" #f))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) +;; db's are dbdat's +;; (define (db:sync-tables tbls fromdb todb . slave-dbs) (mutex-lock! *db-sync-mutex*) - (cond - ((not fromdb) (debug:print 3 "WARNING: db:sync-tables called with fromdb missing") -1) - ((not todb) (debug:print 3 "WARNING: db:sync-tables called with todb missing") -2) - ((not (sqlite3:database? fromdb)) - (debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) - ((not (sqlite3:database? todb)) - (debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4) - (else - (let ((stmts (make-hash-table)) ;; table-field => stmt - (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) - (numrecs (make-hash-table)) - (start-time (current-milliseconds)) - (tot-count 0)) - (for-each ;; table - (lambda (tabledat) - (let* ((tablename (car tabledat)) - (fields (cdr tabledat)) - (num-fields (length fields)) - (field->num (make-hash-table)) - (num->field (apply vector (map car fields))) - (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") - " FROM " tablename ";")) - (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " - " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) - (fromdat '()) - (todat (make-hash-table)) - (count 0)) - - ;; set up the field->num table - (for-each - (lambda (field) - (hash-table-set! field->num field count) - (set! count (+ count 1))) - fields) - - ;; read the source table - (sqlite3:for-each-row - (lambda (a . b) - (set! fromdat (cons (apply vector a b) fromdat))) - fromdb - full-sel) - - (debug:print-info 2 "found " (length fromdat) " records to sync") - - ;; read the target table - (sqlite3:for-each-row - (lambda (a . b) - (hash-table-set! todat a (apply vector a b))) - todb - full-sel) - - ;; first pass implementation, just insert all changed rows - (for-each - (lambda (targdb) - (let ((stmth (sqlite3:prepare targdb full-ins))) - (sqlite3:with-transaction - targdb - (lambda () - (for-each ;; - (lambda (fromrow) - (let* ((a (vector-ref fromrow 0)) - (curr (hash-table-ref/default todat a #f)) - (same #t)) - (let loop ((i 0)) - (if (or (not curr) - (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) - (set! same #f)) - (if (and same - (< i (- num-fields 1))) - (loop (+ i 1)))) - (if (not same) - (begin - (apply sqlite3:execute stmth (vector->list fromrow)) - (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) - fromdat))) - (sqlite3:finalize! stmth))) - (append (list todb) slave-dbs)))) - tbls) - (let* ((runtime (- (current-milliseconds) start-time)) - (should-print (common:low-noise-print 30 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate. - (if should-print (debug:print 0 "INFO: db sync, total run time " runtime " ms")) - (for-each - (lambda (dat) - (let ((tblname (car dat)) - (count (cdr dat))) - (set! tot-count (+ tot-count count)) - (if (> count 0) - (if should-print (debug:print 0 (format #f " ~10a ~5a" tblname count)))))) - (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) - tot-count))) - (mutex-unlock! *db-sync-mutex*)) + (handle-exceptions + exn + (begin + (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") + (print-call-chain (current-error-port)) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (debug:print 0 " src db: " (db:dbdat-get-path fromdb)) + (for-each (lambda (dbdat) + (debug:print 0 " dbpath: " (db:dbdat-get-path dbdat))) + (cons todb slave-dbs)) + (if *server-run* ;; we are inside a server + (set! *time-to-exit* #t) ;; let watch dog know that it is time to die. + (exit 1))) + (cond + ((not fromdb) (debug:print 3 "WARNING: db:sync-tables called with fromdb missing") -1) + ((not todb) (debug:print 3 "WARNING: db:sync-tables called with todb missing") -2) + ((not (sqlite3:database? (db:dbdat-get-db fromdb))) + (debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) + ((not (sqlite3:database? (db:dbdat-get-db todb))) + (debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4) + (else + (let ((stmts (make-hash-table)) ;; table-field => stmt + (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) + (numrecs (make-hash-table)) + (start-time (current-milliseconds)) + (tot-count 0)) + (for-each ;; table + (lambda (tabledat) + (let* ((tablename (car tabledat)) + (fields (cdr tabledat)) + (num-fields (length fields)) + (field->num (make-hash-table)) + (num->field (apply vector (map car fields))) + (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") + " FROM " tablename ";")) + (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " + " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) + (fromdat '()) + (fromdats '()) + (totrecords 0) + (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10"))) + (todat (make-hash-table)) + (count 0)) + + ;; set up the field->num table + (for-each + (lambda (field) + (hash-table-set! field->num field count) + (set! count (+ count 1))) + fields) + + ;; read the source table + (sqlite3:for-each-row + (lambda (a . b) + (set! fromdat (cons (apply vector a b) fromdat)) + (if (> (length fromdat) batch-len) + (begin + (set! fromdats (cons fromdat fromdats)) + (set! fromdat '()) + (set! totrecords (+ totrecords 1))))) + (db:dbdat-get-db fromdb) + full-sel) + + (debug:print-info 2 "found " totrecords " records to sync") + + ;; read the target table + (sqlite3:for-each-row + (lambda (a . b) + (hash-table-set! todat a (apply vector a b))) + (db:dbdat-get-db todb) + full-sel) + + ;; first pass implementation, just insert all changed rows + (for-each + (lambda (targdb) + (let* ((db (db:dbdat-get-db targdb)) + (stmth (sqlite3:prepare db full-ins))) + ;; (db:delay-if-busy targdb) ;; NO WAITING + (for-each + (lambda (fromdat-lst) + (sqlite3:with-transaction + db + (lambda () + (for-each ;; + (lambda (fromrow) + (let* ((a (vector-ref fromrow 0)) + (curr (hash-table-ref/default todat a #f)) + (same #t)) + (let loop ((i 0)) + (if (or (not curr) + (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) + (set! same #f)) + (if (and same + (< i (- num-fields 1))) + (loop (+ i 1)))) + (if (not same) + (begin + (apply sqlite3:execute stmth (vector->list fromrow)) + (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) + fromdat-lst)) + )) + fromdats) + (sqlite3:finalize! stmth))) + (append (list todb) slave-dbs)))) + tbls) + (let* ((runtime (- (current-milliseconds) start-time)) + (should-print (common:low-noise-print 30 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate. + (if should-print (debug:print 0 "INFO: db sync, total run time " runtime " ms")) + (for-each + (lambda (dat) + (let ((tblname (car dat)) + (count (cdr dat))) + (set! tot-count (+ tot-count count)) + (if (> count 0) + (if should-print (debug:print 0 (format #f " ~10a ~5a" tblname count)))))) + (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) + tot-count))) + (mutex-unlock! *db-sync-mutex*))) ;; options: ;; ;; 'killservers - kills all servers ;; 'dejunk - removes junk records @@ -503,65 +619,76 @@ (let* ((toppath (launch:setup-for-run)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f)) (mtdb (if toppath (db:open-megatest-db))) (run-ids (if run-ids run-ids - (if toppath (db:get-all-run-ids mtdb)))) - (mdb (tasks:open-db)) - (servers (tasks:get-all-servers mdb))) + (if toppath (begin + (db:delay-if-busy mtdb) + (db:get-all-run-ids mtdb))))) + (tdbdat (tasks:open-db)) + (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) ;; kill servers (if (member 'killservers options) (for-each (lambda (server) - (tasks:server-delete-record mdb (vector-ref server 0) "dbmigration") + (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration") (tasks:kill-server (vector-ref server 2)(vector-ref server 1))) servers)) ;; clear out junk records ;; (if (member 'dejunk options) - (db:clean-up mtdb)) + (begin + (db:delay-if-busy mtdb) + (db:clean-up mtdb))) ;; adjust test-ids to fit into proper range ;; (if (member 'adj-testids options) - (db:prep-megatest.db-for-migration mtdb)) + (begin + (db:delay-if-busy mtdb) + (db:prep-megatest.db-for-migration mtdb))) ;; sync runs, test_meta etc. ;; (if (member 'old2new options) (begin (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) (for-each (lambda (run-id) + (db:delay-if-busy mtdb) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) (debug:print 0 "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") (db:replace-test-records dbstruct run-id testrecs) - (sqlite3:finalize! (dbr:dbstruct-get-rundb dbstruct)))) + (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct))))) run-ids))) ;; now ensure all newdb data are synced to megatest.db (if (member 'new2old options) (for-each (lambda (run-id) - (let ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) + (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) + (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) + ;; (db:delay-if-busy frundb) + ;; (db:delay-if-busy mtdb) (if (eq? run-id 0) - (db:sync-tables (db:sync-main-list dbstruct)(db:get-db fromdb run-id) mtdb) + (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb) (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb)))) - run-ids)) - - (db:close-all dbstruct) - (sqlite3:finalize! mdb))) + (cons 0 run-ids))) + ;; (db:close-all dbstruct) + ;; (sqlite3:finalize! mdb) + )) ;; 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) (if (or *db-write-access* (not (member proc *db:all-write-procs*))) (let* ((db (cond + ((pair? idb) (db:dbdat-get-db idb)) ((sqlite3:database? idb) idb) ((not idb) (debug:print 0 "ERROR: cannot open-run-close with #f anymore")) ((procedure? idb) (idb)) (else (debug:print 0 "ERROR: cannot open-run-close with #f anymore")))) (res #f)) @@ -582,11 +709,11 @@ (else (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (print-call-chain) + (print-call-chain (current-error-port)) (thread-sleep! sleep-time) (debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) (apply open-run-close-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) @@ -594,16 +721,17 @@ (define open-run-close open-run-close-exception-handling) ;; open-run-close-no-exception-handling ;; open-run-close-exception-handling) ;;) -(define (db:initialize-main-db db) +(define (db:initialize-main-db dbdat) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) - (fieldstr (keys->key/field keys))) + (fieldstr (keys->key/field keys)) + (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")) @@ -614,11 +742,11 @@ (sqlite3:with-transaction db (lambda () (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")) + (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) keys) (sqlite3:execute db (conc "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " fieldstr (if havekeys "," "") " runname TEXT DEFAULT 'norun', @@ -742,11 +870,12 @@ 136000)))) ;; 136000))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (begin (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") - (sqlite3:execute db (conc "PRAGMA synchronous = 0;")))) + (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;")) + )) db)) (define (db:log-local-event . loglst) (let ((logline (apply conc loglst))) (db:log-event logline))) @@ -773,11 +902,12 @@ ;; (select testname,item_path,event_time+run_duration as ;; end_time,strftime('%s','now') as now from tests where state in ;; ('RUNNING','REMOTEHOSTSTART','LAUNCED')); (define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime) - (let* ((db (db:get-db dbstruct run-id)) + (let* ((dbdat (db:get-db dbstruct run-id)) + (db (db:dbdat-get-db dbdat)) (incompleted '()) (oldlaunched '()) (toplevels '()) (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) (deadtime (if (and deadtime-str @@ -790,11 +920,11 @@ ;; ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) - ;; (db:delay-if-busy) + (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -806,11 +936,11 @@ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; - ;; (db:delay-if-busy) + (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -822,11 +952,11 @@ (debug:print-info 18 "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. ;; - ;; (db:delay-if-busy) + (db:delay-if-busy dbdat) (let* (;; (min-incompleted (filter (lambda (x) ;; (let* ((testpath (cadr x)) ;; (tdatpath (conc testpath "/testdat.db")) ;; (dbexists (file-exists? tdatpath))) ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete @@ -843,10 +973,11 @@ (string-intersperse (map conc all-ids) ",") ");"))))) ;; Now do rollups for the toplevel tests ;; + (db:delay-if-busy dbdat) (for-each (lambda (toptest) (let ((test-name (list-ref toptest 3))) ;; (run-id (list-ref toptest 5))) (db:general-call db 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) ;; (list run-id test-name)))) @@ -861,13 +992,13 @@ ;; 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) +(define (db:clean-up dbdat) (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") - (let* (;; (db (db:get-db dbstruct #f)) + (let* ((db (db:dbdat-get-db dbdat)) (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 @@ -880,10 +1011,11 @@ ;; 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);" )))) + (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 "Records count before clean: " tot)) @@ -893,10 +1025,11 @@ (debug:print-info 0 "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) + (db:delay-if-busy dbdat) (sqlite3:execute db "VACUUM;"))) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S ;;====================================================================== @@ -908,15 +1041,18 @@ ;; (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)) + (res #f) + (dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat))) + (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (val) (set! res val)) - (db:get-db dbstruct #f) + db "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)))) @@ -929,16 +1065,20 @@ (debug:print-info 4 "launch throttle factor=" *global-delta*) (set! *last-global-delta-printed* *global-delta*))) res)) (define (db:set-var dbstruct var val) - ;; (db:delay-if-busy) - (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)) + (let ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat))) + (db:delay-if-busy dbdat) + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) (define (db:del-var dbstruct var) ;; (db:delay-if-busy) - (sqlite3:execute (db:get-db dbstruct #f) "DELETE FROM metadat WHERE var=?;" var)) + (db:with-db dbstruct #f #t + (lambda (db) + (sqlite3:execute db "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 @@ -951,11 +1091,11 @@ (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (key) (set! res (cons key res))) - (db:get-db dbstruct #f) + db "SELECT fieldname FROM keys ORDER BY id DESC;"))) (set! *db-keys* res) res))) ;; look up values in a header/data structure @@ -976,28 +1116,38 @@ ;;====================================================================== ;; R U N S ;;====================================================================== (define (db:get-run-name-from-id dbstruct run-id) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (runname) - (set! res runname)) - (db:get-db dbstruct #f) - "SELECT runname FROM runs WHERE id=?;" - run-id) - res)) + (db:with-db + dbstruct + #f ;; this is for the main runs db + #f ;; does not modify db + (lambda (db) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (runname) + (set! res runname)) + db + "SELECT runname FROM runs WHERE id=?;" + run-id) + res)))) (define (db:get-run-key-val dbstruct run-id key) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (val) - (set! res val)) - (db:get-db dbstruct #f) - (conc "SELECT " key " FROM runs WHERE id=?;") - run-id) - res)) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (val) + (set! res val)) + db + (conc "SELECT " key " FROM runs WHERE id=?;") + run-id) + res)))) ;; keys list to key1,key2,key3 ... (define (runs:get-std-run-fields keys remfields) (let* ((header (append keys remfields)) (keystr (conc (keys->keystr keys) "," @@ -1020,11 +1170,12 @@ ;; register a test run with the db, this accesses the main.db and does NOT ;; use server api ;; (define (db:register-run dbstruct keyvals runname state status user) - (let* ((db (db:get-db dbstruct #f)) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat)) (keys (map car keyvals)) (keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... @@ -1033,22 +1184,23 @@ (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (let ((res #f)) - ;; (db:delay-if-busy) + (db:delay-if-busy dbdat) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) + (db:delay-if-busy dbdat) (apply sqlite3:for-each-row (lambda (id) (set! res id)) db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) ;(debug:print 4 "qry: " qry) qry) qryvals) - ;; (db:delay-if-busy) + (db:delay-if-busy dbdat) (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) res) (begin (debug:print 0 "ERROR: Called without all necessary keys") #f)))) @@ -1148,78 +1300,101 @@ (keys (db:get-keys dbstruct)) (header keys) ;; (map key:get-fieldname keys)) (keystr (keys->keystr keys)) (qrystr (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';")) (seen (make-hash-table))) - (sqlite3:for-each-row - (lambda (a . x) - (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:get-db dbstruct #f) - qrystr) - (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) - (vector header res))) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (a . x) + (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 + qrystr) + (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) + (vector header res))))) ;; just get count of runs (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: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)) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (let ((numruns 0)) + (debug:print-info 11 "db:get-num-runs START " runpatt) + (sqlite3:for-each-row + (lambda (count) + (set! numruns count)) + db + "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) + (debug:print-info 11 "db:get-num-runs END " runpatt) + numruns)))) (define (db:get-all-run-ids dbstruct) - (let ((run-ids '())) - (sqlite3:for-each-row - (lambda (run-id) - (set! run-ids (cons run-id run-ids))) - (db:get-db dbstruct #f) - "SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") - (reverse run-ids))) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (let ((run-ids '())) + (sqlite3:for-each-row + (lambda (run-id) + (set! run-ids (cons run-id run-ids))) + db + "SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") + (reverse run-ids))))) ;; get some basic run stats ;; ;; ( (runname (( state count ) ... )) ;; ( ... (define (db:get-run-stats dbstruct) - (let ((totals (make-hash-table)) - (curr (make-hash-table)) - (res '()) - (runs-info '())) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat)) + (totals (make-hash-table)) + (curr (make-hash-table)) + (res '()) + (runs-info '())) ;; First get all the runname/run-ids + (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (run-id runname) (set! runs-info (cons (list run-id runname) runs-info))) - (db:get-db dbstruct #f) + db "SELECT id,runname FROM runs WHERE state != 'deleted';") ;; for each run get stats data (for-each (lambda (run-info) ;; get the net state/status counts for this run - (let ((run-id (car run-info)) - (run-name (cadr run-info))) - (sqlite3:for-each-row - (lambda (state status count) - (let ((netstate (if (equal? state "COMPLETED") status state))) - (if (string? netstate) - (begin - (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) - (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count)))))) - (db:get-db dbstruct run-id) - "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;") - ;; add the per run counts to res - (for-each (lambda (state) - (set! res (cons (list run-name state (hash-table-ref curr state)) res))) - (sort (hash-table-keys curr) string>=)) - (set! curr (make-hash-table)))) + (let* ((run-id (car run-info)) + (run-name (cadr run-info))) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (state status count) + (let ((netstate (if (equal? state "COMPLETED") status state))) + (if (string? netstate) + (begin + (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) + (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count)))))) + db + "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;") + ;; add the per run counts to res + (for-each (lambda (state) + (set! res (cons (list run-name state (hash-table-ref curr state)) res))) + (sort (hash-table-keys curr) string>=)) + (set! curr (make-hash-table)))))) runs-info) (for-each (lambda (state) (set! res (cons (list "Totals" state (hash-table-ref totals state)) res))) (sort (hash-table-keys totals) string>=)) res)) @@ -1259,114 +1434,145 @@ (db:with-db dbstruct #f #f ;; reads db, does not write to it. (lambda (db) (sqlite3:for-each-row (lambda (a . r) (set! res (cons (list->vector (cons a r)) res))) - (db:get-db dbstruct #f) + db qry-str runnamepatt))) (vector header res))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) (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 (vector #f #f #f #f)) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat)) + (res (vector #f #f #f #f)) (keys (db:get-keys dbstruct)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) + (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) - (db:get-db dbstruct #f) + db (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 dbstruct run-id comment) - ;; (db:delay-if-busy) - (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) - run-id)) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) + run-id)))) ;; does not (obviously!) removed dependent data. But why not!!? (define (db:delete-run dbstruct run-id) ;; First set any related tests to DELETED - (let ((db (db:get-db dbstruct run-id))) - ;; (db:delay-if-busy) - (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))) + (let* ((rdbdat (db:get-db dbstruct run-id)) + (rdb (db:dbdat-get-db rdbdat)) + (dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat))) + (db:delay-if-busy rdbdat) + (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='';") + (sqlite3:execute rdb "DELETE FROM test_steps;") + (sqlite3:execute rdb "DELETE FROM test_data;") + (db:delay-if-busy dbdat) + (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))) (define (db:update-run-event_time dbstruct run-id) - ;; (db:delay-if-busy) - (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)) + (db:with-db + dbstruct + #f + #t + (lambda (db) + (sqlite3:execute db "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:get-db dbstruct #f) "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) - ;; (db:delay-if-busy) - (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))) + (db:with-db + dbstruct + #f + #t + (lambda (db) + (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'),?);" + user (conc newlockval " " run-id)) + (debug:print-info 1 "" newlockval " run number " run-id))))) (define (db:set-run-status dbstruct run-id status msg) - (let ((db (db:get-db dbstruct #f))) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat))) + (db:delay-if-busy dbdat) (if msg (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) (define (db:get-run-status dbstruct run-id) (let ((res "n/a")) - (sqlite3:for-each-row - (lambda (status) - (set! res status)) - (db:get-db dbstruct #f) - "SELECT status FROM runs WHERE id=?;" - run-id) - res)) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (status) + (set! res status)) + db + "SELECT status FROM runs WHERE id=?;" + run-id) + res)))) ;;====================================================================== ;; K E Y S ;;====================================================================== ;; get key val pairs for a given run-id ;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) (define (db:get-key-val-pairs dbstruct run-id) (let* ((keys (db:get-keys dbstruct)) - (res '())) + (res '()) + (dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - ;; (debug:print 0 "qry: " qry) + (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (key-val) (set! res (cons (list key key-val) res))) - (db:get-db dbstruct #f) qry run-id))) + db qry run-id))) keys) (reverse res))) ;; get key vals for a given run-id (define (db:get-key-vals dbstruct run-id) (let* ((keys (db:get-keys dbstruct)) - (res '())) + (res '()) + (dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) + (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (key-val) (set! res (cons key-val res))) - (db:get-db dbstruct #f) qry run-id))) + db qry run-id))) keys) (let ((final-res (reverse res))) (hash-table-set! *keyvals* run-id final-res) final-res))) @@ -1403,11 +1609,11 @@ ;; not-in #t = above behaviour, #f = must match (define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) (if (not (number? run-id)) (begin ;; no need to treat this as an error by default (debug:print 4 "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) - ;; (print-call-chain) + ;; (print-call-chain (current-error-port)) '()) (let* ((qryvalstr (case qryvals ((shortlist) "id,run_id,testname,item_path,state,status") ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") (else qryvals))) @@ -1514,13 +1720,23 @@ test-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 dbstruct run-ids testpatt states statuses not-in) - (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) + (debug:print 0 "ERROR: BROKN!") + ;; (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) +) +;; get a useful subset of the tests data (used in dashboard +;; +(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in) + (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path")) + +;; do not use. +;; (define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f)) ;; (db:delay-if-busy) (let ((res '())) (for-each (lambda (run-id) @@ -1534,26 +1750,28 @@ ;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs ;; (define (db:delete-test-records dbstruct run-id test-id) - (let ((db (db:get-db dbstruct run-id))) - (db:general-call db 'delete-test-step-records (list test-id)) + (let* ((dbdat (db:get-db dbstruct run-id)) + (db (db:dbdat-get-db dbdat))) + (db:general-call dbdat 'delete-test-step-records (list test-id)) ;; (db:delay-if-busy) - (db:general-call db 'delete-test-data-records (list test-id)) + (db:general-call dbdat 'delete-test-data-records (list test-id)) (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) -(define (db:delete-tests-for-run dbdbstruct run-id) - (let ((db (db:get-db dbstruct run-id))) - (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id))) - (define (db:delete-old-deleted-test-records dbstruct) (let ((run-ids (db:get-all-run-ids dbstruct)) (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past (for-each (lambda (run-id) - (sqlite3:execute (db:get-db dbstruct run-id) "DELETE FROM tests WHERE state='DELETED' AND event_timenumber "id" db:test-record-fields)))) - (db:adj-test-id mtdb min-test-id test-id))) + (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id))) testrecs))) ;; 1. move test ids into the 30k * run_id range ;; 2. move step ids into the 30k * run_id range ;; @@ -1783,97 +2034,123 @@ (define (db:prep-megatest.db-for-migration mtdb) (let* ((run-ids (db:get-all-run-ids mtdb))) (for-each (lambda (run-id) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) - (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs))) + (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs))) run-ids))) ;; Get test data using test_id (define (db:get-test-info-by-id dbstruct run-id test-id) - (let ((db (db:get-db dbstruct run-id)) - (res #f)) - (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum) - ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 - (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum))) - (db:get-db dbstruct run-id) - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") - test-id) - res)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res #f)) + (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 + (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum))) + db + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") + test-id) + res)))) ;; Use db:test-get* to access ;; Get test data using test_ids. NB// Only works within a single run!! ;; (define (db:get-test-info-by-ids dbstruct run-id test-ids) - (let ((db (db:get-db dbstruct run-id)) - (res '())) - (sqlite3:for-each-row - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id) - ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id) - res))) - (db:get-db dbstruct run-id) - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" - (string-intersperse (map conc test-ids) ",") ");")) - res)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (a . b) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + (set! res (cons (apply vector a b) res))) + db + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" + (string-intersperse (map conc test-ids) ",") ");")) + res)))) (define (db:get-test-info dbstruct run-id testname item-path) - (let ((db (db:get-db dbstruct run-id)) - (res #f)) - (sqlite3:for-each-row - (lambda (a . b) - (set! res (apply vector a b))) - (db:get-db dbstruct run-id) - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") - test-name item-path) - res)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (apply vector a b))) + db + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") + test-name item-path) + res)))) (define (db:test-get-rundir-from-test-id dbstruct run-id test-id) - (db:first-result-default - (db:get-db dbstruct run-id) - "SELECT rundir FROM tests WHERE id=?;" - #f ;; default result - test-id)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (db:first-result-default + db + "SELECT rundir FROM tests WHERE id=?;" + #f ;; default result + test-id)))) ;;====================================================================== ;; S T E P S ;;====================================================================== (define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile) - (let ((db (db:get-db dbstruct run-id))) - (sqlite3:execute - db - "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" - test-id teststep-name state-in status-in (current-seconds) - ;; (sdb:qry 'getid - (if comment comment "") ;; ) - ;; (sdb:qry 'getid - (if logfile logfile "")))) ;; ) + (db:with-db + dbstruct + run-id + #t + (lambda (db) + (sqlite3:execute + db + "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" + test-id teststep-name state-in status-in (current-seconds) + (if comment comment "") + (if logfile logfile ""))))) ;; db-get-test-steps-for-run (define (db:get-steps-for-test dbstruct run-id test-id) - (let* ((db (db:get-db dbstruct run-id)) - (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))) - db - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (reverse res))) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (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))) + db + "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-id) + (reverse res))))) (define (db:get-steps-data dbstruct run-id test-id) - (let ((db (db:get-db dbstruct run-id)) - (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))) - db - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (reverse res))) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (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))) + db + "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-id) + (reverse res))))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== @@ -1881,33 +2158,36 @@ ;; 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 dbstruct run-id test-id status) - (let ((db (db:get-db dbstruct run-id)) - (fail-count 0) - (pass-count 0)) + (let* ((dbdat (db:get-db dbstruct run-id)) + (db (db:dbdat-get-db dbdat)) + (fail-count 0) + (pass-count 0)) + (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (fcount pcount) (set! fail-count fcount) (set! pass-count pcount)) db "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) ;; Now rollup the counts to the central megatest.db - (db:general-call db 'pass-fail-counts (list pass-count fail-count test-id)) + (db:general-call dbdat 'pass-fail-counts (list pass-count fail-count test-id)) ;; if the test is not FAIL then set status based on the fail and pass counts. - (db:general-call db 'test_data-pf-rollup (list test-id test-id test-id test-id)))) + (db:general-call dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id)))) (define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) - (let ((db (db:get-db dbstruct run-id)) - (csvlist (csv->list (make-csv-reader - (open-input-string csvdata) - '((strip-leading-whitespace? #t) - (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata))) + (let* ((dbdat (db:get-db dbstruct run-id)) + (db (db:dbdat-get-db dbdat)) + (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)) @@ -1951,28 +2231,31 @@ ((>=) (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) + (db:delay-if-busy dbdat) (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units (if comment comment "") status type))) csvlist))) ;;====================================================================== ;; Misc. test related queries ;;====================================================================== (define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt) - (let* ((row-ids '()) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat)) + (row-ids '()) (keystr (string-intersperse (map (lambda (key val) (conc key " like '" val "'")) keynames (string-split target "/")) " AND ")) ;; (testqry (tests:match->sqlqry testpatt)) - (runsqry (sqlite3:prepare (db:get-db dbstruct #f)(conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) + (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) ;; (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) @@ -1980,27 +2263,37 @@ row-ids)) (define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) (let* ((testqry (tests:match->sqlqry testpatt)) (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) - (sqlite3:for-each-row - (lambda (p) - (set! res (cons p res))) - (db:get-db dbstruct run-id) - tstsqry) - res)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (p) + (set! res (cons p res))) + db + tstsqry) + res)))) (define (db:test-toplevel-num-items dbstruct run-id testname) - (let ((res 0)) - (sqlite3:for-each-row - (lambda (num-items) - (set! res num-items)) - (db:get-db dbstruct run-id) - "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');" - run-id - testname) - res)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res 0)) + (sqlite3:for-each-row + (lambda (num-items) + (set! res num-items)) + db + "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');" + run-id + testname) + res)))) ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS ;;====================================================================== @@ -2028,60 +2321,65 @@ (z3:decode-buffer (base64:base64-decode (string-substitute (regexp "_") "=" msg #t))) (lambda ()(deserialize))) - (vector #f #f #f))) ;; crude reply for when things go awry + (begin + (debug:print 0 "ERROR: reception failed. Received " msg " but cannot translate it.") + #f))) ;; crude reply for when things go awry ((zmq)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) (define (db:test-set-status-state dbstruct run-id test-id status state msg) - (let ((db (db:get-db dbstruct run-id))) - (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) - (db:general-call db 'set-test-start-time (list test-id))) - (if msg - (db:general-call db 'state-status-msg (list state status msg test-id)) - (db:general-call db 'state-status (list state status test-id))))) + (let ((dbdat (db:get-db dbstruct run-id))) + (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) + (db:general-call dbdat 'set-test-start-time (list test-id))) + (if msg + (db:general-call dbdat 'state-status-msg (list state status msg test-id)) + (db:general-call dbdat 'state-status (list state status test-id))))) (define (db: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" "LAUNCHED"))) - (let ((db (db:get-db dbstruct run-id))) - (db:general-call db 'update-pass-fail-counts (list test-name test-name test-name)) + (let ((dbdat (db:get-db dbstruct run-id))) + (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name)) (if (equal? status "RUNNING") - (db:general-call db 'top-test-set-running (list test-name)) + (db:general-call dbdat 'top-test-set-running (list test-name)) (if (equal? status "LAUNCHED") - (db:general-call db 'top-test-set (list "LAUNCHED" test-name)) - (db:general-call db 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) + (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name)) + (db:general-call dbdat 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) #f) #f)) (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)) -;; (let ((sleep-time (random 20)) -;; (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) -;; (case err-status -;; ((busy)(thread-sleep! 4)) -;; (else -;; (debug:print 0 "WARNING: possible problem with call to cdb:remote-run, database may be read-only and locked, waiting and trying again ...") -;; (thread-sleep! sleep-time))) + (db:with-db + dbstruct + run-id + #t + (lambda (db) + (sqlite3:execute db 'register-test run-id test-name item-path)))) (define (db:test-get-logfile-info dbstruct run-id test-name) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (path final_logf) - ;; (let ((path (sdb:qry 'getstr path-id)) - ;; (final_logf (sdb:qry 'getstr 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,final_logf FROM tests WHERE testname=? AND item_path='';" - test-name) - res)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (path final_logf) + ;; (let ((path (sdb:qry 'getstr path-id)) + ;; (final_logf (sdb:qry 'getstr 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 + "SELECT rundir,final_logf 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 ;;====================================================================== @@ -2178,33 +2476,36 @@ (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version)) (else (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")))) -(define (db:general-call db stmtname params) +(define (db:general-call dbdat stmtname params) (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) - (apply sqlite3:execute db query params) - #t)) + (db:delay-if-busy dbdat) + (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) + #t)) ;; BUG or Sillyness, why do I return #t instead of the query result? ;; get the previous records for when these tests were run where all keys match but runname ;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests ;; can use wildcards. Also can likely be factored in with get test paths? ;; ;; Run this remotely!! ;; (define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path) - (let* ((db (db:get-db dbstruct #f)) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat)) (keys (db:get-keys db)) (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id + (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (a . b) (set! keyvals (cons a b))) db (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) @@ -2238,107 +2539,111 @@ (hash-table-set! tests-hash full-testname testdat)))) results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) -;; (let* ((remtries 10) -;; (proc #f)) -;; (set! proc (lambda (remtries) -;; (if (> remtries 0) -;; (handle-exceptions -;; exn -;; (let ((sleep-time (random 30)) -;; (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) -;; (case err-status -;; ((busy) -;; (thread-sleep! sleep-time) -;; (proc 10)) ;; we never give up on busy -;; (else -;; (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") -;; (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) -;; (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) -;; (print-call-chain) -;; (debug:print 0 "Sleeping for " sleep-time) -;; (thread-sleep! sleep-time) -;; (debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up") -;; (proc (- remtries 1))))) -;; (apply sqlite3:execute db query params)) -;; (debug:print 0 "ERROR: too many attempts to access db were made and no sucess. query: " -;; query ", params: " params)))) -;; (proc remtries)) -(define (db:delay-if-busy #!key (count 6)) - (let ((dbfj (conc *toppath* "/megatest.db-journal"))) - (if (file-exists? dbfj) - (case count - ((6) - (thread-sleep! 0.2) - (db:delay-if-busy count: 5)) - ((5) - (thread-sleep! 0.4) - (db:delay-if-busy count: 4)) - ((4) - (thread-sleep! 0.8) - (db:delay-if-busy count: 3)) - ((3) - (thread-sleep! 1.6) - (db:delay-if-busy count: 2)) - ((2) - (thread-sleep! 3.2) - (db:delay-if-busy count: 1)) - ((1) - (thread-sleep! 6.4) - (db:delay-if-busy count: 0)) - (else - (debug:print-info 0 "delaying db access due to high database load.") - (thread-sleep! 12.8)))))) -;; (db:delay-if-busy) -;; (apply sqlite3:execute db query params))) -;; (db:delay-if-busy) + +(define (db:delay-if-busy dbdat #!key (count 6)) + (if (not (configf:lookup *configdat* "server" "delay-on-busy")) + (and dbdat (db:dbdat-get-db dbdat)) + (if dbdat + (let* ((dbpath (db:dbdat-get-path dbdat)) + (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline + (dbfj (conc dbpath "-journal"))) + (if (handle-exceptions + exn + (begin + (debug:print-info 0 "WARNING: failed to test for existance of " dbfj) + (thread-sleep! 1) + (db:delay-if-busy count (- count 1))) + (file-exists? dbfj)) + (case count + ((6) + (thread-sleep! 0.2) + (db:delay-if-busy count: 5)) + ((5) + (thread-sleep! 0.4) + (db:delay-if-busy count: 4)) + ((4) + (thread-sleep! 0.8) + (db:delay-if-busy count: 3)) + ((3) + (thread-sleep! 1.6) + (db:delay-if-busy count: 2)) + ((2) + (thread-sleep! 3.2) + (db:delay-if-busy count: 1)) + ((1) + (thread-sleep! 6.4) + (db:delay-if-busy count: 0)) + (else + (debug:print-info 0 "delaying db access due to high database load.") + (thread-sleep! 12.8)))) + db) + "bogus result from db:delay-if-busy"))) (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:get-db dbstruct run-id) - "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';" - test-name) - res)) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (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 testname=? AND item_path != '';" + test-name) + res)))) ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; read the record given a 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 jobgroup) - (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) - (db:get-db dbstruct #f) - "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" - testname) - res)) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) + (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) + db + "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" + testname) + res)))) ;; create a new record for a given testname (define (db:testmeta-add-record dbstruct testname) - (db:delay-if-busy) - (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)) + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:execute + db + "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 dbstruct testname field value) - (db:delay-if-busy) - (sqlite3:execute (db:get-db dbstruct #f) (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:execute + db + (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)))) (define (db:testmeta-get-all dbstruct) - (let ((res '())) - (sqlite3:for-each-row - (lambda (a . b) - (set! res (cons (apply vector a b) res))) - (db:get-db dbstruct run-id) - "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") - res)) + (db:with-db dbstruct #f #f + (lambda (db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (cons (apply vector a b) res))) + db + "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") + res)))) ;;====================================================================== ;; M I S C M A N A G E M E N T I T E M S ;;====================================================================== @@ -2429,28 +2734,10 @@ (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) -;;====================================================================== -;; SQLITE3 HELPERS -;;====================================================================== - -;; convert to -inline -(define (db:first-result-default db stmt default . params) - (handle-exceptions - exn - (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) - ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) - (if (eq? err-status 'done) - default - (begin - (debug:print 0 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain) - default))) - (apply sqlite3:first-result db stmt params))) - ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== ;; NOT REWRITTEN YET!!!!! Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -13,23 +13,25 @@ ;; ;; ;; Accessors for a dbstruct ;; -(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) -(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 1)) -(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 2)) +(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) ;; ( db path ) +(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 1)) ;; ( db path ) +(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 2)) (define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 3)) -(define-inline (dbr:dbstruct-get-rundb vec) (vector-ref vec 4)) -(define-inline (dbr:dbstruct-get-inmem vec) (vector-ref vec 5)) +(define-inline (dbr:dbstruct-get-rundb vec) (vector-ref vec 4)) ;; ( db path ) +(define-inline (dbr:dbstruct-get-inmem vec) (vector-ref vec 5)) ;; ( db #f ) (define-inline (dbr:dbstruct-get-mtime vec) (vector-ref vec 6)) (define-inline (dbr:dbstruct-get-rtime vec) (vector-ref vec 7)) (define-inline (dbr:dbstruct-get-stime vec) (vector-ref vec 8)) (define-inline (dbr:dbstruct-get-inuse vec) (vector-ref vec 9)) -(define-inline (dbr:dbstruct-get-refdb vec) (vector-ref vec 10)) +(define-inline (dbr:dbstruct-get-refdb vec) (vector-ref vec 10)) ;; ( db path ) (define-inline (dbr:dbstruct-get-locdbs vec) (vector-ref vec 11)) -(define-inline (dbr:dbstruct-get-olddb vec) (vector-ref vec 12)) +(define-inline (dbr:dbstruct-get-olddb vec) (vector-ref vec 12)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-get-main-path vec) (vector-ref vec 13)) +;; (define-inline (dbr:dbstruct-get-rundb-path vec) (vector-ref vec 14)) ;; (define-inline (dbr:dbstruct-get-run-id vec) (vector-ref vec 13)) (define-inline (dbr:dbstruct-set-main! vec val)(vector-set! vec 0 val)) (define-inline (dbr:dbstruct-set-strdb! vec val)(vector-set! vec 1 val)) (define-inline (dbr:dbstruct-set-path! vec val)(vector-set! vec 2 val)) @@ -41,16 +43,19 @@ (define-inline (dbr:dbstruct-set-stime! vec val)(vector-set! vec 8 val)) (define-inline (dbr:dbstruct-set-inuse! vec val)(vector-set! vec 9 val)) (define-inline (dbr:dbstruct-set-refdb! vec val)(vector-set! vec 10 val)) (define-inline (dbr:dbstruct-set-locdbs! vec val)(vector-set! vec 11 val)) (define-inline (dbr:dbstruct-set-olddb! vec val)(vector-set! vec 12 val)) +(define-inline (dbr:dbstruct-set-main-path! vec val)(vector-set! vec 13 val)) +(define-inline (dbr:dbstruct-set-rundb-path! vec val)(vector-set! vec 14 val)) + ; (define-inline (dbr:dbstruct-set-run-id! vec val)(vector-set! vec 13 val)) ;; constructor for dbstruct ;; (define (make-dbr:dbstruct #!key (path #f)(local #f)) - (let ((v (make-vector 14 #f))) + (let ((v (make-vector 15 #f))) (dbr:dbstruct-set-path! v path) (dbr:dbstruct-set-local! v local) (dbr:dbstruct-set-locdbs! v (make-hash-table)) v)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -228,15 +228,20 @@ (fullname (conc testname "/" itempath)) (dispname (if (string=? itempath "") testname (conc " " itempath))) (rownum (hash-table-ref/default testname-to-row fullname #f)) (test-path (append run-path (if (equal? itempath "") (list testname) - (list testname itempath))))) + (list testname itempath)))) + (tb (dboard:data-get-tests-tree *data*))) (print "INFONOTE: run-path: " run-path) (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" test-path userdata: (conc "test-id: " test-id)) + (let ((node-num (tree:find-node tb (cons "Runs" test-path))) + (color (car (gutils:get-color-for-state-status state status)))) + (debug:print 0 "node-num: " node-num ", color: " color) + (iup:attribute-set! tb (conc "COLOR" node-num) color)) (hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id) (if (not rownum) (let ((rownums (hash-table-values testname-to-row))) (set! rownum (if (null? rownums) 1 @@ -441,20 +446,21 @@ (iup:vbox ;; (iup:label "Run statistics" #:expand "HORIZONTAL") stats-matrix))) (define (dcommon:servers-table) - (let* ((colnum 0) + (let* ((tdbdat (tasks:open-db)) + (colnum 0) (rownum 0) (servers-matrix (iup:matrix #:expand "YES" #:numcol 7 #:numcol-visible 7 #:numlin-visible 5 )) (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) (updater (lambda () - (let ((servers (tasks:get-all-servers (tasks:get-db)))) + (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) ;; (set! colnum 0) ;; (for-each (lambda (colname) ;; ;; (print "colnum: " colnum " colname: " colname) ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) @@ -632,5 +638,135 @@ (if (not (null? tal)) ;; leave a column of space to the right to list items (loop (car tal) (cdr tal)))))))) +;;====================================================================== +;; S T E P S +;;====================================================================== + +;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!! +;; +;; get a pretty table to summarize steps +;; +(define (dcommon: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 + (tdb:step-get-stepname step) + ;; stepname start end status Duration Logfile + (vector (tdb:step-get-stepname step) "" "" "" "" "")))) + (debug:print 6 "record(before) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)) + (case (string->symbol (tdb:step-get-state step)) + ((start)(vector-set! record 1 (tdb:step-get-event_time step)) + (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (tdb:step-get-status step))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + ((end) + (vector-set! record 2 (any->number (tdb:step-get-event_time step))) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) + (endt (any->number (vector-ref record 2)))) + (debug:print 4 "record[1]=" (vector-ref record 1) + ", startt=" startt ", endt=" endt + ", get-status: " (tdb:step-get-status step)) + (if (and (number? startt)(number? endt)) + (seconds->hr-min-sec (- endt startt)) "-1"))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + (else + (vector-set! record 2 (tdb:step-get-state step)) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (tdb:step-get-event_time step)))) + (hash-table-set! res (tdb:step-get-stepname step) record) + (debug:print 6 "record(after) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)))) + ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) + (sort steps (lambda (a b) + (cond + ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) + ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) + (< (tdb:step-get-id a) (tdb:step-get-id b))) + (else #f))))) + res)) + +(define (dcommon:get-compressed-steps dbstruct run-id test-id) + (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id)) + (comprsteps (dcommon: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 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)) + (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)) + (colnum 0) + (deleted #f)) + ;; (debug:print-info 0 "cleaning " rownum ":" colnum) + (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum)) + (next-col (if (eq? colnum 6) 1 (+ colnum 1))) + (mtrx-rc (conc rownum ":" colnum)) + (curr-val (iup:attribute steps-matrix mtrx-rc))) + ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val) + (if (and (string? curr-val) + (not (equal? curr-val ""))) + (begin + (iup:attribute-set! steps-matrix mtrx-rc "") + (loop next-row next-col #t)) + (if (eq? colnum 6) ;; not done, didn't get a full blank row + (if deleted (loop next-row next-col #f)) ;; exit on this not met + (loop next-row next-col deleted))))) + (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -134,11 +134,12 @@ (http-transport:try-start-server run-id ipaddrstr start-port server-id))) ;; This is recursively run by http-transport:run until sucessful ;; (define (http-transport:try-start-server run-id ipaddrstr portnum server-id) - (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))) + (let ((config-hostname (configf:lookup *configdat* "server" "hostname")) + (tdbdat (tasks:open-db))) (debug:print-info 0 "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname) (handle-exceptions exn (begin (print-error-message exn) @@ -155,16 +156,16 @@ (http-transport:try-start-server run-id ipaddrstr (portlogger:open-run-close portlogger:find-port) server-id)) (begin - (tasks:server-force-clean-run-record (tasks:get-db) run-id ipaddrstr portnum " http-transport:try-start-server") + (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server") (print "ERROR: Tried and tried but could not start the server")))) ;; any error in following steps will result in a retry (set! *server-info* (list ipaddrstr portnum)) (tasks:server-set-interface-port - (tasks:get-db) + (db:delay-if-busy tdbdat) server-id ipaddrstr portnum) (debug:print 0 "INFO: Trying to start server on " ipaddrstr ":" portnum) ;; This starts the spiffy server ;; NEED WAY TO SET IP TO #f TO BIND ALL @@ -173,11 +174,11 @@ (start-server port: portnum bind-address: (if (equal? config-hostname "-") ipaddrstr config-hostname)) (start-server port: portnum)) ;; (portlogger:open-run-close portlogger:set-port portnum "released") - (tasks:server-force-clean-run-record (tasks:get-db) run-id ipaddrstr portnum " http-transport:try-start-server") + (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server") (debug:print 1 "INFO: server has been stopped")))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== @@ -241,11 +242,12 @@ (let* ((fullurl (if (vector? serverdat) (http-transport:server-dat-get-api-req serverdat) (begin (debug:print 0 "FATAL ERROR: http-transport:client-api-send-receive called with no server info") (exit 1)))) - (res #f)) + (res #f) + (success #t)) (handle-exceptions exn (if (> numretries 0) (begin (mutex-unlock! *http-mutex*) @@ -272,22 +274,27 @@ ;; process and return it. (let* ((send-recieve (lambda () (mutex-lock! *http-mutex*) ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines) ;; ((exn http client-error) e (print e))) - (set! res (handle-exceptions - exn - (begin - (debug:print 0 "ERROR: failure in with-input-from-request. Giving up.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - #f) - (with-input-from-request ;; was dat - fullurl - (list (cons 'key "thekey") - (cons 'cmd cmd) - (cons 'params params)) - read-string))) + (set! res (vector + success + (handle-exceptions + exn + (begin + (set! success #f) + (debug:print 0 "WARNING: failure in with-input-from-request to " fullurl ". Killing associated server to allow clean retry.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (hash-table-delete! *runremote* run-id) + ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine. + #f) + (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*) )) (time-out (lambda () @@ -348,16 +355,17 @@ ;; (define (http-transport:keep-running server-id run-id) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive - (let* ((server-info (let loop ((start-time (current-seconds)) + (let* ((tdbdat (tasks:open-db)) + (server-info (let loop ((start-time (current-seconds)) (changed #t) (last-sdat "not this")) (let ((sdat #f)) (thread-sleep! 0.01) - (debug:print-info 0 "Waiting for server alive signal") + (debug:print-info 0 "Waiting for server alive signature") (mutex-lock! *heartbeat-mutex*) (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) (if (and sdat (not changed) @@ -364,17 +372,21 @@ (> (- (current-seconds) start-time) 2)) sdat (begin (debug:print-info 0 "Still waiting, last-sdat=" last-sdat) (sleep 4) - (loop start-time - (equal? sdat last-sdat) - sdat)))))) + (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes + (begin + (debug:print 0 "ERROR: transport appears to have died, exiting server " server-id " for run " run-id) + (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature") + (exit)) + (loop start-time + (equal? sdat last-sdat) + sdat))))))) (iface (car server-info)) (port (cadr server-info)) (last-access 0) - (tdb (tasks:open-db)) (server-timeout (let ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (and (string? tmo) (string->number tmo)) (* 60 60 (string->number tmo)) ;; (* 3 24 60 60) ;; default to three days @@ -385,11 +397,11 @@ (server-state 'available)) ;; Use this opportunity to sync the inmemdb to db (let ((start-time (current-milliseconds)) (sync-time #f) (rem-time #f)) - + ;; inmemdb is a dbstruct (if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t)) (set! sync-time (- (current-milliseconds) start-time)) (set! rem-time (quotient (- 4000 sync-time) 1000)) (debug:print 2 "SYNC: time= " sync-time ", rem-time=" rem-time) @@ -396,14 +408,14 @@ ;; ;; set_running after our first pass through and start the db ;; (if (eq? server-state 'available) (begin - (tasks:server-set-state! tdb server-id "dbprep") + (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep") (thread-sleep! 5) ;; give some margin for queries to complete before switching from file based access to server based access (set! *inmemdb* (db:setup run-id)) - (tasks:server-set-state! tdb server-id "running"))) + (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running"))) (if (and (<= rem-time 4) (> rem-time 0)) (thread-sleep! rem-time) (thread-sleep! 4))) ;; fallback for if the math is changed ... @@ -451,95 +463,92 @@ ;; ;; (if (tasks:server-am-i-the-server? tdb run-id) ;; (tasks:server-set-state! tdb server-id "running")) ;; (loop 0 server-state)) - (begin - (debug:print-info 0 "Starting to shutdown the server.") - ;; need to delete only *my* server entry (future use) - (set! *time-to-exit* #t) - (if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t)) - ;; - ;; start_shutdown - ;; - (tasks:server-set-state! tdb server-id "shutting-down") - (portlogger:open-run-close portlogger:set-port port "released") - (thread-sleep! 5) - (debug:print-info 0 "Max cached queries was " *max-cache-size*) - (debug:print-info 0 "Number of cached writes " *number-of-writes*) - (debug:print-info 0 "Average cached write time " - (if (eq? *number-of-writes* 0) - "n/a (no writes)" - (/ *writes-total-delay* - *number-of-writes*)) - " ms") - (debug:print-info 0 "Number non-cached queries " *number-non-write-queries*) - (debug:print-info 0 "Average non-cached time " - (if (eq? *number-non-write-queries* 0) - "n/a (no queries)" - (/ *total-non-write-delay* - *number-non-write-queries*)) - " ms") - (debug:print-info 0 "Server shutdown complete. Exiting") - (tasks:server-delete-record tdb server-id " http-transport:keep-running") - (exit)))))) + (http-transport:server-shutdown server-id port))))) + +(define (http-transport:server-shutdown server-id port) + (let ((tdbdat (tasks:open-db))) + (debug:print-info 0 "Starting to shutdown the server.") + ;; need to delete only *my* server entry (future use) + (set! *time-to-exit* #t) + (if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t)) + ;; + ;; start_shutdown + ;; + (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") + (portlogger:open-run-close portlogger:set-port port "released") + (thread-sleep! 5) + (debug:print-info 0 "Max cached queries was " *max-cache-size*) + (debug:print-info 0 "Number of cached writes " *number-of-writes*) + (debug:print-info 0 "Average cached write time " + (if (eq? *number-of-writes* 0) + "n/a (no writes)" + (/ *writes-total-delay* + *number-of-writes*)) + " ms") + (debug:print-info 0 "Number non-cached queries " *number-non-write-queries*) + (debug:print-info 0 "Average non-cached time " + (if (eq? *number-non-write-queries* 0) + "n/a (no queries)" + (/ *total-non-write-delay* + *number-non-write-queries*)) + " ms") + (debug:print-info 0 "Server shutdown complete. Exiting") + (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete") + (exit))) ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (http-transport:launch run-id) - (set! *run-id* run-id) - (if (args:get-arg "-daemonize") - (begin - (daemon:ize) - (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it - (begin - (current-error-port *alt-log-file*) - (current-output-port *alt-log-file*))))) - (if (server:check-if-running run-id) - (begin - (debug:print 0 "INFO: Server for run-id " run-id " already running") - (exit 0))) - (let loop ((server-id (tasks:server-lock-slot (tasks:get-db) run-id)) - (remtries 4)) - (if (not server-id) - (if (> remtries 0) - (begin - (thread-sleep! 2) - (loop (tasks:server-lock-slot (tasks:get-db) run-id) - (- remtries 1))) - (begin - ;; since we didn't get the server lock we are going to clean up and bail out - (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") - (tasks:server-delete-records-for-this-pid (tasks:get-db) " http-transport:launch") - )) - (let* ((th2 (make-thread (lambda () - (debug:print-info 0 "Server run thread started") - (http-transport:run - (if (args:get-arg "-server") - (args:get-arg "-server") - "-") - run-id - server-id)) "Server run")) - (th3 (make-thread (lambda () - (debug:print-info 0 "Server monitor thread started") - (http-transport:keep-running server-id run-id)) - "Keep running"))) - ;; Database connection - - - ;; don't start the db here - - ;; (set! *inmemdb* (db:setup run-id)) - - - (thread-start! th2) - (thread-start! th3) - (set! *didsomething* #t) - (thread-join! th2) - (exit))))) + (let* ((tdbdat (tasks:open-db))) + (set! *run-id* run-id) + (if (args:get-arg "-daemonize") + (begin + (daemon:ize) + (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it + (begin + (current-error-port *alt-log-file*) + (current-output-port *alt-log-file*))))) + (if (server:check-if-running run-id) + (begin + (debug:print 0 "INFO: Server for run-id " run-id " already running") + (exit 0))) + (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) + (remtries 4)) + (if (not server-id) + (if (> remtries 0) + (begin + (thread-sleep! 2) + (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id) + (- remtries 1))) + (begin + ;; since we didn't get the server lock we are going to clean up and bail out + (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") + (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch") + )) + (let* ((th2 (make-thread (lambda () + (debug:print-info 0 "Server run thread started") + (http-transport:run + (if (args:get-arg "-server") + (args:get-arg "-server") + "-") + run-id + server-id)) "Server run")) + (th3 (make-thread (lambda () + (debug:print-info 0 "Server monitor thread started") + (http-transport:keep-running server-id run-id)) + "Keep running"))) + (thread-start! th2) + (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor. + (thread-start! th3) + (set! *didsomething* #t) + (thread-join! th2) + (exit)))))) (define (http-transport:server-signal-handler signum) (signal-mask! signum) (handle-exceptions exn Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -64,11 +64,11 @@ (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) ;; (runremote (assoc/default 'runremote cmdinfo)) (transport (assoc/default 'transport cmdinfo)) - (serverinf (assoc/default 'serverinf cmdinfo)) + ;; (serverinf (assoc/default 'serverinf cmdinfo)) (port (assoc/default 'port cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (target (assoc/default 'target cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) @@ -99,11 +99,13 @@ ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* ;; (let ((test-info (rmt:get-testinfo-state-status run-id test-id))) (if (not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") - (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed"))) + (begin + (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed") + (exit)))) (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) (set! keys (rmt:get-keys)) ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process ;; one of these is defunct/redundant ... @@ -112,10 +114,15 @@ (debug:print 0 "Failed to setup, exiting") ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) (exit 1))) (change-directory *toppath*) + + ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This + ;; seems non-ideal but could well break stuff + ;; BUG? BUG? BUG? + (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))) ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target) ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; Now have runconfigs data loaded, set environment vars (for-each (lambda (section) @@ -158,11 +165,13 @@ (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) - (list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree")))) + (list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree")) + (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) + (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;; (change-directory top-path) ;; Can setup as client for server mode now ;; (client:setup) @@ -493,19 +502,19 @@ (for-each (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) (freespc (cond ((not (directory? dirpath)) - (if (common:low-noise-print 20 "disks" disk-num) + (if (common:low-noise-print 50 "disks not a dir " disk-num) (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a directory - ignoring it.")) -1) ((not (file-write-access? dirpath)) - (if (common:low-noise-print 20 "disks" disk-num) + (if (common:low-noise-print 50 "disks not writeable " disk-num) (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not writeable - ignoring it.")) -1) ((not (eq? (string-ref dirpath 0) #\/)) - (if (common:low-noise-print 20 "disks" disk-num) + (if (common:low-noise-print 50 "disks not a proper path " disk-num) (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a fully qualified path - ignoring it.")) -1) (else (get-df dirpath))))) (if (> freespc bestsize) @@ -658,11 +667,11 @@ ;; If there is already a symlink delete it and recreate it. (handle-exceptions exn (begin - (debug:print 0 "ERROR: Failed to re-create link " linktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit)) (if (symbolic-link? lnktarget) (delete-file lnktarget)) (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget))))) (if (not (directory? test-path)) @@ -780,11 +789,11 @@ (z3:encode-buffer (with-output-to-string (lambda () ;; (list 'hosts hosts) (write (list (list 'testpath test-path) (list 'transport (conc *transport-type*)) - (list 'serverinf *server-info*) + ;; (list 'serverinf *server-info*) (list 'toppath *toppath*) (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) (list 'run-id run-id ) Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ lock-queue.scm @@ -5,41 +5,47 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. -;;====================================================================== -;; launch a task - this runs on the originating host, tests themselves -;; -;;====================================================================== - (use sqlite3 srfi-18) (import (prefix sqlite3 sqlite3:)) (declare (unit lock-queue)) (declare (uses common)) +(declare (uses tasks)) ;;====================================================================== ;; attempt to prevent overlapping updates of rollup files by queueing ;; update requests in an sqlite db ;;====================================================================== +;;====================================================================== +;; db record, +;;====================================================================== + +(define (make-lock-queue:db-dat)(make-vector 3)) +(define-inline (lock-queue:db-dat-get-db vec) (vector-ref vec 0)) +(define-inline (lock-queue:db-dat-get-path vec) (vector-ref vec 1)) +(define-inline (lock-queue:db-dat-set-db! vec val)(vector-set! vec 0 val)) +(define-inline (lock-queue:db-dat-set-path! vec val)(vector-set! vec 1 val)) + (define (lock-queue:open-db fname #!key (count 10)) (let* ((actualfname (conc fname ".lockdb")) (dbexists (file-exists? actualfname)) (db (sqlite3:open-database actualfname)) (handler (make-busy-timeout 136000))) (if dbexists - db + (vector db actualfname) (begin (handle-exceptions exn (begin (thread-sleep! 10) (if (> count 0) (lock-queue:open-db fname count: (- count 1)) - db)) + (vector db actualfname))) (sqlite3:with-transaction db (lambda () (sqlite3:execute db @@ -55,63 +61,67 @@ id INTEGER PRIMARY KEY, test_id INTEGER, run_lock TEXT, CONSTRAINT runlock_constraint UNIQUE (run_lock));")))))) (sqlite3:set-busy-handler! db handler) - db)) + (vector db actualfname))) -(define (lock-queue:set-state db test-id newstate #!key (remtries 10)) +(define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10)) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) (handle-exceptions exn (if (> remtries 0) (begin (debug:print 0 "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 30) - (lock-queue:set-state db test-id newstate remtries: (- remtries 1))) + (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1))) (begin (debug:print 0 "ERROR: Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") #f)) - (sqlite3:execute db "UPDATE queue SET state=? WHERE test_id=?;" + (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;" newstate test-id))) -(define (lock-queue:any-younger? db mystart test-id #!key (remtries 10)) +(define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10)) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) (handle-exceptions exn (if (> remtries 0) (begin (debug:print 0 "WARNING: exception on lock-queue:any-younger. Trying again in 30 seconds.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 30) - (lock-queue:any-younger? db mystart test-id remtries: (- remtries 1))) + (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1))) (begin (debug:print 0 "ERROR: Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") #f)) (let ((res #f)) (sqlite3:for-each-row (lambda (tid) ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as (if (not (equal? tid test-id)) (set! res tid))) - db + (lock-queue:db-dat-get-db dbdat) "SELECT test_id FROM queue WHERE start_time > ?;" mystart) res))) -(define (lock-queue:get-lock db test-id #!key (count 10)) - (let ((res #f) - (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';")) - (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');"))) +(define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f)) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal") + (let* ((res #f) + (db (lock-queue:db-dat-get-db dbdat)) + (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';")) + (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');"))) (let ((result (handle-exceptions exn (begin (debug:print 0 "WARNING: failed to get queue lock. Will try again in a few seconds") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 10) (if (> count 0) - (lock-queue:get-lock db test-id count: (- count 1))) + (lock-queue:get-lock dbdat test-id count: (- count 1))) #f) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tid lockstate) @@ -128,72 +138,92 @@ (sqlite3:finalize! lckqry) (sqlite3:finalize! mklckqry) result))) (define (lock-queue:release-lock fname test-id #!key (count 10)) - (let ((db (lock-queue:open-db fname))) + (let* ((dbdat (lock-queue:open-db fname))) (handle-exceptions exn (begin (debug:print 0 "WARNING: Failed to release queue lock. Will try again in few seconds") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (thread-sleep! 10) + (thread-sleep! (/ count 10)) (if (> count 0) - (lock-queue:release-lock fname test-id count: (- count 1)) - #f)) - (sqlite3:execute db "DELETE FROM runlocks WHERE test_id=?;" test-id) - (sqlite3:finalize! db)))) + (begin + (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)) + (lock-queue:release-lock fname test-id count: (- count 1))) + (let ((journal (conc fname "-journal"))) + ;; If we've tried ten times and failed there is a serious problem + ;; try to remove the lock db and allow it to be recreated + (handle-exceptions + exn + #f + (if (file-exists? journal)(delete-file journal)) + (if (file-exists? fname) (delete-file fname)) + #f)))) + (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id) + (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))))) -(define (lock-queue:steal-lock db test-id #!key (count 10)) +(define (lock-queue:steal-lock dbdat test-id #!key (count 10)) + (debug:print-info 0 "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat)) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal") (handle-exceptions exn (begin (debug:print 0 "WARNING: Failed to steal queue lock. Will try again in few seconds") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 10) (if (> count 0) - (lock-queue:steal-lock db test-id count: (- count 1)) + (lock-queue:steal-lock dbdat test-id count: (- count 1)) #f)) - (sqlite3:execute db "DELETE FROM runlocks WHERE run_lock='locked';")) - (lock-queue:get-lock db test-it)) + (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';")) + (lock-queue:get-lock dbdat test-it)) ;; returns #f if ok to skip the task ;; returns #t if ok to proceed with task ;; otherwise waits ;; -(define (lock-queue:wait-turn fname test-id #!key (count 10)) - (let ((db (lock-queue:open-db fname)) - (mystart (current-seconds))) +(define (lock-queue:wait-turn fname test-id #!key (count 10)(waiting-msg #f)) + (let* ((dbdat (lock-queue:open-db fname)) + (mystart (current-seconds)) + (db (lock-queue:db-dat-get-db dbdat))) (handle-exceptions exn (begin (debug:print 0 "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) (thread-sleep! 10) (if (> count 0) - (lock-queue:wait-turn fname test-id count: (- count 1)) - #f)) + (begin + (sqlite3:finalize! db) + (lock-queue:wait-turn fname test-id count: (- count 1))) + (begin + (debug:print 0 "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain") + (print-call-chain (current-error-port)) + #f))) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") (sqlite3:execute db "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');" test-id mystart) (thread-sleep! 1) ;; give other tests a chance to register (let ((result - (let loop ((younger-waiting (lock-queue:any-younger? db mystart test-id))) + (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id))) (if younger-waiting (begin ;; no need for us to wait. mark in the lock queue db as skipping - (lock-queue:set-state db test-id "skipping") + (lock-queue:set-state dbdat test-id "skipping") #f) ;; let the calling process know that nothing needs to be done - (if (lock-queue:get-lock db test-id) + (if (lock-queue:get-lock dbdat test-id) #t (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock - (lock-queue:steal-lock db test-id) + (lock-queue:steal-lock dbdat test-id) (begin (thread-sleep! 1) - (loop (lock-queue:any-younger? db mystart test-id))))))))) + (loop (lock-queue:any-younger? dbdat mystart test-id))))))))) (sqlite3:finalize! db) result)))) ;; (use trace) ;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1,1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6005) +(define megatest-version 1.6006) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -286,61 +286,46 @@ ;; The watchdog is to keep an eye on things like db sync etc. ;; (define *watchdog* (make-thread (lambda () - (let loop () - (thread-sleep! 5) ;; five second resolution is only a minor burden and should be tolerable - - ;; sync for filesystem local db writes - ;; - (let ((start-time (current-seconds))) - (mutex-lock! *db-multi-sync-mutex*) - (for-each - (lambda (run-id) - (let ((last-write (hash-table-ref/default *db-local-sync* run-id 0))) - (if ;; (and - (> (- start-time last-write) 5) ;; every five seconds - ;; (common:db-access-allowed?)) - (begin - (db:multi-db-sync (list run-id) 'new2old) - (if (common:low-noise-print 30 "sync new to old") - (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " (- (current-seconds) start-time) " seconds")) - (hash-table-delete! *db-local-sync* run-id))))) - (hash-table-keys *db-local-sync*)) - (mutex-unlock! *db-multi-sync-mutex*)) - - ;; keep going unless time to exit - ;; - (if (not *time-to-exit*) - (loop)))) - "Watchdog thread")) + (thread-sleep! 0.05) ;; delay for startup + (let ((legacy-sync (configf:lookup *configdat* "setup" "megatest-db"))) + (let loop () + ;; sync for filesystem local db writes + ;; + (let ((start-time (current-seconds)) + (servers-started (make-hash-table))) + (for-each + (lambda (run-id) + (mutex-lock! *db-multi-sync-mutex*) + (if (and legacy-sync + (hash-table-ref/default *db-local-sync* run-id #f)) + ;; (if (> (- start-time last-write) 5) ;; every five seconds + (begin ;; let ((sync-time (- (current-seconds) start-time))) + (db:multi-db-sync (list run-id) 'new2old) + (if (common:low-noise-print 30 "sync new to old") + (let ((sync-time (- (current-seconds) start-time))) + (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) + ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run + ;; (begin + ;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id) + ;; (server:kind-run run-id))))) + (hash-table-delete! *db-local-sync* run-id))) + (mutex-unlock! *db-multi-sync-mutex*)) + (hash-table-keys *db-local-sync*))) + + ;; keep going unless time to exit + ;; + (if (not *time-to-exit*) + (begin + (thread-sleep! 1) ;; wait one second before syncing again + (loop))))) + "Watchdog thread"))) (thread-start! *watchdog*) -(define (std-exit-procedure) - (rmt:print-db-stats) - (let ((run-ids (hash-table-keys *db-local-sync*))) - (if (not (null? run-ids)) - (db:multi-db-sync run-ids 'new2old))) - (if *dbstruct-db* (db:close-all *dbstruct-db*)) - (if *megatest-db* (begin - (sqlite3:interrupt! *megatest-db*) - (sqlite3:finalize! *megatest-db* #t))) - (if *task-db* (let ((db (vector-ref *task-db* 0))) - (sqlite3:interrupt! db) - (sqlite3:finalize! db #t)))) - -(define (std-signal-handler signum) - (signal-mask! signum) - (debug:print 0 "ERROR: Received signal " signum " exiting promptly") - (std-exit-procedure) - (exit)) - -(set-signal-handler! signal/int std-signal-handler) -(set-signal-handler! signal/term std-signal-handler) - (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) (debug:print-info 0 "Sending log output to " (args:get-arg "-log")) (current-error-port oup) (current-output-port oup))) @@ -405,11 +390,11 @@ (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) -;; (on-exit std-exit-procedure) +(on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== @@ -540,11 +525,12 @@ (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) (let ((tl (launch:setup-for-run))) (if tl - (let* ((servers (open-run-close tasks:get-all-servers tasks:open-db)) + (let* ((tdbdat (tasks:open-db)) + (servers (tasks:get-all-servers (db:delay-if-busy tdbdat))) (fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n") (servers-to-kill '()) (killinfo (args:get-arg "-stop-server")) (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f)) (sid (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f))) @@ -569,13 +555,13 @@ ;; (zmq-sockets (if status (server:client-connect hostname port) #f))) ;; no need to login as status of #t indicates we are connecting to correct ;; server (if (equal? state "dead") (if (> last-update (* 25 60 60)) ;; keep records around for slighly over a day. - (open-run-close tasks:server-deregister tasks:open-db hostname pullport: pullport pid: pid action: 'delete)) + (tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid action: 'delete)) (if (> last-update 20) ;; Mark as dead if not updated in last 20 seconds - (open-run-close tasks:server-deregister tasks:open-db hostname pullport: pullport pid: pid))) + (tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid))) (format #t fmtstr id mt-ver pid hostname (conc interface ":" pullport) pubport last-update (if status "alive" "dead") transport) (if (or (equal? id sid) (equal? sid 0)) ;; kill all/any (begin @@ -810,11 +796,11 @@ (tdb:step-get-status step) (tdb:step-get-event_time step))) steps))))) tests))))) runs) - (db:close-all dbstruct) + ;; (db:close-all dbstruct) (set! *didsomething* #t)))) ;;====================================================================== ;; full run ;;====================================================================== @@ -1258,24 +1244,24 @@ (exit 1))) ;; keep this one local ;; (open-run-close db:clean-up #f) (db:multi-db-sync #f ;; do all run-ids - 'new2old + ;; 'new2old 'killservers 'dejunk - 'adj-testids - 'old2new + ;; 'adj-testids + ;; 'old2new 'new2old ) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin (if (not (launch:setup-for-run)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 "Failed to setup, exiting") b (exit 1))) (open-run-close db:find-and-mark-incomplete #f) (set! *didsomething* #t))) ;;====================================================================== @@ -1368,11 +1354,11 @@ #f ;; do all run-ids 'killservers 'dejunk 'adj-testids 'old2new - 'new2old + ;; 'new2old ) (set! *didsomething* #t))) (if (args:get-arg "-sync-to-megatest.db") (begin Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -168,11 +168,11 @@ ;; speed up for common cases with a little logic (define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (if (not (and run-id test-id)) (begin (debug:print 0 "ERROR: bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate) - (print-call-chain) + (print-call-chain (current-error-port)) #f) (begin (cond ((and newstate newstatus newcomment) (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id)) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use format) +(use format numbers) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use sqlite3 srfi-1 posix regex regex-case srfi-69) @@ -275,14 +275,17 @@ (conc "-e " (get-environment-variable "SHELL")) ""))) (system (conc "cd " rundir ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (message-window (conc "Directory " rundir " not found"))))) - (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10")) - (command-launch-button (iup:button "Execute!" #:action (lambda (x) - (let ((cmd (iup:attribute command-text-box "VALUE"))) - (system (conc cmd " &")))))) + (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12")) + (command-launch-button (iup:button "Execute!" + ;; #:expand "HORIZONTAL" + #:size "50x" + #:action (lambda (x) + (let ((cmd (iup:attribute command-text-box "VALUE"))) + (system (conc cmd " &")))))) (run-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname " -runtests " (conc testname "/" (if (equal? item-path "") @@ -324,13 +327,13 @@ #:numlin 5 #:numcol-visible 1 #:numlin-visible 5)) (steps-matrix (iup:matrix #:expand "YES" - #:numcol 5 + #:numcol 6 #:numlin 50 - #:numcol-visible 5 + #:numcol-visible 6 #:numlin-visible 8)) (data-matrix (iup:matrix #:expand "YES" #:numcol 8 #:numlin 50 @@ -355,15 +358,18 @@ (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix)) ;; Steps matrix (iup:attribute-set! steps-matrix "0:1" "Step Name") (iup:attribute-set! steps-matrix "0:2" "Start") + (iup:attribute-set! steps-matrix "WIDTH2" "40") (iup:attribute-set! steps-matrix "0:3" "End") - (iup:attribute-set! steps-matrix "WIDTH3" "50") + (iup:attribute-set! steps-matrix "WIDTH3" "40") (iup:attribute-set! steps-matrix "0:4" "Status") - (iup:attribute-set! steps-matrix "WIDTH4" "50") - (iup:attribute-set! steps-matrix "0:5" "Log File") + (iup:attribute-set! steps-matrix "WIDTH4" "40") + (iup:attribute-set! steps-matrix "0:5" "Duration") + (iup:attribute-set! steps-matrix "WIDTH5" "40") + (iup:attribute-set! steps-matrix "0:6" "Log File") (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") ;; (iup:attribute-set! steps-matrix "WIDTH1" "120") ;; (iup:attribute-set! steps-matrix "WIDTH0" "100") @@ -394,38 +400,46 @@ (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" )) (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment")) (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration")) (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description")))) - (iup:vbox - (iup:hbox - run-info-matrix - test-info-matrix) - (iup:hbox - test-run-matrix - meta-dat-matrix) - (iup:vbox - (iup:vbox - (iup:hbox - (iup:button "View Log" #:action viewlog #:size "80x") - (iup:button "Start Xterm" #:action xterm #:size "80x") - (iup:button "Run Test" #:action run-test #:size "80x") - (iup:button "Clean Test" #:action remove-test #:size "80x")) - (apply - iup:hbox - (list command-text-box command-launch-button)))) - (iup:vbox - (let ((tabs (iup:tabs - steps-matrix - data-matrix))) - (iup:attribute-set! tabs "TABTITLE0" "Test Steps") - (iup:attribute-set! tabs "TABTITLE1" "Test Data") - tabs))))) + (iup:split + #:orientation "HORIZONTAL" + (iup:vbox + (iup:hbox + (iup:vbox + run-info-matrix + test-info-matrix) + ;; test-info-matrix) + (iup:vbox + test-run-matrix + meta-dat-matrix)) + (iup:vbox + (iup:vbox + (iup:hbox + (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x" + (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x" + (iup:hbox + (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x" + (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x" + (iup:hbox + ;; hiup:split ;; hbox + ;; #:orientation "HORIZONTAL" + ;; #:value 300 + command-text-box + command-launch-button))) + (iup:vbox + (let ((tabs (iup:tabs + steps-matrix + data-matrix))) + (iup:attribute-set! tabs "TABTITLE0" "Test Steps") + (iup:attribute-set! tabs "TABTITLE1" "Test Data") + tabs))))) ;; Test browser (define (tests window-id) - (iup:hbox + (iup:split (let* ((tb (iup:treebox #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) @@ -446,14 +460,18 @@ ;; get test-id ;; then get test record (if testdat (let* ((test-id (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f)) (test-data (hash-table-ref/default testdat test-id #f)) + (run-id (db:test-get-run_id test-data)) (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*) - (db:test-get-run_id test-data) '())) + run-id + '())) (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) - (runname (if (null? targ/runname) "" (car (cdr targ/runname))))) + (runname (if (null? targ/runname) "" (car (cdr targ/runname)))) + (steps-dat (dcommon:get-compressed-steps *dbstruct-local* run-id test-id))) + (if test-data (begin ;; (for-each (lambda (data) @@ -494,14 +512,15 @@ (db:test-get-uname test-data) (db:test-get-diskfree test-data) (db:test-get-cpuload test-data) (seconds->hr-min-sec (db:test-get-run_duration test-data))) (make-list 5 ""))) + )) + (dcommon:populate-steps steps-dat steps-matrix)))))) ;;(list meta-dat-matrix ;; (if test-id ;; (list ( - ))))))) ;; db:test-get-id ;; db:test-get-run_id ;; db:test-get-testname @@ -560,10 +579,11 @@ ;; Main Panel (define (main-panel window-id) (iup:dialog #:title "Megatest Control Panel" #:menu (dcommon:main-menu) + #:shrink "YES" (let ((tabtop (iup:tabs (runs window-id) (tests window-id) (runcontrol window-id) (mtest window-id) Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -8,14 +8,15 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) -(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking) +(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3) (import (prefix sqlite3 sqlite3:)) (declare (unit portlogger)) +(declare (uses db)) ;; lsof -i (define (portlogger:open-db fname) @@ -26,20 +27,28 @@ (begin (system (conc "rm -f " fname)) (sqlite3:open-database fname)))) (handler (make-busy-timeout 136000)) (canwrite (file-write-access? fname))) + ;; (db-init (lambda () + ;; (sqlite3:execute + ;; db + ;; "CREATE TABLE IF NOT EXISTS ports ( + ;; port INTEGER PRIMARY KEY, + ;; state TEXT DEFAULT 'not-used', + ;; fail_count INTEGER DEFAULT 0, + ;; update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")))) (sqlite3:set-busy-handler! db handler) - (sqlite3:execute db "PRAGMA synchronous = 0;") - (if (not exists) - (sqlite3:execute - db - "CREATE TABLE IF NOT EXISTS ports ( + (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") + ;; (if (not exists) ;; needed with IF NOT EXISTS? + (sqlite3:execute + db + "CREATE TABLE IF NOT EXISTS ports ( port INTEGER PRIMARY KEY, state TEXT DEFAULT 'not-used', fail_count INTEGER DEFAULT 0, - update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")) + update_time TIMESTAMP DEFAULT (strftime('%s','now')) );") db)) (define (portlogger:open-run-close proc . params) (let* ((fname (conc "/tmp/." (current-user-name) "-portlogger.db")) (avail (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away @@ -48,11 +57,12 @@ (begin ;; (release-dot-lock fname) (debug:print 0 "ERROR: portlogger:open-run-close failed. " proc " " params) (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 "exn=" (condition->list exn)) - (print-call-chain)) + (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it + (print-call-chain (current-error-port))) (let* (;; (lock (obtain-dot-lock fname 2 9 10)) (db (portlogger:open-db fname)) (res (apply proc db params))) (sqlite3:finalize! db) ;; (release-dot-lock fname) @@ -94,11 +104,11 @@ exn (begin (debug:print 0 "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 "exn=" (condition->list exn)) - (print-call-chain) + (print-call-chain (current-error-port)) (debug:print 0 "Continuing anyway.") #f) (sqlite3:fold-row (lambda (var curr) (or curr var curr)) @@ -119,11 +129,11 @@ exn (begin (debug:print 0 "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 "exn=" (condition->list exn)) - (print-call-chain) + (print-call-chain (current-error-port)) (debug:print 0 "Continuing anyway.")) (portlogger:take-port db portnum)) portnum)) ;; set port to "released", "failed" etc. @@ -150,11 +160,11 @@ (begin (debug:print 0 "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (print-call-chain)) + (print-call-chain (current-error-port))) (cond ((> numargs 1) ;; most commands (case (string->symbol (car args)) ;; commands with two or more params ((take)(portlogger:take-port db (string->number (cadr args)))) ((set) (portlogger:set-port db Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -52,69 +52,85 @@ (> queries-per-second 10)) (begin (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) #t) #f)))) + +(define (rmt:get-connection-info run-id) + (let ((cinfo (hash-table-ref/default *runremote* run-id #f))) + (if cinfo + cinfo + ;; NB// can cache the answer for server running for 10 seconds ... + ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) + (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id) + (client:setup run-id) + #f)))) ;; cmd is a symbol ;; vars is a json string encoding the parameters for the call ;; -(define (rmt:send-receive cmd rid params) +(define (rmt:send-receive cmd rid params #!key (attemptnum 0)) ;; clean out old connections (mutex-lock! *db-multi-sync-mutex*) (let ((expire-time (- (current-seconds) 60))) (for-each (lambda (run-id) (let ((connection (hash-table-ref/default *runremote* run-id #f))) - (if ;; (and connection - (< (http-transport:server-dat-get-last-access connection) expire-time) ; ) + (if (and connection + (< (http-transport:server-dat-get-last-access connection) expire-time)) (begin (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses") (hash-table-delete! *runremote* run-id))))) (hash-table-keys *runremote*))) (mutex-unlock! *db-multi-sync-mutex*) (let* ((run-id (if rid rid 0)) - (connection-info (let ((cinfo (hash-table-ref/default *runremote* run-id #f))) - (if cinfo - cinfo - ;; NB// can cache the answer for server running for 10 seconds ... - ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) - (if (tasks:server-running-or-starting? (tasks:get-db) run-id) - (let ((res (client:setup run-id))) - (if res - (hash-table-ref/default *runremote* run-id #f) ;; client:setup filled this in (hopefully) - #f)) - #f)))) + (connection-info (rmt:get-connection-info run-id)) (jparams (db:obj->string params))) (if connection-info - (let ((res (http-transport:client-api-send-receive run-id connection-info cmd jparams))) + ;; use the server if have connection info + (let* ((dat (http-transport:client-api-send-receive run-id connection-info cmd jparams)) + (res (if (and dat (vector? dat)) (vector-ref dat 1) #f)) + (success (if (and dat (vector? dat)) (vector-ref dat 0) #f))) (http-transport:server-dat-update-last-access connection-info) - (if res + (if success (db:string->obj res) - (let ((new-connection-info (client:setup run-id))) + ;; (if (< attemptnum 100) + ;; (begin + ;; (hash-table-delete! *runremote* run-id) + ;; (thread-sleep! 0.5) + ;; (rmt:send-receive cmd rid params attempnum: (+ attemptnum 1))) + ;; (begin + ;; (print-call-chain (current-error-port)) + ;; (debug:print 0 "ERROR: too many attempts to communicate have failed. Giving up. Kill your mtest processes and start over") + ;; (exit 1))))) + (begin ;; let ((new-connection-info (client:setup run-id))) (debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.") - (rmt:send-receive cmd run-id params)))) - (let ((max-avg-qry (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "-1")))) - (debug:print-info 4 "no server and read-only query, bypassing normal channel") - ;; (if (rmt:write-frequency-over-limit? cmd run-id)(server:kind-run run-id)) - (let ((curr-max (rmt:get-max-query-average))) - (if (> (cdr curr-max) max-avg-qry) - (begin - (debug:print-info 3 "Max average query, " (inexact->exact (round (cdr curr-max))) "ms (" (car curr-max) ") exceeds " max-avg-qry ", try starting server ...") - (server:kind-run run-id)))) - (rmt:open-qry-close-locally cmd run-id params))))) - -(define (rmt:update-db-stats rawcmd params duration) + (hash-table-delete! *runremote* run-id) ;; don't keep using the same connection + + ;; no longer killing the server in http-transport:client-api-send-receive + ;; may kill it here but what are the criteria? + ;; start with three calls then kill server + (if (eq? attemptnum 3)(tasks:kill-server-run-id run-id)) + (thread-sleep! 2) + (rmt:send-receive cmd run-id params attemptnum: (+ attemptnum 1))))) + (if (and (< attemptnum 10) + (tasks:need-server run-id)) + (begin + (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10) + (rmt:send-receive cmd rid params (+ attemptnum 1))) + (rmt:open-qry-close-locally cmd run-id params))))) + +(define (rmt:update-db-stats run-id rawcmd params duration) (mutex-lock! *db-stats-mutex*) (handle-exceptions exn (begin (debug:print 0 "WARNING: stats collection failed in update-db-stats") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) #f) ;; if this fails we don't care, it is just stats - (let* ((cmd (if (eq? rawcmd 'general-call) (car params) rawcmd)) + (let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd))) (stat-vec (hash-table-ref/default *db-stats* cmd #f))) (if (not stat-vec) (let ((newvec (vector 0 0))) (hash-table-set! *db-stats* cmd newvec) (set! stat-vec newvec))) @@ -133,29 +149,32 @@ (sort (hash-table-keys *db-stats*) (lambda (a b) (> (vector-ref (hash-table-ref *db-stats* a) 0) (vector-ref (hash-table-ref *db-stats* b) 0))))))) -(define (rmt:get-max-query-average) +(define (rmt:get-max-query-average run-id) (mutex-lock! *db-stats-mutex*) - (let* ((cmds (hash-table-keys *db-stats*)) - (res (if (null? cmds) - (cons 'none 0) - (let loop ((cmd (car cmds)) - (tal (cdr cmds)) - (max-cmd (car cmds)) - (res 0)) - (let* ((cmd-dat (hash-table-ref *db-stats* cmd)) - (tot (vector-ref cmd-dat 0)) - (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction - (currmax (max res curravg)) - (newmax-cmd (if (> curravg res) cmd max-cmd))) - (if (null? tal) - (if (> tot 10) - (cons newmax-cmd currmax) - (cons 'none 0)) - (loop (car tal)(cdr tal) newmax-cmd currmax))))))) + (let* ((runkey (conc "run-id=" run-id " ")) + (cmds (filter (lambda (x) + (substring-index runkey x)) + (hash-table-keys *db-stats*))) + (res (if (null? cmds) + (cons 'none 0) + (let loop ((cmd (car cmds)) + (tal (cdr cmds)) + (max-cmd (car cmds)) + (res 0)) + (let* ((cmd-dat (hash-table-ref *db-stats* cmd)) + (tot (vector-ref cmd-dat 0)) + (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction + (currmax (max res curravg)) + (newmax-cmd (if (> curravg res) cmd max-cmd))) + (if (null? tal) + (if (> tot 10) + (cons newmax-cmd currmax) + (cons 'none 0)) + (loop (car tal)(cdr tal) newmax-cmd currmax))))))) (mutex-unlock! *db-stats-mutex*) res)) (define (rmt:open-qry-close-locally cmd run-id params) (let* ((dbstruct-local (if *dbstruct-db* @@ -167,27 +186,30 @@ (db-file-path (db:dbfile-path 0))) ;; (read-only (not (file-read-access? db-file-path))) (let* ((start (current-milliseconds)) (res (api:execute-requests dbstruct-local (symbol->string cmd) params)) (duration (- (current-milliseconds) start))) - (rmt:update-db-stats cmd params duration) + (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write (if (not (member cmd api:read-only-queries)) (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) - (if (not (hash-table-ref/default *db-local-sync* run-id #f)) - (hash-table-set! *db-local-sync* run-id start-time)) ;; the oldest "write" + ;; (if (not (hash-table-ref/default *db-local-sync* run-id #f)) + ;; just set it every time. Is a write more expensive than a read and does it matter? + (hash-table-set! *db-local-sync* (or run-id 0) start-time) ;; the oldest "write" (mutex-unlock! *db-multi-sync-mutex*))) res))) (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) - (jparams (db:obj->string params)) ;; (rmt:dat->json-str params)) - (res (http-transport:client-api-send-receive run-id connection-info cmd jparams))) - (if res - (db:string->obj res) - res))) + (jparams (db:obj->string params)) ;; (rmt:dat->json-str params)) + (dat (http-transport:client-api-send-receive run-id connection-info cmd jparams))) + (if (and dat (vector-ref dat 0)) + (db:string->obj (vector-ref dat 1)) + (begin + (debug:print 0 "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat) + dat)))) ;; Wrap json library for strings (why the ports crap in the first place?) (define (rmt:dat->json-str dat) (with-output-to-string (lambda () @@ -265,11 +287,11 @@ (define (rmt:get-test-info-by-id run-id test-id) (if (and (number? run-id)(number? test-id)) (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)) (begin (debug:print 0 "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) - (print-call-chain) + (print-call-chain (current-error-port)) #f))) (define (rmt:test-get-rundir-from-test-id run-id test-id) (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) @@ -290,20 +312,57 @@ (define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) (if (number? run-id) (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)) (begin (debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id) - (print-call-chain) + (print-call-chain (current-error-port)) '()))) +;; IDEA: Threadify these - they spend a lot of time waiting ... +;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) - (let ((run-id-list (if run-ids + (let ((multi-run-mutex (make-mutex)) + (run-id-list (if run-ids run-ids - (rmt:get-all-run-ids)))) - (apply append (map (lambda (run-id) - (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) - run-id-list)))) + (rmt:get-all-run-ids))) + (result '())) + (if (null? run-id-list) + '() + (for-each + (lambda (th) + + (thread-join! th)) ;; I assume that joining completed threads just moves on + (let loop ((hed (car run-id-list)) + (tal (cdr run-id-list)) + (threads '())) + (let* ((newthread (make-thread + (lambda () + (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in)))) + (if (list? res) + (begin + (mutex-lock! multi-run-mutex) + (set! result (append result res)) + (mutex-unlock! multi-run-mutex)) + (debug:print 0 "ERROR: get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) + (conc "multi-run-thread for run-id " hed))) + (newthreads (cons newthread threads))) + (thread-start! newthread) + (thread-sleep! 0.5) ;; give that thread some time to start + (if (null? tal) + newthreads + (loop (car tal)(cdr tal) newthreads)))))) + result)) + +;; ;; IDEA: Threadify these - they spend a lot of time waiting ... +;; ;; +;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) +;; (let ((run-id-list (if run-ids +;; run-ids +;; (rmt:get-all-run-ids)))) +;; (apply append (map (lambda (run-id) +;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) +;; run-id-list)))) (define (rmt:delete-test-records run-id test-id) (rmt:send-receive 'delete-test-records run-id (list run-id test-id))) ;; This is not needed as test steps are deleted on test delete call Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -66,10 +66,11 @@ keyvals) ;; Set up various and sundry known vars here (setenv "MT_RUN_AREA_HOME" toppath) (setenv "MT_RUNNAME" runname) (setenv "MT_TARGET" target) + (setenv "MT_TESTSUITENAME" (common:get-testsuite-name)) (set! envdat (append envdat (list (list "MT_RUN_AREA_HOME" toppath) (list "MT_RUNNAME" runname) (list "MT_TARGET" target)))) @@ -159,13 +160,13 @@ (hash-table-set! *runs:denoise* key currtime) #t) #f))) (define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) - (thread-sleep! (cond - ((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while - (else 0))) + ;;(thread-sleep! (cond + ;; ((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while + ;; (else 0))) (let* ((num-running (rmt:get-count-tests-running run-id)) (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) (if (string? jobg-count) (string->number jobg-count) @@ -213,25 +214,26 @@ (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names #f) ;; (hash-table-keys all-tests-registry)) (test-names #f) ;; (tests:filter-test-names all-test-names test-patts)) (required-tests #f) ;;(lset-intersection equal? (string-split test-patts ",") test-names))) ;; test-names)) ;; Added test-names as initial for required-tests but that failed to work (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) - (tasks-db (tasks:open-db))) + (tdbdat (tasks:open-db))) + + (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (set-signal-handler! signal/int (lambda (signum) (signal-mask! signum) - (let ((tdb (tasks:open-db))) - (tasks:set-state-given-param-key tdb task-key "killed") - ;; (sqlite3:interrupt! tdb) ;; seems silly? - (sqlite3:finalize! tdb)) + (print "Received signal " signum ", cleaning up before exit. Please wait...") + (let ((tdbdat (tasks:open-db))) + (tasks:set-state-given-param-key (db:delay-if-busy tdbdat) task-key "killed")) (print "Killed by signal " signum ". Exiting") (exit))) ;; register this run in monitor.db - (tasks:add tasks-db "run-tests" user target runname test-patts task-key) ;; params) - (tasks:set-state-given-param-key tasks-db task-key "running") + (tasks:add (db:delay-if-busy tdbdat) "run-tests" user target runname test-patts task-key) ;; params) + (tasks:set-state-given-param-key (db:delay-if-busy tdbdat) task-key "running") (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) @@ -392,12 +394,13 @@ (if (not (hash-table-ref/default flags "-rerun" #f)) (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS")) (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))))) (debug:print-info 0 "No tests to run"))) (debug:print-info 4 "All done by here") - (tasks:set-state-given-param-key tasks-db task-key "done") - (sqlite3:finalize! tasks-db))) + (tasks:set-state-given-param-key (db:delay-if-busy tdbdat) task-key "done") + ;; (sqlite3:finalize! tasks-db) + )) ;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable. ;; ;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns @@ -551,14 +554,16 @@ (list (car newtal)(append (cdr newtal) reg) '() reruns)))) ((and (null? fails) (null? prereq-fails) (null? non-completed)) - (if (runs:can-keep-running? hed 5) + (if (runs:can-keep-running? hed 20) (begin (runs:inc-cant-run-tests hed) (debug:print-info 1 "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0)) + ;; getting here likely means the system is way overloaded, kill a full minute before continuing + (thread-sleep! 60) ;; num-retries code was here ;; we use this opportunity to move contents of reg to tal (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met? (begin (debug:print-info 1 "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue") @@ -669,27 +674,24 @@ ;; Register tests ;; ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) - (if #t ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs + ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs + (let register-loop ((numtries 15)) + (rmt:general-call 'register-test run-id run-id test-name item-path) + (thread-sleep! 0.5) + (if (rmt:get-test-id run-id test-name item-path) + (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) + (if (> numtries 0) + (register-loop (- numtries 1)) + (debug:print 0 "ERROR: failed to register test " (runs:make-full-test-name test-name item-path))))) + (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) (begin - (rmt:general-call 'register-test run-id run-id test-name item-path) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done)) - (let ((th (make-thread (lambda () - (mutex-lock! registry-mutex) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start) - (mutex-unlock! registry-mutex) - ;; If haven't done it before register a top level test if this is an itemized test - (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) - (rmt:general-call 'register-test run-id run-id test-name "")) - (rmt:general-call 'register-test run-id run-id test-name item-path) - (mutex-lock! registry-mutex) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) - (mutex-unlock! registry-mutex)) - (conc test-name "/" item-path)))) - (thread-start! th))) + (rmt:general-call 'register-test run-id run-id test-name "") + (if (rmt:get-test-id run-id test-name "") + (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done)))) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) (if (and (null? tal)(null? reg)) (list hed tal (append reg (list hed)) reruns) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) @@ -890,11 +892,12 @@ (if (and mcj (string->number mcj)) (string->number mcj) 1))) ;; length of the register queue ahead (reglen (if (number? reglen-in) reglen-in 1)) (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle - (last-time-some-running (current-seconds))) + (last-time-some-running (current-seconds)) + (tdbdat (tasks:open-db))) ;; Initialize the test-registery hash with tests that already have a record ;; convert state to symbol and use that as the hash value (for-each (lambda (trec) (let ((id (db:test-get-id trec)) @@ -938,11 +941,16 @@ (tfullname (runs:make-full-test-name test-name item-path)) (newtal (append tal (list hed))) (regfull (>= (length reg) reglen)) (num-running (rmt:get-count-tests-running-for-run-id run-id))) - (if (> num-running 0) + ;; every couple minutes verify the server is there for this run + (if (and (common:low-noise-print 60 "try start server" run-id) + (tasks:need-server run-id)) + (tasks:start-and-wait-for-server tdbdat run-id 10)) + + (if (> num-running 0) (set! last-time-some-running (current-seconds))) (if (> (current-seconds)(+ last-time-some-running 240)) (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) ;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*)) @@ -1116,11 +1124,11 @@ (debug:print-info 0 "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name)) (set! last-time-incomplete (current-seconds)) (rmt:find-and-mark-incomplete run-id #f))) (if (not (eq? num-running prev-num-running)) (debug:print-info 0 "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds))))) - (thread-sleep! 15) + (thread-sleep! 5) ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) ;; LET* ((test-record ;; we get here on "drop through". All done! (debug:print-info 1 "All tests launched"))) @@ -1396,11 +1404,11 @@ ;; NB// should pass in keys? ;; (define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(remove-data-only #f)) (common:clear-caches) ;; clear all caches (let* ((db #f) - (tasks-db (tasks:open-db)) + (tdbdat (tasks:open-db)) (keys (rmt:get-keys)) (rundat (mt:get-runs-by-patt keys runnamepatt target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1)) (states (if state (string-split state ",") '())) @@ -1433,16 +1441,18 @@ (debug:print-info 4 "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin (case action ((remove-runs) + (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; seek and kill in flight -runtests with % as testpatt here (if (equal? testpatt "%") - (tasks:kill-runner tasks-db target run-name) + (tasks:kill-runner (db:delay-if-busy tdbdat) target run-name) (debug:print 0 "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) + (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) ((run-wait) @@ -1548,11 +1558,12 @@ ;; (debug:print 1 "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) ))))) )) runs) - (sqlite3:finalize! tasks-db)) + ;; (sqlite3:finalize! (db:delay-if-busy tdbdat)) + ) #t) (define (runs:remove-test-directory db test remove-data-only) (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree (real-dir (if (file-exists? run-dir) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -114,11 +114,11 @@ ;; kind start up of servers, wait 40 seconds before allowing another server for a given ;; run-id to be launched (define (server:kind-run run-id) (let ((last-run-time (hash-table-ref/default *server-kind-run* run-id #f))) (if (or (not last-run-time) - (> (- (current-seconds) last-run-time) 40)) + (> (- (current-seconds) last-run-time) 30)) (begin (server:run run-id) (hash-table-set! *server-kind-run* run-id (current-seconds)))))) ;; The generic run a server command. Dispatches the call to server 0 if run-id != 0 @@ -127,12 +127,13 @@ (if (eq? run-id 0) (server:run run-id) (rmt:start-server run-id))) (define (server:check-if-running run-id) - (let loop ((server (tasks:get-server (tasks:get-db) run-id)) - (trycount 0)) + (let ((tdbdat (tasks:open-db))) + (let loop ((server (tasks:get-server (db:delay-if-busy tdbdat) run-id)) + (trycount 0)) (if server ;; note: client:start will set *runremote*. this needs to be changed ;; also, client:start will login to the server, also need to change that. ;; ;; client:start returns #t if login was successful. @@ -143,25 +144,26 @@ ;; if the server didn't respond we must remove the record (if res #t (begin (debug:print-info 0 "server at " server " not responding, removing record") - (tasks:server-force-clean-running-records-for-run-id (tasks:get-db) run-id + (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id " server:check-if-running") res))) - #f))) + #f)))) ;; called in megatest.scm, host-port is string hostname:port ;; (define (server:ping run-id host:port) - (let* ((host-port (let ((slst (string-split host:port ":"))) - (if (eq? (length slst) 2) - (list (car slst)(string->number (cadr slst))) - #f))) - (toppath (launch:setup-for-run)) - (server-db-dat (if (not host-port)(tasks:get-server (tasks:get-db) run-id) #f))) - (if (not run-id) + (let ((tdbdat (tasks:open-db))) + (let* ((host-port (let ((slst (string-split host:port ":"))) + (if (eq? (length slst) 2) + (list (car slst)(string->number (cadr slst))) + #f))) + (toppath (launch:setup-for-run)) + (server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f))) + (if (not run-id) (begin (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n") (print "ERROR: No run-id") (exit 1)) (if (and (not host-port) @@ -178,11 +180,11 @@ (begin (print "LOGIN_OK") (exit 0)) (begin (print "LOGIN_FAILED") - (exit 1)))))))) + (exit 1))))))))) ;; run ping in separate process, safest way in some cases ;; (define (server:ping-server run-id iface port) (with-input-from-pipe Index: synchash.scm ================================================================== --- synchash.scm +++ synchash.scm @@ -117,11 +117,11 @@ (map make-indexed data)))) ;; add each element keyed by the keynum'th val (else ;; (debug:print-info 2 "Non-get runs call") (map make-indexed newdat)))) ;; (debug:print-info 2 "postdat: " postdat) - (if (not indb)(sqlite3:finalize! db)) + ;; (if (not indb)(sqlite3:finalize! db)) (if (not synchash) (begin (set! synchash (make-hash-table)) (hash-table-set! *synchashes* synckey synchash))) (synchash:get-delta postdat synchash))) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -22,34 +22,45 @@ ;; Tasks db ;;====================================================================== ;; wait up to aprox n seconds for a journal to go away ;; -(define (tasks:wait-on-journal path n #!key (remove #f)) - (let ((fullpath (conc path "-journal"))) - (handle-exceptions - exn - #t ;; if stuff goes wrong just allow it to move on - (let loop ((journal-exists (file-exists? fullpath)) - (count n)) ;; wait ten times ... - (if journal-exists - (if (> count 0) - (begin - (thread-sleep! 1) - (loop (file-exists? fullpath) - (- count 1))) - (begin - (if remove (system (conc "rm -rf " path))) - #f)) - #t))))) +(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f)) + (if (not (string? path)) + (debug:print 0 "ERROR: Called tasks:wait-on-journal with path=" path " (not a string)") + (let ((fullpath (conc path "-journal"))) + (handle-exceptions + exn + (begin + (print-call-chain (current-error-port)) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 " exn=" (condition->list exn)) + (debug:print 0 "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") + #t) ;; if stuff goes wrong just allow it to move on + (let loop ((journal-exists (file-exists? fullpath)) + (count n)) ;; wait ten times ... + (if journal-exists + (begin + (if (and waiting-msg + (eq? (modulo n 30) 0)) + (debug:print 0 waiting-msg)) + (if (> count 0) + (begin + (thread-sleep! 1) + (loop (file-exists? fullpath) + (- count 1))) + (begin + (if remove (system (conc "rm -rf " fullpath))) + #f))) + #t)))))) (define (tasks:get-task-db-path) - (if *task-db* - (vector-ref *task-db* 1) - (let* ((linktree (configf:lookup *configdat* "setup" "linktree")) - (dbpath (conc linktree "/.db/monitor.db"))) - dbpath))) + (let* ((linktree (configf:lookup *configdat* "setup" "linktree")) + (dbpath (conc linktree "/.db"))) + dbpath)) + + ;; If file exists AND ;; file readable ;; ==> open it ;; If file exists AND @@ -56,30 +67,47 @@ ;; file NOT readable ;; ==> open in-mem version ;; If file NOT exists ;; ==> open in-mem version ;; -(define (tasks:open-db) - (let* ((dbpath (tasks:get-task-db-path)) - (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away - (exists (file-exists? dbpath)) - (write-access (file-write-access? dbpath)) - (mdb (cond - ((file-write-access? *toppath*)(sqlite3:open-database dbpath)) - ((file-read-access? dbpath) (sqlite3:open-database dbpath)) - (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) - (handler (make-busy-timeout 36000))) - (if (and exists - (not write-access)) - (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control - (sqlite3:set-busy-handler! mdb handler) - (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) - (if (or (and (not exists) - (file-write-access? *toppath*)) - (not (file-read-access? dbpath))) - (begin - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, +(define (tasks:open-db #!key (numretries 4)) + (if *task-db* + *task-db* + (handle-exceptions + exn + (if (> numretries 0) + (begin + (print-call-chain (current-error-port)) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 " exn=" (condition->list exn)) + (thread-sleep! 1) + (tasks:open-db numretries (- numretries 1))) + (begin + (print-call-chain (current-error-port)) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 " exn=" (condition->list exn)))) + (let* ((dbpath (tasks:get-task-db-path)) + (dbfile (conc dbpath "/monitor.db")) + (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away + (exists (file-exists? dbpath)) + (write-access (file-write-access? dbpath)) + (mdb (cond ;; what the hek is *toppath* doing here? + ((and (string? *toppath*)(file-write-access? *toppath*)) + (sqlite3:open-database dbfile)) + ((file-read-access? dbpath) (sqlite3:open-database dbfile)) + (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) + (handler (make-busy-timeout 36000))) + (if (and exists + (not write-access)) + (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control + (sqlite3:set-busy-handler! mdb handler) + (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) + ;; (if (or (and (not exists) + ;; (file-write-access? *toppath*)) + ;; (not (file-read-access? dbpath))) + ;; (begin + (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, action TEXT DEFAULT '', owner TEXT, state TEXT DEFAULT 'new', target TEXT DEFAULT '', name TEXT DEFAULT '', @@ -86,18 +114,18 @@ testpatt TEXT DEFAULT '', keylock TEXT, params TEXT, creation_time TIMESTAMP, execution_time TIMESTAMP);") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, + (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, pid INTEGER, start_time TIMESTAMP, last_update TIMESTAMP, hostname TEXT, username TEXT, CONSTRAINT monitors_constraint UNIQUE (pid,hostname));") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, + (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, pid INTEGER, interface TEXT, hostname TEXT, port INTEGER, pubport INTEGER, @@ -106,31 +134,25 @@ state TEXT, mt_version TEXT, heartbeat TIMESTAMP, transport TEXT, run_id INTEGER);") -;; CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, + ;; CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));") + (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, server_id INTEGER, pid INTEGER, hostname TEXT, cmdline TEXT, login_time TIMESTAMP, logout_time TIMESTAMP DEFAULT -1, CONSTRAINT clients_constraint UNIQUE (pid,hostname));") - - )) - mdb)) - -(define (tasks:get-db) - (if *task-db* - (vector-ref *task-db* 0) - (let ((db (tasks:open-db)) - (pth (tasks:get-task-db-path))) - (set! *task-db* (vector db pth)) - db))) - + + ;)) + (sqlite3:execute mdb "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs + (set! *task-db* (cons mdb dbpath)) + *task-db*)))) + ;;====================================================================== ;; Server and client management ;;====================================================================== ;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname @@ -145,11 +167,11 @@ (define (tasks:server-lock-slot mdb run-id) (tasks:server-clean-out-old-records-for-run-id mdb run-id " tasks:server-lock-slot") (if (< (tasks:num-in-available-state mdb run-id) 4) (begin (tasks:server-set-available mdb run-id) - (thread-sleep! 2) ;; Try removing this. It may not be needed. + ;; (thread-sleep! 2) ;; Try removing this. It may not be needed. (tasks:server-am-i-the-server? mdb run-id)) #f)) ;; register that this server may come online (first to register goes though with the process) (define (tasks:server-set-available mdb run-id) @@ -286,23 +308,37 @@ mdb (conc "SELECT " selstr " FROM servers WHERE run_id=? AND state in ('available','running','dbprep') ORDER BY start_time DESC;") run-id) (vector header res))) -(define (tasks:get-server mdb run-id) +(define (tasks:get-server mdb run-id #!key (retries 10)) (let ((res #f) (best #f)) - (sqlite3:for-each-row - (lambda (id interface port pubport transport pid hostname) - (set! res (vector id interface port pubport transport pid hostname))) - mdb - ;; removed: - ;; strftime('%s','now')-heartbeat < 10 AND mt_version = ? - "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers + (handle-exceptions + exn + (begin + (print-call-chain (current-error-port)) + (debug:print 0 "WARNING: tasks:get-server db access error.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 " for run " run-id) + (print-call-chain (current-error-port)) + (if (> retries 0) + (begin + (debug:print 0 " trying call to tasks:get-server again in 10 seconds") + (thread-sleep! 10) + (tasks:get-server mdb run-id retries: (- retries 0))) + (debug:print 0 "10 tries of tasks:get-server all crashed and burned. Giving up and returning \"no server found\""))) + (sqlite3:for-each-row + (lambda (id interface port pubport transport pid hostname) + (set! res (vector id interface port pubport transport pid hostname))) + mdb + ;; removed: + ;; strftime('%s','now')-heartbeat < 10 AND mt_version = ? + "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers WHERE run_id=? AND state='running' ORDER BY start_time DESC LIMIT 1;" run-id) ;; (common:version-signature) run-id) - res)) + res))) (define (tasks:server-running-or-starting? mdb run-id) (let ((res #f)) (sqlite3:for-each-row (lambda (id) @@ -309,10 +345,50 @@ (set! res id)) mdb ;; NEEDS dbprep ADDED "SELECT id FROM servers WHERE run_id=? AND (state = 'running' OR (state = 'dbprep' AND (strftime('%s','now') - start_time) < 60));" run-id) res)) +(define (tasks:server-running? mdb run-id) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (id) + (set! res id)) + mdb ;; NEEDS dbprep ADDED + "SELECT id FROM servers WHERE run_id=? AND state = 'running';" run-id) + res)) + +(define (tasks:need-server run-id) + (let ((forced (configf:lookup *configdat* "server" "required")) + (maxqry (cdr (rmt:get-max-query-average run-id))) + (threshold (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "10")))) + (cond + (forced + (if (common:low-noise-print 60 run-id "server required is set") + (debug:print-info 0 "Server required is set, starting server.")) + #t) + ((> maxqry threshold) + (if (common:low-noise-print 60 run-id "Max query time execeeded") + (debug:print-info 0 "Max avg query time of " maxqry "ms exceeds limit of " threshold "ms, starting server.")) + #t) + (else + #f)))) + +;; try to start a server and wait for it to be available +;; +(define (tasks:start-and-wait-for-server tdbdat run-id delay-max-tries) + ;; ensure a server is running for this run + (let loop ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id)) + (delay-time 0)) + (if (and (not server-dat) + (< delay-time delay-max-tries)) + (begin + (if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id) + (debug:print 0 "Try starting server for run-id " run-id)) + (server:kind-run run-id) + (thread-sleep! (min delay-time 5)) + (loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1)))))) + (define (tasks:get-all-servers mdb) (let ((res '())) (sqlite3:for-each-row (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 @@ -331,49 +407,25 @@ (unsetenv "TARGETHOST_LOGF") (unsetenv "TARGETHOST")) ;; look up a server by run-id and send it a kill, also delete the record for that server ;; -(define (tasks:kill-server-run-id run-id) - (let* ((tdb (tasks:open-db)) - (sdat (tasks:get-server mdb run-id))) +(define (tasks:kill-server-run-id run-id #!key (tag "default")) + (let* ((tdbdat (tasks:open-db)) + (sdat (tasks:get-server (db:delay-if-busy tdbdat) run-id))) (if sdat (let ((hostname (vector-ref sdat 6)) - (pid (vector-ref sdat 5))) - (debug:print-info 0 "Killing server for run-id " run-id " on host " hostname " with pid " pid) + (pid (vector-ref sdat 5)) + (server-id (vector-ref sdat 0))) + (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "killed") + (debug:print-info 0 "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid) (tasks:kill-server hostname pid) - (tasks:server-delete-record mdb server-id tag) ) - (debug:print-info 0 "No server found for run-id " run-id ", nothing to kill")))) - -;; (if status ;; #t means alive -;; (begin -;; (if (equal? hostname (get-host-name)) -;; (handle-exceptions -;; exn -;; (debug:print-info 0 "server may or may not be dead, check for megatest -server running as pid " pid "\n" -;; " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) -;; (debug:print 1 "Sending signal/term to " pid " on " hostname) -;; (process-signal pid signal/term) -;; (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill -;; ;;(process-signal pid signal/kill) -;; ) ;; local machine, send sig term -;; (begin -;; ;;(debug:print-info 1 "Stopping remote servers not yet supported.")))) -;; (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide") -;; (let ((serverdat (list hostname port))) -;; (hash-table-set! *runremote* run-id (http-transport:client-connect hostname port)) -;; (cdb:kill-server serverdat pid))))) ;; remote machine, try telling server to commit suicide -;; (begin -;; (if status -;; (if (equal? hostname (get-host-name)) -;; (begin -;; (debug:print-info 1 "Sending signal/term to " pid " on " hostname) -;; (process-signal pid signal/term) ;; local machine, send sig term -;; (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill -;; (process-signal pid signal/kill)) -;; (debug:print 0 "WARNING: Can't kill frozen server on remote host " hostname)))))) - + (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id tag) ) + (debug:print-info 0 "No server found for run-id " run-id ", nothing to kill")) + ;; (sqlite3:finalize! tdb) + )) + ;;====================================================================== ;; Tasks and Task monitors ;;====================================================================== @@ -668,13 +720,15 @@ (if (process:alive? pid) (process-signal pid signal/kill))))) ;; (call-with-environment-variables (let ((old-targethost (getenv "TARGETHOST"))) (setenv "TARGETHOST" hostname) + (setenv "TARGETHOST_LOGF" "server-kills.log") (system (conc "nbfake kill " pid)) (if old-targethost (setenv "TARGETHOST" old-targethost)) - (unsetenv "TARGETHOST")))) + (unsetenv "TARGETHOST") + (unsetenv "TARGETHOST_LOGF")))) (debug:print 0 "ERROR: no record or improper record for " target "/" run-name " in tasks_queue in monitor.db")))) records))) ;;====================================================================== Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -22,10 +22,11 @@ (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses client)) (declare (uses mt)) +(declare (uses db)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") @@ -53,27 +54,29 @@ (string->number (args:get-arg "-override-timeout")) 136000)))) (handle-exceptions exn (begin + (print-call-chain (current-error-port)) (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! dbexists #f)) ;; must force re-creation of tables, more tom-foolery (set! db (sqlite3:open-database dbpath))) (if *db-write-access* (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin - (sqlite3:execute db "PRAGMA synchronous = FULL;") + (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") (debug:print-info 11 "Initialized test database " dbpath) (tdb: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 + (print-call-chain (current-error-port)) (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " dbpath ".\n " ((condition-property-accessor 'exn 'message) exn)) #f) ;; Is there a cheaper single line operation that will check for existance of a table @@ -110,21 +113,24 @@ (tdb (open-test-db test-path))) (apply proc tdb params))) (define (tdb: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 ( + (sqlite3:with-transaction + db + (lambda () + (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 ( + "CREATE TABLE IF NOT EXISTS test_data ( id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, @@ -133,29 +139,29 @@ 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 ( + "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 ( + ;; 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));")) + CONSTRAINT metadat_constraint UNIQUE (var));")))) (debug:print 11 "db:testdb-initialize END")) (define (tdb:read-test-data tdb test-id categorypatt) (let ((res '())) (sqlite3:for-each-row Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -647,31 +647,10 @@ ;; (let ((remtries 10)) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (uname (get-uname "-srvpio")) (hostname (get-host-name))) - ;; (handle-exceptions - ;; exn - ;; (if (> remtries 0) - ;; (begin - ;; (set! remtries (- remtries 1)) - ;; (thread-sleep! 10) - ;; (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1))) - ;; (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) - ;; (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up") - ;; (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") - ;; (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - ;; (print "exn=" (condition->list exn)) - ;; (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - ;; (print-call-chain))) - ;; (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 run-id test-id cpuload diskfree minutes uname hostname) (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname))) ;; (define (tests:set-partial-meta-info test-id run-id minutes work-area) (define (tests:set-partial-meta-info test-id run-id minutes work-area remtries) (let* ((cpuload (get-cpu-load)) @@ -679,20 +658,22 @@ (remtries 10)) (handle-exceptions exn (if (> remtries 0) (begin + (print-call-chain (current-error-port)) + (debug:print-info 0 "WARNING: failed to set meta info. Will try " remtries " more times") (set! remtries (- remtries 1)) (thread-sleep! 10) (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1))) (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up") (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (print-call-chain))) + (print-call-chain (current-error-port)))) (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) ))) ;;====================================================================== ;; A R C H I V I N G Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -19,11 +19,14 @@ # The NEWTARGET causes some tests to fail. Do not use until this is fixed. NEWTARGET = "$(OS)/$(FS)/$(VER)" TARGET = "ubuntu/nfs/none" -all : test1 test2 test3 test4 test5 test6 test7 test8 test9 +all : unit test1 test2 test3 test4 test5 test6 test7 test8 test9 + +unit : + ./rununittest.sh basicserver $(DEBUG) server : cd ..;make -j;make install cd fullrun;$(MEGATEST) -server - -debug $(DEBUG) -run-id $(RUNID) @@ -166,19 +169,22 @@ cd fullrun;$(BINPATH)/dashboard -rows 15 & dashboard : cleanprep cd fullrun && $(BINPATH)/dashboard -rows $(ROWS) & +newdashboard : cleanprep + cd fullrun && $(BINPATH)/newdashboard & + remove : cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -itempatt % :sysname % :fsname % :datapath % clean : rm cleanprep kill : killall -v mtest main.sh dboard || true - rm -rf *run/db/* */megatest.db */logging.db */monitor.db fullrun/tmp/mt_*/* fullrun/tmp/mt_*/.db* fullrun/logs/*.log fullrun/*.log || true + rm -rf /tmp/.$(USER)-portlogger.db *run/db/* */megatest.db */logging.db */monitor.db fullrun/tmp/mt_*/* fullrun/tmp/mt_*/.db* fullrun/logs/*.log fullrun/*.log || true killall -v mtest dboard || true hardkill : kill sleep 2;killall -v mtest main.sh dboard -9 Index: tests/fdktestqa/testqa/Makefile ================================================================== --- tests/fdktestqa/testqa/Makefile +++ tests/fdktestqa/testqa/Makefile @@ -1,9 +1,10 @@ BINDIR = $(PWD)/../../../bin PATH := $(BINDIR):$(PATH) MEGATEST = $(BINDIR)/megatest DASHBOARD = $(BINDIR)/dashboard +NEWDASHBOARD = $(BINDIR)/newdashboard RUNNAME = a all : $(MEGATEST) -remove-runs -target a/b :runname c -testpatt %/% @@ -24,11 +25,14 @@ $(MEGATEST) -runtests bigrun3 -target a/bigrun3 :runname $(RUNNAME) dashboard : $(DASHBOARD) -rows 20 & +newdashboard : + $(NEWDASHBOARD) & + compile : (cd ../../..;make -j && make install) clean : rm -rf ../simple*/*/* megatest.db db/* ../simple*/.db/* logs/* monitor.db Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -61,11 +61,11 @@ # or for hard links # testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. # FULL or 2, NORMAL or 1, OFF or 0 -synchronous OFF +synchronous 0 # Throttle roughly scales the db access milliseconds to seconds delay throttle 0.2 # Max retries allows megatest to re-check that a tests status has changed # as tests can have transient FAIL status occasionally maxretries 20 @@ -124,19 +124,27 @@ MAX_ALLOWED_LOAD 200 # XTERM [system xterm] # RUNDEAD [system exit 56] [server] +synchronous 0 # If the server can't be started on this port it will try the next port until # it succeeds port 8080 # This server will keep running this number of hours after last access. # Three minutes is 0.05 hours # timeout 0.025 -timeout 0.01 +timeout 0.1 + +# Server is required - slower but more resistant to Sqlite issues. +# required yes + +# Start server when average query takes longer than this +server-query-threshold 100 +# 55500 # daemonize yes # hostname #{scheme (get-host-name)} ## disks are: Index: tests/rununittest.sh ================================================================== --- tests/rununittest.sh +++ tests/rununittest.sh @@ -4,14 +4,20 @@ # # Ensure all is made (cd ..;make && make install) +# put megatest on path from correct location +mtbindir=$(readlink -f ../bin) + +export PATH="${mtbindir}:$PATH" + # Clean setup # -rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db -rm -rf simplelinks/ simpleruns/ simplerun/db/ +dbdir=$(cd simplerun;megatest -show-config -section setup -var linktree)/.db +rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db $dbdir/*.db +rm -rf simplelinks/ simpleruns/ simplerun/db/ $dbdir mkdir -p simplelinks simpleruns (cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm) # Run the test $1 is the unit test to run cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1 Index: tests/simplerun/megatest.config ================================================================== --- tests/simplerun/megatest.config +++ tests/simplerun/megatest.config @@ -10,11 +10,11 @@ # be aware that some unit tests will fail with this due to persistent data # # tmpdb /tmp # This is your link path, you can move it but it is generally better to keep it stable -linktree #{shell readlink -f #{getenv PWD}/../simplelinks} +linktree #{getenv MT_RUN_AREA_HOME}/../simplelinks # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] state start end completed @@ -27,6 +27,6 @@ [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] -disk0 #{shell readlink -f #{getenv PWD}/../simpleruns} +disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -24,17 +24,17 @@ (lambda (file) (print "Loading " file) (load file)) files)) -(define *runremote* #f) - (let* ((unit-test-name (list-ref (argv) 4)) (fname (conc "../unittests/" unit-test-name ".scm"))) (if (file-exists? fname) (load fname) (print "ERROR: Unit test " unit-test-name " not found in unittests directory"))) + + (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/" "%abc%") (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a" "abc") (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b" "abc") (list #t #t #t #f #f #t #t #t #f #t #t #t #f #t)) Index: tests/unittests/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -2,113 +2,219 @@ ;; S E R V E R ;;====================================================================== ;; Run like this: ;; -;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) - -(set! *transport-type* 'http) - -(test "setup for run" #t (begin (setup-for-run) - (string? (getenv "MT_RUN_AREA_HOME")))) - -(test "server-register, get-best-server" #t (let ((res #f)) - (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) - (set! res (open-run-close tasks:get-best-server tasks:open-db)) - (number? (vector-ref res 3)))) - -(test "de-register server" #f (let ((res #f)) - (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) - (vector? (open-run-close tasks:get-best-server tasks:open-db)))) - -(define server-pid #f) - -;; Not sure how the following should work, replacing it with system of megatest -server -;; (test "launch server" #t (let ((pid (process-fork (lambda () -;; ;; (daemon:ize) -;; (server:launch 'http))))) -;; (set! server-pid pid) -;; (number? pid))) -(system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") - -(let loop ((n 10)) - (thread-sleep! 1) ;; need to wait for server to start. - (let ((res (open-run-close tasks:get-best-server tasks:open-db))) - (print "tasks:get-best-server returned " res) - (if (and (not res) - (> n 0)) - (loop (- n 1))))) - -(test "get-best-server" #t (begin - (client:launch) - (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) - (vector? dat)))) - -(define *keys* (keys:config-get-fields *configdat*)) -(define *keyvals* (keys:target->keyval *keys* "a/b/c")) - -(test #f #t (string? (car *runremote*))) -(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) - -(test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test - -;; RUNS -(test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) -(test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) - (vector-ref (vector-ref rinfo 1) 3))) -(test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) - -;; TESTS -(test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) -(test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) -(test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) -(test "get test id" 1 (rmt:get-test-id 1 "test1" "")) -(test "sync back" #t (> (rmt:sync-inmem->db) 0)) -(test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) -(test "get keys" #t (list? (rmt:get-keys))) -(test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) -(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) - (db:test-get-comment trec))) - -;; MORE RUNS -(test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) - (header (vector-ref runs 0)) - (data (vector-ref runs 1))) - (and (list? header) - (list? data) - (vector? (car data))))) - -(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) -(test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) - -;;====================================================================== -;; D B -;;====================================================================== - -(test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) -(test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) - (+ (db:test-get-pass_count dat) - (db:test-get-fail_count dat)))) - -(define testregistry (make-hash-table)) -(for-each - (lambda (tname) - (for-each - (lambda (itempath) - (let ((tkey (conc tname "/" itempath)) - (rpass (random 10)) - (rfail (random 10))) - (hash-table-set! testregistry tkey (list tname itempath)) - (rmt:general-call 'register-test 1 tname itempath) - (let* ((tid (rmt:get-test-id 1 tname itempath)) - (tdat (rmt:get-test-info-by-id tid))) - (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) - (let* ((resdat (rmt:get-test-info-by-id tid))) - (test "set/get pass fail counts" (list rpass rfail) - (list (db:test-get-pass_count resdat) - (db:test-get-fail_count resdat))))))) - (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) - (list "test1" "test2" "test3" "test4" "test5")) - - -(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) - +;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) + +(delete-file* "logs/1.log") +(define run-id 1) + +(test "setup for run" #t (begin (launch:setup-for-run) + (string? (getenv "MT_RUN_AREA_HOME")))) + +;; NON Server tests go here + +(test #f #f (db:dbdat-get-path *db*)) +(test #f #f (db:get-run-name-from-id *db* run-id)) +(test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) + +;; (exit) + +;; Server tests go here +(test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) +(server:kind-run run-id) +(test "did server start within 20 seconds?" + #t + (let loop ((remtries 20) + (running (tasks:server-running-or-starting? (db:delay-if-busy + (tasks:open-db)) + run-id))) + (if running + (> running 0) + (if (> remtries 0) + (begin + (thread-sleep! 1.1) + (loop (- remtries 1) + (tasks:server-running-or-starting? (db:delay-if-busy + (tasks:open-db)) + run-id))))))) + +(test "did server become available" #t + (let loop ((remtries 10) + (res (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) + (if res + (vector? res) + (begin + (if (> remtries 0) + (begin + (thread-sleep! 1.1) + (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) + res))))) + +(define user (current-user-name)) +(define runname "mytestrun") +(define keys (rmt:get-keys)) +(define runinfo #f) +(define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) +(define header (vector "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) + +;; Setup +;; +(test #f #f (not (client:setup run-id))) +(test #f #f (not (hash-table-ref/default *runremote* run-id #f))) + +;; Login +;; +(test #f '(#t "successful login") (rmt:login-no-auto-client-setup (hash-table-ref/default *runremote* run-id #f) run-id)) +(test #f '(#t "successful login") (rmt:login run-id)) + +;; Keys +;; +(test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) + +;; No data in db +;; +(test #f '() (rmt:get-all-run-ids)) +(test #f #f (rmt:get-run-name-from-id run-id)) +(test #f + (let ((runrec (vector #f #f))) + (vector-set! runrec header 0) + (vector-set! runrec (vector #f #f #f #f) 1) + runrec) + (rmt:get-run-info run-id)) + +;; Insert data into db +;; +(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) +;; (test #f #f (rmt:get-runs-by-patt keys runname)) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) + +;; With data in db +;; +(test #f '(1) (rmt:get-all-run-ids)) +(test #f runname (rmt:get-run-name-from-id run-id)) +(test #f + runname + (let ((run-info (rmt:get-run-info run-id))) + (db:get-value-by-header (db:get-rows run-info) + (db:get-header run-info) + "runname"))) + + ;; (vector header (vector "abc" "def" 1 "mytestrun" "new" "n/a" "matt" 1416280640.0)) + +;; test killing server +;; +(tasks:kill-server-run-id run-id) + +(test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) + +;; (test #f #f (client:setup run-id)) + +;; (set! *transport-type* 'http) +;; +;; (test "setup for run" #t (begin (launch:setup-for-run) +;; (string? (getenv "MT_RUN_AREA_HOME")))) +;; +;; (test "server-register, get-best-server" #t (let ((res #f)) +;; (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) +;; (set! res (open-run-close tasks:get-best-server tasks:open-db)) +;; (number? (vector-ref res 3)))) +;; +;; (test "de-register server" #f (let ((res #f)) +;; (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) +;; (vector? (open-run-close tasks:get-best-server tasks:open-db)))) +;; +;; (define server-pid #f) +;; +;; ;; Not sure how the following should work, replacing it with system of megatest -server +;; ;; (test "launch server" #t (let ((pid (process-fork (lambda () +;; ;; ;; (daemon:ize) +;; ;; (server:launch 'http))))) +;; ;; (set! server-pid pid) +;; ;; (number? pid))) +;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") +;; +;; (let loop ((n 10)) +;; (thread-sleep! 1) ;; need to wait for server to start. +;; (let ((res (open-run-close tasks:get-best-server tasks:open-db))) +;; (print "tasks:get-best-server returned " res) +;; (if (and (not res) +;; (> n 0)) +;; (loop (- n 1))))) +;; +;; (test "get-best-server" #t (begin +;; (client:launch) +;; (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) +;; (vector? dat)))) +;; +;; (define *keys* (keys:config-get-fields *configdat*)) +;; (define *keyvals* (keys:target->keyval *keys* "a/b/c")) +;; +;; (test #f #t (string? (car *runremote*))) +;; (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) +;; +;; (test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test +;; +;; ;; RUNS +;; (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) +;; (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) +;; (vector-ref (vector-ref rinfo 1) 3))) +;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) +;; +;; ;; TESTS +;; (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) +;; (test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) +;; (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) +;; (test "get test id" 1 (rmt:get-test-id 1 "test1" "")) +;; (test "sync back" #t (> (rmt:sync-inmem->db) 0)) +;; (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) +;; (test "get keys" #t (list? (rmt:get-keys))) +;; (test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) +;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) +;; (db:test-get-comment trec))) +;; +;; ;; MORE RUNS +;; (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) +;; (header (vector-ref runs 0)) +;; (data (vector-ref runs 1))) +;; (and (list? header) +;; (list? data) +;; (vector? (car data))))) +;; +;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) +;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) +;; +;; ;;====================================================================== +;; ;; D B +;; ;;====================================================================== +;; +;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) +;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) +;; (+ (db:test-get-pass_count dat) +;; (db:test-get-fail_count dat)))) +;; +;; (define testregistry (make-hash-table)) +;; (for-each +;; (lambda (tname) +;; (for-each +;; (lambda (itempath) +;; (let ((tkey (conc tname "/" itempath)) +;; (rpass (random 10)) +;; (rfail (random 10))) +;; (hash-table-set! testregistry tkey (list tname itempath)) +;; (rmt:general-call 'register-test 1 tname itempath) +;; (let* ((tid (rmt:get-test-id 1 tname itempath)) +;; (tdat (rmt:get-test-info-by-id tid))) +;; (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) +;; (let* ((resdat (rmt:get-test-info-by-id tid))) +;; (test "set/get pass fail counts" (list rpass rfail) +;; (list (db:test-get-pass_count resdat) +;; (db:test-get-fail_count resdat))))))) +;; (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) +;; (list "test1" "test2" "test3" "test4" "test5")) +;; +;; +;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) +;; + +(exit) Index: tree.scm ================================================================== --- tree.scm +++ tree.scm @@ -88,10 +88,11 @@ (nodenum (tree:find-node obj newpath))) ;; Add the branch under lastnode if not found (if (not nodenum) (begin (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) + ;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE? (if userdata (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) (if (null? tal) #t ;; reset to top @@ -112,10 +113,15 @@ (newpath (append trimpath (list node-title)))) (if (>= currnode nodenum) newpath (loop (+ currnode 1) newpath))))) + +(define (tree:delete-node obj top node-path) ;; node-path is a list of strings + (let ((id (tree:find-node obj (cons top node-path)))) + (print "Found node to remove " id " for path " top " " node-path) + (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED"))) #| (let* ((tb (iup:treebox #:value 0