Overview
Comment: | Broke connection to server out of open-db |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
35d5a0947094d8ae5714e50d8f2bb4e9 |
User & Date: | matt on 2012-02-26 07:47:52 |
Other Links: | manifest | tags |
Context
2012-02-26
| ||
14:00 | Merged from archiving branch, added caching for steps check-in: 65ae97a3b1 user: matt tags: trunk | |
07:47 | Broke connection to server out of open-db check-in: 35d5a09470 user: matt tags: trunk | |
01:11 | More rpc related changes check-in: c810f51721 user: matt tags: trunk | |
Changes
Modified dashboard.scm from [0be6593524] to [4b685b7cb0].
︙ | ︙ | |||
74 75 76 77 78 79 80 81 82 83 84 85 86 87 | (if (not (setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) (define *db* (open-db)) (define toplevel #f) (define dlg #f) (define max-test-num 0) (define *keys* (rdb:get-keys *db*)) (define *dbkeys* (map (lambda (x)(vector-ref x 0)) (append *keys* (list (vector "runname" "blah"))))) | > | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | (if (not (setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) (define *db* (open-db)) (server:client-setup *db*) (define toplevel #f) (define dlg #f) (define max-test-num 0) (define *keys* (rdb:get-keys *db*)) (define *dbkeys* (map (lambda (x)(vector-ref x 0)) (append *keys* (list (vector "runname" "blah"))))) |
︙ | ︙ |
Modified db.scm from [df4f1d4f19] to [18429e2674].
︙ | ︙ | |||
33 34 35 36 37 38 39 | (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout 36000))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (db:initialize db)) | < < | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout 36000))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (db:initialize db)) db)) (define (db:initialize db) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) |
︙ | ︙ |
Modified launch.scm from [565c46e34b] to [0201b79908].
︙ | ︙ | |||
88 89 90 91 92 93 94 95 96 97 98 99 100 101 | (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db (set! db (open-db)) (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory work-area) (set-run-config-vars db run-id) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars db run-id) (set-item-env-vars itemdat) | > > | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory work-area) (set-run-config-vars db run-id) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars db run-id) (set-item-env-vars itemdat) |
︙ | ︙ | |||
144 145 146 147 148 149 150 151 152 153 154 155 156 157 | ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) (db (open-db))) (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") (let loop ((ezstep (car ezstepslst)) (tal (cdr ezstepslst)) (prevstep #f)) | > > | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 | ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) (db (open-db))) (if (not (args:get-arg "-server")) (server:client-setup db)) (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") (let loop ((ezstep (car ezstepslst)) (tal (cdr ezstepslst)) (prevstep #f)) |
︙ | ︙ | |||
242 243 244 245 246 247 248 249 250 251 252 253 254 255 | start-seconds))))) (kill-tries 0)) (let loop ((minutes (calc-minutes))) (let* ((db (open-db)) (cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (tmpfree (get-df "/tmp"))) (if (not cpuload) (begin (debug:print 0 "WARNING: CPULOAD not found.") (set! cpuload "n/a"))) (if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a"))) (set! kill-job? (test-get-kill-request db run-id test-name itemdat)) (rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree) (if kill-job? (begin (mutex-lock! m) | > > | 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 | start-seconds))))) (kill-tries 0)) (let loop ((minutes (calc-minutes))) (let* ((db (open-db)) (cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (tmpfree (get-df "/tmp"))) (if (not (args:get-arg "-server")) (server:client-setup db)) (if (not cpuload) (begin (debug:print 0 "WARNING: CPULOAD not found.") (set! cpuload "n/a"))) (if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a"))) (set! kill-job? (test-get-kill-request db run-id test-name itemdat)) (rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree) (if kill-job? (begin (mutex-lock! m) |
︙ | ︙ | |||
285 286 287 288 289 290 291 292 293 294 295 296 297 298 | (th2 (make-thread runit))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) (mutex-lock! m) (set! db (open-db)) (let* ((item-path (item-list->path itemdat)) (testinfo (db:get-test-info db run-id test-name item-path))) (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) (begin (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) (test-set-status! db run-id test-name (if kill-job? "KILLED" "COMPLETED") | > > | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 | (th2 (make-thread runit))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) (mutex-lock! m) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (let* ((item-path (item-list->path itemdat)) (testinfo (db:get-test-info db run-id test-name item-path))) (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) (begin (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) (test-set-status! db run-id test-name (if kill-job? "KILLED" "COMPLETED") |
︙ | ︙ |
Modified megatest.scm from [c404370efb] to [a7b4c83986].
︙ | ︙ | |||
238 239 240 241 242 243 244 245 246 247 248 249 250 251 | (exit 4)) ((let ((db #f)) (if (not (setup-for-run)) (begin (debug:print 0 print "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (not (car *configinfo*)) (begin (debug:print 0 "ERROR: Attempted to remove test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables (runs:remove-runs db (args:get-arg ":runname") | > > | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 | (exit 4)) ((let ((db #f)) (if (not (setup-for-run)) (begin (debug:print 0 print "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (if (not (car *configinfo*)) (begin (debug:print 0 "ERROR: Attempted to remove test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables (runs:remove-runs db (args:get-arg ":runname") |
︙ | ︙ | |||
273 274 275 276 277 278 279 280 281 282 283 284 285 286 | (testpatt (args:get-arg "-testpatt")) (itempatt (args:get-arg "-itempatt")) (runsdat (rdb:get-runs db runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) (keys (rdb:get-keys db)) (keynames (map key:get-fieldname keys))) ;; Each run (for-each (lambda (run) (debug:print 2 "Run: " (string-intersperse (map (lambda (x) (db:get-value-by-header run header x)) keynames) "/") | > > | 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 | (testpatt (args:get-arg "-testpatt")) (itempatt (args:get-arg "-itempatt")) (runsdat (rdb:get-runs db runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) (keys (rdb:get-keys db)) (keynames (map key:get-fieldname keys))) (if (not (args:get-arg "-server")) (server:client-setup db)) ;; Each run (for-each (lambda (run) (debug:print 2 "Run: " (string-intersperse (map (lambda (x) (db:get-value-by-header run header x)) keynames) "/") |
︙ | ︙ | |||
438 439 440 441 442 443 444 445 446 447 448 449 450 451 | (debug:print 0 "ERROR: -target is required.") (exit 1))) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -test-paths, exiting") (exit 1))) (set! db (open-db)) (let* ((itempatt (args:get-arg "-itempatt")) (keys (rdb:get-keys db)) (keynames (map key:get-fieldname keys)) (paths (db:test-get-paths-matching db keynames target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) | > > | 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 | (debug:print 0 "ERROR: -target is required.") (exit 1))) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -test-paths, exiting") (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (let* ((itempatt (args:get-arg "-itempatt")) (keys (rdb:get-keys db)) (keynames (map key:get-fieldname keys)) (paths (db:test-get-paths-matching db keynames target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) |
︙ | ︙ | |||
485 486 487 488 489 490 491 | (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -archive, exiting") (exit 1))) | | > > | 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 | (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -archive, exiting") (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (let* ((itempatt (args:get-arg "-itempatt")) (keys (rdb:get-keys db)) (keynames (map key:get-fieldname keys)) (paths (db:test-get-paths-matching db keynames target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) |
︙ | ︙ | |||
557 558 559 560 561 562 563 564 565 566 567 568 569 570 | (logfile (args:get-arg "-setlog"))) (change-directory testpath) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (and state status) (rdb:teststep-set-status! db run-id test-name step state status itemdat (args:get-arg "-m") logfile) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6))) (sqlite3:finalize! db) (set! *didsomething* #t)))) | > > | 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 | (logfile (args:get-arg "-setlog"))) (change-directory testpath) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (if (and state status) (rdb:teststep-set-status! db run-id test-name step state status itemdat (args:get-arg "-m") logfile) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6))) (sqlite3:finalize! db) (set! *didsomething* #t)))) |
︙ | ︙ | |||
593 594 595 596 597 598 599 600 601 602 603 604 605 606 | (status (args:get-arg ":status"))) (change-directory testpath) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (args:get-arg "-load-test-data") (db:load-test-data db run-id test-name itemdat)) (if (args:get-arg "-setlog") (test-set-log! db run-id test-name itemdat (args:get-arg "-setlog"))) (if (args:get-arg "-set-toplog") (test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") | > > | 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 | (status (args:get-arg ":status"))) (change-directory testpath) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (if (args:get-arg "-load-test-data") (db:load-test-data db run-id test-name itemdat)) (if (args:get-arg "-setlog") (test-set-log! db run-id test-name itemdat (args:get-arg "-setlog"))) (if (args:get-arg "-set-toplog") (test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") |
︙ | ︙ | |||
631 632 633 634 635 636 637 | ;; run the test step (debug:print 2 "INFO: Running \"" fullcmd "\"") (change-directory startingdir) (set! exitstat (system fullcmd)) ;; cmd params)) (set! *globalexitstatus* exitstat) (change-directory testpath) ;; re-open the db | | > > | 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 | ;; run the test step (debug:print 2 "INFO: Running \"" fullcmd "\"") (change-directory startingdir) (set! exitstat (system fullcmd)) ;; cmd params)) (set! *globalexitstatus* exitstat) (change-directory testpath) ;; re-open the db (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) (if logprofile (let* ((htmllogfile (conc stepname ".html")) (oldexitstat exitstat) (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) (debug:print 2 "INFO: running \"" cmd "\"") (change-directory startingdir) |
︙ | ︙ | |||
684 685 686 687 688 689 690 691 692 693 694 695 696 697 | (let ((db #f) (keys #f)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (set! keys (rdb:get-keys db)) (debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", ")) (sqlite3:finalize! db) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin | > > | 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 | (let ((db #f) (keys #f)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (set! keys (rdb:get-keys db)) (debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", ")) (sqlite3:finalize! db) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin |
︙ | ︙ | |||
723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 | (begin (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db (set! db (open-db)) (runs:update-all-test_meta db) (sqlite3:finalize! db) (set! *didsomething* #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== (if (args:get-arg "-repl") (let* ((toppath (setup-for-run)) (db (if toppath (open-db) #f))) (if db (begin (set! *db* db) (import readline) (import apropos) (gnu-history-install-file-manager (string-append (or (get-environment-variable "HOME") ".") "/.megatest_history")) (current-input-port (make-gnu-readline-port "megatest> ")) | > > > > | > | 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 | (begin (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (runs:update-all-test_meta db) (sqlite3:finalize! db) (set! *didsomething* #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== (if (args:get-arg "-repl") (let* ((toppath (setup-for-run)) (db (if toppath (open-db) #f))) (if db (begin (set! *db* db) (if (not (args:get-arg "-server")) (server:client-setup db)) (import readline) (import apropos) (gnu-history-install-file-manager (string-append (or (get-environment-variable "HOME") ".") "/.megatest_history")) (current-input-port (make-gnu-readline-port "megatest> ")) (repl))) (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if (not *didsomething*) (debug:print 0 help)) |
︙ | ︙ |
Modified runs.scm from [87f314f9eb] to [27defb6fc2].
︙ | ︙ | |||
400 401 402 403 404 405 406 | (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique (testdat (rdb:get-test-info db run-id test-name item-path))) (if (not testdat) (begin ;; ensure that the path exists before registering the test (system (conc "mkdir -p " new-test-path)) | | | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 | (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique (testdat (rdb:get-test-info db run-id test-name item-path))) (if (not testdat) (begin ;; ensure that the path exists before registering the test (system (conc "mkdir -p " new-test-path)) (rtests:register-test db run-id test-name item-path) (set! testdat (rdb:get-test-info db run-id test-name item-path)))) (change-directory test-path) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat)) 'failed-to-insert)) |
︙ | ︙ | |||
580 581 582 583 584 585 586 587 588 589 590 591 592 593 | (let ((db #f) (keys #f)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (set! keys (rdb:get-keys db)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL (runconfig (read-config runconfigf #f #f environ-patt: #f))) (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) | > > | 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 | (let ((db #f) (keys #f)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (set! keys (rdb:get-keys db)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL (runconfig (read-config runconfigf #f #f environ-patt: #f))) (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) |
︙ | ︙ |
Modified server.scm from [91a0daa68e] to [83f96f7c65].
︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 | (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo) (import (prefix sqlite3 sqlite3:)) (declare (unit server)) (declare (uses common)) (declare (uses db)) (include "common_records.scm") (include "db_records.scm") ;; procstr is the name of the procedure to be called as a string (define (server:autoremote procstr params) (handle-exceptions | > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo) (import (prefix sqlite3 sqlite3:)) (declare (unit server)) (declare (uses common)) (declare (uses db)) (declare (uses tests)) (include "common_records.scm") (include "db_records.scm") ;; procstr is the name of the procedure to be called as a string (define (server:autoremote procstr params) (handle-exceptions |
︙ | ︙ | |||
183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 | (db:get-test-info db run-id testname item-path))) (rpc:publish-procedure! 'rdb:delete-test-records (lambda (test-id) (db:delete-test-records db test-id))) (set! *rpc:listener* rpc:listener) (on-exit (lambda () (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port) (sqlite3:finalize! db))) (thread-start! th1) (thread-join! th1))) ;; rpc:server))) (define (server:find-free-port-and-open port) (handle-exceptions exn (begin (print "Failed to bind to port " (rpc:default-server-port) ", trying next port") (server:find-free-port-and-open (+ port 1))) (rpc:default-server-port port) (tcp-listen (rpc:default-server-port)))) (define (server:client-setup db) | > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 | (db:get-test-info db run-id testname item-path))) (rpc:publish-procedure! 'rdb:delete-test-records (lambda (test-id) (db:delete-test-records db test-id))) (rpc:publish-procedure! 'rtests:register-test (lambda (run-id test-name item-path) (tests:register-test db run-id test-name item-path))) (set! *rpc:listener* rpc:listener) (on-exit (lambda () (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port) (sqlite3:finalize! db))) (thread-start! th1) (thread-join! th1))) ;; rpc:server))) (define (server:find-free-port-and-open port) (handle-exceptions exn (begin (print "Failed to bind to port " (rpc:default-server-port) ", trying next port") (server:find-free-port-and-open (+ port 1))) (rpc:default-server-port port) (tcp-listen (rpc:default-server-port)))) (define (server:client-setup db) (if *runremote* (debug:print 0 "ERROR: Attempt to connect to server but already connected") (let* ((hostinfo (db:get-var db "SERVER")) (hostdat (if hostinfo (string-split hostinfo ":"))) (host (if hostinfo (car hostdat))) (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) (if (and port (string->number port)) (let ((portn (string->number port))) (debug:print 2 "INFO: Setting up to connect to host " host ":" port) (handle-exceptions exn (begin (print "Exception: " exn) (set! *runremote* #f)) (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server ((rpc:procedure 'serve:login host portn) *toppath*)) (begin (debug:print 2 "INFO: Connected to " host ":" port) (set! *runremote* (vector host portn))) (begin (debug:print 2 "INFO: Failed to connect to " host ":" port) (set! *runremote* #f))))) (debug:print 2 "INFO: no server available"))))) |
Modified tests.scm from [ded3e6a05b] to [70b97ad27c].
|
| | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp rpc) (import (prefix sqlite3 sqlite3:)) (import (prefix rpc rpc:)) (declare (unit tests)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") (define (tests:register-test db run-id test-name item-path) (let ((item-paths (if (equal? item-path "") (list item-path) (list item-path "")))) (for-each (lambda (pth) (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');" run-id |
︙ | ︙ | |||
375 376 377 378 379 380 381 | ;;====================================================================== (define (test:archive db test-id) #f) (define (test:archive-tests db keynames target) #f) | > > > > > > > > > > > | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 | ;;====================================================================== (define (test:archive db test-id) #f) (define (test:archive-tests db keynames target) #f) ;;====================================================================== ;; R P C ;;====================================================================== (define (rtests:register-test db run-id test-name item-path) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rtests:register-test host port) run-id test-name item-path)) (tests:register-test db run-id test-name item-path))) |