Overview
Comment: | Merging in v1.60-zero-local-access to v1.60 |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | v1.60-zero-local-access |
Files: | files | file ages | folders |
SHA1: |
c6c921401ea6c363e3316865c685bed7 |
User & Date: | matt on 2015-11-11 23:00:14 |
Other Links: | branch diff | manifest | tags |
Context
2015-11-11
| ||
23:00 | Merging in v1.60-zero-local-access to v1.60 Closed-Leaf check-in: c6c921401e user: matt tags: v1.60-zero-local-access | |
22:58 | Added simple lock to on-exit call of sync to megatest.db. Set lots of vars when triggers are called. check-in: 2bae638e0f user: matt tags: v1.60-zero-local-access | |
20:47 | All states supported now check-in: ab348d3b46 user: matt tags: v1.60 | |
Changes
Modified api.scm from [7425d00411] to [d2df3c2dd1].
︙ | ︙ | |||
214 215 216 217 218 219 220 221 222 223 224 225 226 227 | ((get-runs) (apply db:get-runs dbstruct params)) ((get-num-runs) (apply db:get-num-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)) ((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)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) ;; MISC ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) | > | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 | ((get-runs) (apply db:get-runs dbstruct params)) ((get-num-runs) (apply db:get-num-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)) ((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)) ;; MISC ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) |
︙ | ︙ |
Modified common.scm from [2955bbfc6b] to [2d3a0413db].
︙ | ︙ | |||
266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 | ;;====================================================================== ;; 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 "-server") (args:get-arg "-set-run-status") (args:get-arg "-remove-runs") (args:get-arg "-get-run-status") )) (define (common:legacy-sync-required) (configf:lookup *configdat* "setup" "megatest-db")) (define (std-exit-procedure) | > > > > > > > > | | > | > > > > | 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | ;;====================================================================== ;; 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") )) (define (common:legacy-sync-required) (configf:lookup *configdat* "setup" "megatest-db")) (define (std-exit-procedure) ;; (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)) (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")) ;; 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 (sqlite3:interrupt! *megatest-db*) (sqlite3:finalize! *megatest-db* #t) |
︙ | ︙ |
Modified dashboard.scm from [3d081ca889] to [7bcb6b3970].
︙ | ︙ | |||
88 89 90 91 92 93 94 | (print "Failed to find megatest.config, exiting") (exit 1))) (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")) | | > > | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | (print "Failed to find megatest.config, exiting") (exit 1))) (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* (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*))) (define toplevel #f) (define dlg #f) |
︙ | ︙ |
Modified db.scm from [3b21c0f4f0] to [d10bf78e86].
︙ | ︙ | |||
136 137 138 139 140 141 142 | ;; (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) ;; (define (db:dbfile-path run-id) | > | > | > > > > > | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 | ;; (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) ;; (define (db:dbfile-path run-id) (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 (begin (debug:print 0 "ERROR: Couldn't create path to " dbdir) |
︙ | ︙ | |||
1820 1821 1822 1823 1824 1825 1826 | "SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") (reverse run-ids))))) ;; get some basic run stats ;; ;; ( (runname (( state count ) ... )) ;; ( ... | | | | < < < < < < < < < < < | | | | | | | | | | | | | | | | | | | < | 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 | "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 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) (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)) ;; db:get-runs-by-patt ;; get runs by list of criteria |
︙ | ︙ | |||
3160 3161 3162 3163 3164 3165 3166 | (hash-table-set! tests-hash full-testname testdat)))) results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) (define (db:delay-if-busy dbdat #!key (count 6)) | | | 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 | (hash-table-set! tests-hash full-testname testdat)))) results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) (define (db:delay-if-busy dbdat #!key (count 6)) (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"))) (if (handle-exceptions exn |
︙ | ︙ |
Modified dcommon.scm from [5d1caffec5] to [f2eb55f8d3].
︙ | ︙ | |||
398 399 400 401 402 403 404 | general-matrix)) (define (dcommon:run-stats dbstruct) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) (updater (lambda () | | > > | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 | general-matrix)) (define (dcommon:run-stats dbstruct) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) (updater (lambda () (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 (apply max (map cadr col-indices)))) (max-visible (max (- *num-tests* 15) 3)) |
︙ | ︙ |
Modified megatest.scm from [47f4506230] to [c312c4165d].
︙ | ︙ | |||
322 323 324 325 326 327 328 | ;; The watchdog is to keep an eye on things like db sync etc. ;; (define *time-zero* (current-seconds)) (define *watchdog* (make-thread (lambda () (thread-sleep! 0.05) ;; delay for startup | | | | > > > | > > | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 | ;; The watchdog is to keep an eye on things like db sync etc. ;; (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)) (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))) (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))) (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 ;; (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))))) |
︙ | ︙ | |||
360 361 362 363 364 365 366 | (debug:print-info 4 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) (if (and (not *time-to-exit*) | | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 | (debug:print-info 4 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) (if (and (not *time-to-exit*) (< count 40)) ;; aprox 30-40 seconds (begin (thread-sleep! 1) (delay-loop (+ count 1)))) (loop))) (if (common:low-noise-print 30) (debug:print-info 0 "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))) "Watchdog thread"))) |
︙ | ︙ |
Modified mt.scm from [d7eb2f40fc] to [3fc7d68694].
︙ | ︙ | |||
143 144 145 146 147 148 149 150 151 152 153 154 155 156 | (file-exists? test-rundir) (directory? test-rundir)) (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 () (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"))) (if cmd ;; Putting the commandline into ( )'s means no control over the shell. | > | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 | (file-exists? test-rundir) (directory? test-rundir)) (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"))) (if cmd ;; Putting the commandline into ( )'s means no control over the shell. |
︙ | ︙ |
Modified rmt.scm from [58033889c8] to [1253a2efe8].
︙ | ︙ | |||
620 621 622 623 624 625 626 627 628 629 630 631 632 633 | (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) (if (null? results) #f (car results)))))))))) ;;====================================================================== ;; S T E P S ;;====================================================================== ;; Getting steps is more complicated. ;; ;; If given work area | > > > > > > > > > > > > > > > > > > > > | 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 | (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) (if (null? results) #f (car results)))))))))) ;; 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. ;; ;; If given work area |
︙ | ︙ |