Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -216,10 +216,11 @@ ((get-all-run-ids) (db:get-all-run-ids dbstruct)) ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) + ((get-run-stats) (apply db:get-run-stats dbstruct params)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -268,10 +268,11 @@ ;; E X I T H A N D L I N G ;;====================================================================== (define (common:legacy-sync-recommended) (or (args:get-arg "-runtests") + (args:get-arg "-run") (args:get-arg "-server") (args:get-arg "-set-run-status") (args:get-arg "-remove-runs") (args:get-arg "-get-run-status") )) @@ -278,12 +279,19 @@ (define (common:legacy-sync-required) (configf:lookup *configdat* "setup" "megatest-db")) (define (std-exit-procedure) - (let ((no-hurry (if *time-to-exit* ;; hurry up - #f + ;; (let ((dbpath (db:dbfile-path run-id)) + ;; (lockf (conc dbpath "/." run-id ".lck"))) + ;; (common:simple-file-lock lockf) + ;; (db:multi-db-sync (list run-id) 'new2old) + ;; (common:simple-file-release-lock lockf)) + (let* ((dbpath (db:dbfile-path #f)) + (lockf (conc dbpath "/.megatest.lck")) + (no-hurry (if *time-to-exit* ;; hurry up + #f (begin (set! *time-to-exit* #t) #t)))) (debug:print-info 4 "starting exit process, finalizing databases.") (if (and no-hurry (debug:debug-mode 18)) @@ -290,11 +298,16 @@ (rmt:print-db-stats)) (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds (let ((run-ids (hash-table-keys *db-local-sync*))) (if (and (not (null? run-ids)) (configf:lookup *configdat* "setup" "megatest-db")) - (if no-hurry (db:multi-db-sync run-ids 'new2old)))) + ;; was if no-hurry but I always want it sync'd I think ... + ;; (if no-hurry (db:multi-db-sync run-ids 'new2old)))) + (begin + (common:simple-file-lock lockf) + (db:multi-db-sync run-ids 'new2old) + (common:simple-file-release-lock lockf)))) (if *dbstruct-db* (db:close-all *dbstruct-db*)) (if *inmemdb* (db:close-all *inmemdb*)) (if (and *megatest-db* (sqlite3:database? *megatest-db*)) (begin Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -90,12 +90,14 @@ (define *useserver* (or(not (args:get-arg "-use-local")) (configf:lookup *configdat* "dashboard" "use-server"))) (define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) -(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* - local: #t)) +(define *dbstruct-local* (if *useserver* + #f + (make-dbr:dbstruct path: *dbdir* + local: #t))) (define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? *db-file-path*))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -138,12 +138,19 @@ ;; NB// #f => return dbdir only ;; (was planned to be; zeroth db with name=main.db) ;; (define (db:dbfile-path run-id) - (let* ((dbdir (or (configf:lookup *configdat* "setup" "dbdir") - (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) + (let* ((dbdirs (filter string? + (list (configf:lookup *configdat* "setup" "dbdir") + (conc *toppath* "/.db") + (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))) + (existing-dirs (filter file-exists? dbdirs)) + (dbdir (if (null? existing-dirs) + (or (configf:lookup *configdat* "setup" "dbdir") + (conc *toppath* "/.db")) + (car existing-dirs))) (fname (if run-id (if (eq? run-id 0) "main.db" (conc run-id ".db")) #f))) (handle-exceptions exn @@ -1822,50 +1829,38 @@ ;; get some basic run stats ;; ;; ( (runname (( state count ) ... )) ;; ( ... -(define (db:get-run-stats dbstruct) - (let* ((dbdat (db:get-db dbstruct #f)) +(define (db:get-run-stats dbstruct run-id run-name) + (let* ((dbdat (db:get-db dbstruct run-id)) (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 - "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats - ;; 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))) - (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) + ;; (db:delay-if-busy dbdat) + (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)))) (for-each (lambda (state) (set! res (cons (list "Totals" state (hash-table-ref totals state)) res))) (sort (hash-table-keys totals) string>=)) res)) @@ -3162,11 +3157,11 @@ (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) (define (db:delay-if-busy dbdat #!key (count 6)) - (if (not (configf:lookup *configdat* "server" "delay-on-busy")) + (if #f ;; (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"))) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -400,11 +400,13 @@ (define (dcommon:run-stats dbstruct) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) (updater (lambda () - (let* ((run-stats (db:get-run-stats dbstruct)) + (let* ((run-stats (if dbstruct + (db:get-run-stats dbstruct) + (rmt:get-all-run-stats))) (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) (row-indices (car indices)) (col-indices (cadr indices)) (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -324,14 +324,17 @@ (define *time-zero* (current-seconds)) (define *watchdog* (make-thread (lambda () (thread-sleep! 0.05) ;; delay for startup - (let ((legacy-sync (common:legacy-sync-required)) - (debug-mode (debug:debug-mode 1)) - (last-time (current-seconds))) - (if (common:legacy-sync-recommended) + (let* ((legacy-sync (common:legacy-sync-required)) + (debug-mode (debug:debug-mode 1)) + (last-time (current-seconds)) + (dbpath (db:dbfile-path #f)) + (lockf (conc dbpath "/.megatest.lck"))) + (if (or legacy-sync + (common:legacy-sync-recommended)) ;; for now do *some* syncing to megatest.db for backup purposes (let loop () ;; sync for filesystem local db writes ;; (let ((start-time (current-seconds)) (servers-started (make-hash-table))) @@ -340,11 +343,13 @@ (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))) + (common:simple-file-lock lockf) (db:multi-db-sync (list run-id) 'new2old) + (common:simple-file-release-lock lockf) (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 @@ -362,11 +367,11 @@ ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) (if (and (not *time-to-exit*) - (< count 11)) ;; aprox 5-6 seconds + (< count 40)) ;; aprox 30-40 seconds (begin (thread-sleep! 1) (delay-loop (+ count 1)))) (loop))) (if (common:low-noise-print 30) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -145,10 +145,11 @@ (call-with-environment-variables (list (cons "MT_TEST_NAME" test-name) (cons "MT_TEST_RUN_DIR" test-rundir) (cons "MT_ITEMPATH" (db:test-get-item-path test-dat))) (lambda () + (runs:set-megatest-env-vars run-id) ;;; WARNING: This sets a lot of vars!!!! (push-directory test-rundir) (set! tconfig (mt:lazy-read-test-config test-name)) (for-each (lambda (trigger) (let ((cmd (configf:lookup tconfig "triggers" trigger)) (logf (conc test-rundir "/last-trigger.log"))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -622,10 +622,30 @@ (not (null? tal))) (loop (car tal)(cdr tal)) (if (null? results) #f (car results)))))))))) +;; call with run-id #f +;; +(define (rmt:get-all-run-stats) + (let* ((runs-dat (rmt:get-runs "%" #f #f '())) + (header (db:get-header runs-dat)) + (runs (db:get-rows runs-dat))) + (fold (lambda (run currdat) + (let* ((run-id (db:get-value-by-header run header "id")) + (run-name (db:get-value-by-header run header "runname"))) + (if (and run-id run-name) + (append (rmt:get-run-stats run-id run-name) currdat) + (begin + (debug:print 0 "ERROR: Bad run-id or run-name in " run) + currdat)))) + '() + runs))) + +(define (rmt:get-run-stats run-id run-name) + (rmt:send-receive 'get-run-stats run-id (list run-id run-name))) + ;;====================================================================== ;; S T E P S ;;====================================================================== ;; Getting steps is more complicated.