Overview
Comment: | wip |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.70001-multi-db-rebased |
Files: | files | file ages | folders |
SHA1: |
5b44c9ab44c3d538b0b5e73275d2b7c1 |
User & Date: | mrwellan on 2022-03-10 19:13:21 |
Other Links: | branch diff | manifest | tags |
Context
2022-03-11
| ||
17:43 | wip Closed-Leaf check-in: 0a6c8321d5 user: mrwellan tags: v1.70001-multi-db-rebased | |
2022-03-10
| ||
19:13 | wip check-in: 5b44c9ab44 user: mrwellan tags: v1.70001-multi-db-rebased | |
2022-03-02
| ||
20:46 | Broke out stuff from db.scm that is used for db file management into dbfile.scm check-in: 77c71d1c14 user: matt tags: v1.70001-multi-db-rebased | |
Changes
Modified Makefile from [3c2516e0df] to [ea4c347c2d].
︙ | ︙ | |||
168 169 170 171 172 173 174 | tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm megatest-version.scm | | | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 | tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm megatest-version.scm rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm common_records.scm : altdb.scm # mofiles/stml2.o : mofiles/cookie.o # configf.o : mofiles/commonmod.o vg.o dashboard.o : vg_records.scm megatest-version.scm |
︙ | ︙ |
Modified archive.scm from [35b9e5966e] to [a7e538df23].
︙ | ︙ | |||
395 396 397 398 399 400 401 | (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" )) (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path))) (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path) (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:")) (sleep 2) (db:multi-db-sync | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 | (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" )) (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path))) (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path) (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:")) (sleep 2) (db:multi-db-sync (db:setup-db *dbstruct-dbs* *toppath* #f) 'killservers ;'dejunk ;'adj-testids 'old2new ) (debug:print-info 1 *default-log-port* "dropping triggers to update linktree") (rmt:drop-all-triggers) |
︙ | ︙ |
Modified common.scm from [cf6013c9c1] to [85af3678ab].
︙ | ︙ | |||
589 590 591 592 593 594 595 | ;; Force a megatest cleanup-db if version is changed and skip-version-check not specified ;; Do NOT check if not on homehost! ;; (define (common:exit-on-version-changed) (if (common:on-homehost?) (if (common:api-changed?) (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")) | | | | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 | ;; Force a megatest cleanup-db if version is changed and skip-version-check not specified ;; Do NOT check if not on homehost! ;; (define (common:exit-on-version-changed) (if (common:on-homehost?) (if (common:api-changed?) (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")) (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db")) (read-only (not (file-write-access? dbfile))) (dbstruct (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t))) (debug:print 0 *default-log-port* "WARNING: Version mismatch!\n" " expected: " (common:version-signature) "\n" " got: " (common:get-last-run-version)) (cond ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t) ((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only) |
︙ | ︙ | |||
981 982 983 984 985 986 987 988 989 990 991 992 993 994 | (string-translate *toppath* "/" ".")) )))) (set! *db-cache-path* dbpath) ;; ensure megatest area has .db (let ((dbarea (conc *toppath* "/.db"))) (if (not (file-exists? dbarea)) (create-directory dbarea))) dbpath)) #f))) (define (common:get-area-path-signature) (message-digest-string (md5-primitive) *toppath*)) (define (common:get-signature str) | > > > > | 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 | (string-translate *toppath* "/" ".")) )))) (set! *db-cache-path* dbpath) ;; ensure megatest area has .db (let ((dbarea (conc *toppath* "/.db"))) (if (not (file-exists? dbarea)) (create-directory dbarea))) ;; ensure tmp area has .db (let ((dbarea (conc dbpath "/.db"))) (if (not (file-exists? dbarea)) (create-directory dbarea))) dbpath)) #f))) (define (common:get-area-path-signature) (message-digest-string (md5-primitive) *toppath*)) (define (common:get-signature str) |
︙ | ︙ | |||
1039 1040 1041 1042 1043 1044 1045 | ;;====================================================================== ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage (define (common:watchdog) (debug:print-info 13 *default-log-port* "common:watchdog entered.") (if (launch:setup) (if (common:on-homehost?) | | | 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 | ;;====================================================================== ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage (define (common:watchdog) (debug:print-info 13 *default-log-port* "common:watchdog entered.") (if (launch:setup) (if (common:on-homehost?) (let ((dbstruct (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t))) (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct) (cond ((dbr:dbstruct-read-only dbstruct) (debug:print-info 13 *default-log-port* "loading read-only watchdog") (common:readonly-watchdog dbstruct)) (else (debug:print-info 13 *default-log-port* "loading writable-watchdog.") |
︙ | ︙ | |||
1075 1076 1077 1078 1079 1080 1081 | (begin (set! *time-to-exit* #t) #t)))) (debug:print-info 4 *default-log-port* "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 | | | 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 | (begin (set! *time-to-exit* #t) #t)))) (debug:print-info 4 *default-log-port* "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 (if *dbstruct-dbs* (db:close-all *dbstruct-dbs*)) ;; one second allocated (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) |
︙ | ︙ |
Modified db.scm from [b4305ec98a] to [ea4381cd60].
︙ | ︙ | |||
20 21 22 23 24 25 26 | ;;====================================================================== ;; Database access ;;====================================================================== ;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc | | | > > | > > > > > > > > > | > > > > > | 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 | ;;====================================================================== ;; Database access ;;====================================================================== ;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc (use (srfi 18) extras tcp stack (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest (prefix base64 base64:) format dot-locking z3 typed-records matchable) (declare (unit db)) (declare (uses common)) (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses keys)) (declare (uses ods)) |
︙ | ︙ | |||
289 290 291 292 293 294 295 | (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 (dbname (db:run-id->dbname run-id)) (dbexists (common:file-exists? dbpath)) | | | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 | (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 (dbname (db:run-id->dbname run-id)) (dbexists (common:file-exists? dbpath)) (mtdbfname (conc *toppath* "/"dbname)) (mtdbexists (common:file-exists? mtdbfname)) (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbfname) #f)) (mtdb (db:open-megatest-db mtdbfname)) ;; the reference db for syncing (refdbfname (conc dbpath "/"dbname"_ref")) (refndb (db:open-megatest-db refdbfname)) ;; (mtdbpath (db:dbdat-get-path mtdb)) ;; the tmpdb (tmpdbfname (conc dbpath"/"dbname)) ;; /tmp/<stuff>/.db/[main|1,2...].db (tmpdb (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-db)) (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) |
︙ | ︙ | |||
357 358 359 360 361 362 363 | db "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);") last-update-time)) ;)) ;; set up a single db (e.g. main.db, 1.db ... etc.) ;; | | | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 | db "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);") last-update-time)) ;)) ;; set up a single db (e.g. main.db, 1.db ... etc.) ;; (define (db:setup-db dbstructs areapath run-id) (let* ((dbname (db:run-id->dbname run-id)) (dbstruct (or (hash-table-ref/default dbstructs dbname #f) (make-dbr:dbstruct)))) (db:open-db dbstruct run-id areapath: areapath do-sync: #t) (hash-table-set! dbstructs dbname dbstruct) dbstruct)) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; ;; called in http-transport and replicated in rmt.scm for *local* access. |
︙ | ︙ |
Modified dbfile.scm from [1036dcffd2] to [e09aadfd93].
︙ | ︙ | |||
34 35 36 37 38 39 40 | ;; each db entry is a pair ( db . dbfilepath ) ;; NOTE: Need one dbr:dbstruct per main.db, 1.db ... ;; (defstruct dbr:dbstruct (dbname #f) (dbdats (make-hash-table)) ;; id => dbdat | | | | | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | ;; each db entry is a pair ( db . dbfilepath ) ;; NOTE: Need one dbr:dbstruct per main.db, 1.db ... ;; (defstruct dbr:dbstruct (dbname #f) (dbdats (make-hash-table)) ;; id => dbdat (tmpdb #f) (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack (mtdb #f) (refndb #f) (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) (stmt-cache (make-hash-table)) ) ;; goal is to converge on one struct for an area but for now it is too confusing (defstruct dbr:dbdat (db #f) ;; should rename this to oddb for on disk db (tmpdb #f) (dbhstack #f) ;; do not init with a stack (last-sync 0) |
︙ | ︙ |
Deleted fs-transport.scm version [d1050dcefe].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Modified http-transport.scm from [2202b22e9f] to [3300e19a72].
︙ | ︙ | |||
95 96 97 98 99 100 101 | ;; This is were we set up the database connections (let* (($ (request-vars source: 'both)) (dat ($ 'dat)) (res #f)) (cond ((equal? (uri-path (request-uri (current-request))) '(/ "api")) | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | ;; This is were we set up the database connections (let* (($ (request-vars source: 'both)) (dat ($ 'dat)) (res #f)) (cond ((equal? (uri-path (request-uri (current-request))) '(/ "api")) (send-response body: (api:process-request *dbstruct-dbs* $) ;; the $ is the request vars proc headers: '((content-type text/plain))) (mutex-lock! *heartbeat-mutex*) (set! *db-last-access* (current-seconds)) (mutex-unlock! *heartbeat-mutex*)) ((equal? (uri-path (request-uri (current-request))) '(/ "")) (send-response body: (http-transport:main-page))) |
︙ | ︙ | |||
456 457 458 459 460 461 462 | (with-output-to-file started-file (lambda ()(print (current-process-id))))) (let loop ((count 0) (server-state 'available) (bad-sync-count 0) (start-time (current-milliseconds))) ;; Use this opportunity to sync the tmp db to megatest.db | | | | 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 | (with-output-to-file started-file (lambda ()(print (current-process-id))))) (let loop ((count 0) (server-state 'available) (bad-sync-count 0) (start-time (current-milliseconds))) ;; Use this opportunity to sync the tmp db to megatest.db (if (not server-going) ;; *dbstruct-dbs* (begin (debug:print 0 *default-log-port* "SERVER: dbprep") (set! *dbstruct-dbs* (db:setup #t)) ;; run-id)) FIXME!!! (set! server-going #t) (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version)) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine. (thread-start! *watchdog*))) ;; when things go wrong we don't want to be doing the various queries too often ;; so we strive to run this stuff only every four seconds or so. (let* ((sync-time (- (current-milliseconds) start-time)) |
︙ | ︙ |
Modified megatest.scm from [841d3d78b0] to [78b560ce68].
︙ | ︙ | |||
39 40 41 42 43 44 45 46 47 48 49 | (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. (declare (uses env)) (declare (uses diff-report)) (declare (uses dbmod)) (declare (uses dbmod.import)) ;; (declare (uses ftail)) ;; (import ftail) | > > | > | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. (declare (uses env)) (declare (uses diff-report)) (declare (uses dbmod)) (declare (uses dbmod.import)) (declare (uses dbfile)) (declare (uses dbfile.import)) ;; (declare (uses ftail)) ;; (import ftail) (import dbmod dbfile) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") |
︙ | ︙ | |||
2293 2294 2295 2296 2297 2298 2299 | (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) ;; keep this one local ;; (open-run-close patch-db #f) | | | | | | 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 | (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) ;; keep this one local ;; (open-run-close patch-db #f) (let ((dbstructs (db:setup #f areapath: *toppath*))) (common:cleanup-db dbstructs full: #t)) (set! *didsomething* #t))) (if (args:get-arg "-cleanup-db") (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (let ((dbstructs (db:setup #f areapath: *toppath*))) (common:cleanup-db dbstructs)) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") |
︙ | ︙ | |||
2360 2361 2362 2363 2364 2365 2366 | (set! *didsomething* #t) (exit 0))) (if (or (getenv "MT_RUNSCRIPT") (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup)) | | | | | | > | 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 | (set! *didsomething* #t) (exit 0))) (if (or (getenv "MT_RUNSCRIPT") (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup)) (dbstructs (if (and toppath (common:on-homehost?)) (db:setup #t) #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) (if *toppath* (cond ((getenv "MT_RUNSCRIPT") ;; How to run megatest scripts ;; ;; #!/bin/bash ;; ;; export MT_RUNSCRIPT=yes ;; megatest << EOF ;; (print "Hello world") ;; (exit) ;; EOF (repl)) (else (begin (set! *db* dbstructs) (import extras) ;; might not be needed ;; (import csi) (import readline) (import apropos) (import dbfile) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (if *use-new-readline* (begin (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) (current-input-port (make-readline-port "megatest> "))) (begin |
︙ | ︙ |
Modified rmt.scm from [ed2cbd88f2] to [842b52e01e].
︙ | ︙ | |||
366 367 368 369 370 371 372 | (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)) | | | | | | | | | | | | | | | | | | | | 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 | (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))) (db-file-path (db:dbfile-path)) ;; 0)) (dbstructs-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) (read-only (not (file-write-access? db-file-path))) (start (current-milliseconds)) (resdat (if (not (and read-only qry-is-write)) (let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params)))) (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. exn ;; This is an attempt to detect that situation and recover gracefully (begin (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy (if (and (vector? v) (> (vector-length v) 1)) (let ((newvec (vector (vector-ref v 0)(vector-ref v 1)))) newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record (vector #t '())))) ;; we could also check that the returned types are valid (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) |
︙ | ︙ |