Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -99,10 +99,15 @@ ;; these come from processmod ;; ;; (define setenv set-environment-variable!) ;; (define unsetenv unset-environment-variable!) ;; (define getenv get-environment-variable) + +;; move all the miscellanea into this struct +;; +(defstruct runs:gendat inc-results inc-results-last-update inc-results-fmt run-info runname target) + (define *bdat* #f) ;; the one and only (someday) global? (defstruct bdat (home (getenv "HOME")) @@ -113,10 +118,13 @@ (target #f) (this-exe-fullpath #f) (this-exe-dir #f) (this-exe-name #f) (orig-env #f) + + ;; runs stuff + (runs-data #f) ;; was runs:general-data ;; (server-loop-heart-beat (current-seconds)) ) ;; move all needed initialization into here ;; break it into pieces if need be later @@ -127,10 +135,20 @@ ;; bdat stuff (bdat-this-exe-fullpath-set! bdat fullp) (bdat-this-exe-dir-set! bdat (pathname-directory fullp)) (bdat-this-exe-name-set! bdat (pathname-strip-directory fullp)) (bdat-orig-env-set! bdat (get-the-original-environment)) + ;; setup runs-data + (bdat-runs-data-set! bdat (make-runs:gendat + inc-results: (make-hash-table) + inc-results-last-update: 0 + ;; state status time duration test-name item-path + inc-results-fmt: "~12a~12a~20a~12a~40a\n" + run-info: #f + runname: #f + target: #f)) + (set! *bdat* bdat) ;; set up signal handlers (set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) ;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! @@ -332,10 +350,43 @@ (define *verbosity* 1) (define *logging* #f) (define *common:thread-punchlist* (make-hash-table)) + +(define *last-num-running-tests* 0) +(define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run +(define *runs:denoise* (make-hash-table)) ;; key => last-time-ran + +(define runs:nothing-left-in-queue-count 0) + +(define *max-tries-hash* (make-hash-table)) + +(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id + +(define *db:process-queue-mutex* (make-mutex)) +(define *http-functions* (make-hash-table)) +(define *http-mutex* (make-mutex)) + +;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here +;; I'm pretty sure it is defunct. + +;; This next block all imported en-mass from the api branch +(define *http-requests-in-progress* 0) +(define *http-connections-next-cleanup* (current-seconds)) + +(define *number-of-writes* 0) +(define *number-non-write-queries* 0) + +;; NB// #f => return dbdir only +;; (was planned to be; zeroth db with name=main.db) +;; +;; If run-id is #f return to create and retrieve the path where the db will live. +;; +;; (define db:dbfile-path common:get-db-tmp-area) +(define *global-db-store* (make-hash-table)) + ;;====================================================================== ;; end globals ;;====================================================================== Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -96,13 +96,10 @@ ;; (include "db_records.scm") (include "key_records.scm") ;; (include "run_records.scm") -(define *number-of-writes* 0) -(define *number-non-write-queries* 0) - ;;====================================================================== ;; R E C O R D S ;;====================================================================== ;; each db entry is a pair ( db . dbfilepath ) @@ -208,11 +205,11 @@ ;; inuse gets set automatically for rundb's ;; (define (db:get-db dbstruct) ;; run-id) (if (stack? (dbr:dbstruct-dbstack dbstruct)) (if (stack-empty? (dbr:dbstruct-dbstack dbstruct)) - (let ((newdb (db:open-megatest-db path: (db:dbfile-path)))) + (let ((newdb (db:open-megatest-db path: (common:get-db-tmp-area)))) ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb) newdb) (stack-pop! (dbr:dbstruct-dbstack dbstruct))) (db:open-db dbstruct))) @@ -225,14 +222,14 @@ (define (db:dbdat-get-path dbdat) (if (pair? dbdat) (cdr dbdat) #f)) -(define-inline (db:generic-error-printout exn . message) +(define (db:generic-error-printout exn . message) (print-call-chain (current-error-port)) (apply debug:print-error 0 *default-log-port* message) - (debug:print-error 0 *default-log-port* " params: " params + (debug:print-error 0 *default-log-port* ;; " params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", arguments: " ((condition-property-accessor 'exn 'arguments) exn) ", location: " ((condition-property-accessor 'exn 'location) exn) )) @@ -296,17 +293,10 @@ ;; ;; ;; (define (db:get-path dbstruct id) ;; (let ((fdb (db:get-filedb dbstruct))) ;; (filedb:get-path db id))) -;; NB// #f => return dbdir only -;; (was planned to be; zeroth db with name=main.db) -;; -;; If run-id is #f return to create and retrieve the path where the db will live. -;; -(define db:dbfile-path common:get-db-tmp-area) - (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) ;; open an sql database inside a file lock @@ -390,11 +380,11 @@ (define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct (if (stack? tmpdb-stack) (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used (let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10)) - (dbpath (db:dbfile-path )) ;; path to tmp db area + (dbpath (common:get-db-tmp-area )) ;; path to tmp db area (dbexists (common:file-exists? dbpath)) (tmpdbfname (conc dbpath "/megatest.db")) (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db"))) @@ -1056,12 +1046,10 @@ db (conc "UPDATE runs SET " column "='x' WHERE " column "='';")) (set! field-num (+ field-num 1)))) fields))) -(define *global-db-store* (make-hash-table)) - (define (db:get-access-mode) (if (args:get-arg "-use-db-cache") 'cached 'rmt)) ;; Add db direct ;; @@ -2214,11 +2202,11 @@ ;;====================================================================== ;; no-sync.db - small bits of data to be shared between servers ;;====================================================================== (define (db:open-no-sync-db) - (let* ((dbpath (db:dbfile-path)) + (let* ((dbpath (common:get-db-tmp-area)) (dbname (conc dbpath "/no-sync.db")) (db-exists (common:file-exists? dbname)) (db (sqlite3:open-database dbname))) (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) (if (not db-exists) @@ -2522,11 +2510,11 @@ res)) ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) ;; (define (db:get-changed-run-ids since-time) - (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir")) + (let* ((dbdir (common:get-db-tmp-area)) ;; (configf:lookup *configdat* "setup" "dbdir")) (alldbs (glob (conc dbdir "/[0-9]*.db"))) (changed (filter (lambda (dbfile) (> (file-modification-time dbfile) since-time)) alldbs))) (delete-duplicates @@ -3447,10 +3435,11 @@ indx (if (null? tal) #f (loop (car tal)(cdr tal)(+ indx 1))))))) +;; CONVERT THIS TO A FUNCTION! (define db:test-record-qry-selector (string-intersperse db:test-record-fields ",")) (define (db:update-tesdata-on-repilcate-db dbstruct old-lt new-lt) (db:with-db dbstruct #f #f Index: http-transportmod.scm ================================================================== --- http-transportmod.scm +++ http-transportmod.scm @@ -122,12 +122,10 @@ ;; ====================================================================== ;; Call this to start the actual server ;; -(define *db:process-queue-mutex* (make-mutex)) -(define *http-functions* (make-hash-table)) (define (http-get-function fnkey) (hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet"))) (define (http-transport:run hostn) ;; Configurations for server @@ -257,18 +255,10 @@ ;;====================================================================== ;; C L I E N T S ;;====================================================================== -(define *http-mutex* (make-mutex)) - -;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here -;; I'm pretty sure it is defunct. - -;; This next block all imported en-mass from the api branch -(define *http-requests-in-progress* 0) -(define *http-connections-next-cleanup* (current-seconds)) (define (http-transport:get-time-to-cleanup) (let ((res #f)) (mutex-lock! *http-mutex*) (set! res (> (current-seconds) *http-connections-next-cleanup*)) Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -143,12 +143,10 @@ (client:setup areapath) #f)))) ;;====================================================================== -(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id - ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected #;(common:telemetry-log (conc "rmt:"(->string cmd)) @@ -453,11 +451,11 @@ (mutex-unlock! *db-stats-mutex*) res)) (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) (let* ((qry-is-write (not (member cmd api:read-only-queries))) - (db-file-path (db:dbfile-path)) ;; 0)) + (db-file-path (common:get-db-tmp-area)) ;; 0)) (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) (read-only (not (file-writable? db-file-path))) (start (current-milliseconds)) (resdat (if (not (and read-only qry-is-write)) (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) Index: runsmod.scm ================================================================== --- runsmod.scm +++ runsmod.scm @@ -207,11 +207,10 @@ ;; Every time can-run-more-tests is called increment the delay ;; ;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine ;; -(define *last-num-running-tests* 0) ;; (define *runs:can-run-more-tests-count* 0) (define (runs:shrink-can-run-more-tests-count runsdat) (runs:dat-can-run-more-tests-count-set! runsdat 0)) (define (runs:inc-can-run-more-tests-count runsdat) @@ -221,20 +220,17 @@ ;; (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2))) ;; Temporary globals. Move these into the logic or into common ;; -(define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run (define (runs:inc-cant-run-tests testname) (hash-table-set! *seen-cant-run-tests* testname (+ (hash-table-ref/default *seen-cant-run-tests* testname 0) 1))) (define (runs:can-keep-running? testname n) (< (hash-table-ref/default *seen-cant-run-tests* testname 0) n)) -(define *runs:denoise* (make-hash-table)) ;; key => last-time-ran - ;; mechanism to limit printing info to the screen that is repetitive. ;; ;; Example: ;; (if (runs:lownoise "waiting on tasks" 60) ;; (debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ...")) @@ -1252,34 +1248,21 @@ t)) ((DELETED) #f) (else t))))) tests)) -;; move all the miscellanea into this struct -;; -(defstruct runs:gendat inc-results inc-results-last-update inc-results-fmt run-info runname target) - -(define *runs:general-data* - (make-runs:gendat - inc-results: (make-hash-table) - inc-results-last-update: 0 - inc-results-fmt: "~12a~12a~20a~12a~40a\n" ;; state status time duration test-name item-path - run-info: #f - runname: #f - target: #f - ) - ) - (define (runs:incremental-print-results run-id) - (let ((curr-sec (current-seconds)) - (last-update (runs:gendat-inc-results-last-update *runs:general-data*))) + (let* ((curr-sec (current-seconds)) + (runs-data (bdat-runs-data *bdat*)) + (last-update (runs:gendat-inc-results-last-update runs-data)) + (runs-data (bdat-runs-data *bdat*))) (if (> (- curr-sec last-update) 5) ;; at least five seconds since last update - (let* ((run-dat (or (runs:gendat-run-info *runs:general-data*)(rmt:get-run-info run-id))) - (runname (or (runs:gendat-runname *runs:general-data*) + (let* ((run-dat (or (runs:gendat-run-info runs-data)(rmt:get-run-info run-id))) + (runname (or (runs:gendat-runname runs-data) (db:get-value-by-header (db:get-rows run-dat) (db:get-header run-dat) "runname"))) - (target (or (runs:gendat-target *runs:general-data*)(rmt:get-target run-id))) + (target (or (runs:gendat-target runs-data)(rmt:get-target run-id))) (testsdat (let ((res (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses #f #f ;; offset limit #f ;; not-in #f ;; sort-by @@ -1292,21 +1275,21 @@ (begin (debug:print-error 0 *default-log-port* "FAILED TO GET DATA using rmt:get-tests-for-run. Notify developers if you see this. result: " res) '()))))) - (runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 1)) - (if (not (runs:gendat-run-info *runs:general-data*)) - (runs:gendat-run-info-set! *runs:general-data* run-dat)) - (if (not (runs:gendat-runname *runs:general-data*)) - (runs:gendat-runname-set! *runs:general-data* runname)) - (if (not (runs:gendat-target *runs:general-data*)) - (runs:gendat-target-set! *runs:general-data* target)) + (runs:gendat-inc-results-last-update-set! runs-data (- curr-sec 1)) + (if (not (runs:gendat-run-info runs-data)) + (runs:gendat-run-info-set! runs-data run-dat)) + (if (not (runs:gendat-runname runs-data)) + (runs:gendat-runname-set! runs-data runname)) + (if (not (runs:gendat-target runs-data)) + (runs:gendat-target-set! runs-data target)) (for-each (lambda (testdat) (let* ((test-id (db:test-get-id testdat)) - (prevdat (hash-table-ref/default (runs:gendat-inc-results *runs:general-data*) + (prevdat (hash-table-ref/default (runs:gendat-inc-results runs-data) (conc run-id "," test-id) #f)) (test-name (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (state (db:test-get-state testdat)) (status (db:test-get-status testdat)) @@ -1314,11 +1297,11 @@ (duration (db:test-get-run_duration testdat))) (if (and (not (member state '("DELETED" "REMOTEHOSTSTART" "RUNNING" "LAUNCHED""NOT_STARTED"))) (not (and prevdat (equal? state (db:test-get-state prevdat)) (equal? status (db:test-get-status prevdat))))) - (let ((fmt (runs:gendat-inc-results-fmt *runs:general-data*)) + (let ((fmt (runs:gendat-inc-results-fmt runs-data)) (dtime (seconds->year-work-week/day-time event-time))) (if (runs:lownoise "inc-print" 600) (format #t fmt "State" "Status" "Start Time" "Duration" "Test path")) ;; (debug:print 0 *default-log-port* "fmt: " fmt " state: " state " status: " status " test-name: " test-name " item-path: " item-path " dtime: " dtime) ;; (debug:print 0 #f "event-time: " event-time " duration: " duration) @@ -1326,22 +1309,21 @@ state status dtime (seconds->hr-min-sec duration) (conc "lt/" target "/" runname "/" test-name (if (string-null? item-path) "" (conc "/" item-path)))) - (hash-table-set! (runs:gendat-inc-results *runs:general-data*) (conc run-id "," test-id) testdat))))) + (hash-table-set! (runs:gendat-inc-results runs-data) (conc run-id "," test-id) testdat))))) testsdat))) ;; I don't think this should be here? -- Matt - #;(runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 10)) + #;(runs:gendat-inc-results-last-update-set! runs-data (- curr-sec 10)) )) ;; every time though the loop increment the test/itempatt val. ;; when the min is > max-allowed and none running then force exit ;; -(define *max-tries-hash* (make-hash-table)) (define (runs:pretty-long-list lst) (if (> (length lst) 8)(append (take lst 3)(list "...")) lst)) ;;====================================================================== Index: tasksmod.scm ================================================================== --- tasksmod.scm +++ tasksmod.scm @@ -166,11 +166,11 @@ (tasks:open-db numretries (- numretries 1))) (begin (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* " exn=" (condition->list exn)))) - (let* ((dbpath (db:dbfile-path )) ;; (tasks:get-task-db-path)) + (let* ((dbpath (common:get-db-tmp-area )) ;; (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 (common:file-exists? dbpath)) (write-access (file-writable? dbpath)) (mdb (cond ;; what the hek is *toppath* doing here? @@ -324,11 +324,11 @@ ;; #;(define (tasks:start-monitor db mdb) (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more (debug:print-info 1 *default-log-port* "Not starting monitor, already have more than two running") (let* ((megatestdb (conc *toppath* "/megatest.db")) - (monitordbf (conc (db:dbfile-path #f) "/monitor.db")) + (monitordbf (conc (common:get-db-tmp-area) "/monitor.db")) (last-db-update 0)) ;; (file-modification-time megatestdb))) (task:register-monitor mdb) (let loop ((count 0) (next-touch 0)) ;; next-touch is the time where we need to update last_update ;; if the db has been modified we'd best look at the task queue