Overview
Comment: | Fixed param order issue that was causing some server crashes. Cleaned up some exception handing |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.60 |
Files: | files | file ages | folders |
SHA1: |
3a0e887fa84a31cc2684fedafb292e38 |
User & Date: | matt on 2014-11-18 00:15:30 |
Other Links: | branch diff | manifest | tags |
Context
2014-11-18
| ||
09:32 | Force start on servers before doing write heavy stuff. The transition when doing writes from direct access -> server needs improving. This is a work-around (but a good feature anyway. check-in: c101fd0ec9 user: mrwellan tags: v1.60 | |
00:15 | Fixed param order issue that was causing some server crashes. Cleaned up some exception handing check-in: 3a0e887fa8 user: matt tags: v1.60 | |
2014-11-17
| ||
20:32 | Adding back some tests check-in: faa19d1d5f user: matt tags: v1.60 | |
Changes
Modified common_records.scm from [785b03b237] to [08c9f6257d].
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | 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 27 28 29 30 31 32 33 34 35 36 37 38 39 | + + + + + + + + + + + + + + + + + + + | ;;====================================================================== ;; Copyright 2006-2012, 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. ;;====================================================================== ;; (use trace) ;; Some of these routines use: ;; ;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html ;; ;; Syntax for defining macros in a simple style similar to function definiton, ;; when there is a single pattern for the argument list and there are no keywords. ;; ;; (define-simple-syntax (name arg ...) body ...) ;; (define-syntax define-simple-syntax (syntax-rules () ((_ (name arg ...) body ...) (define-syntax name (syntax-rules () ((name arg ...) (begin body ...))))))) (define-syntax common:handle-exceptions (syntax-rules () ((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...)))) (define (debug:calc-verbosity vstr) (cond ((number? vstr) vstr) ((not (string? vstr)) 1) ;; ((string-match "^\\s*$" vstr) 1) (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) (cond |
︙ |
Modified db.scm from [f79d03493a] to [d047d1e2d5].
︙ | |||
30 31 32 33 34 35 36 37 38 39 40 41 42 43 | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | + + + + + + + + + + + + + + + + + + | (include "key_records.scm") (include "run_records.scm") (define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's (define *number-of-writes* 0) (define *number-non-write-queries* 0) ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== ;; convert to -inline (define (db:first-result-default db stmt default . params) (handle-exceptions exn (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) (if (eq? err-status 'done) default (begin (debug:print 0 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) ;; Get/open a database ;; if run-id => get run specific db ;; 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 ;; |
︙ | |||
427 428 429 430 431 432 433 434 435 436 437 438 439 440 | 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 | + - - + + + | ;; (define (db:sync-tables tbls fromdb todb . slave-dbs) (mutex-lock! *db-sync-mutex*) (handle-exceptions exn (begin (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") (print-call-chain (current-error-port)) (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (debug:print 0 " src db: " (db:dbdat-get-path fromdb)) (for-each (lambda (dbdat) (debug:print 0 " dbpath: " (db:dbdat-get-path dbdat))) (cons todb slave-dbs)) |
︙ | |||
1861 1862 1863 1864 1865 1866 1867 | 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 | + + - - + + + | (define (db:test-get-top-process-pid dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (db) (db:first-result-default db |
︙ | |||
2658 2659 2660 2661 2662 2663 2664 | 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 | - - - - - - - - - - - - - - - - - - | ;; if the test is not found then clearly the waiton is not met... ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) |
︙ |
Modified http-transport.scm from [0ec84bc71c] to [068fb6dcc3].
︙ | |||
461 462 463 464 465 466 467 | 461 462 463 464 465 466 467 468 469 470 471 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 | + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | ;; Consider implementing some smarts here to re-insert the record or kill self is ;; the db indicates so ;; ;; (if (tasks:server-am-i-the-server? tdb run-id) ;; (tasks:server-set-state! tdb server-id "running")) ;; (loop 0 server-state)) (http-transport:server-shutdown server-id port))))) |
︙ |
Modified launch.scm from [3011b582fa] to [e538ecba1a].
︙ | |||
62 63 64 65 66 67 68 | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | - + | (top-path (assoc/default 'toppath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) ;; (runremote (assoc/default 'runremote cmdinfo)) (transport (assoc/default 'transport cmdinfo)) |
︙ | |||
785 786 787 788 789 790 791 | 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 | - + | (debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run"))) (set! cmdparms (base64:base64-encode (z3:encode-buffer (with-output-to-string (lambda () ;; (list 'hosts hosts) (write (list (list 'testpath test-path) (list 'transport (conc *transport-type*)) |
︙ |
Modified tasks.scm from [f329b3e32b] to [d12c4149c9].
︙ | |||
26 27 28 29 30 31 32 | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | + + + + + - + | ;; (define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f)) (if (not (string? path)) (debug:print 0 "ERROR: Called tasks:wait-on-journal with path=" path " (not a string)") (let ((fullpath (conc path "-journal"))) (handle-exceptions exn (begin (print-call-chain (current-error-port)) (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 " exn=" (condition->list exn)) (debug:print 0 "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") |
︙ | |||
306 307 308 309 310 311 312 | 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 | - + + - - - - - - - - - + + + + + + + + + | (vector header res))) (define (tasks:get-server mdb run-id #!key (retries 10)) (let ((res #f) (best #f)) (handle-exceptions exn |
︙ | |||
373 374 375 376 377 378 379 | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 | - - - - - - - - - - - - - - - - - - - - - - - - - - - - | (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) )) |
︙ |
Modified tdb.scm from [13705ac22c] to [575d5c7ba8].
︙ | |||
52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | + + | (dbexists (file-exists? dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) (handle-exceptions exn (begin (print-call-chain (current-error-port)) (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) (set! db (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access (set! dbexists #f)) ;; must force re-creation of tables, more tom-foolery (set! db (sqlite3:open-database dbpath))) (if *db-write-access* (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") (debug:print-info 11 "Initialized test database " dbpath) (tdb:testdb-initialize db))) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") (debug:print-info 11 "open-test-db END (sucessful)" work-area) ;; now let's test that everything is correct (handle-exceptions exn (begin (print-call-chain (current-error-port)) (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " dbpath ".\n " ((condition-property-accessor 'exn 'message) exn)) #f) ;; Is there a cheaper single line operation that will check for existance of a table ;; and raise an exception ? (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) |
︙ |
Modified tests.scm from [3b87b51253] to [2a580a2e0e].
︙ | |||
645 646 647 648 649 650 651 | 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 | - - - - - - - - - - - - - - - - - - - - - + + | (define (tests:set-full-meta-info db test-id run-id minutes work-area remtries) ;; (define (tests:set-full-meta-info test-id run-id minutes work-area) ;; (let ((remtries 10)) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (uname (get-uname "-srvpio")) (hostname (get-host-name))) |
︙ |