Changes In Branch matt-db-sync-2 Through [828d218b23] Excluding Merge-Ins
This is equivalent to a diff from efa4004401 to 828d218b23
2016-11-04
| ||
20:02 | Merged in 828d2 Closed-Leaf check-in: 2444b3e509 user: matt tags: v1.62-side | |
2016-10-31
| ||
23:17 | Commented out line used for debugging check-in: d37abcb490 user: matt tags: v1.62-side | |
17:18 | Watchdog enabled. Duplicate overlapping runs of sync-to prevented. check-in: 95a867e2e7 user: mrwellan tags: matt-db-sync-2, v1.62-side | |
15:42 | Added the refactored watchdog back check-in: 828d218b23 user: mrwellan tags: matt-db-sync-2, v1.62-side | |
13:56 | db cache can do a sync to megatest.db if it has write access. The db timestamps are used to minimize burden but this is still likely not a good idea and should be removed. check-in: 12001d6988 user: mrwellan tags: matt-db-sync-2, v1.62-side | |
10:21 | Refactoring commit 92a15e into matt-db-sync-2. Updated api list of read-only queries. check-in: 80c6955310 user: mrwellan tags: matt-db-sync-2, v1.62-side | |
09:55 | Bring in working parts of cached-db to v1.62 check-in: efa4004401 user: mrwellan tags: v1.62-side | |
2016-10-30
| ||
11:29 | Added check for unrecognised parameters to dashboard and added MT_TESTSUITE_NAME var for all situations. Changed name from MT_TESTSUITENAME check-in: 008a2a445e user: matt tags: v1.62, v1.6206 | |
2016-10-28
| ||
18:04 | Added a color to hex function check-in: 955fb16781 user: mrwellan tags: matt-db-sync | |
Modified api.scm from [bcdab13d33] to [fe7a2f21be].
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | (declare (uses tasks)) ;; allow these queries through without starting a server ;; (define api:read-only-queries '(get-key-val-pairs get-keys test-toplevel-num-items get-test-info-by-id test-get-rundir-from-test-id get-count-tests-running-for-testname get-count-tests-running get-count-tests-running-in-jobgroup get-previous-test-run-record get-matching-previous-test-run-records test-get-logfile-info test-get-records-for-index-file get-testinfo-state-status test-get-top-process-pid test-get-paths-matching-keynames-target-new get-prereqs-not-met get-count-tests-running-for-run-id get-run-info get-run-status | > > > > | > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | (declare (uses tasks)) ;; allow these queries through without starting a server ;; (define api:read-only-queries '(get-key-val-pairs get-keys get-key-vals test-toplevel-num-items get-test-info-by-id test-get-rundir-from-test-id get-count-tests-running-for-testname get-count-tests-running get-count-tests-running-in-jobgroup get-previous-test-run-record get-matching-previous-test-run-records test-get-logfile-info test-get-records-for-index-file get-testinfo-state-status test-get-top-process-pid test-get-paths-matching-keynames-target-new get-prereqs-not-met get-count-tests-running-for-run-id get-run-info get-run-status get-run-stats get-targets get-target ;; register-run get-tests-for-run get-test-id get-tests-for-runs-mindata get-run-name-from-id get-runs get-num-runs get-all-run-ids get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data get-steps-for-test read-test-data login tasks-get-last testmeta-get-record have-incompletes? synchash-get )) (define api:write-queries '( |
︙ | ︙ |
Modified common.scm from [5849a40b64] to [51dcb7dd1a].
︙ | ︙ | |||
383 384 385 386 387 388 389 | (args:get-arg "-use-db-cache") ;; feels like a bad idea ... )) (define (common:legacy-sync-required) (configf:lookup *configdat* "setup" "megatest-db")) ;; run-ids | | | | | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 | (args:get-arg "-use-db-cache") ;; feels like a bad idea ... )) (define (common:legacy-sync-required) (configf:lookup *configdat* "setup" "megatest-db")) ;; run-ids ;; if #f use *db-local-sync* : or 'local-sync-flags ;; if #t use timestamps : or 'timestamps (define (common:sync-to-megatest.db run-ids) (let ((start-time (current-seconds)) (run-ids-to-process (if (list? run-ids) run-ids (if (or (eq? run-ids 'timestamps)(eq? run-ids #t)) (db:get-changed-run-ids (let* ((mtdb-fpath (conc *toppath* "/megatest.db")) (mtdb-exists (file-exists? mtdb-fpath))) (if mtdb-exists (file-modification-time mtdb-fpath) 0))) (hash-table-keys *db-local-sync*))))) (debug:print-info 4 *default-log-port* "Processing run-ids: " run-ids-to-process) |
︙ | ︙ | |||
413 414 415 416 417 418 419 | (debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds") (if (common:low-noise-print 30 "sync new to old") (debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) (hash-table-delete! *db-local-sync* run-id))) (mutex-unlock! *db-multi-sync-mutex*)) run-ids-to-process))) | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 | (debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds") (if (common:low-noise-print 30 "sync new to old") (debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) (hash-table-delete! *db-local-sync* run-id))) (mutex-unlock! *db-multi-sync-mutex*)) run-ids-to-process))) (define (common:watchdog) (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 (or (common:legacy-sync-recommended) legacy-sync) (let loop () ;; sync for filesystem local db writes ;; (let ((start-time (current-seconds))) (common:sync-to-megatest.db 'local-sync-flags) (if (and debug-mode (> (- start-time last-time) 60)) (begin (set! last-time start-time) (debug:print-info 4 *default-log-port* "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 4)) ;; was 11, changing to 4. (begin (thread-sleep! 1) (delay-loop (+ count 1)))) (loop))) (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*)))))) (define (std-exit-procedure) (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) #t)))) |
︙ | ︙ |
Modified dashboard-tests.scm from [269ce18d09] to [1853b426ee].
︙ | ︙ | |||
15 16 17 18 19 20 21 | (use format fmt) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) | | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | (use format fmt) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use srfi-1 posix regex regex-case srfi-69) (use (prefix sqlite3 sqlite3:)) (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) (declare (uses gutils)) (declare (uses rmt)) (declare (uses ezsteps)) |
︙ | ︙ |
Modified dashboard.scm from [a3ba83c9cc] to [3a6a1edeb1].
︙ | ︙ | |||
102 103 104 105 106 107 108 109 110 111 112 113 114 115 | ;; TODO: Move this inside (main) ;; (if (not (launch:setup)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) ;; data common to all tabs goes here ;; (defstruct dboard:commondat ((curr-tab-num 0) : number) please-update tabdats | > > > > > > > > > | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | ;; TODO: Move this inside (main) ;; (if (not (launch:setup)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) ;; create a watch dog to move changes from lt/.db/*.db to megatest.db ;; (if (file-write-access? (conc *toppath* "/megatest.db")) (thread-start! (make-thread common:watchdog "Watchdog thread")) (if (not (args:get-arg "-use-db-cache")) (begin (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") (hash-table-set! args:arg-hash "-use-db-cache" #t)))) ;; data common to all tabs goes here ;; (defstruct dboard:commondat ((curr-tab-num 0) : number) please-update tabdats |
︙ | ︙ |
Modified db.scm from [843bf5a690] to [4f9b8565c3].
︙ | ︙ | |||
87 88 89 90 91 92 93 | ;; if db already open - return inmem ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; (define (db:get-db dbstruct run-id) (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through dbstruct | > > | > | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | ;; if db already open - return inmem ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; (define (db:get-db dbstruct run-id) (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through dbstruct (if (pair? dbstruct) dbstruct ;; pass pair ( db . path ) on through (begin ;; (assert (dbr:dbstruct? dbstruct)) ;; so much legacy, but by here we should have a genuine dbstruct (let ((dbdat (if (or (not run-id) (eq? run-id 0)) (db:open-main dbstruct) (db:open-rundb dbstruct run-id) ))) dbdat))))) ;; legacy handling of structure for managing db's. Refactor this into dbr:? (define (db:dbdat-get-db dbdat) (if (pair? dbdat) (car dbdat) dbdat)) |
︙ | ︙ | |||
319 320 321 322 323 324 325 326 327 328 329 330 331 332 | ;; (define (db:setup run-id #!key (local #f)) (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dbstruct (make-dbr:dbstruct path: dbdir local: local))) dbstruct)) ;; Open the classic megatest.db file in toppath ;; (define (db:open-megatest-db #!key (path #f)) (let* ((dbpath (or path (conc *toppath* "/megatest.db"))) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) | > > | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 | ;; (define (db:setup run-id #!key (local #f)) (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dbstruct (make-dbr:dbstruct path: dbdir local: local))) dbstruct)) ;; Open the classic megatest.db file in toppath ;; ;; NOTE: returns a dbdat not a dbstruct! ;; (define (db:open-megatest-db #!key (path #f)) (let* ((dbpath (or path (conc *toppath* "/megatest.db"))) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) |
︙ | ︙ | |||
811 812 813 814 815 816 817 | (if (eq? access-mode 'cached) (apply db:call-with-cached-db db-cmd params) (apply rmt-cmd params))) ;; return the target db handle so it can be used ;; (define (db:cache-for-read-only source target #!key (use-last-update #f)) | < | 816 817 818 819 820 821 822 823 824 825 826 827 828 829 | (if (eq? access-mode 'cached) (apply db:call-with-cached-db db-cmd params) (apply rmt-cmd params))) ;; return the target db handle so it can be used ;; (define (db:cache-for-read-only source target #!key (use-last-update #f)) (if (and (hash-table-ref/default *global-db-store* target #f) (>= (file-modification-time target)(file-modification-time source))) (hash-table-ref *global-db-store* target) (let* ((toppath (launch:setup)) (targ-db-last-mod (if (file-exists? target) (file-modification-time target) 0)) |
︙ | ︙ | |||
839 840 841 842 843 844 845 | (define (db:call-with-cached-db proc . params) ;; first cache the db in /tmp (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name))) (fname (conc (common:get-area-path-signature) ".db")) (cache-dir (common:get-create-writeable-dir (list (conc "/tmp/" (current-user-name) "/" cname-part) (conc "/tmp/" (current-user-name) "-" cname-part) | | > > > > > > > > > | | > | 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 | (define (db:call-with-cached-db proc . params) ;; first cache the db in /tmp (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name))) (fname (conc (common:get-area-path-signature) ".db")) (cache-dir (common:get-create-writeable-dir (list (conc "/tmp/" (current-user-name) "/" cname-part) (conc "/tmp/" (current-user-name) "-" cname-part) (conc "/tmp/" (current-user-name) "_" cname-part)))) (megatest-db (conc *toppath* "/megatest.db"))) ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir) (if (not cache-dir) (begin (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db") (exit 1)) (let* ((th1 (make-thread (lambda () (if (and (file-exists? megatest-db) (file-write-access? megatest-db)) (begin (common:sync-to-megatest.db 'timestamps) ;; internally mutexes on *db-local-sync* (debug:print-info 2 *default-log-port* "Done syncing to megatest.db")))) "call-with-cached-db sync-to-megatest.db")) (cache-db (db:cache-for-read-only megatest-db (conc cache-dir "/" fname) use-last-update: #t))) (thread-start! th1) (apply proc cache-db params) )))) ;; options: ;; ;; 'killservers - kills all servers ;; 'dejunk - removes junk records |
︙ | ︙ |
Modified rmt.scm from [bb562bf1d7] to [e2c119edf6].
︙ | ︙ | |||
225 226 227 228 229 230 231 | (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 #!key (remretries 5)) | > > | < | < | > | > > > | < < | | | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | (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 #!key (remretries 5)) (let* ((qry-is-write (not (member cmd api:read-only-queries))) (dbdir (db:dbfile-path #f)) (dbstruct-local (if *dbstruct-db* *dbstruct-db* (let* ((db (make-dbr:dbstruct path: dbdir local: #t))) (set! *dbstruct-db* db) db))) (read-only (not (file-write-access? dbdir))) (start (current-milliseconds)) (resdat (if (not (and read-only qry-is-write)) (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)) (vector #t '()))) (success (vector-ref resdat 0)) (res (vector-ref resdat 1)) (duration (- (current-milliseconds) start))) (if (and read-only qry-is-write) (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) (if (not success) (if (> remretries 0) (begin (debug:print-error 0 *default-log-port* "local query failed. Trying again.") (thread-sleep! (/ (random 5000) 1000)) ;; some random delay (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1))) (begin (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up") #f)) (begin ;; (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write (if qry-is-write (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) (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 (handle-exceptions exn #f |
︙ | ︙ |