Changes In Branch v1.64-new-pkts Excluding Merge-Ins
This is equivalent to a diff from 77f7d5ef17 to 1de85e740b
2017-03-20
| ||
15:15 | merged v1.64-new-pkts check-in: 77cb77fb6a user: bjbarcla tags: v1.64 | |
13:35 | Merged server-fix Closed-Leaf check-in: 1de85e740b user: matt tags: v1.64-new-pkts | |
12:50 | Merged in homehost-protection patch check-in: 25c202aa9d user: matt tags: v1.64-new-pkts | |
12:12 | missing server fix commit Closed-Leaf check-in: 74d9575642 user: matt tags: server-fix | |
2017-03-16
| ||
18:05 | Adapt to refactored pkts egg. check-in: 8a6b4757c8 user: matt tags: v1.64-new-pkts | |
2017-03-15
| ||
23:44 | Cleaned up after bug squishing. Several minor bugs found. Added all-rmt unit test and made it the default sole unit flow to run Closed-Leaf check-in: 77f7d5ef17 user: matt tags: v1.64-bug-sqlish | |
21:14 | bug squashing frenzy using overriding of handle-exceptions to expose problems. partial progress snapshot check-in: 8e70f505b7 user: matt tags: v1.64-bug-sqlish | |
Modified archive.scm from [31c5249136] to [7dd47285c1].
︙ | |||
109 110 111 112 113 114 115 | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | - + | (archive-info (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space)) (archive-dir (if archive-info (cdr archive-info) #f)) (archive-id (if archive-info (car archive-info) -1)) (disk-groups (make-hash-table)) (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (compress (or (configf:lookup *configdat* "archive" "compress") "9")) |
︙ | |||
209 210 211 212 213 214 215 | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 | - + | (hash-table-keys disk-groups)) #t)) (define (archive:bup-restore archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) |
︙ |
Modified cgisetup/models/pgdb.scm from [c3a02037dc] to [0f76410646].
︙ | |||
24 25 26 27 28 29 30 | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | - + | ;; (import chicken) (use typed-records (prefix dbi dbi:)) ;; given a configdat lookup the connection info and open the db ;; (define (pgdb:open configdat #!key (dbname #f)) |
︙ |
Modified common.scm from [cb8fbcb993] to [eab4c1e605].
︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | 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 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | + + + - - - - - - + + + + + + + | (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit common)) (declare (uses keys)) (include "common_records.scm") ;; (require-library margs) ;; (include "margs.scm") ;; (define old-exit exit) ;; ;; (define (exit . code) ;; (if (null? code) ;; (old-exit) ;; (old-exit code))) (define getenv get-environment-variable) (define (safe-setenv key val) (if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables. (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"") |
︙ | |||
950 951 952 953 954 955 956 | 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 | - - + + + + + + + | ((and (equal? args-testpatt "%") rtestpatt) (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt) rtestpatt) (else args-testpatt)))) (define (common:get-linktree) (or (getenv "MT_LINKTREE") |
︙ | |||
1008 1009 1010 1011 1012 1013 1014 | 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 | + + + + + + + + + + + + - - - - - - - - - - - - + + + + + + + + + + + + | (common:get-homehost trynum: (- trynum 1))) #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" ) (handle-exceptions exn (if (> trynum 0) (let ((delay-time (* (- 5 trynum) 5))) (mutex-unlock! *homehost-mutex*) (debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file, delaying " delay-time " seconds and trying again, message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! delay-time) (common:get-homehost trynum: (- trynum 1))) (begin (mutex-unlock! *homehost-mutex*) (debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file after trying five times. Giving up and exiting, message: " ((condition-property-accessor 'exn 'message) exn)) (exit 1))) |
︙ | |||
1609 1610 1611 1612 1613 1614 1615 | 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 | - + + | (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (string-search whitesp val) "\"" ""))) |
︙ |
Modified configf.scm from [881a699c98] to [346c0caf52].
︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | + | ;; Config file handling ;;====================================================================== (use regex regex-case) ;; directory-utils) (declare (unit configf)) (declare (uses process)) (declare (uses env)) (declare (uses keys)) (include "common_records.scm") ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) |
︙ |
Modified http-transport.scm from [91a7291a41] to [a75c26faf4].
︙ | |||
55 56 57 58 59 60 61 | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | - + | (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (portlogger:open-run-close portlogger:find-port)) |
︙ |
Modified launch.scm from [e503042943] to [b27c32acbe].
︙ | |||
10 11 12 13 14 15 16 | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | - + | ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== (use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv) |
︙ | |||
411 412 413 414 415 416 417 | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 | - + - + + + | (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (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)) |
︙ | |||
441 442 443 444 445 446 447 448 449 450 451 452 453 454 | 443 444 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 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 | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path ) ;; (rollup-status 0) (if contour (setenv "MT_CONTOUR" contour)) ;; On NFS it can be slow and unreliable to get needed startup information. ;; i. Check if we are on the homehost, if so, proceed ;; ii. Check if host and port passed in via CMDINFO are valid and if ;; possible use them. (let ((bestadrs (server:get-best-guess-address (get-host-name))) (needcare #f)) (if (equal? homehost bestadrs) ;; we are likely on the homehost (debug:print-info 0 *default-log-port* "test " test-name " appears to be running on the homehost " homehost) (let ((host-port (if serverurl (string-split serverurl ":") #f))) (if (not *runremote*)(set! *runremote* (make-remote))) ;; init *runremote* (if (string? homehost) (if (and host-port (> (length host-port) 1)) (let* ((host (car host-port)) (port (cadr host-port)) (start-res (http-transport:client-connect host port)) (ping-res (rmt:login-no-auto-client-setup start-res))) (if (and start-res ping-res) (let ((url (http-transport:server-dat-make-url start-res))) (remote-conndat-set! *runremote* start-res) (remote-server-url-set! *runremote* url) (debug:print-info 0 *default-log-port* "connected to " url " using CMDINFO data.")) (debug:print-info 0 *default-log-port* "received " host ":" port " for url but could not connect.") )) (begin (debug:print-info 0 *default-log-port* (if host-port (conc "received invalid host-port information " host-port) "no host-port information received")) ;; potential for bad situation if simultaneous starting of hundreds of jobs on servers, set needcare. (set! needcare #t))) (begin (debug:print-info 0 *default-log-port* "received no homehost information. Please report this to support as it should not happen.") (set! needcare #t))))) (if needcare ;; due to very slow NFS we will do a brute force mkdir to ensure that the directory inode it truly available on this host (let ((logdir (conc top-path "/logs"))) ;; we'll try to create this directory (handle-exceptions exn (debug:print 0 *default-log-port* "Failed to create directory " logdir " expect problems, message: " ((condition-property-accessor 'exn 'message) exn)) (create-directory logdir #t))))) ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (file-exists? top-path) (> count 10)) (change-directory top-path) (begin (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " top-path " not found") |
︙ | |||
574 575 576 577 578 579 580 | 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 | - + | (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) |
︙ | |||
680 681 682 683 684 685 686 | 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 | - + | (define (launch:cache-config) ;; if we have a linktree and -runtests and -target and the directory exists dump the config ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg (if (and *configdat* (or (args:get-arg "-run") (args:get-arg "-runtests") (args:get-arg "-execute"))) |
︙ | |||
740 741 742 743 744 745 746 | 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 | - + | res))) (define (launch:setup-body #!key (force #f) (areapath #f)) (let* ((toppath (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath (runname (common:args-get-runname)) (target (common:args-get-target exit-if-bad: #t)) (linktree (common:get-linktree)) |
︙ | |||
798 799 800 801 802 803 804 | 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 | + - - + + + + | (begin (debug:print-error 0 *default-log-port* "you are not in a megatest area!") (exit 1))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it (let* ((keys (rmt:get-keys)) (key-vals (keys:target->keyval keys target)) (linktree (common:get-linktree)) |
︙ | |||
838 839 840 841 842 843 844 | 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 | - + - | (set! *runconfigdat* rdat) (set! *toppath* toppath) (set! *configstatus* 'partial)) (begin (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.") (exit 2)))))) ;; additional house keeping |
︙ | |||
915 916 917 918 919 920 921 | 960 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 | - + + - - + + + | (define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat #!key (remtries 2)) (let* ((item-path (if (string? itemdat) itemdat (item-list->path itemdat))) ;; if pass in string - just use it (runname (if (string? run-info) ;; if we pass in a string as run-info use it as run-name. run-info (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname"))) |
︙ | |||
1086 1087 1088 1089 1090 1091 1092 | 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 | - + | ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) (define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex (let* ((item-path (item-list->path itemdat)) |
︙ | |||
1183 1184 1185 1186 1187 1188 1189 | 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 | - + + + + + + + + | (create-directory work-area #t) (debug:print 0 *default-log-port* "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) |
︙ |
Modified megatest.scm from [95c7d4b1ae] to [b75104b2c8].
︙ | |||
286 287 288 289 290 291 292 293 294 295 296 297 298 299 | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 | + + | "-target-db" "-source-db" "-src-target" "-src-runname" "-diff-email" "-sync-to" "-prefix-target" "-pgsync" "-diff-html" ) (list "-h" "-help" "--help" "-manual" "-version" "-force" "-xterm" |
︙ | |||
524 525 526 527 528 529 530 | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 | - + | ;; (if (args:get-arg "-clean-cache") (begin (set! *didsomething* #t) ;; suppress the help output. (if (getenv "MT_TARGET") ;; no point in trying if no target (if (args:get-arg "-runname") (let* ((toppath (launch:setup)) |
︙ |
Modified mt.scm from [0a710abd80] to [410c526eee].
︙ | |||
206 207 208 209 210 211 212 | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 | - + | (let ((test-dirs (tests:get-tests-search-path *configdat*))) (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) ;; Setting MT_LINKTREE here is almost certainly unnecessary. (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) (if (and (file-exists? tconfig-file) (file-read-access? tconfig-file)) |
︙ |
Modified mtut.scm from [fdb1ede093] to [9e88c442a2].
︙ | |||
10 11 12 13 14 15 16 | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | - + | ;; (include "common.scm") ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) |
︙ | |||
341 342 343 344 345 346 347 | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 | - + - + | (lambda (pkt) (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) (exists (lookup-by-uuid pdb uuid #f))) (if (not exists) (let* ((pktdat (string-intersperse (with-input-from-file pkt read-lines) "\n")) |
︙ | |||
760 761 762 763 764 765 766 | 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 | - + | (fold (lambda (a res) (let* ((key (car a)) ;; get the key name (val (cdr a)) (par (lookup-param-by-key key))) ;; (print "key: " key " val: " val " par: " par) (if par (conc res " " (param-translate par) " " val) |
︙ | |||
806 807 808 809 810 811 812 | 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 | - + | (areas (configf:get-section mtconf "areas")) (contours (configf:get-section mtconf "contours")) (pkts (find-pkts pdb '(cmd) '())) (torun (make-hash-table)) ;; target => ( ... info ... ) (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering (for-each (lambda (pktdat) |
︙ |
Modified rmt.scm from [93944166e1] to [5167aff935].
︙ | |||
34 35 36 37 38 39 40 | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | - - - - - + + + + + | ;; else return #f to let the calling proc know that there is no server available ;; (define (rmt:get-connection-info areapath #!key (area-dat #f)) ;; TODO: push areapath down. (let* ((runremote (or area-dat *runremote*)) (cinfo (if (remote? runremote) (remote-conndat runremote) #f))) |
︙ |
Modified runconfigs.config from [bc209cef2e] to [beb35b097a].
|
Modified runs.scm from [a2e7cae34f] to [8959c65de3].
︙ | |||
19 20 21 22 23 24 25 26 27 28 29 30 31 32 | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | + | (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses mt)) (declare (uses archive)) (declare (uses keys)) ;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") |
︙ | |||
54 55 56 57 58 59 60 | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | - + | (define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) (let* ((target (or intarget (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) |
︙ |
Modified tasks.scm from [3a8b93e01e] to [e18dae9779].
︙ | |||
58 59 60 61 62 63 64 | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | - + | (if remove (system (conc "rm -rf " fullpath))) #f))) #t)))))) (define (tasks:get-task-db-path) (let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir") (configf:lookup *configdat* "setup" "dbdir") |
︙ | |||
614 615 616 617 618 619 620 | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 | - + | (define (tasks:run-id->mtpg-run-id dbh cached-info run-id) (let* ((runs-ht (hash-table-ref cached-info 'runs)) (runinf (hash-table-ref/default runs-ht run-id #f))) (if runinf runinf ;; already cached (let* ((keytarg (string-intersperse (rmt:get-keys) "/")) ;; e.g. version/iteration/platform (spec-id (pgdb:get-ttype dbh keytarg)) |
︙ |