Overview
Comment: | Mostly working after stripping even more junk out ... |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.62-no-rpc |
Files: | files | file ages | folders |
SHA1: |
01fd2fa26b9a206e3f527e7399ff74c2 |
User & Date: | matt on 2016-11-21 22:18:20 |
Other Links: | branch diff | manifest | tags |
Context
2016-11-22
| ||
07:33 | Merged in v1.62-side changes to get the efficient db sync check-in: ff1d02545b user: matt tags: v1.62-no-rpc | |
2016-11-21
| ||
22:18 | Mostly working after stripping even more junk out ... check-in: 01fd2fa26b user: matt tags: v1.62-no-rpc | |
20:06 | Stripped server stuff out to get db access down to bare metal check-in: de910838a1 user: matt tags: v1.62-no-rpc | |
Changes
Modified common.scm from [521f7397cb] to [c51e104a50].
︙ | ︙ | |||
407 408 409 410 411 412 413 | dbpath))) ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:legacy-sync-recommended) | > > | | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 | dbpath))) ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:legacy-sync-recommended) (or (and (common:get-homehost) (cdr (common:get-homehost))) (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") )) |
︙ | ︙ | |||
627 628 629 630 631 632 633 | (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") #f) #f)))) ;; logic for getting homehost. Returns (host . at-home) ;; (define (common:get-homehost) | > | > | | | | | | | | | | | | | | | | | | | | 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 654 655 656 657 658 659 660 661 662 663 664 | (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") #f) #f)))) ;; logic for getting homehost. Returns (host . at-home) ;; (define (common:get-homehost) (cond (*home-host* *home-host*) ((not *toppath*) #f) ;; don't know toppath yet? return #f (else (let* ((currhost (get-host-name)) (bestadrs (server:get-best-guess-address currhost)) ;; first look in config, then look in file .homehost, create it if not found (homehost (or (configf:lookup *configdat* "server" "homehost" ) (let ((hhf (conc *toppath* "/.homehost"))) (if (file-exists? hhf) (with-input-from-file hhf read-line) (if (file-write-access? *toppath*) (begin (with-output-to-file hhf (lambda () (print bestadrs))) (common:get-homehost)) #f))))) (at-home (or (equal? homehost currhost) (equal? homehost bestadrs)))) (set! *home-host* (cons homehost at-home)) *home-host*)))) ;;====================================================================== ;; M I S C L I S T S ;;====================================================================== ;; items in lista are matched value and position in listb ;; return the remaining items in listb or #f |
︙ | ︙ | |||
957 958 959 960 961 962 963 | (if match (let ((newval (string->number (cadr match)))) (if (number? newval) (set! freespc newval)))))) (car df-results)) freespc)) | < < < | < | | | < < < | > > > > > > > > > > > > > | | 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 | (if match (let ((newval (string->number (cadr match)))) (if (number? newval) (set! freespc newval)))))) (car df-results)) freespc)) (define (common:check-space-in-dir dirpath required) (let* ((dbspace (if (directory? dirpath) (get-df dirpath) 0))) (list (> dbspace required) dbspace required dirpath))) ;; check space in dbdir and in megatest dir ;; returns: ok/not dbspace required-space ;; (define (common:check-db-dir-space) (let* ((required (string->number (or (configf:lookup *configdat* "setup" "dbdir-space-required") "100000"))) (dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir)) (tdbspace (common:check-space-in-dir dbdir required)) (mdbspace (common:check-space-in-dir *toppath* required))) (sort (list tdbspace mdbspace) (lambda (a b) (< (cadr a)(cadr b)))))) ;; check available space in dbdir, exit if insufficient ;; (define (common:check-db-dir-and-exit-if-insufficient) (let* ((spacedat (car (common:check-db-dir-space))) ;; look only at worst for now (is-ok (car spacedat)) (dbspace (cadr spacedat)) (required (caddr spacedat)) (dbdir (cadddr spacedat))) (if (not is-ok) (begin (debug:print-error 0 *default-log-port* "Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.") |
︙ | ︙ |
Modified dashboard-tests.scm from [e8603abab6] to [5fc35a4338].
︙ | ︙ | |||
413 414 415 416 417 418 419 | dlog)) ;;====================================================================== ;; ;;====================================================================== (define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) | | | | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 | dlog)) ;;====================================================================== ;; ;;====================================================================== (define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) (let* ((db-path (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) (dbstruct #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") ;; local: #t)) (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) (if (not testdat) (begin |
︙ | ︙ |
Modified db.scm from [dbf520bf9b] to [12276ed6d7].
︙ | ︙ | |||
76 77 78 79 80 81 82 | ;; if #f => get main db ;; 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 . blah) ;; run-id) (or (dbr:dbstruct-tmpdb dbstruct) | | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | ;; if #f => get main db ;; 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 . blah) ;; run-id) (or (dbr:dbstruct-tmpdb dbstruct) (db:open-db dbstruct))) ;; ;; legacy handling of structure for managing db's. Refactor this into dbr:? (define (db:dbdat-get-db dbdat) (if (pair? dbdat) (car dbdat) dbdat)) |
︙ | ︙ | |||
243 244 245 246 247 248 249 | ;; ;;; (mutex-unlock! *rundb-mutex*) ;;; why did we need a mutex on opening db's? ;; (db:sync-tables db:sync-tests-only *megatest-db* db) ;; db)) ;; This routine creates the db if not already present. It is only called if the db is not already opened ;; (define (db:open-db dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) | | | | | < | | 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 274 | ;; ;;; (mutex-unlock! *rundb-mutex*) ;;; why did we need a mutex on opening db's? ;; (db:sync-tables db:sync-tests-only *megatest-db* db) ;; db)) ;; This routine creates the db if not already present. It is only called if the db is not already opened ;; (define (db:open-db dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let ((tmpdb (dbr:dbstruct-tmpdb dbstruct))) ;; RA => Returns the first reference in dbstruct (if tmpdb tmpdb ;; (mutex-lock! *rundb-mutex*) (let* ((dbpath (db:dbfile-path)) ;; 0)) (dbexists (file-exists? dbpath)) (tmpdb (db:open-megatest-db dbdir: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (mtdb (db:open-megatest-db)) (write-access (file-write-access? dbpath))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (dbr:dbstruct-mtdb-set! dbstruct mtdb) (dbr:dbstruct-tmpdb-set! dbstruct tmpdb) ;; olddb is already a (cons db path) ;; (mutex-unlock! *rundb-mutex*) (if (and (not dbexists) *db-write-access*) ;; did not have a prior db and do have write access (db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically tmpdb)))) ;; 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 (db:setup) ;; . junk) ;; #!key (run-id #f) (local #f)) (let* (;; (dbdir (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) |
︙ | ︙ | |||
310 311 312 313 314 315 316 | ;; (refdb (dbr:dbstruct-refdb dbstruct)) (tmpdb (dbr:dbstruct-tmpdb dbstruct)) (mtdb (dbr:dbstruct-mtdb dbstruct)) ;; (runid (dbr:dbstruct-run-id dbstruct)) ) (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id) ;; (mutex-lock! *http-mutex*) | < | | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 | ;; (refdb (dbr:dbstruct-refdb dbstruct)) (tmpdb (dbr:dbstruct-tmpdb dbstruct)) (mtdb (dbr:dbstruct-mtdb dbstruct)) ;; (runid (dbr:dbstruct-run-id dbstruct)) ) (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id) ;; (mutex-lock! *http-mutex*) (db:sync-tables (db:sync-all-tables-list tmpdb) tmpdb mtdb))) ;; (if (eq? run-id 0) ;; ;; runid equal to 0 is main.db ;; (if maindb ;; (if (or (not (number? mtime)) ;; (not (number? stime)) ;; (> mtime stime) ;; force-sync) |
︙ | ︙ | |||
439 440 441 442 443 444 445 | '("units" #f) '("comment" #f) '("status" #f) '("type" #f)))) ;; needs db to get keys, this is for syncing all tables ;; | | | | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 | '("units" #f) '("comment" #f) '("status" #f) '("type" #f)))) ;; needs db to get keys, this is for syncing all tables ;; (define (db:sync-main-list dbstruct) (let ((keys (db:get-keys dbstruct))) (list (list "keys" '("id" #f) '("fieldname" #f) '("fieldtype" #f)) (list "metadat" '("var" #f) '("val" #f)) (append (list "runs" |
︙ | ︙ | |||
463 464 465 466 467 468 469 470 471 472 473 474 475 476 | '("description" #f) '("reviewed" #f) '("iterated" #f) '("avg_runtime" #f) '("avg_disk" #f) '("tags" #f) '("jobgroup" #f))))) ;; use bunch of Unix commands to try to break the lock and recreate the db ;; (define (db:move-and-recreate-db dbdat) (let* ((dbpath (db:dbdat-get-path dbdat)) (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath)) | > > > > | 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 | '("description" #f) '("reviewed" #f) '("iterated" #f) '("avg_runtime" #f) '("avg_disk" #f) '("tags" #f) '("jobgroup" #f))))) (define (db:sync-all-tables-list dbstruct) (append (db:sync-main-list dbstruct) db:sync-tests-only)) ;; use bunch of Unix commands to try to break the lock and recreate the db ;; (define (db:move-and-recreate-db dbdat) (let* ((dbpath (db:dbdat-get-path dbdat)) (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath)) |
︙ | ︙ | |||
759 760 761 762 763 764 765 | ;; 'old2new - sync megatest.db records to .db/{main,1,2 ...}.db ;; 'new2old - sync .db/{main,1,2,3 ...}.db to megatest.db ;; 'closeall - close all opened dbs ;; ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync run-ids . options) | | > | | > | | | < < | | | | | | | | | | | | | | | > | | | | | | | | | | | > | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 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 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 | ;; 'old2new - sync megatest.db records to .db/{main,1,2 ...}.db ;; 'new2old - sync .db/{main,1,2,3 ...}.db to megatest.db ;; 'closeall - close all opened dbs ;; ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync run-ids . options) (if (not (launch:setup)) (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.") (let* ((dbstruct (db:setup)) (mtdb (dbr:dbstruct-mtdb dbstruct)) (tmpdb (dbr:dbstruct-tmpdb dbstruct)) (allow-cleanup (if run-ids #f #t)) ;; (run-ids (if run-ids ;; run-ids ;; (db:get-all-run-ids mtdb))) (tdbdat (tasks:open-db)) (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) ;; kill servers (if (member 'killservers options) (for-each (lambda (server) (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration") (tasks:kill-server (vector-ref server 2)(vector-ref server 1))) servers)) ;; clear out junk records ;; (if (member 'dejunk options) (begin (db:delay-if-busy mtdb) (db:clean-up mtdb) (db:clean-up tmpdb))) ;; adjust test-ids to fit into proper range ;; ;; (if (member 'adj-testids options) ;; (begin ;; (db:delay-if-busy mtdb) ;; (db:prep-megatest.db-for-migration mtdb))) ;; sync runs, test_meta etc. ;; (if (member 'old2new options) ;; (begin (db:sync-tables (db:sync-all-tables-list dbstruct) mtdb tmpdb)) ;; (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) ;; (for-each ;; (lambda (run-id) ;; (db:delay-if-busy mtdb) ;; (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) ;; ;; (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) ;; (debug:print 0 *default-log-port* "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") ;; (db:replace-test-records dbstruct run-id testrecs) ;; (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct))))) ;; run-ids))) ;; now ensure all newdb data are synced to megatest.db ;; do not use the run-ids list passed in to the function ;; (if (member 'new2old options) (db:sync-tables (db:sync-all-tables-list dbstruct) tmpdb mtdb)) ;; (let* ((maindb (make-dbr:dbstruct path: toppath local: #t)) ;; (src-run-ids (if run-ids run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0))))) ;; (all-run-ids (sort (delete-duplicates (cons 0 src-run-ids)) <)) ;; (count 1) ;; (total (length all-run-ids)) ;; (dead-runs '())) ;; ;; first fix schema if needed ;; (map ;; (lambda (th) ;; (thread-join! th)) ;; (map ;; (lambda (run-id) ;; (thread-start! ;; (make-thread ;; (lambda () ;; (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) ;; (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) ;; (if (eq? run-id 0) ;; (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) ;; (db:patch-schema-maindb run-id maindb)) ;; (db:patch-schema-rundb run-id frundb))) ;; (set! count (+ count 1)) ;; (debug:print 0 *default-log-port* "Finished patching schema for " (if (eq? run-id 0) " main.db " (conc run-id ".db")) ", " count " of " total))))) ;; all-run-ids)) ;; ;; Then sync and fix db's ;; (set! count 0) ;; (process-fork ;; (lambda () ;; (map ;; (lambda (th) ;; (thread-join! th)) ;; (map ;; (lambda (run-id) ;; (thread-start! ;; (make-thread ;; (lambda () ;; (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) ;; (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) ;; (if (eq? run-id 0) ;; (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) ;; (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb) ;; (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f)))) ;; (begin ;; ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db ;; (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb) ;; (db:clean-up-rundb (db:get-db fromdb run-id))))) ;; (set! count (+ count 1)) ;; (debug:print 0 *default-log-port* "Finished clean up of " ;; (if (eq? run-id 0) ;; " main.db " (conc run-id ".db")) ", " count " of " total))))) ;; all-run-ids)))) ;; removed deleted runs ;; (let ((dbdir (tasks:get-task-db-path))) ;; (for-each (lambda (run-id) ;; (let ((fullname (conc dbdir "/" run-id ".db"))) ;; (if (file-exists? fullname) ;; (begin ;; (debug:print 0 *default-log-port* "Removing database file for deleted run " fullname) ;; (delete-file fullname))))) ;; dead-runs)))) ;; ;; (db:close-all dbstruct) ;; (sqlite3:finalize! mdb) ))) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (if (or *db-write-access* (not (member proc *db:all-write-procs*))) (let* ((db (cond |
︙ | ︙ |