Overview
Comment: | Merged b9d5 |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | v1.80-revolution-multi-server |
Files: | files | file ages | folders |
SHA1: |
92d02e9bbaf1d54cdeb3bdb1b9076fec |
User & Date: | matt on 2023-12-16 19:51:37 |
Other Links: | branch diff | manifest | tags |
Context
2023-12-16
| ||
19:51 | Merged b9d5 Leaf check-in: 92d02e9bba user: matt tags: v1.80-revolution-multi-server | |
19:50 | Merged 7372 check-in: f605e2b0d5 user: matt tags: v1.80-revolution-multi-server | |
2023-12-13
| ||
13:06 | Moved the addition of /.mtdb for db paths up to db:setup, and removed it from other places. Initial implementation of -cleanup-db. check-in: b9d51df3ee user: mmgraham tags: v1.80-revolution | |
Changes
Modified common.scm from [adf24d701b] to [0e724c12c1].
︙ | ︙ | |||
423 424 425 426 427 428 429 | 'schema 'killservers 'adj-target 'new2old '(dejunk) )) ((tcp nfs) | < | | 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 | 'schema 'killservers 'adj-target 'new2old '(dejunk) )) ((tcp nfs) (apply db:multi-db-sync dbstruct 'schema 'killservers 'adj-target 'new2old '(dejunk) ))) |
︙ | ︙ |
Modified db.scm from [d6b6de146b] to [d74d37ec7f].
︙ | ︙ | |||
129 130 131 132 133 134 135 | default (begin (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) | | | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | default (begin (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) (define (db:setup) (assert *toppath* "FATAL: db:setup called before launch:setup has been run.") (let* ((tmpdir (common:make-tmpdir-name *toppath* ""))) (if (not *dbstruct-dbs*) (dbfile:setup (conc *toppath* "/.mtdb") tmpdir) *dbstruct-dbs*))) ;; moved from dbfile ;; ;; ADD run-id SUPPORT ;; (define (db:create-all-triggers dbstruct) |
︙ | ︙ | |||
519 520 521 522 523 524 525 | ;; dbfiles) ;; ;; WHY does the dbdat need to be added back? ;; (if dbdat (dbfile:add-dbdat dbstruct #f dbdat)) ;; ) ;; #t) (define (db:kill-servers) | > > > > > | > > | | | > > > > > | > > | < | < > > | | > | > > > > > > > > > > > > > > > > > > > > > > | > > > | | | | | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 | ;; dbfiles) ;; ;; WHY does the dbdat need to be added back? ;; (if dbdat (dbfile:add-dbdat dbstruct #f dbdat)) ;; ) ;; #t) (define (db:kill-servers) (let* ((tl (launch:setup)) ;; need this to initialize *toppath* (servdir (conc *toppath* "/.servinfo")) (servfiles (glob (conc servdir "/*:*.db"))) (fmtstr "~10a~22a~10a~25a~25a~8a\n") (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db")))) (ttdat (make-tt areapath: *toppath*)) ) (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state") (for-each (lambda (dbfile) (let* ( (dbfname (conc (pathname-file dbfile) ".db")) (sfiles (tt:find-server *toppath* dbfname)) ) (for-each (lambda (sfile) (let ( (sinfos (tt:get-server-info-sorted ttdat dbfname)) ) (for-each (lambda (sinfo) (let* ( (db (list-ref sinfo 5)) (pid (list-ref sinfo 4)) (host (list-ref sinfo 0)) (port (list-ref sinfo 1)) (server-id (list-ref sinfo 3)) (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2)))) (last-mod (seconds->string (list-ref sinfo 2))) (killed (system (conc "ssh " host " kill " pid " > /dev/null"))) (dummy2 (sleep 1)) (state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive")) ) (format #t fmtstr db (conc host ":" port) pid age last-mod state) (system (conc "rm " sfile)) ) ) sinfos ) ) ) sfiles ) ) ) dbfiles ) ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id. (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db")) (delete-file (conc *toppath* "/.mtdb/no-sync.db")) ) ) ) ;; options: ;; ;; 'killservers - kills all servers ;; 'dejunk - removes junk records ;; 'adj-testids - move test-ids into correct ranges ;; 'old2new - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db ;; 'new2old - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced) ;; 'closeall - close all opened dbs ;; 'schema - attempt to apply schema changes ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync dbstruct . options) (let* (;; (dbdat (db:open-db dbstruct #f dbfile:db-init-proc)) (data-synced 0) ;; count of changed records (tmp-area (common:make-tmpdir-name *toppath* "")) (old2new (member 'old2new options)) (dejunk (member 'dejunk options)) (killservers (member 'killservers options)) (src-area (if old2new *toppath* tmp-area)) (dest-area (if old2new tmp-area (conc *toppath* "/.mtdb"))) (dbfiles (if old2new (glob (conc *toppath* "/.mtdb/*.db")) (glob (conc tmp-area "/*.db")))) (keys (db:get-keys dbstruct)) (sync-durations (make-hash-table))) ;; kill servers ;; (if killservers (db:kill-servers)) (if (not dbfiles) (debug:print-error 0 *default-log-port* "no dbfiles found in " (conc *toppath* "/.mtdb")) (for-each (lambda (srcfile) (debug:print-info 3 *default-log-port* "file: " srcfile) (let* ((fname (conc (pathname-file srcfile) ".db")) (basename (pathname-file srcfile)) (run-id (if (string= basename "main") #f (string->number basename))) (destfile (conc dest-area "/" fname)) (dest-directory dest-area) (time1 (file-modification-time srcfile)) (time2 (if (file-exists? destfile) (begin (debug:print-info 2 *default-log-port* "destfile " destfile " exists") (file-modification-time destfile)) (begin (debug:print-info 0 *default-log-port* "Sync - I do not see file " destfile) |
︙ | ︙ | |||
596 597 598 599 600 601 602 | #t) ((and changed *time-to-exit*) ;; last sync #t) (else #f)))) (if (or dejunk do-cp) (let* ((start-time (current-milliseconds)) | < < | | < | | | 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 | #t) ((and changed *time-to-exit*) ;; last sync #t) (else #f)))) (if (or dejunk do-cp) (let* ((start-time (current-milliseconds)) (subdb (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc))) (dbdat (or (dbfile:get-dbdat dbstruct run-id) (dbfile:open-db dbstruct run-id dbfile:db-init-proc))) (mtdb (dbr:subdb-mtdbdat subdb)) ;; ;; BUG: -mrw- I think this next line is wrong. run-id should be the path to .mtdb/<runid>.db ;; (tmpdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc))) (debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds") (if old2new (begin (if dejunk (db:clean-up run-id mtdb)) (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) #f mtdb tmpdb)) (begin (if dejunk (db:clean-up run-id tmpdb)) (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) #f tmpdb mtdb))) (hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time))) (debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date")))) dbfiles)) data-synced)) ;; Sync all changed db's ;; (define (db:tmp->megatest.db-sync dbstruct run-id last-update) (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))) (res '())) (for-each (lambda (subdb) (let* ((mtdb (dbr:subdb-mtdb subdb)) (tmpdb (db:get-subdb dbstruct run-id)) (refndb (dbr:subdb-refndb subdb)) (newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb))) ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; BUG: verify this is really needed (dbfile:add-dbdat dbstruct run-id tmpdb) (set! res (cons newres res)))) subdbs) res)) |
︙ | ︙ | |||
1140 1141 1142 1143 1144 1145 1146 | ;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up run-id dbdat) | < < < | 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 | ;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up run-id dbdat) (if run-id (db:clean-up-rundb dbdat) (db:clean-up-maindb dbdat) ) ) |
︙ | ︙ |
Modified dbfile.scm from [e1df0bf86e] to [7dc2a5434a].
︙ | ︙ | |||
266 267 268 269 270 271 272 | ;; just the filename (define (dbfile:run-id->dbfname run-id) (conc (dbfile:run-id->dbnum run-id)".db")) ;; the path in MTRAH with the filename (define (dbfile:run-id->dbname run-id) | | | | 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 | ;; just the filename (define (dbfile:run-id->dbfname run-id) (conc (dbfile:run-id->dbnum run-id)".db")) ;; the path in MTRAH with the filename (define (dbfile:run-id->dbname run-id) (conc (dbfile:run-id->dbfname run-id))) ;; 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. ;; (define (dbfile:setup areapath tmppath) (cond (*dbstruct-dbs* (dbfile:print-err "WARNING: dbfile:setup called when *dbstruct-dbs* is already initialized") *dbstruct-dbs*) ;; TODO: when multiple areas are supported, this optimization will be a hazard (else (let* ((dbstruct (make-dbr:dbstruct areapath: areapath tmppath: tmppath))) (set! *dbstruct-dbs* dbstruct) |
︙ | ︙ | |||
357 358 359 360 361 362 363 | (dbfile:open-db dbstruct run-id init-proc)) (let* ((dbdat (dbfile:get-dbdat dbstruct run-id))) (if dbdat dbdat (let* ((tmppath (dbr:dbstruct-tmppath dbstruct)) (tmpdbpath (dbfile:run-id->path tmppath run-id)) (dbdat (dbfile:open-sqlite3-db tmpdbpath init-proc sync-mode: 0 journal-mode: "WAL"))) | > | | 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 | (dbfile:open-db dbstruct run-id init-proc)) (let* ((dbdat (dbfile:get-dbdat dbstruct run-id))) (if dbdat dbdat (let* ((tmppath (dbr:dbstruct-tmppath dbstruct)) (tmpdbpath (dbfile:run-id->path tmppath run-id)) (dbdat (dbfile:open-sqlite3-db tmpdbpath init-proc sync-mode: 0 journal-mode: "WAL"))) ;; the following line short-circuits the "one db handle per thread" model ;; ;; (dbfile:add-dbdat dbstruct run-id dbdat) ;; dbdat)))))) ;; COMBINE dbfile:open-sqlite-db and dbfile:lock-create-open ;; |
︙ | ︙ | |||
452 453 454 455 456 457 458 | (begin (if (file-exists? fname ) (let ((db (sqlite3:open-database fname))) ;; pragmas synchronous not needed because this db is used read-only ;; (sqlite3:execute db (conc "PRAGMA synchronous = "mode";") (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 30000)) ;; read-only but still need timeout db ) | | | 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 | (begin (if (file-exists? fname ) (let ((db (sqlite3:open-database fname))) ;; pragmas synchronous not needed because this db is used read-only ;; (sqlite3:execute db (conc "PRAGMA synchronous = "mode";") (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 30000)) ;; read-only but still need timeout db ) (print "cautious-open-database: file doesn't exist: " fname)))) (exn (io-error) (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.") (retry)) (exn (corrupt) (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.") (retry)) (exn (busy) |
︙ | ︙ |
Modified megatest.scm from [4f7c279d10] to [c54fcd3e34].
︙ | ︙ | |||
2448 2449 2450 2451 2452 2453 2454 | (exit 1))) ;; (if (not (server:choose-server *toppath* 'home?)) ;; (begin ;; (debug:print 0 *default-log-port* "Servers are not running on this host or no servers alive. Cannot run cleanup-db") ;; (exit 1))) | | | 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 | (exit 1))) ;; (if (not (server:choose-server *toppath* 'home?)) ;; (begin ;; (debug:print 0 *default-log-port* "Servers are not running on this host or no servers alive. Cannot run cleanup-db") ;; (exit 1))) (let ((dbstructs (db:setup))) (common:cleanup-db dbstructs)) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin (if (not (launch:setup)) (begin |
︙ | ︙ |