Changes In Branch archiving Through [5af4229eb4] Excluding Merge-Ins
This is equivalent to a diff from 12a41bff5e to 5af4229eb4
2014-12-02
| ||
23:56 | Merging archiving back to trunk check-in: ab10662391 user: matt tags: v1.60 | |
2014-12-01
| ||
13:54 | Merged v1.60 into multi-transport check-in: 1888a270be user: mrwellan tags: multi-transport | |
2014-11-30
| ||
22:55 | Fixed couple problems with tasks_queue migration check-in: 35909bedef user: matt tags: archiving | |
22:30 | Moved tasks_queue into main.db check-in: 5af4229eb4 user: matt tags: archiving | |
13:02 | Merging in v1.60 check-in: b2aa3b8559 user: matt tags: archiving | |
12:44 | Bring v1.60 back to trunk check-in: 2f9676f58c user: matt tags: trunk | |
12:37 | Merged v1.60 into old dev branch Closed-Leaf check-in: 61fd6d3c06 user: matt tags: dev | |
12:19 | Merged ABORT changes check-in: 12a41bff5e user: matt tags: v1.60 | |
09:53 | Merged fix for get-tests-for-run(s) check-in: c8184e551e user: matt tags: v1.60 | |
2014-01-09
| ||
11:06 | first change for ABORT Closed-Leaf check-in: 19d75f5d3d user: marasaia tags: add-abort-support | |
Modified api.scm from [b8269d4337] to [5e80ce2ed9].
︙ | ︙ | |||
124 125 126 127 128 129 130 131 132 133 134 135 136 137 | ((sync-inmem->db) (db:sync-touched dbstruct run-id force-sync: #t)) ((sdb-qry) (apply sdb:qry params)) ;; TESTMETA ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) (else (list "ERROR" 0)))) ;; http-server send-response ;; api:process-request ;; db:* ;; | > > > > > > | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 | ((sync-inmem->db) (db:sync-touched dbstruct run-id force-sync: #t)) ((sdb-qry) (apply sdb:qry params)) ;; TESTMETA ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) ;; TASKS ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) ((tasks-add) (apply tasks:add dbstruct params)) ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) (else (list "ERROR" 0)))) ;; http-server send-response ;; api:process-request ;; db:* ;; |
︙ | ︙ |
Modified db.scm from [cbd895f712] to [3911c1048a].
︙ | ︙ | |||
323 324 325 326 327 328 329 | (if (or (not (number? mtime)) (not (number? stime)) (> mtime stime) force-sync) (begin (db:delay-if-busy rundb) (db:delay-if-busy olddb) | < | > | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 | (if (or (not (number? mtime)) (not (number? stime)) (> mtime stime) force-sync) (begin (db:delay-if-busy rundb) (db:delay-if-busy olddb) (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) (mutex-unlock! *http-mutex*) num-synced) (begin (mutex-unlock! *http-mutex*) 0)))))) (define (db:close-main dbstruct) |
︙ | ︙ | |||
767 768 769 770 771 772 773 774 775 776 777 778 779 780 | reviewed TIMESTAMP, iterated TEXT DEFAULT '', avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. | > > > > > > > > > > > > > | 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 | reviewed TIMESTAMP, iterated TEXT DEFAULT '', avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, action TEXT DEFAULT '', owner TEXT, state TEXT DEFAULT 'new', target TEXT DEFAULT '', name TEXT DEFAULT '', testpatt TEXT DEFAULT '', keylock TEXT, params TEXT, creation_time TIMESTAMP, execution_time TIMESTAMP);") ;; move this clean up call somewhere else (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. |
︙ | ︙ |
Added mlaunch.scm version [4f4e7034c8].
> > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | ;; Copyright 2006-2014, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') ;;====================================================================== ;; MLAUNCH ;; ;; take jobs from the given queue and keep launching them keeping ;; the cpu load at the targeted level ;; ;;====================================================================== (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) (import (prefix sqlite3 sqlite3:)) (declare (unit mlaunch)) (declare (uses db)) (declare (uses common)) |
Modified rmt.scm from [0582204ff9] to [bd81b52c68].
︙ | ︙ | |||
571 572 573 574 575 576 577 | (rmt:send-receive 'testmeta-update-field #f (list test-name fld val))) (define (rmt:test-data-rollup run-id test-id status) (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status))) (define (rmt:csv->test-data run-id test-id csvdata) (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata))) | > > > > > > > > > > > > > | 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 | (rmt:send-receive 'testmeta-update-field #f (list test-name fld val))) (define (rmt:test-data-rollup run-id test-id status) (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status))) (define (rmt:csv->test-data run-id test-id csvdata) (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata))) ;;====================================================================== ;; T A S K S ;;====================================================================== (define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt) (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt))) (define (rmt:tasks-add action owner target runname testpatt params) (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params))) (define (rmt:tasks-set-state-given-param-key dbstruct param-key new-state) (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state))) |
Modified runs.scm from [396462afab] to [22b3739b80].
︙ | ︙ | |||
226 227 228 229 230 231 232 | (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((tdbdat (tasks:open-db))) (tasks:set-state-given-param-key (db:delay-if-busy tdbdat) task-key "killed")) (print "Killed by signal " signum ". Exiting") (exit))) ;; register this run in monitor.db | | | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 | (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((tdbdat (tasks:open-db))) (tasks:set-state-given-param-key (db:delay-if-busy tdbdat) task-key "killed")) (print "Killed by signal " signum ". Exiting") (exit))) ;; register this run in monitor.db (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params) (rmt:tasks-set-state-given-param-key (db:delay-if-busy tdbdat) task-key "running") (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; Now generate all the tests lists (set! all-tests-registry (tests:get-all)) |
︙ | ︙ | |||
392 393 394 395 396 397 398 | (if (not (hash-table-ref/default flags "-preclean" #f)) (hash-table-set! flags "-preclean" #t)) (if (not (hash-table-ref/default flags "-rerun" #f)) (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS")) (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))))) (debug:print-info 0 "No tests to run"))) (debug:print-info 4 "All done by here") | | | 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 | (if (not (hash-table-ref/default flags "-preclean" #f)) (hash-table-set! flags "-preclean" #t)) (if (not (hash-table-ref/default flags "-rerun" #f)) (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS")) (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))))) (debug:print-info 0 "No tests to run"))) (debug:print-info 4 "All done by here") (rmt:tasks-set-state-given-param-key (db:delay-if-busy tdbdat) task-key "done") ;; (sqlite3:finalize! tasks-db) )) ;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable. ;; ;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns |
︙ | ︙ | |||
1442 1443 1444 1445 1446 1447 1448 | (if (not (null? tests)) (begin (case action ((remove-runs) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; seek and kill in flight -runtests with % as testpatt here (if (equal? testpatt "%") | | | 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 | (if (not (null? tests)) (begin (case action ((remove-runs) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; seek and kill in flight -runtests with % as testpatt here (if (equal? testpatt "%") (tasks:kill-runner target run-name) (debug:print 0 "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) |
︙ | ︙ |
Modified tasks.scm from [af4bc3dbb1] to [a07c5a816e].
︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 | ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) (import (prefix sqlite3 sqlite3:)) (declare (unit tasks)) (declare (uses db)) (declare (uses common)) (include "task_records.scm") ;;====================================================================== ;; Tasks db ;;====================================================================== | > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) (import (prefix sqlite3 sqlite3:)) (declare (unit tasks)) (declare (uses db)) (declare (uses rmt)) (declare (uses common)) (include "task_records.scm") ;;====================================================================== ;; Tasks db ;;====================================================================== |
︙ | ︙ | |||
101 102 103 104 105 106 107 | (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (sqlite3:set-busy-handler! mdb handler) (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) ;; (if (or (and (not exists) ;; (file-write-access? *toppath*)) ;; (not (file-read-access? dbpath))) ;; (begin | > > > | | | | | | | | | | | | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (sqlite3:set-busy-handler! mdb handler) (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) ;; (if (or (and (not exists) ;; (file-write-access? *toppath*)) ;; (not (file-read-access? dbpath))) ;; (begin ;; ;; TASKS QUEUE MOVED TO main.db ;; ;; (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, ;; action TEXT DEFAULT '', ;; owner TEXT, ;; state TEXT DEFAULT 'new', ;; target TEXT DEFAULT '', ;; name TEXT DEFAULT '', ;; testpatt TEXT DEFAULT '', ;; keylock TEXT, ;; params TEXT, ;; creation_time TIMESTAMP, ;; execution_time TIMESTAMP);") (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, pid INTEGER, start_time TIMESTAMP, last_update TIMESTAMP, hostname TEXT, username TEXT, CONSTRAINT monitors_constraint UNIQUE (pid,hostname));") |
︙ | ︙ | |||
143 144 145 146 147 148 149 | hostname TEXT, cmdline TEXT, login_time TIMESTAMP, logout_time TIMESTAMP DEFAULT -1, CONSTRAINT clients_constraint UNIQUE (pid,hostname));") ;)) | < | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 | hostname TEXT, cmdline TEXT, login_time TIMESTAMP, logout_time TIMESTAMP DEFAULT -1, CONSTRAINT clients_constraint UNIQUE (pid,hostname));") ;)) (set! *task-db* (cons mdb dbpath)) *task-db*)))) ;;====================================================================== ;; Server and client management ;;====================================================================== |
︙ | ︙ | |||
420 421 422 423 424 425 426 | (debug:print-info 0 "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid) (tasks:kill-server hostname pid) (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id tag) ) (debug:print-info 0 "No server found for run-id " run-id ", nothing to kill")) ;; (sqlite3:finalize! tdb) )) | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | < < < < < < < < < < < < < < < < | < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | (debug:print-info 0 "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid) (tasks:kill-server hostname pid) (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id tag) ) (debug:print-info 0 "No server found for run-id " run-id ", nothing to kill")) ;; (sqlite3:finalize! tdb) )) ;;====================================================================== ;; M O N I T O R S ;;====================================================================== (define (tasks:remove-monitor-record mdb) (sqlite3:execute mdb "DELETE FROM monitors WHERE pid=? AND hostname=?;" (current-process-id) (get-host-name))) (define (tasks:get-monitors mdb) (let ((res '())) (sqlite3:for-each-row (lambda (a . rem) (set! res (cons (apply vector a rem) res))) mdb "SELECT id,pid,strftime('%m/%d/%Y %H:%M',datetime(start_time,'unixepoch'),'localtime'),strftime('%m/%d/%Y %H:%M:%S',datetime(last_update,'unixepoch'),'localtime'),hostname,username FROM monitors ORDER BY last_update ASC;") (reverse res) )) (define (tasks:monitors->text-table monitors) (let ((fmtstr "~4a~8a~20a~20a~10a~10a")) (conc (format #f fmtstr "id" "pid" "start time" "last update" "hostname" "user") "\n" (string-intersperse (map (lambda (monitor) (format #f fmtstr (tasks:monitor-get-id monitor) |
︙ | ︙ | |||
635 636 637 638 639 640 641 642 | (lambda (id pid host last-update delta) (print "Going to delete stale record for monitor with pid " pid " on host " host " last updated " delta " seconds ago") (set! deadlist (cons id deadlist))) mdb "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS delta FROM monitors WHERE delta > 700;") (sqlite3:execute mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');"))) ) | > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > | > > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | | | | > > > | | | | > | > > > | | > > > | | | | | | < < < < | > | | | | | > > > | | | 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 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 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 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 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 | (lambda (id pid host last-update delta) (print "Going to delete stale record for monitor with pid " pid " on host " host " last updated " delta " seconds ago") (set! deadlist (cons id deadlist))) mdb "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS delta FROM monitors WHERE delta > 700;") (sqlite3:execute mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');"))) ) (define (tasks:register-monitor db mdb) (let* ((pid (current-process-id)) (hostname (get-host-name)) (userinfo (user-information (current-user-id))) (username (car userinfo))) (print "Register monitor, pid: " pid ", hostname: " hostname ", username: " username) (sqlite3:execute mdb "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);" pid hostname username))) (define (tasks:get-num-alive-monitors mdb) (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) mdb "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;" (car (user-information (current-user-id)))) res)) ;; (define (tasks:start-monitor db mdb) (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more (debug:print-info 1 "Not starting monitor, already have more than two running") (let* ((megatestdb (conc *toppath* "/megatest.db")) (monitordbf (conc (configf:lookup *configdat* "setup" "linktree") "/.db/monitor.db")) (last-db-update 0)) ;; (file-modification-time megatestdb))) (task:register-monitor mdb) (let loop ((count 0) (next-touch 0)) ;; next-touch is the time where we need to update last_update ;; if the db has been modified we'd best look at the task queue (let ((modtime (file-modification-time megatestdbpath ))) (if (> modtime last-db-update) (tasks:process-queue db mdb last-db-update megatestdb next-touch)) ;; WARNING: Possible race conditon here!! ;; should this update be immediately after the task-get-action call above? (if (> (current-seconds) next-touch) (begin (tasks:monitors-update mdb) (loop (+ count 1)(+ (current-seconds) 240))) (loop (+ count 1) next-touch))))))) ;;====================================================================== ;; T A S K S Q U E U E ;; ;; NOTE:: These operate on task_queue which is in main.db ;; ;;====================================================================== ;; NOTE: It might be good to add one more layer of checking to ensure ;; that no task gets run in parallel. ;; register a task (define (tasks:add dbstruct action owner target runname testpatt params) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time) VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);" action owner target runname testpatt (if params params ""))))) (define (keys:key-vals-hash->target keys key-params) (let ((tmp (hash-table-ref/default key-params (vector-ref (car keys) 0) ""))) (if (> (length keys) 1) (for-each (lambda (key) (set! tmp (conc tmp "/" (hash-table-ref/default key-params (vector-ref key 0) "")))) (cdr keys))) tmp)) ;; for use from the gui, not ported ;; ;; (define (tasks:add-from-params mdb action keys key-params var-params) ;; (let ((target (keys:key-vals-hash->target keys key-params)) ;; (owner (car (user-information (current-user-id)))) ;; (runname (hash-table-ref/default var-params "runname" #f)) ;; (testpatts (hash-table-ref/default var-params "testpatts" "%")) ;; (params (hash-table-ref/default var-params "params" ""))) ;; (tasks:add mdb action owner target runname testpatts params))) ;; return one task from those who are 'new' OR 'waiting' AND more than 10sec old ;; (define (tasks:snag-a-task dbstruct) (let ((res #f) (keytxt (conc (current-process-id) "-" (get-host-name) "-" (car (user-information (current-user-id)))))) (db:with-db dbstruct #f #t (lambda (db) ;; first randomly set a new to pid-hostname-hostname (sqlite3:execute db "UPDATE tasks_queue SET keylock=? WHERE id IN (SELECT id FROM tasks_queue WHERE state='new' OR (state='waiting' AND (strftime('%s','now')-execution_time) > 10) OR state='reset' ORDER BY RANDOM() LIMIT 1);" keytxt) (sqlite3:for-each-row (lambda (id . rem) (set! res (apply vector id rem))) db "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time FROM tasks_queue WHERE keylock=? ORDER BY execution_time ASC LIMIT 1;" keytxt) (if res ;; yep, have work to be done (begin (sqlite3:execute db "UPDATE tasks_queue SET state='inprogress',execution_time=strftime('%s','now') WHERE id=?;" (tasks:task-get-id res)) res) #f))))) (define (tasks:reset-stuck-tasks dbstruct) (let ((res '())) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:for-each-row (lambda (id delta) (set! res (cons id res))) db "SELECT id,strftime('%s','now')-execution_time AS delta FROM tasks_queue WHERE state='inprogress' AND delta>700 ORDER BY delta DESC LIMIT 2;") (sqlite3:execute db (conc "UPDATE tasks_queue SET state='reset' WHERE id IN ('" (string-intersperse (map conc res) "','") "');") ))))) ;; return all tasks in the tasks_queue table ;; (define (tasks:get-tasks dbstruct types states) (let ((res '())) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (id . rem) (set! res (cons (apply vector id rem) res))) db (conc "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time FROM tasks_queue " ;; WHERE ;; state IN " statesstr " AND ;; action IN " actionsstr " ORDER BY creation_time DESC;")) res)))) ;; remove tasks given by a string of numbers comma separated (define (tasks:remove-queue-entries dbstruct task-ids) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");"))))) (define (tasks:process-queue dbstruct) (let* ((task (tasks:snag-a-task dbstruct)) (action (if task (tasks:task-get-action task) #f))) (if action (print "tasks:process-queue task: " task)) (if action (case (string->symbol action) ((run) (tasks:start-run dbstruct task)) ((remove) (tasks:remove-runs dbstruct task)) ((lock) (tasks:lock-runs dbstruct task)) ;; ((monitor) (tasks:start-monitor db task)) ((rollup) (tasks:rollup-runs dbstruct task)) ((updatemeta)(tasks:update-meta dbstruct task)) ((kill) (tasks:kill-monitors dbstruct task)))))) (define (tasks:tasks->text tasks) (let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a")) (conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n" (string-intersperse (map (lambda (task) (format #f fmtstr (tasks:task-get-id task) (tasks:task-get-action task) (tasks:task-get-owner task) (tasks:task-get-state task) (tasks:task-get-target task) (tasks:task-get-name task) (tasks:task-get-test task) ;; (tasks:task-get-item task) (tasks:task-get-params task))) tasks) "\n")))) (define (tasks:set-state dbstruct task-id state) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE id=?;" state task-id)))) ;;====================================================================== ;; Access using task key (stored in params; (hash-table->alist flags) hostname pid ;;====================================================================== (define (tasks:param-key->id dbstruct task-params) (db:with-db dbstruct #f #f (lambda (db) (handle-exceptions exn #f (sqlite3:first-result db "SELECT id FROM tasks_queue WHERE params LIKE ?;" task-params))))) (define (tasks:set-state-given-param-key dbstruct param-key new-state) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key)))) (define (tasks:get-records-given-param-key dbstruct param-key state-patt action-patt test-patt) (db:with-db dbstruct #f #f (lambda (db) (handle-exceptions exn '() (sqlite3:first-row db "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" param-key state-patt action-patt test-patt))))) (define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt) ;; (handle-exceptions ;; exn ;; '() ;; (sqlite3:first-row (let ((db (db:delay-if-busy (db:get-db dbstruct #f))) (res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (cons a b) res))) db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue WHERE target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" target run-name state-patt action-patt test-patt) res)) ;; ) ;; kill any runner processes (i.e. processes handling -runtests) that match target/runname ;; ;; do a remote call to get the task queue info but do the killing as self here. ;; (define (tasks:kill-runner target run-name) (let ((records (rmt:find-task-queue-records target run-name "%" "running" "run-tests")) (hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string (if (null? records) (debug:print 0 "No run launching processes found for " target " / " run-name) (debug:print 0 "Found " (length records) " run(s) to kill.")) (for-each (lambda (record) (let* ((param-key (list-ref record 8)) |
︙ | ︙ | |||
723 724 725 726 727 728 729 | (let ((old-targethost (getenv "TARGETHOST"))) (setenv "TARGETHOST" hostname) (setenv "TARGETHOST_LOGF" "server-kills.log") (system (conc "nbfake kill " pid)) (if old-targethost (setenv "TARGETHOST" old-targethost)) (unsetenv "TARGETHOST") (unsetenv "TARGETHOST_LOGF")))) | | < < < < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | 754 755 756 757 758 759 760 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 | (let ((old-targethost (getenv "TARGETHOST"))) (setenv "TARGETHOST" hostname) (setenv "TARGETHOST_LOGF" "server-kills.log") (system (conc "nbfake kill " pid)) (if old-targethost (setenv "TARGETHOST" old-targethost)) (unsetenv "TARGETHOST") (unsetenv "TARGETHOST_LOGF")))) (debug:print 0 "ERROR: no record or improper record for " target "/" run-name " in tasks_queue in main.db")))) records))) ;; (define (tasks:start-run dbstruct mdb task) ;; (let ((flags (make-hash-table))) ;; (hash-table-set! flags "-rerun" "NOT_STARTED") ;; (if (not (string=? (tasks:task-get-params task) "")) ;; (hash-table-set! flags "-setvars" (tasks:task-get-params task))) ;; (print "Starting run " task) ;; ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY ;; (runs:run-tests db ;; (tasks:task-get-target task) ;; (tasks:task-get-name task) ;; (tasks:task-get-test task) ;; (tasks:task-get-item task) ;; (tasks:task-get-owner task) ;; flags) ;; (tasks:set-state mdb (tasks:task-get-id task) "waiting"))) ;; ;; (define (tasks:rollup-runs db mdb task) ;; (let* ((flags (make-hash-table)) ;; (keys (db:get-keys db)) ;; (keyvals (keys:target-keyval keys (tasks:task-get-target task)))) ;; ;; (hash-table-set! flags "-rerun" "NOT_STARTED") ;; (print "Starting rollup " task) ;; ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY ;; (runs:rollup-run db ;; keys ;; keyvals ;; (tasks:task-get-name task) ;; (tasks:task-get-owner task)) ;; (tasks:set-state mdb (tasks:task-get-id task) "waiting"))) |
Modified tests/fullrun/megatest.config from [a6f800861f] to [4a5fb14ff7].
︙ | ︙ | |||
164 165 166 167 168 169 170 | # to your jobgroups where N is the number of parallel runs you are likely to see # sqlite3 6 blockz 10 # to your jobgroups where N is the number of parallel runs you are likely to see # | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | # to your jobgroups where N is the number of parallel runs you are likely to see # sqlite3 6 blockz 10 # to your jobgroups where N is the number of parallel runs you are likely to see # #====================================================================== # Machine flavors # # These specify lists of hosts or scripts to use or call for various # flavors of task. # #====================================================================== [flavors] plain hosts: xena, phoebe strong command: NBFAKE_HOST=zeus nbfake arm hosts: cubian [archive] # use machines of these flavor useflavors plain targsize 2G [archive-disks] # Archives will be organised under these paths like this: # <testsuite>/<creationdate> # Within the archive the data is structured like this: # <target>/<runname>/<test>/ disk0 /mfs/archives |