Overview
Comment: | wip |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.80-tcp-inmem |
Files: | files | file ages | folders |
SHA1: |
0cc9990634f980a5b71a7e0b8187d239 |
User & Date: | matt on 2023-02-16 20:52:16 |
Other Links: | branch diff | manifest | tags |
Context
2023-02-16
| ||
21:16 | Mixed up tt:handler and tt:client-connect-to-server. tt:handler is a bad name. check-in: 3970f89cba user: matt tags: v1.80-tcp-inmem | |
20:52 | wip check-in: 0cc9990634 user: matt tags: v1.80-tcp-inmem | |
13:24 | wip, compiles check-in: 12dfb79088 user: matt tags: v1.80-tcp-inmem | |
Changes
Modified common.scm from [9cf1db18d8] to [bd866cb06f].
︙ | |||
247 248 249 250 251 252 253 | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 | - - - - - - - - - - - - - - - - - - - - - - - | (define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*)) (define (common:get-sync-lock-filepath) (let* ((tmp-area (common:get-db-tmp-area)) (lockfile (conc tmp-area "/megatest.db.sync-lock"))) lockfile)) |
︙ |
Modified commonmod.scm from [35092db3d2] to [2f94513c1a].
︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | + | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit commonmod)) ;; (declare (uses debugprint)) (use srfi-69) (module commonmod * (import scheme |
︙ | |||
38 39 40 41 42 43 44 45 46 47 48 49 50 51 | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | + + | posix regex regex-case srfi-1 srfi-18 srfi-69 typed-records ;; debugprint ) ;;====================================================================== ;; CONTENTS ;; ;; config file utils ;; misc conversion, data manipulation functions |
︙ | |||
533 534 535 536 537 538 539 540 | 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 | + + + + + + + + + + + + + + + + + + + + + + - + + | (hash-table-set! dat key1 (make-hash-table)) (db:hoh-set! dat key1 key2 val))))) (define (db:hoh-get dat key1 key2) (let* ((subhash (hash-table-ref/default dat key1 #f))) (and subhash (hash-table-ref/default subhash key2 #f)))) ;;====================================================================== ;; when called from a wrapper I need sometimes to find the calling ;; wrapper, this is for dashboard to find the correct megatest. ;; (define (common:find-local-megatest #!optional (progname "megatest")) (let ((res (filter file-exists? (map (lambda (updir) (let* ((lm (car (argv))) (dir (pathname-directory lm)) (exe (pathname-strip-directory lm))) (conc (if dir (conc dir "/") "") (case (string->symbol exe) ((dboard) (conc updir progname)) ((mtest) (conc updir progname)) ((dashboard) progname) (else exe))))) '("../../" "../"))))) (if (null? res) (begin ;; (debug:print 0 *default-log-port* "Failed to find this executable! Using what can be found on the path") progname) (car res)))) |
Modified db.scm from [8ad20ecf12] to [5ccfde4036].
︙ | |||
20 21 22 23 24 25 26 27 28 29 30 31 32 33 | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | + + + + + + + + + + | ;;====================================================================== ;; Database access ;;====================================================================== ;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc (declare (unit db)) (declare (uses common)) (declare (uses debugprint)) (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses keys)) (declare (uses ods)) (declare (uses client)) (declare (uses mt)) (use (srfi 18) extras tcp stack (prefix sqlite3 sqlite3:) srfi-1 posix |
︙ | |||
42 43 44 45 46 47 48 | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | - - - - - - - - - - + | format dot-locking z3 typed-records matchable files) |
︙ |
Modified dbfile.scm from [e2ae99b5f6] to [3625445cee].
︙ | |||
39 40 41 42 43 44 45 | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | - + + | ports commonmod ;; debugprint ) (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic |
︙ |
Modified dbmemmod.scm from [44a9b812e0] to [40c7d92533].
︙ | |||
15 16 17 18 19 20 21 | 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 | - + + - | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit dbmemmod)) |
︙ |
Modified launch.scm from [a705b2e0b2] to [71dc1696f9].
︙ | |||
31 32 33 34 35 36 37 38 39 40 41 42 43 | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | + - + + | (declare (unit launch)) (declare (uses subrun)) (declare (uses common)) (declare (uses commonmod)) (declare (uses configf)) (declare (uses db)) (declare (uses ezsteps)) (declare (uses dbfile)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "megatest-fossil-hash.scm") |
︙ | |||
1141 1142 1143 1144 1145 1146 1147 | 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 | - + + + + | (begin (setenv "MT_RUN_AREA_HOME" *toppath*) (setenv "MT_TESTSUITENAME" (common:get-testsuite-name))) (begin (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") (set! *toppath* #f) ;; force it to be false so we return #f #f)) |
︙ |
Modified megatest.scm from [c83ac29735] to [afc7c13a07].
︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | + + | (define (toplevel-command . a) #f) (declare (uses common)) ;; (declare (uses megatest-version)) (declare (uses margs)) (declare (uses commonmod)) (declare (uses commonmod.import)) (declare (uses mtargs)) (declare (uses mtargs.import)) (declare (uses debugprint)) (declare (uses debugprint.import)) (declare (uses runs)) (declare (uses launch)) (declare (uses server)) (declare (uses client)) (declare (uses tests)) |
︙ | |||
48 49 50 51 52 53 54 | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | - - - + + + - | (declare (uses diff-report)) (declare (uses db)) (declare (uses dbfile)) (declare (uses dbfile.import)) (declare (uses dbmod)) (declare (uses dbmod.import)) (declare (uses tcp-transportmod)) |
︙ | |||
83 84 85 86 87 88 89 90 | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | + - | (use sparse-vectors) (require-library mutils) (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file ;; set some parameters here (include "transport-mode.scm") |
︙ |
Modified rmt.scm from [92c8008249] to [8d3c2d9888].
︙ | |||
19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | 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 | + + - + | ;;====================================================================== (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) (declare (uses http-transport)) (declare (uses commonmod)) (declare (uses dbfile)) (declare (uses dbmemmod)) (declare (uses tcp-transportmod)) (include "common_records.scm") ;; (declare (uses rmtmod)) ;; used by http-transport (import dbfile) ;; rmtmod) (import commonmod |
︙ |
Modified tcp-transportmod.scm from [bcc58b423c] to [922ca0812d].
︙ | |||
40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | 40 41 42 43 44 45 46 47 48 49 50 51 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 | + - + + + + | matchable md5 message-digest ports posix regex regex-case s11n srfi-1 srfi-18 srfi-4 srfi-69 stack typed-records tcp-server tcp |
︙ | |||
87 88 89 90 91 92 93 | 91 92 93 94 95 96 97 98 99 100 101 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 130 131 132 | + + + + - - + + + + + + + + + + + + + + + + + + + + + + + + | (host-port #f) (cmd-thread #f) ) (define (tt:make-remote areapath) (make-tt area: areapath)) ;; ;; DUPLICATED WITH tt:handler (I think) ;; |
︙ | |||
121 122 123 124 125 126 127 | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 | - - + + + + + + + + + + + + + + + + + - + + + + | (thread-sleep! 1) (tt:handler runremote cmd rid params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe))))))) (define (tt:bid-for-servership run-id) #f) |
︙ | |||
241 242 243 244 245 246 247 248 249 250 251 252 253 254 | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 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 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | ;; future: ping oldest, if alive remove other :<dbfname> files ;; (define (tt:find-server ttdat dbfname) (let* ((areapath (tt-areapath ttdat)) (servdir (tt:get-servinfo-dir areapath)) (sfiles (glob (conc servdir"/*:"dbfname)))) sfiles)) ;; given a path to a server info file return: host port startseconds server-id ;; example of what it's looking for in the log file: ;; SERVER STARTED: 10.38.175.67:50216 AT 1616502350.0 server-id: 4907e90fc55c7a09694e3f658c639cf4 ;; (define (tt:server-get-info logf) (let ((server-rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+) pid: (\\d+)")) ;; SERVER STARTED: host:port AT timesecs server id (dbprep-rx (regexp "^SERVER: dbprep")) (dbprep-found 0) (bad-dat (list #f #f #f #f #f))) (handle-exceptions exn (begin ;; WARNING: this is potentially dangerous to blanket ignore the errors (if (file-exists? logf) (debug:print-info 2 *default-log-port* "Unable to get server info from "logf", exn=" exn)) bad-dat) ;; no idea what went wrong, call it a bad server (with-input-from-file logf (lambda () (let loop ((inl (read-line)) (lnum 0)) (if (not (eof-object? inl)) (let ((mlst (string-match server-rx inl)) (dbprep (string-match dbprep-rx inl))) (if dbprep (set! dbprep-found 1)) (if (not mlst) (if (< lnum 500) ;; give up if more than 500 lines of server log read (loop (read-line)(+ lnum 1)) (begin (debug:print-info 0 *default-log-port* "Unable to get server info from first 500 lines of " logf ) bad-dat)) (match mlst ((_ host port start server-id pid) (list host (string->number port) (string->number start) server-id (string->number pid))) (else (debug:print 0 *default-log-port* "ERROR: did not recognise SERVER line info "mlst) bad-dat)))) (begin (if dbprep-found (begin (debug:print-info 2 *default-log-port* "Server is in dbprep at " (common:human-time)) (thread-sleep! 0.5)) ;; was 25 sec but that blocked things from starting? (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (seconds->time-string (current-seconds)))) bad-dat)))))))) ;; Given an area path, start a server process ### NOTE ### > file 2>&1 ;; if the target-host is set ;; try running on that host ;; incidental: rotate logs in logs/ dir. ;; (define (tt:server-process-run areapath testsuite mtexe run-id #!key (profile-mode "")) ;; areapath is *toppath* for a given testsuite area |
︙ |