Comment: | Merged v1.65 into v1.64-areas-dashboard in prep to move to basing off v1.65 |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.64-areas-dashboard |
Files: | files | file ages | folders |
SHA1: |
adc89fda393154699c1712a5d8869184 |
User & Date: | mrwellan on 2017-09-13 11:10:02 |
Other Links: | branch diff | manifest | tags |
2017-11-29
| ||
10:15 | Pulled in some missing changes from v1.64 Leaf check-in: 20b0d4e9a1 user: mrwellan tags: v1.64-areas-dashboard | |
2017-11-17
| ||
14:24 | Attempted merge Leaf check-in: 3436c3834f user: mrwellan tags: attempted-merge (unpublished) | |
2017-09-13
| ||
17:45 | Resurected example flow Leaf check-in: 68a6b805c5 user: mrwellan tags: v1.65-areas-dashboard | |
11:10 | Merged v1.65 into v1.64-areas-dashboard in prep to move to basing off v1.65 check-in: adc89fda39 user: mrwellan tags: v1.64-areas-dashboard | |
2017-09-12
| ||
12:21 | added web tables to mt-pg.sql check-in: 5c94f3c919 user: pjhatwal tags: v1.65 | |
2017-08-28
| ||
21:25 | All rmt: calls replaced with db: calls using the dbstructs from areas. check-in: f9b5189ffe user: matt tags: v1.64-areas-dashboard | |
Modified .mtutil.scm from [3e3e4527c3] to [c25417b18d].
︙ | ︙ | |||
21 22 23 24 25 26 27 | last-name)))) (define (str-first-char->number str) (char->integer (string-ref str 0))) ;; example of how to set up and write target mappers ;; | < | | | < | | | < | | | | | | | | | | | | | | | | | | | | | | | < | | > > > > > | | 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 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | last-name)))) (define (str-first-char->number str) (char->integer (string-ref str 0))) ;; example of how to set up and write target mappers ;; (add-target-mapper 'prefix-contour (lambda (target run-name area area-path reason contour mode-patt) (conc contour "/" target))) (add-target-mapper 'prefix-area-contour (lambda (target run-name area area-path reason contour mode-patt) (conc area "/" contour "/" target))) (add-runname-mapper 'corporate-ww (lambda (target run-name area area-path reason contour mode-patt) (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt) (let* ((last-name (get-last-runname area-path target)) (last-letter (let* ((ch (if (string? last-name) (let ((len (string-length last-name))) (substring last-name (- len 1) len)) "a")) (chnum (str-first-char->number ch)) (a (str-first-char->number "a")) (z (str-first-char->number "z"))) (if (and (>= chnum a)(<= chnum z)) chnum #f))) (next-letter (if last-letter (list->string (list (integer->char (+ last-letter 1)))) ;; surely there is an easier way? "a"))) ;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter) (conc (seconds->wwdate (current-seconds)) next-letter)))) (add-runname-mapper 'auto (lambda (target run-name area area-path reason contour mode-patt) "auto-eh")) ;; run only areas where first letter of area name is "a" ;; (add-area-checker 'first-letter-a (lambda (area target contour) (string-match "^a.*$" area))) |
Modified Makefile from [32f21cf39e] to [5be2de8f29].
︙ | ︙ | |||
48 49 50 51 52 53 54 | dboard : $(OFILES) $(GOFILES) dashboard.scm dashboard-areas.scm csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard | | | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | dboard : $(OFILES) $(GOFILES) dashboard.scm dashboard-areas.scm csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut TCMTOBJS = \ api.o \ archive.o \ cgisetup/models/pgdb.o \ client.o \ |
︙ | ︙ | |||
144 145 146 147 148 149 150 151 152 153 154 155 156 157 | $(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut $(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil chmod a+x $(PREFIX)/bin/mtutil $(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt $(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt | > > > | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 | $(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut install-mtut : mtut $(INSTALL) mtut $(PREFIX)/bin/mtut $(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil chmod a+x $(PREFIX)/bin/mtutil $(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt $(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt |
︙ | ︙ |
Modified api.scm from [c4438e36a1] to [00e49270d6].
︙ | ︙ | |||
275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 | ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) ((get-var) (apply db:get-var dbstruct params)) ((get-run-stats) (apply db:get-run-stats dbstruct params)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) ;; TEST DATA ((read-test-data) (apply db:read-test-data dbstruct params)) ((read-test-data*) (apply db:read-test-data* dbstruct params)) ;; MISC ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) (run-id (cadr params)) | > > | 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 | ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) ((get-var) (apply db:get-var dbstruct params)) ((get-run-stats) (apply db:get-run-stats dbstruct params)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params)) ;; TEST DATA ((read-test-data) (apply db:read-test-data dbstruct params)) ((read-test-data*) (apply db:read-test-data* dbstruct params)) ((get-data-info-by-id) (apply db:get-data-info-by-id dbstruct params)) ;; MISC ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) (run-id (cadr params)) |
︙ | ︙ |
Modified archive.scm from [882dbab237] to [78f500d300].
1 2 3 4 5 6 7 8 9 10 11 | ;; 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') | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | ;; 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') (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) (declare (unit archive)) (declare (uses db)) (declare (uses common)) (include "common_records.scm") (include "db_records.scm") |
︙ | ︙ |
Modified cgisetup/models/pgdb.scm from [add2d5c9c3] to [875743c283].
︙ | ︙ | |||
96 97 98 99 100 101 102 | ;;====================================================================== ;; R U N S ;;====================================================================== ;; given a target spec id, target and run-name return the run-id ;; if no run found return #f ;; | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 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 188 189 190 191 192 | ;;====================================================================== ;; R U N S ;;====================================================================== ;; given a target spec id, target and run-name return the run-id ;; if no run found return #f ;; (define (pgdb:get-run-id dbh spec-id target run-name area-id) (dbi:get-one dbh "SELECT id FROM runs WHERE ttype_id=? AND target=? AND run_name=? and area_id=?;" spec-id target run-name area-id)) ;; given a run-id return all the run info ;; (define (pgdb:get-run-info dbh run-id ) ;; to join ttype or not? (dbi:get-one-row dbh ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 "SELECT id,target,ttype_id,run_name,state,status,owner,event_time,comment,fail_count,pass_count,last_update,area_id FROM runs WHERE id=? ;" run-id )) ;; refresh the data in a run record ;; (define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count area-id) ;; area-id) (dbi:exec dbh "UPDATE runs SET state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=? WHERE id=? and area_id=?;" state status owner event-time comment fail-count pass-count run-id area-id)) ;; given all needed info create run record ;; (define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id) (dbi:exec dbh "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id ) VALUES (?,?,?,?,?,?,?,?,?,?,?);" ttype-id target run-name state status owner event-time comment fail-count pass-count area-id)) ;;====================================================================== ;; T E S T - S T E P S ;;====================================================================== (define (pgdb:get-test-step-id dbh test-id stepname state) (dbi:get-one dbh "SELECT id FROM test_steps WHERE test_id=? AND stepname=? and state = ? ;" test-id stepname state)) (define (pgdb:insert-test-step dbh test-id stepname state status event_time comment logfile) (dbi:exec dbh "INSERT INTO test_steps (test_id,stepname,state,status,event_time,logfile,comment) VALUES (?,?,?,?,?,?,?);" test-id stepname state status event_time logfile comment)) (define (pgdb:update-test-step dbh step-id test-id stepname state status event_time comment logfile) (dbi:exec dbh "UPDATE test_steps SET test_id=?,stepname=?,state=?,status=?,event_time=?,logfile=?,comment=? WHERE id=?;" test-id stepname state status event_time logfile comment step-id)) ;;====================================================================== ;; T E S T - D A T A ;;====================================================================== (define (pgdb:get-test-data-id dbh test-id category variable) (dbi:get-one dbh "SELECT id FROM test_data WHERE test_id=? AND category=? and variable = ? ;" test-id category variable)) (define (pgdb:insert-test-data dbh test-id category variable value expected tol units comment status type) (dbi:exec dbh "INSERT INTO test_data (test_id, category, variable, value, expected, tol, units, comment, status, type) VALUES (?,?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units comment status type)) (define (pgdb:update-test-data dbh data-id test-id category variable value expected tol units comment status type) (dbi:exec dbh "UPDATE test_data SET test_id=?, category=?, variable=?, value=?, expected=?, tol=?, units=?, comment=?, status=?, type=? WHERE id=?;" test-id category variable value expected tol units comment status type data-id )) ;;====================================================================== ;; T E S T S ;;====================================================================== ;; given run-id, test_name and item_path return test-id ;; |
︙ | ︙ | |||
196 197 198 199 200 201 202 | SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE t.state='COMPLETED' AND r.target LIKE ? GROUP BY r.target;" target-patt)) | > | | | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > > > | > > > > > > > | > > > > > > > > > > > > > | > | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 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 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 | SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE t.state='COMPLETED' AND r.target LIKE ? GROUP BY r.target;" target-patt)) (define (pgdb:get-latest-run-stats-given-target dbh ttype-id target-patt limit offset) (dbi:get-rows dbh ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;" "SELECT r.target, r.event_time, COUNT(*) AS total, SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other, r.id FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE t.state like '%' AND ttype_id=? AND r.target LIKE ? and r.id in (SELECT DISTINCT on (target) id from runs where target like ? AND ttype_id=? order by target,event_time desc) GROUP BY r.target,r.id order by r.event_time desc limit ? offset ? ;" ttype-id target-patt target-patt ttype-id limit offset)) (define (pgdb:get-latest-run-stats-given-pattern dbh patt limit offset) (dbi:get-rows dbh ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target ILIKE ? GROUP BY r.target,t.status;" "SELECT r.target, r.event_time, COUNT(*) AS total, SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other, r.id FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE t.state like '%' AND r.target ILIKE ? and r.id in (SELECT DISTINCT on (target) id from runs where target ilike ? order by target,event_time desc) GROUP BY r.target,r.id order by r.event_time desc limit ? offset ? ;" patt patt limit offset)) (define (pgdb:get-count-data-stats-target-latest dbh ttype-id target-patt) (dbi:get-rows dbh "SELECT count(*) from (SELECT DISTINCT on (target) id from runs where target like ? AND ttype_id = ? order by target, event_time desc ) as x;" target-patt ttype-id)) (define (pgdb:get-latest-run-cnt dbh ttype-id target-patt) (let* ((cnt-result (pgdb:get-count-data-stats-target-latest dbh ttype-id target-patt)) ;(cnt-row (car (cnt-result))) (cnt 0) ) (for-each (lambda (row) (set! cnt (vector-ref row 0 ))) cnt-result) cnt)) (define (pgdb:get-count-data-stats-latest-pattern dbh patt) (dbi:get-rows dbh "SELECT count(*) from (SELECT DISTINCT on (target) id from runs where target ilike ? order by target, event_time desc ) as x;" patt)) (define (pgdb:get-latest-run-cnt-by-pattern dbh target-patt) (let* ((cnt-result (pgdb:get-count-data-stats-latest-pattern dbh target-patt)) ;(cnt-row (car (cnt-result))) (cnt 0) ) (for-each (lambda (row) (set! cnt (vector-ref row 0 ))) cnt-result) cnt)) (define (pgdb:get-run-stats-history-given-target dbh ttype-id target-patt) (dbi:get-rows dbh ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;" "SELECT r.run_name,COUNT(*) AS total, SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE t.state like '%' AND ttype_id=? AND r.target LIKE ? GROUP BY r.run_name;" ttype-id target-patt )) (define (pgdb:get-all-run-stats-target-slice dbh target-patt limit offset) (dbi:get-rows dbh "SELECT r.target, r.run_name,r.event_time, COUNT(*) AS total, SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE r.target LIKE ? GROUP BY r.target,r.run_name, r.event_time order by r.target,r.event_time desc limit ? offset ? ;" target-patt limit offset)) (define (pgdb:get-count-data-stats-target-slice dbh target-patt) (dbi:get-rows dbh "SELECT count(*) from (SELECT r.target, r.run_name,r.event_time, COUNT(*) AS total FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE r.target LIKE ? GROUP BY r.target,r.run_name, r.event_time ) as x;" target-patt)) (define (pgdb:get-slice-cnt dbh target-patt) (let* ((cnt-result (pgdb:get-count-data-stats-target-slice dbh target-patt)) ;(cnt-row (car (cnt-result))) (cnt 0) ) (for-each (lambda (row) (set! cnt (vector-ref row 0 ))) cnt-result) cnt)) (define (pgdb:get-target-types dbh) (dbi:get-rows dbh "SELECT id,target_spec FROM ttype;")) (define (pgdb:get-distict-target-slice dbh) (dbi:get-rows dbh " select distinct on (split_part (target, '/', 1)) (split_part (target, '/', 1)) from runs;")) (define (pgdb:get-distict-target-slice3 dbh) (dbi:get-rows dbh " select distinct on (split_part (target, '/', 3)) (split_part (target, '/', 3)) from runs;")) ;; (define (pgdb:get-targets dbh target-patt) (let ((ttypes (pgdb:get-target-types dbh))) (map (lambda (ttype-dat) (let ((tt-id (vector-ref ttype-dat 0)) (ttype (vector-ref ttype-dat 1))) |
︙ | ︙ | |||
285 286 287 288 289 290 291 292 293 | ;; create a hash of hashes with keys extracted from all-parts ;; using row-or-col to choose row or column ;; ht{row key}=>ht{col key}=>data ;; ;; fnum is the field number in the tuples to be split ;; (define (pgdb:coalesce-runs dbh runs all-parts row-or-col fnum) (let* ((data (make-hash-table))) | > > > > > > > > > > > > > > | < > > > > > > > > > > > > > > > > > > | 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 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 | ;; create a hash of hashes with keys extracted from all-parts ;; using row-or-col to choose row or column ;; ht{row key}=>ht{col key}=>data ;; ;; fnum is the field number in the tuples to be split ;; (define (pgdb:mk-pattern dot type bp rel) (let* ((typ (if (equal? type "all") "%" type)) (dotprocess (if (equal? dot "all") "%" dot)) (rel-num (if (equal? rel "") "%" rel)) (pattern (conc "%/" bp "/" dotprocess "/" typ "_" rel-num))) pattern)) (define (pgdb:coalesce-runs dbh runs all-parts row-or-col fnum) (let* ((data (make-hash-table))) (for-each (lambda (run) (let* ((target (vector-ref run fnum)) (parts (string-split target "/")) (first (car parts)) (rest (string-intersperse (cdr parts) "/")) (coldat (hash-table-ref/default data first #f))) (if (not coldat)(let ((newht (make-hash-table))) (hash-table-set! data first newht) (set! coldat newht))) (hash-table-set! coldat rest run))) runs) data)) (define (pgdb:coalesce-runs1 runs ) (let* ((data (make-hash-table))) (for-each (lambda (run) (let* ((target (vector-ref run 0)) (parts (string-split target "/")) (first (car parts)) (rest (string-intersperse (cdr parts) "/")) (coldat (hash-table-ref/default data first #f))) (if (not coldat)(let ((newht (make-hash-table))) (hash-table-set! data first newht) (set! coldat newht))) (hash-table-set! coldat rest run))) |
︙ | ︙ | |||
377 378 379 380 381 382 383 | (let* ((data (make-hash-table))) (for-each (lambda (run) (let* ((run-name (vector-ref run 0))) (hash-table-set! data run-name run))) runs) data)) | > > > > > > > > > > | 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 | (let* ((data (make-hash-table))) (for-each (lambda (run) (let* ((run-name (vector-ref run 0))) (hash-table-set! data run-name run))) runs) data)) (define (pgdb:get-pg-lst tab2-pages) (let loop ((i 1) (lst `())) (cond ((> i tab2-pages ) lst) (else (loop (+ i 1) (append lst (list i))))))) |
Added cgisetup/pages/filter-defs-template.scm version [af1a6727be].
> > > | 1 2 3 | (define *p* '("a" "b" "c")) (define *k* '("all" "a")) (define *d* '("all" 1 2 3 6 5 8 11 12)) |
Modified cgisetup/pages/home.scm from [25e1fcbe47] to [a4707fbef0].
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | ;;====================================================================== ;; Copyright 2017, 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 regex) (load "models/pgdb.scm") (include "pages/home_ctrl.scm") (include "pages/home_view.scm") | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | ;;====================================================================== ;; Copyright 2017, 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 regex) (load "models/pgdb.scm") (include "pages/filter-defs.scm") (include "pages/home_ctrl.scm") (include "pages/home_view.scm") |
Modified cgisetup/pages/home_ctrl.scm from [e5b104a203] to [64b5eee90a].
︙ | ︙ | |||
10 11 12 13 14 15 16 | ;;====================================================================== ;; a function <pagename>-action is called on POST (define (home-action action) (case (string->symbol action) ((filter) | | | | | | < < | | | | < < < < < < | < < | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | ;;====================================================================== ;; a function <pagename>-action is called on POST (define (home-action action) (case (string->symbol action) ((filter) (let ((dot (s:get-input 'dot)) (type (s:get-input 'kit-type)) (rel (s:get-input 'rel-num)) (bp (s:get-input 'bp))) ;; ;; s:set! is a page local var. Better than s:session-var-set! but still not a good idea. ;; (s:set! "dot" dot) (s:set! "type" type) (s:set! "bp" bp) (s:set! "rel" rel))))) |
Modified cgisetup/pages/home_view.scm from [4f70880903] to [f43ad9b3a3].
1 2 3 4 5 6 7 8 9 10 11 12 13 | ;;====================================================================== ;; Copyright 2017, 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. ;;====================================================================== (define (pages:home session db shared) (let* ((dbh (s:db)) | > > > > > | > > > > | > | | < | | | < > > | | > > | > > | < | < < < | | < < | | | > > > | > > > | < < < < < < < < | < < < < < < < < < < | < < < < < < < < < | | | < < < < < < < < < < < < < < < < < < < < < < < | | | | | | > | > > > | | | < < > | > | | > | > > > > > > > | < < < | < < < < < < < < < < < < < < < < | | > | | | | | | | 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 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 83 84 85 86 87 88 89 90 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 133 134 135 136 137 | ;;====================================================================== ;; Copyright 2017, 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. ;;====================================================================== (define (pages:home session db shared) (let* ((dbh (s:db)) (limit 50) (curr-page (if (or (equal? (s:get-param "pg") "") (equal? (s:get-param "pg") #f)) 1 (string->number (s:get-param "pg")))) (offset (- (* limit curr-page) limit)) (dot (if (s:get-param "dot") (string->number (s:get-param "dot")) (if (and (s:get "dot") (not (equal? (s:get "dot") "all"))) (string->number (s:get "dot")) "all"))) (type (if (s:get-param "type") (s:get-param "type") (if (and (s:get "type") (not (equal? (s:get "type") "all"))) (s:get "type") "all"))) (bp (if (s:get-param "bp") (s:get-param "bp") (if (s:get "bp") (s:get "bp") "p1273"))) (rel (if (s:get-param "rel") (s:get-param "rel") (if (and (s:get "rel") (not (equal? (s:get "rel") "all"))) (s:get "rel") ""))) (pattern (pgdb:mk-pattern dot type bp rel)) ; (targets (pgdb:get-targets-of-type dbh selected tfilter)) (all-data (pgdb:get-latest-run-stats-given-pattern dbh pattern limit offset)) ;'() ) ; (pgdb:get-stats-given-type-target dbh selected tfilter) ; (pgdb:get-stats-given-target dbh tfilter) (cnt (pgdb:get-latest-run-cnt-by-pattern dbh pattern)) (total-pages (ceiling (/ cnt limit))) (page-lst (pgdb:get-pg-lst total-pages)) (ordered-data (pgdb:coalesce-runs1 all-data)) (rel-val (if (equal? rel "") "%" rel))) (s:div 'class "col_12" (s:ul 'class "tabs left" (map (lambda (x) (s:li (s:a 'href (conc "#" x) x))) *process*)) (map (lambda (x) (s:div 'id x 'class "tab-content" (s:div 'class "col_11" (s:fieldset "Area type and target filter" (s:form 'action (conc "home.filter#" x) 'method "post" (s:div 'class "col_12" (s:div 'class "col_3" (s:label "Release Type") (s:select (map (lambda (x) (if (equal? x type) (list x x x #t) (list x x x #f)) ) *kit-types*) 'name "kit-type")) (s:div 'class "col_3" (s:label "Dot") (s:select (map (lambda (x) (if (equal? x dot) (list x x x #t) (list x x x #f))) *dots*) 'name "dot")) (s:div 'class "col_3" (s:input 'type "hidden" 'value x 'name "bp") (s:label "Release #") (s:input 'type "text" 'name "rel-num" 'value rel-val)) (s:div 'class "col_2" (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit"))))) (s:br) ;(s:p (conc dot(string? dot) )) (s:p (map (lambda (i) (s:span (s:a 'href (s:link-to "home" 'pg i ) "PAGE " i )" | ")) page-lst)) (s:p " Result Format: total / pass / fail / other") (if (equal? x bp) (begin (s:fieldset (conc "Runs data for " pattern) (let* ((a-keys (pgdb:ordered-data->a-keys ordered-data)) (b-keys (pgdb:ordered-data->b-keys ordered-data a-keys))) (s:table 'class "striped" (s:tr (s:th 'class "heading" ) (map (lambda (th-key) (s:th 'class "heading" th-key )) a-keys)) (map (lambda (row-key) (s:tr (s:td row-key) (map (lambda (col-key) (let ((val (let* ((ht (hash-table-ref/default ordered-data col-key #f))) (if ht (hash-table-ref/default ht row-key #f))))) (if val (let* ((total (vector-ref val 2)) (event-time (vector-ref val 1)) (pass (vector-ref val 3)) (fail (vector-ref val 4)) (other (vector-ref val 5)) (id (vector-ref val 6)) (passper (round (* (/ pass total) 100))) (failper (- 100 passper)) (history (pgdb:get-run-stats-history-given-target dbh 1 (conc col-key "/" row-key))) (history-hash (pgdb:get-history-hash history)) (history-keys (sort (hash-table-keys history-hash) string>=?)) (run-key (string-substitute "[/]" "_x_" (conc col-key "/" row-key) 'all))) (s:td 'style (conc "background: -webkit-linear-gradient(left, green " passper "%, red); background: -o-linear-gradient(right, green " passper "%, red); background: -moz-linear-gradient(right, green " passper "%, red); background: linear-gradient(to right, green " passper "%, red);") (s:a 'class "white" 'href (s:link-to "run" 'target run-key) (conc "Latest:" total "/" pass "/" fail "/" other)) (s:span " | ") (s:a 'id id 'class "viewmodal" 'title "Click to see description" "History") (s:br) (s:div 'id (conc "myModal" id) 'class "modal" (s:div 'class "modal-content" (s:span 'id id 'class "close" "×") ;(s:p (conc "Modal " id "..")) (s:div (s:table (s:tr |
︙ | ︙ | |||
187 188 189 190 191 192 193 | (hpass (vector-ref history-row 2)) (hfail (vector-ref history-row 3)) (hother (vector-ref history-row 4)) (passper (round (* (/ hpass htotal) 100)))) (s:tr (s:td history-key) (s:td 'style (conc "background: -webkit-linear-gradient(left, green " passper "%, red); background: -o-linear-gradient(right, green " passper "%, red); background: -moz-linear-gradient(right, green " passper "%, red); background: linear-gradient(to right, green " passper "%, red);") (conc htotal "/" hpass "/" hfail "/" hother ))))) | | < < < | > > | > | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | (hpass (vector-ref history-row 2)) (hfail (vector-ref history-row 3)) (hother (vector-ref history-row 4)) (passper (round (* (/ hpass htotal) 100)))) (s:tr (s:td history-key) (s:td 'style (conc "background: -webkit-linear-gradient(left, green " passper "%, red); background: -o-linear-gradient(right, green " passper "%, red); background: -moz-linear-gradient(right, green " passper "%, red); background: linear-gradient(to right, green " passper "%, red);") (conc htotal "/" hpass "/" hfail "/" hother ))))) history-keys))))))) (s:td "")))) a-keys))) b-keys)))) ) (begin (s:p "")))))) *process*)))) |
Modified cgisetup/pages/index.scm from [5f74568a94] to [33603d85dd].
1 2 3 4 5 6 7 8 9 10 11 12 13 | ;;====================================================================== ;; Copyright 2017, 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 regex) ;; (load "models/pgdb.scm") | > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | ;;====================================================================== ;; Copyright 2017, 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 regex) ;; (load "models/pgdb.scm") (include "pages/index_ctrl.scm") (include "pages/index_view.scm") |
Modified cgisetup/pages/index_ctrl.scm from [afbe8a90ae] to [1874aaac3c].
︙ | ︙ | |||
60 61 62 63 64 65 66 | <script type="text/javascript" src="https://ajax.googleapis.com/ajax/libs/jquery/1.6.4/jquery.min.js"></script> <!--[if lt IE 9]><script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script><![endif]--> EOF )) (define index:javascript #<<EOF | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 | <script type="text/javascript" src="https://ajax.googleapis.com/ajax/libs/jquery/1.6.4/jquery.min.js"></script> <!--[if lt IE 9]><script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script><![endif]--> EOF )) (define index:javascript #<<EOF <!-- <script type="text/javascript" src="/js/prettify.js"></script> PRETTIFY --> <script type="text/javascript" src="/js/kickstart.js"></script> <!-- KICKSTART --> <script type="text/javascript" src="/js/pjhatwal-modal.js "></script> <!-- Modal --> EOF ) |
Modified cgisetup/pages/index_view.scm from [7dcf5f509d] to [5626af0f40].
︙ | ︙ | |||
20 21 22 23 24 25 26 27 28 29 30 31 32 | (s:title (conc "Megatest")) (s:head index:kickstart-junk ) (s:body (s:div 'class "grid flex" 'id "top_of_page" ;; add visible to columns to help visualize them e.g. "col_12 visible" (case (string->symbol page-name) ((index) (s:call "home")) (else (s:call page-name)))) index:jquery index:javascript )))))) | > > > > > > > | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | (s:title (conc "Megatest")) (s:head index:kickstart-junk ) (s:body (s:div 'class "grid flex" 'id "top_of_page" ;; add visible to columns to help visualize them e.g. "col_12 visible" (s:ul 'class "menu" (s:li (s:a 'href "" (s:i 'class "fa fa-inbox") "QA Summary") (s:ul (s:li (s:a 'href "/cgi-bin/megatest.sh/home" "Component Snapshot")) (s:li (s:a 'href "/cgi-bin/megatest.sh/kitprogress" "Kit/Contour progress")) ))) ;(s:li (s:a 'href (s:link-to "run" ) "Runs"))) (case (string->symbol page-name) ((index) (s:call "home")) (else (s:call page-name)))) index:jquery index:javascript )))))) |
Modified client.scm from [950fa4a4a2] to [b8e0e236d3].
︙ | ︙ | |||
8 9 10 11 12 13 14 | ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== ;; C L I E N T S ;;====================================================================== | < | | < < < < | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== ;; C L I E N T S ;;====================================================================== (use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5 message-digest matchable spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils) (declare (unit client)) (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. |
︙ | ︙ |
Modified common.scm from [d946026e4f] to [c97b79852f].
1 2 3 4 5 6 7 8 9 10 11 12 | ;;====================================================================== ;; 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 srfi-1 data-structures posix regex-case (prefix base64 base64:) | < < | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | ;;====================================================================== ;; 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 srfi-1 data-structures posix regex-case (prefix base64 base64:) matchable regex posix srfi-18 extras pkts (prefix dbi dbi:) (prefix sqlite3 sqlite3:) ) (declare (unit common)) (include "common_records.scm") |
︙ | ︙ | |||
863 864 865 866 867 868 869 | #f (let loop ((hed (car dirs)) (tal (cdr dirs))) (let ((res (or (and (directory? hed) (file-write-access? hed) hed) (handle-exceptions | | > > | | 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 | #f (let loop ((hed (car dirs)) (tal (cdr dirs))) (let ((res (or (and (directory? hed) (file-write-access? hed) hed) (handle-exceptions exn (begin (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.") #f) (create-directory hed #t))))) (if (and (string? res) (directory? res)) res (if (null? tal) #f (loop (car tal)(cdr tal)))))))) |
︙ | ︙ | |||
1012 1013 1014 1015 1016 1017 1018 1019 1020 | (define (common:args-get-runname) (let ((res (or (args:get-arg "-runname") (args:get-arg ":runname") (getenv "MT_RUNNAME")))) ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ... res)) (define (common:args-get-target #!key (split #f)(exit-if-bad #f)) | > > > > | | 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 | (define (common:args-get-runname) (let ((res (or (args:get-arg "-runname") (args:get-arg ":runname") (getenv "MT_RUNNAME")))) ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ... res)) (define (common:get-fields cfgdat) (let ((fields (hash-table-ref/default cfgdat "fields" '()))) (map car fields))) (define (common:args-get-target #!key (split #f)(exit-if-bad #f)) (let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '())) (numkeys (length keys)) (target (or (args:get-arg "-reqtarg") (args:get-arg "-target") (getenv "MT_TARGET"))) (tlist (if target (string-split target "/" #t) '())) (valid (if target (or (null? keys) ;; probably don't know our keys yet |
︙ | ︙ | |||
1546 1547 1548 1549 1550 1551 1552 | ((< (+ load (/ (random 250) 1000)) ;; add a random factor to keep from getting in a rut (+ best-load (/ (random 250) 1000)) ) (set! best-load load) (set! best-host hostname))))) hosts) best-host)) | | > > > > | | 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 | ((< (+ load (/ (random 250) 1000)) ;; add a random factor to keep from getting in a rut (+ best-load (/ (random 250) 1000)) ) (set! best-load load) (set! best-host hostname))))) hosts) best-host)) (define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)) (let* ((loadavg (common:get-cpu-load remote-host)) (numcpus (if (< 1 numcpus-in) ;; not possible (common:get-num-cpus remote-host) numcpus-in)) (maxload (max maxload-in 0.5)) ;; so maxload must be greater than 0.5 for now BUG - FIXME? (first (car loadavg)) (next (cadr loadavg)) (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1 (loadjmp (- first next))) (cond ((and (> first adjload) (> count 0)) (debug:print-info 0 *default-log-port* "server start delayed " waitdelay " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg "")) (thread-sleep! waitdelay) (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)) |
︙ | ︙ | |||
2186 2187 2188 2189 2190 2191 2192 | ((equal? status "WARN") "orange") ((equal? status "KILLED") "orange") ((equal? status "KILLREQ") "purple") ((equal? status "RUNNING") "blue") ((equal? status "ABORT") "brown") (else "black"))) | | | | | < < < < < < < < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 | ((equal? status "WARN") "orange") ((equal? status "KILLED") "orange") ((equal? status "KILLREQ") "purple") ((equal? status "RUNNING") "blue") ((equal? status "ABORT") "brown") (else "black"))) ;; ;;====================================================================== ;; ;; N A N O M S G C L I E N T ;; ;;====================================================================== ;; ;; ;; ;; (define (common:send-dboard-main-changed) ;; (let* ((dashboard-ips (mddb:get-dashboards))) ;; (for-each ;; (lambda (ipadr) ;; (let* ((soc (common:open-nm-req (conc "tcp://" ipadr))) ;; (msg (conc "main " *toppath*)) ;; (res (common:nm-send-receive-timeout soc msg))) ;; (if (not res) ;; couldn't reach that dashboard - remove it from db ;; (print "ERROR: couldn't reach dashboard " ipadr)) ;; res)) ;; dashboard-ips))) ;; ;; ;; ;;====================================================================== ;; ;; D A S H B O A R D D B ;; ;;====================================================================== ;; ;; (define (mddb:open-db) ;; (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db")))) ;; (set-busy-handler! db (busy-timeout 10000)) ;; (for-each ;; (lambda (qry) ;; (exec (sql db qry))) ;; (list ;; "CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));" ;; "CREATE TABLE IF NOT EXISTS dashboards ( ;; id INTEGER PRIMARY KEY, ;; pid INTEGER, ;; username TEXT, ;; hostname TEXT, ;; ipaddr TEXT, ;; portnum INTEGER, ;; start_time TIMESTAMP DEFAULT (strftime('%s','now')), ;; CONSTRAINT hostport UNIQUE (hostname,portnum) ;; );" ;; )) ;; db)) ;; ;; ;; register a dashboard ;; ;; ;; (define (mddb:register-dashboard port) ;; (let* ((pid (current-process-id)) ;; (hostname (get-host-name)) ;; (ipaddr (server:get-best-guess-address hostname)) ;; (username (current-user-name)) ;; (car userinfo))) ;; (db (mddb:open-db))) ;; (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) ;; (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);") ;; pid username hostname ipaddr port) ;; (close-database db))) ;; ;; ;; unregister a monitor ;; ;; ;; (define (mddb:unregister-dashboard host port) ;; (let* ((db (mddb:open-db))) ;; (print "Register unregister monitor, host:port=" host ":" port) ;; (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port) ;; (close-database db))) ;; ;; ;; get registered dashboards ;; ;; ;; (define (mddb:get-dashboards) ;; (let ((db (mddb:open-db))) ;; (query fetch-column ;; (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;")))) ;;====================================================================== ;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S ;;====================================================================== ;; ;; [hosts] ;; arm cubie01 cubie02 |
︙ | ︙ | |||
2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 | (mthome-cfgfile (conc *toppath* "/.mtviews.config"))) (if (common:file-exists? mthome-cfgfile) (read-config mthome-cfgfile view-cfgdat #t)) ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas (if (common:file-exists? home-cfgfile) (read-config home-cfgfile view-cfgdat #t)) view-cfgdat)) ;;====================================================================== ;; H I E R A R C H I C A L H A S H T A B L E S ;;====================================================================== ;; Every element including top element is a vector: ;; <vector subhash value> | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 | (mthome-cfgfile (conc *toppath* "/.mtviews.config"))) (if (common:file-exists? mthome-cfgfile) (read-config mthome-cfgfile view-cfgdat #t)) ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas (if (common:file-exists? home-cfgfile) (read-config home-cfgfile view-cfgdat #t)) view-cfgdat)) ;;====================================================================== ;; Manage pkts, used in servers, tests and likely other contexts so put ;; in common ;;====================================================================== (define common:pkt-spec '((server . ((action . a) (pid . d) (ipaddr . i) (port . p))) (test . ((cpuuse . c) (diskuse . d) (item-path . i) (runname . r) (state . s) (target . t) (status . u))))) (define (common:get-pkts-dirs mtconf use-lt) (let* ((pktsdirs-str (or (configf:lookup mtconf "setup" "pktsdirs") (and use-lt (conc *toppath* "/lt/.pkts")))) (pktsdirs (if pktsdirs-str (string-split pktsdirs-str " ") #f))) pktsdirs)) ;; use-lt is use linktree "lt" link to find pkts dir (define (common:with-queue-db mtconf proc #!key (use-lt #f)(toppath-in #f)) (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt)) (pktsdir (if pktsdirs (car pktsdirs) #f)) (toppath (or (configf:lookup mtconf "scratchdat" "toppath") toppath-in)) (pdbpath (or (configf:lookup mtconf "setup" "pdbpath") pktsdir))) (cond ((not (and pktsdir toppath pdbpath)) (debug:print 0 *default-log-port* "ERROR: settings are missing in your megatest.config for area management.") (debug:print 0 *default-log-port* " you need to have pktsdir in the [setup] section.")) ((not (common:file-exists? pktsdir)) (debug:print 0 *default-log-port* "ERROR: pkts directory not found " pktsdir)) ((not (equal? (file-owner pktsdir)(current-effective-user-id))) (debug:print 0 *default-log-port* "ERROR: directory " pktsdir " is not owned by " (current-effective-user-name))) (else (let* ((pdb (open-queue-db pdbpath "pkts.db" schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))) (proc pktsdirs pktsdir pdb) (dbi:close pdb)))))) (define (common:load-pkts-to-db mtconf) (common:with-queue-db mtconf (lambda (pktsdirs pktsdir pdb) (for-each (lambda (pktsdir) ;; look at all (cond ((not (common:file-exists? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist.")) ((not (directory? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory.")) ((not (file-read-access? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable.")) (else (debug:print-info 0 *default-log-port* "Loading packets found in " pktsdir) (let ((pkts (glob (conc pktsdir "/*.pkt")))) (for-each (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")) (apkt (pkt->alist pktdat)) (ptype (alist-ref 'T apkt))) (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue")) (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...") ))) pkts))))) pktsdirs)))) (define (common:get-pkt-alists pkts) (map (lambda (x) (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt pkts)) ;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending ;; also delete duplicates by target i.e. (car pkt) ;; (define (common:get-pkt-times pkts) (delete-duplicates (sort (map (lambda (x) `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x)))) pkts) (lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target ;;====================================================================== ;; H I E R A R C H I C A L H A S H T A B L E S ;;====================================================================== ;; Every element including top element is a vector: ;; <vector subhash value> |
︙ | ︙ |
Modified configf.scm from [b1611ec83f] to [cfc96f0d59].
︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 | ;; Config file handling ;;====================================================================== (use regex regex-case) ;; directory-utils) (declare (unit configf)) (declare (uses process)) (declare (uses env)) (include "common_records.scm") ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) | > | 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))) |
︙ | ︙ | |||
398 399 400 401 402 403 404 | ;; pathenvvar will set the named var to the path of the config (define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) (toppath (car configinfo)) (configfile (cadr configinfo)) (set-fields (lambda (curr-section next-section ht path) | | | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 | ;; pathenvvar will set the named var to the path of the config (define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) (toppath (car configinfo)) (configfile (cadr configinfo)) (set-fields (lambda (curr-section next-section ht path) (let ((field-names (if ht (common:get-fields ht) '())) (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target")))) (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht) (if (not (null? field-names))(keys:target-set-args field-names target #f)))))) (if toppath (change-directory toppath)) (if (and toppath pathenvvar)(setenv pathenvvar toppath)) (let ((configdat (if configfile (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f)))) |
︙ | ︙ |
Modified dashboard-tests.scm from [17c63127ed] to [974a2ffdcc].
︙ | ︙ | |||
38 39 40 41 42 43 44 | ;;====================================================================== ;; C O M M O N ;;====================================================================== (define *dashboard-comment-share-slot* #f) (define (dtests:get-pre-command #!key (default-override #f)) | > > > > | | > > > > > > | | | 38 39 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 | ;;====================================================================== ;; C O M M O N ;;====================================================================== (define *dashboard-comment-share-slot* #f) (define (dtests:get-pre-command #!key (default-override #f)) (let* ((orig-pre-command "export CMD='") (viewscreen-pre-command "viewscreen ") (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) (define (dtests:get-post-command #!key (default-override #f)) (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) (viewscreen-post-command "") (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) (define (test-info-panel testdat store-label widgets) (iup:frame #:title "Test Info" ; #:expand "YES" (iup:hbox ; #:expand "YES" (apply iup:vbox ; #:expand "YES" |
︙ | ︙ |
Modified db.scm from [7e22a9a5c3] to [1e33d57a52].
︙ | ︙ | |||
3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 | (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile comment) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) (define (db:get-steps-data dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (db) (let ((res '())) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== ;; WARNING: Do NOT call this for the parent test on an iterated test ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored (define (db:test-data-rollup dbstruct run-id test-id status) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 | (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile comment) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) (define (db:get-steps-info-by-id dbstruct test-step-id) (db:with-db dbstruct #f #f (lambda (db) (let* ((res (vector #f #f #f #f #f #f #f #f))) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile comment) (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment))) db "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-step-id) res)))) (define (db:get-steps-data dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (db) (let ((res '())) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (db:get-data-info-by-id dbstruct test-data-id) (db:with-db dbstruct #f #f (lambda (db) (let* ((res (vector #f #f #f #f #f #f #f #f #f #f #f))) (sqlite3:for-each-row (lambda (id test-id category variable value expected tol units comment status type ) (set! res (vector id test-id category variable value expected tol units comment status type))) db "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type FROM test_data WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-data-id) res)))) ;; WARNING: Do NOT call this for the parent test on an iterated test ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored (define (db:test-data-rollup dbstruct run-id test-id status) |
︙ | ︙ |
Modified docs/Makefile from [ef7610ee8e] to [d02c979809].
︙ | ︙ | |||
11 12 13 14 15 16 17 | html/megatest.html : megatest.lyx elyxer megatest.lyx html/megatest.html fossil add html/* megatest.pdf : megatest.lyx lyx -e pdf2 megatest.lyx | > > | 11 12 13 14 15 16 17 18 19 | html/megatest.html : megatest.lyx elyxer megatest.lyx html/megatest.html fossil add html/* megatest.pdf : megatest.lyx lyx -e pdf2 megatest.lyx pkts.pdf : pkts.dot dot -Tpdf pkts.dot -o pkts.pdf |
Added docs/pkts.dot version [efa03bf87d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | digraph megatest_pkts { ranksep=0.05 // rankdir=LR node [shape=box,style=filled]; "SENSORS" [ label = "{ Sensor Processing | { file | git | fossil | script }}" shape = "record"; ]; "RUNS" [ label = "{ Runs Processing | { launch | clean | re-run | archive } | { dispatcher }}"; shape = "record"; ]; "WORK" [ label = "{ Work Items | { start task | task competed }}"; shape = "record"; ]; "USERREQ" [ label = "{ User Requests (Unix and Web) | { launch | clean | re-run | archive }}"; shape = "record"; ]; "MTAREA1" [ label = "{ Megatest Area 1 | { parallel job\nmanagement | test\nmanagement | data\nrollup }}"; shape = "record"; ]; "MTAREA2" [ label = "{ Megatest Area 2 | { parallel job\nmanagement | test\nmanagement | data\nrollup }}"; shape = "record"; ]; "MTAREA3" [ label = "More Megatest Areas ... "; shape = "record"; ]; "PGDB" [ label = "postgres database"; shape = "cylinder"; ]; "WEBAPP" [ label = "{ Web View | { Runs | Contours | Control | Time View }}"; shape = "record"; ]; // "WEBCTRL" [ label = "{ Web View \n(control) }"; // shape = "record"; ]; "SENSORS" -> "SPKTS"; "RUNS" -> "run pkts"; "run pkts" -> "RUNS"; "WORK" -> "work pkts"; "work pkts" -> "RUNS"; "USERREQ" -> "user request pkts"; "SPKTS" -> "RUNS"; "user request pkts" -> "RUNS"; "RUNS" -> "MTAREA1" -> "PGDB"; "RUNS" -> "MTAREA2" -> "PGDB"; "RUNS" -> "MTAREA3" -> "PGDB"; "PGDB" -> "WEBAPP"; // "WEBCTRL" -> "run pkts"; subgraph cluster_pkts { label="Packets"; "SPKTS" [ label = "Sensor Packets" ]; "run pkts"; "work pkts"; "user request pkts"; } } |
Added docs/pkts.pdf version [d5020c63eb].
cannot compute difference between binary files
Modified ezsteps.scm from [7343e2c83a] to [c762a5a017].
1 2 3 4 5 6 7 8 9 10 11 12 | ;; 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. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | ;; 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. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (use srfi-1 posix regex srfi-69 directory-utils) (declare (unit ezsteps)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) ;; (declare (uses sdb)) |
︙ | ︙ |
Modified http-transport.scm from [151d15c33c] to [8eb0d5e749].
1 2 3 4 5 6 7 8 9 10 11 12 | ;; 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. (require-extension (srfi 18) extras tcp s11n) | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | ;; 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. (require-extension (srfi 18) extras tcp s11n) (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) ;; Configurations for server (tcp-buffer-size 2048) (max-connections 2048) |
︙ | ︙ |
Modified keys.scm from [c68ef5527f] to [4dd65969ab].
︙ | ︙ | |||
62 63 64 65 66 67 68 | (list key targ)) keys targtweaked))) ;;====================================================================== ;; config file related routines ;;====================================================================== | | < < < | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | (list key targ)) keys targtweaked))) ;;====================================================================== ;; config file related routines ;;====================================================================== (define keys:config-get-fields common:get-fields) (define (keys:make-key/field-string confdat) (let ((fields (configf:get-section confdat "fields"))) (string-join (map (lambda (field)(conc (car field) " " (cadr field))) fields) ","))) |
Modified launch.scm from [0c1e4ef13e] to [dd33d34146].
︙ | ︙ | |||
19 20 21 22 23 24 25 | (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) | < < < | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") ;;====================================================================== ;; ezsteps |
︙ | ︙ |
Modified lock-queue.scm from [27c3c65ee2] to [d7fae23ac5].
1 2 3 4 5 6 7 8 9 | ;; Copyright 2006-2013, 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. | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | ;; Copyright 2006-2013, 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 (prefix sqlite3 sqlite3:) srfi-18) (declare (unit lock-queue)) (declare (uses common)) (declare (uses tasks)) ;;====================================================================== ;; attempt to prevent overlapping updates of rollup files by queueing |
︙ | ︙ |
Modified megatest-version.scm from [ea84f1a115] to [79665d4b93].
1 2 3 4 5 | ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) | | | 1 2 3 4 5 6 7 | ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) (define megatest-version 1.6502) |
Modified megatest.config from [a8d97f813e] to [f4675900d6].
1 2 3 4 5 6 7 8 | ## commented out due to a bug in v1.6501 in mtutil [fields] a text b text c text [setup] | > > > > | > | > > > | | > | | > > > > > > > > > > > > > > > > > > > | 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 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | ## commented out due to a bug in v1.6501 in mtutil [fields] a text b text c text usercode .mtutil.scm areafilter area-to-run targtrans generic-target-translator runtrans generic-runname-translator [setup] pktsdirs /tmp/mt_pkts /some/other/source [areas] # path=path-to-area;targtrans=script_to_transform_target local path=. # someqa path=../megatestqa/someqa; targtrans=somefunc; areafilter=area-to-run fullrun path=tests/fullrun; # targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run # the target translator can return: a/target OR (list/of targets/to apply/run) OR #f i.e. run nothing # ext-tests path=ext-tests; targtrans=prefix-contour; ext path=ext-tests [contours] # mode-patt/tag-expr quick areas=ext; selector=/QUICKPATT quick2 areafn=check-area; selector=/QUICKPATT # quick areas=fullrun,ext-tests; selector=QUICKPATT/quick # full areas=fullrun,ext-tests; selector=MAXPATT/ # short areas=fullrun,ext-tests; selector=MAXPATT/ # all areas=fullrun,ext-tests # snazy selector=QUICKPATT/ [nopurpose] [access] ext matt:admin mattw:owner [accesstypes] admin run rerun resume remove set-ss owner run rerun resume remove badguy set-ss [setup] maxload 1.2 [listeners] localhost:12345 contact=matt@kiatoa.com localhost:54321 contact=matt@kiatoa.com [listener] script nbfake echo [server] timeout 1 |
Modified megatest.scm from [35786c6bf6] to [a6fd98e3db].
︙ | ︙ | |||
9 10 11 12 13 14 15 | ;; (include "common.scm") ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) | > | | < < < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | ;; (include "common.scm") ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:) readline apropos json http-client directory-utils typed-records http-client srfi-18 extras format) ;; Added for csv stuff - will be removed ;; (use sparse-vectors) (require-library mutils) ;; (use zmq) (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) |
︙ | ︙ |
Added minimt/Makefile version [1ca1494fdb].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | minimt : minimt.scm db.scm setup.scm direct.scm csc minimt.scm run : minimt export PATH="$(PWD)":$(PATH) ; minimt runrun foo/bar run1 runseq : clean run sleep 5;tail -F runtest/*log clean : rm -rf runtest/* |
Added minimt/db.scm version [a9b4773d46].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 83 84 85 86 87 88 89 90 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 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 | ;; pretend to be a simplified Megatest (use sql-de-lite defstruct) ;; init the db - NOTE: takes a db NOT a dbconn ;; (define (init-db db) (with-transaction db (lambda () (for-each (lambda (qrystr) (exec (sql db qrystr))) '("CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, target TEXT NOT NULL, run_name TEXT NOT NULL, state TEXT NOT NULL, status TEXT NOT NULL, CONSTRAINT runs_constraint UNIQUE (run_name));" "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER NOT NULL, test_name TEXT NOT NULL, state TEXT NOT NULL, status TEXT NOT NULL, start_time INTEGER DEFAULT (strftime('%s','now')), end_time INTEGER DEFAULT -1, CONSTRAINT tests_constraint UNIQUE (run_id,test_name));" "CREATE TABLE IF NOT EXISTS steps (id INTEGER PRIMARY KEY, test_id INTEGER NOT NULL, step_name TEXT NOT NULL, state TEXT NOT NULL, status TEXT NOT NULL, CONSTRAINT step_constraint UNIQUE (test_id,step_name));"))))) (defstruct dbconn-dat dbh ;; the database handle writeable ;; do we have write access? path ;; where the db lives name ;; name of the db ) ;; open the database, return a dbconn struct (define (open-create-db path fname init) (let* ((fullname (conc path "/" fname)) (already-exists (file-exists? fullname)) (write-access (and (file-write-access? path) (or (not already-exists) (and already-exists (file-write-access? fullname))))) (db (if (or already-exists write-access) (open-database fullname) (begin (print "FATAL: No existing db and no write access thus cannot create " fullname) ;; no db and no write access cannot proceed. (exit 1)))) (dbconn (make-dbconn-dat))) (set-busy-handler! db (busy-timeout 120000)) ;; set a busy timeout (exec (sql db "PRAGMA synchronous=0;")) (if (and init write-access (not already-exists)) (init db)) (dbconn-dat-dbh-set! dbconn db) (dbconn-dat-writeable-set! dbconn write-access) (dbconn-dat-path-set! dbconn path) (dbconn-dat-name-set! dbconn fname) dbconn)) (define-inline (get-db dbconn) (dbconn-dat-dbh dbconn)) ;; RUNS ;; create a run (define (create-run dbconn target run-name) (exec (sql (get-db dbconn) "INSERT INTO runs (run_name,target,state,status) VALUES (?,?,'NEW','na');") run-name target)) ;; get a run id (define (get-run-id dbconn target run-name) (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM runs WHERE target=? AND run_name=?;") target run-name))) ;; TESTS (defstruct test-dat id run-id test-name state status) ;; create a test (define (create-test dbconn run-id test-name) (exec (sql (get-db dbconn) "INSERT INTO tests (run_id,test_name,state,status) VALUES (?,?,'NOT_STARTED','na');") run-id test-name)) ;; get a test id (define (get-test-id dbconn run-id test-name) (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM tests WHERE run_id=? AND test_name=?;") run-id test-name))) (define-inline (test-row->test-dat row) (make-test-dat id: (list-ref row 0) run-id: (list-ref row 1) test-name: (list-ref row 2) state: (list-ref row 3) status: (list-ref row 4))) ;; get the data for given test-id (define (test-get-record dbconn test-id) (let* ((row (query fetch-row (sql (get-db dbconn) "SELECT id,run_id,test_name,state,status FROM tests WHERE test_id=?;") test-id))) (test-row->test-dat row))) ;; get a bunch of tests data (define (test-get-tests dbconn run-ids test-name-patt) (let* ((rows (query fetch-rows (sql (get-db dbconn) (conc "SELECT id,run_id,test_name,state,status FROM tests WHERE test_name LIKE ? AND run_id IN (" (string-intersperse (map conc run-ids) ",") ");")) test-name-patt))) (map test-row->test-dat rows))) (define (test-set-state-status dbconn test-id new-state new-status) (exec (sql (get-db dbconn) "UPDATE tests SET state=?,status=?,end_time=? WHERE id=?;") new-state new-status (current-seconds) test-id)) ;; STEPS ;; create a step (define (create-step dbconn test-id step-name) (exec (sql (get-db dbconn) "INSERT INTO steps (test_id,step_name,state,status) VALUES (?,?,'NOT_STARTED','na');") test-id step-name)) ;; get a step id (define (get-step-id dbconn test-id step-name) (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM steps WHERE test_id=? AND step_name=?;") test-id step-name))) (define (step-set-state-status dbconn step-id new-state new-status) (exec (sql (get-db dbconn) "UPDATE steps SET state=?,status=? WHERE id=?;") new-state new-status step-id)) ;;====================================================================== ;; Statistics gathering ;;====================================================================== (define *stats* (make-hash-table)) (define (update-stats key duration) (let ((rec (or (hash-table-ref/default *stats* key #f) (let ((new (vector 0 0 0))) (hash-table-set! *stats* key new) new)))) (vector-set! rec 0 (+ (vector-ref rec 0) 1)) ;; num calls (vector-set! rec 1 (+ (vector-ref rec 1) duration)) ;; total duration (if (> duration (vector-ref rec 2) ) (vector-set! rec 2 duration)))) (define (statwrap name proc) (lambda params (let ((start-time (current-milliseconds)) (res (apply proc params))) (update-stats name (- (current-milliseconds) start-time)) res))) (define (print-stats statdat) (hash-table-for-each statdat (lambda (key val) (print key " count: " (vector-ref val 0) " avg: " (/ (vector-ref val 1)(vector-ref val 0)) " max: " (vector-ref val 2))))) |
Added minimt/direct.scm version [54cabed7c0].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | ;; direct API, call the db calls directly (define rmt:create-run (statwrap 'create-run create-run)) (define rmt:create-step (statwrap 'create-step create-step)) (define rmt:create-test (statwrap 'create-test create-test)) (define rmt:get-test-id (statwrap 'get-test-id get-test-id)) (define rmt:get-run-id (statwrap 'get-run-id get-run-id)) (define rmt:open-create-db (statwrap 'open open-create-db)) (define rmt:step-set-state-status (statwrap 'step-set-state-status step-set-state-status)) (define rmt:test-set-state-status (statwrap 'test-set-state-status test-set-state-status)) (define rmt:test-get-tests (statwrap 'test-get-tests test-get-tests)) |
Added minimt/minimt.scm version [b536a35340].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 83 84 85 86 | (use posix) (include "db.scm") ;; define following in setup.scm ;; *remotehost* => host for "tests" ;; *homehost* => host for servers ;; *homepath* => directory from which to run ;; *numtests* => how many tests to simulate for each run ;; *numruns* => how many runs to simulate ;; (include "setup.scm") (include "direct.scm") ;; direct db calls ;; RUN A TEST (define (run-test dbconn run-id test-name) (rmt:create-test dbconn run-id test-name) (let ((test-id (rmt:get-test-id dbconn run-id test-name))) (rmt:test-set-state-status dbconn test-id "LAUNCHED" "na") (thread-sleep! *launchdelay*) (rmt:test-set-state-status dbconn test-id "RUNNING" "na") (let loop ((step-num 0)) (let ((step-name (conc "step" step-num))) (rmt:create-step dbconn test-id step-name) (let ((step-id (get-step-id dbconn test-id step-name))) (rmt:step-set-state-status dbconn step-id "START" -1) (thread-sleep! *stepdelay*) (rmt:step-set-state-status dbconn step-id "END" 0) (print" STEP: " step-name " done."))) (if (< step-num *numsteps*) (loop (+ step-num 1)))) ;; we will do a large but bogus read to simulate the logic in Megatest (rmt:test-get-tests dbconn `(,run-id) "%") (rmt:test-set-state-status dbconn test-id "COMPLETED" (if (> (random 10) 2) "PASS" "FAIL")) (print "TEST: " test-name " done.") (print "Stats:") (print-stats *stats*) test-id)) ;; RUN A RUN (define (run-run dbconn target run-name num-tests) (rmt:create-run dbconn target run-name) (let ((run-id (rmt:get-run-id dbconn target run-name))) (let loop ((test-num 0)) (system (conc "NBFAKE_LOG=test-" test-num "-run-id-" run-id ".log NBFAKE_HOST=" *remotehost* " nbfake minimt runtest " run-id " test-" test-num)) (if (< test-num num-tests) (loop (+ test-num 1)))))) ;; Do what is asked (let ((args (cdr (argv)))) (if (< (length args) 1) (print "Usage: minimt [options]" " runtest run-id testname runrun target runname") (let ((cmd (car args)) (dbconn (rmt:open-create-db *homepath* "mt.db" init-db))) (thread-sleep! 0.5) ;; be sure the db is written out to disk? Should really not be needed. (change-directory *homepath*) (case (string->symbol cmd) ((runtest) (let ((run-id (string->number (cadr args))) (test-name (caddr args))) (print "Launching test " test-name " for run-id " run-id) (run-test dbconn run-id test-name))) ((runrun) (let ((target (cadr args)) (run-name (caddr args))) (run-run dbconn target run-name *numtests*) (print "Use: sqlite3 runtest/mt.db 'select max(end_time)-min(start_time) from tests;' to see the total run time") )) ((runall) (for-each (lambda (target) (let loop ((run-num 0)) (thread-sleep! *rundelay*) (system (conc "NBFAKE_LOG=run-" target "-" run-num ".log nbfake minimt runrun " target " run-" run-num)) (if (< run-num *numruns*) (loop (+ run-num 1))))) *targets*)) ((server) (start-server dbconn)) (else (print "Command: " cmd " not recognised. Run without params to see help."))) (close-database (dbconn-dat-dbh dbconn))))) |
Added minimt/queued.scm version [71e1ba00f3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 83 84 85 86 87 88 89 90 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 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 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 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 | (use nanomsg defstruct srfi-18) ;;====================================================================== ;; Commands ;;====================================================================== (define *commands* (make-hash-table)) (defstruct cmd key proc ctype ;; command type; 'r (read), 'w (write) or 't (transaction) ) (define (register-command key ctype proc) (hash-table-set! *commands* key (make-cmd key: key ctype: ctype proc: proc))) (define (get-proc key) (cmd-proc (hash-table-ref key *commands*))) (for-each (lambda (dat) (apply register-command dat)) `( (create-run w ,create-run) (create-step w ,create-step) (create-test w ,create-test) (get-test-id r ,get-test-id) (get-run-id r ,get-run-id) ;; (open-db w ,open-create-db) (step-set-ss w ,step-set-state-status) (test-set-ss w ,test-set-state-status) (test-get-tests r ,test-get-tests) )) ;;====================================================================== ;; Server/client stuff ;;====================================================================== (define-inline (encode data) (with-output-to-string (lambda () (write data)))) (define-inline (decode data) (with-input-from-string data (lambda () (read)))) ;;====================================================================== ;; Command queue ;;====================================================================== (defstruct qitem command params host-port) (define *cmd-queue* '()) (define *queue-mutex* (make-mutex)) (define (queue-push cmddat) (mutex-lock! *queue-mutex*) (set! *cmd-queue* (cons cmddat *cmd-queue*)) (mutex-unlock! *queue-mutex*)) ;; get all the cmds of type ctype and return them, also remove them from the queue (define (queue-take ctype) (mutex-lock! *queue-mutex*) (let ((res (filter (lambda (x)(eq? (cmd-ctype x) ctype)) *cmd-queue*)) (rem (filter (lambda (x)(not (eq? (cmd-ctype x) ctype))) *cmd-queue*))) (set! *queue* rem) (mutex-unlock! *queue-mutex*) res)) (define (queue-process-commands dbconn commands) (for-each (lambda (qitem) (let ((soc (request-connect (qitem-host-port qitem))) ;; we will be sending the data back to host-port via soc (cmd (hash-table-ref/default *commands* (qitem-command qitem) #f))) (if cmd (let* ((res (apply (get-proc cmd) dbconn (qitem-params qitem))) (pkg (encode `((r . ,res))))) (nn-send soc pkg) (if (not (eq? (nn-recv soc)) "ok") (print "Client failed to receive properly the data from " cmd " request")))))) commands)) ;; the continuously running queue processor ;; (define ((queue-processor dbconn)) (let loop () (queue-process-commands dbconn (queue-take 'r)) ;; reads first, probably largest numbers of them (queue-process-commands dbconn (queue-take 'w)) ;; writes next (queue-process-commands dbconn (queue-take 't)) ;; lastly process transactions (thread-sleep! 0.2) ;; open up the db for any other processes to access (loop))) ;;====================================================================== ;; Client stuff ;;====================================================================== ;; client struct (defstruct client host-port socket last-access) (define *clients* (make-hash-table)) ;; host:port -> client struct (define *client-mutex* (make-mutex)) ;; add a channel or return existing channel, this is a normal req ;; (define (request-connect host-port) (mutex-lock! *client-mutex*) (let* ((curr (hash-table-ref/default *clients* host-port #f))) (if curr (begin (mutex-unlock! *client-mutex*) curr) (let ((req (nn-socket 'req))) (nn-connect req host-port) ;; "inproc://test") (hash-table-set! *clients* host-port req) (mutex-unlock! *client-mutex*) req)))) ;; open up a channel to the server and send a package of info for the server to act on ;; host-port needs to be found and provided ;; (define (generic-db-access host-port) (let* ((soc (request-connect host-port)) ;; NEED *MY* host/port also to let the server know where to send the results ))) (define (client-send-receive soc msg) (nn-send soc msg) (nn-recv soc)) ;;====================================================================== ;; Server ;;====================================================================== (defstruct srvdat host port soc) ;; remember, everyone starts a server, both client and the actual server alike. ;; clients start a server for the server to return results to. ;; (define (start-raw-server #!key (given-host-name #f)) (let ((srvdat (let loop ((portnum 10000)) (handle-exceptions exn (if (< portnum 64000) (loop (+ portnum 1)) #f) (let* ((rep (nn-socket 'rep))) (nn-bind rep (conc "tcp://*:" portnum)) ;; "inproc://test") (make-srvdat port: portnum soc: rep))))) (host-name (or give-host-name (get-host-name))) (soc (srvdat-soc srvdat))) (srvdat-host-set! srvdat host-name) srvdat)) ;; The actual *server* side server ;; (define (start-server dbconn #!key (given-host-name #f)) (let* ((srvdat (start-raw-server given-host-name: given-host-name)) (host-name (srvdat-host srvdat)) (soc (srvdat-soc srvdat))) ;; start the queue processor (thread-start! (queue-processory dbconn) "Queue processor") ;; msg is an alist ;; 'r host:port <== where to return the data ;; 'p params <== data to apply the command to ;; 'e j|s|l <== encoding of the params. default is s (sexp), if not specified is assumed to be default ;; 'c command <== look up the function to call using this key ;; (let loop ((msg-in (nn-recv soc))) (if (not (equal? msg-in "quit")) (let* ((dat (decode msg-in)) (host-port (alist-ref 'r dat)) ;; this is for the reverse req rep where the server is a client of the original client (params (alist-ref 'p dat)) (command (let ((c (alist-ref 'c dat)))(if c (string->symbol c) #f))) (all-good (and host-port params command (hash-table-exists? *commands* command)))) (if all-good (let ((cmddat (make-qitem command: command host-port: host-port params: params))) (queue-push cmddat) ;; put request into the queue (nn-send soc "queued")) ;; reply with "queued" (print "ERROR: BAD request " dat)) (loop (nn-recv soc))))) (nn-close soc))) ;;====================================================================== ;; Gasket layer ;;====================================================================== (define rmt:open-create-db open-create-db) (define (rmt:create-run . params) |
Added minimt/setup.scm version [db4ef679a3].
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | (define *remotehost* "orion") (define *homehost* "zeus") (define *homepath* "/nfs/phoebe/disk1/home/mfs_matt/data/megatest/minimt/runtest") (define *numsteps* 20) (define *numtests* 20) (define *numruns* 5) (define *targets* '("targ1")) (define *testdelay* 0) (define *rundelay* 0) (define *launchdelay* 0) (define *stepdelay* 0) (use trace) (trace-call-sites #t) (trace ;; open-create-db ) |
Modified mlaunch.scm from [4f4e7034c8] to [dc94b7feb1].
︙ | ︙ | |||
13 14 15 16 17 18 19 | ;; MLAUNCH ;; ;; take jobs from the given queue and keep launching them keeping ;; the cpu load at the targeted level ;; ;;====================================================================== | | < | 13 14 15 16 17 18 19 20 21 22 23 24 25 | ;; 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 format) (declare (unit mlaunch)) (declare (uses db)) (declare (uses common)) |
Modified mt-pg.sql from [538f0610d2] to [c919648701].
︙ | ︙ | |||
59 60 61 62 63 64 65 | owner TEXT DEFAULT '', event_time INTEGER DEFAULT extract(epoch from now()), comment TEXT DEFAULT '', fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, last_update INTEGER DEFAULT extract(epoch from now()), area_id INTEGER DEFAULT 0, | | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | owner TEXT DEFAULT '', event_time INTEGER DEFAULT extract(epoch from now()), comment TEXT DEFAULT '', fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, last_update INTEGER DEFAULT extract(epoch from now()), area_id INTEGER DEFAULT 0, CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name, area_id)); CREATE TABLE IF NOT EXISTS run_stats ( id SERIAL PRIMARY KEY, run_id INTEGER, state TEXT, status TEXT, count INTEGER, |
︙ | ︙ | |||
206 207 208 209 210 211 212 213 214 215 216 | test_id INTEGER, state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', du INTEGER, archive_path TEXT); -- TRUNCATE archive_blocks, archive_allocations, extradat, metadat, -- access_log, tests, test_steps, test_data, test_rundat, archives, runs, -- run_stats, test_meta, tasks_queue, archive_disks; | > > > > > > > > > > > > > > > > > > | 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 | test_id INTEGER, state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', du INTEGER, archive_path TEXT); CREATE TABLE IF NOT EXISTS users( id SERIAL PRIMARY KEY , usename TEXT NOT NULL, fullname TEXT NOT NULL, email TEXT NOT NULL, deleted INTEGER default 0 ); CREATE TABLE IF NOT EXISTS webviews( id SERIAL PRIMARY KEY , owner_id INTEGER NOT NULL, name TEXT NOT NULL, ttype_id INTEGER DEFAULT 0, view_specifics TEXT , col TEXT NOT NULL, row TEXT NOT NULL, deleted INTEGER default 0 ); -- TRUNCATE archive_blocks, archive_allocations, extradat, metadat, -- access_log, tests, test_steps, test_data, test_rundat, archives, runs, -- run_stats, test_meta, tasks_queue, archive_disks; |
Modified mtut.scm from [1a4e185888] to [57ec5ff542].
|
| | | | > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | > | | > > > > | | | | | | | | | | | | | | | | | | | | | | | | > | | | | > | > | > | | > | < < < > > | | > | < < | > | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 83 84 85 86 87 88 89 90 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 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 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 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 238 239 240 241 242 243 | ; Copyright 2006-2017, 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. ;; (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) srfi-18 extras format pkts regex regex-case (prefix dbi dbi:) nanomsg) (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses configf)) ;; (declare (uses rmt)) (include "megatest-fossil-hash.scm") (require-library stml) ;; stuff for the mapper and checker functions ;; (define *target-mappers* (make-hash-table)) (define *runname-mappers* (make-hash-table)) (define *area-checkers* (make-hash-table)) ;; helpers for mappers/checkers (define (add-target-mapper name proc) (hash-table-set! *target-mappers* name proc)) (define (add-runname-mapper name proc) (hash-table-set! *runname-mappers* name proc)) (define (add-area-checker name proc) (hash-table-set! *area-checkers* name proc)) ;; given a runkey, xlatr-key and other info return one of the following: ;; list of targets, null list to skip processing ;; (define (map-targets mtconf aval-alist runkey area contour #!key (xlatr-key-in #f)) (let* ((xlatr-key (or xlatr-key-in (conf-get/default mtconf aval-alist 'targtrans))) (proc (hash-table-ref/default *target-mappers* xlatr-key #f))) (if proc (begin (print "Using target mapper: " xlatr-key) (handle-exceptions exn (begin (print "FAILED TO RUN TARGET MAPPER FOR " area ", called " xlatr-key) (print " function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) ) (print " message: " ((condition-property-accessor 'exn 'message) exn)) runkey) (proc runkey area contour))) (begin (if xlatr-key (print "ERROR: Failed to find named target translator " xlatr-key ", using original target.")) `(,runkey))))) ;; no proc then use runkey ;; given mtconf and areaconf extract a translator/filter, first look at areaconf ;; then if not found look at default ;; (define (conf-get/default mtconf areaconf keyname #!key (default #f)) (let ((res (or (alist-ref keyname areaconf) (configf:lookup mtconf "default" (conc keyname)) default))) (if res (string->symbol res) res))) ;; this needs some thought regarding security implications. ;; ;; i. Check that owner of the file and calling user are same? ;; ii. Check that we are in a legal megatest area? ;; iii. Have some form of authentication or record of the md5sum or similar of the file? ;; iv. Use compiled version in preference to .scm version. Thus there is a manual "blessing" ;; required to use .mtutil.scm. ;; (if (common:file-exists? "megatest.config") (if (common:file-exists? ".mtutil.so") (load ".mtutil.so") (if (common:file-exists? ".mtutil.scm") (load ".mtutil.scm")))) ;; Disabled help items ;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) ;; from prior runs with same keys ;; Contour actions ;; import : import pkts ;; dispatch : dispatch queued run jobs from imported pkts ;; rungen : look at input sense list in [rungen] and generate run pkts (define help (conc " mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2017 Usage: mtutil action [options] -h : this help -manual : show the Megatest user manual -version : print megatest version (currently " megatest-version ") Actions: run : initiate runs remove : remove runs rerun : register action for processing set-ss : set state/status archive : compress and move test data to archive disk kill : stop tests or entire runs db : database utilities areas, contours, setup : show areas, contours or setup section from megatest.config Contour actions: process : runs import, rungen and dispatch Trigger propagation actions: tsend a=b,c=d... : send trigger info to all recpients in the [listeners] section tlisten -port N : listen for trigger info on port N Selectors -immediate : apply this action immediately, default is to queue up actions -area areapatt1,area2... : apply this action only to the specified areas -target key1/key2/... : run for key1, key2, etc. -test-patt p1/p2,p3/... : % is wildcard -run-name : required, name for this particular test run -contour contourname : run all targets for contourname, requires -run-name, -target -state-status c/p,c/f : Specify a list of state and status patterns -tag-expr tag1,tag2%,.. : select tests with tags matching expression -mode-patt key : load testpatt from <key> in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified -new state/status : specify new state/status for set-ss Misc -start-dir path : switch to this directory before running mtutil -set-vars V1=1,V2=2 : Add environment variables to a run NB// these are overwritten by values set in config files. -log logfile : send stdout and stderr to logfile -repl : start a repl (useful for extending megatest) -load file.scm : load and run file.scm -debug N|N,M,O... : enable debug messages 0-N or N and M and O ... Utility db pgschema : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\" Examples: # Start a megatest run in the area \"mytests\" mtutil run -area mytests -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick # Start a contour mtutil run -contour quick -target v1.63/aa3e Called as " (string-intersperse (argv) " ") " Version " megatest-version ", built from " megatest-fossil-hash )) ;; args and pkt key specs ;; (define *arg-keys* ;; used keys ;; a - action '( ("-area" . G) ;; maps to group ("-contour" . c) ("-append-config" . d) ("-state" . e) ("-item-patt" . i) ("-sync-to" . k) ("-new" . l) ;; l (see below) is new-ss ("-run-name" . n) ("-mode-patt" . o) ("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt" ("-status" . s) ("-target" . t) ("-tag-expr" . x) ;; misc ("-debug" . #f) ;; for *verbosity* > 2 ("-load" . #f) ;; load and exectute a scheme file ("-log" . #f) ("-msg" . M) ("-start-dir" . S) ("-set-vars" . v) ("-config" . r) )) (define *switch-keys* '( ("-h" . #f) ("-help" . #f) ("--help" . #f) ("-manual" . #f) ("-version" . #f) ;; misc ("-repl" . #f) ("-immediate" . I) ("-preclean" . r) ("-rerun-all" . u) ("-prepend-contour" . w) )) ;; alist to map actions to old megatest commands (define *action-keys* '((run . "-run") (sync . "") (archive . "-archive") (set-ss . "-set-state-status") (remove . "-remove-runs"))) ;; Card types: ;; ;; A action ;; U username (Unix) ;; D timestamp ;; T card type ;; utilitarian alist for standard cards ;; (define *additional-cards* '( ;; Standard Cards (A . action ) (D . timestamp ) (T . cardtype ) (U . user ) ;; username (Z . shar1sum ) ;; Extras (a . runkey ) ;; needed for matching up pkts with target derived from runkey ;; (l . new-ss ) ;; new state/status )) ;; inlst is an alternative input ;; (define (lookup-param-by-key key #!key (inlst #f)) (fold (lambda (a res) (if (eq? (cdr a) key) (car a) |
︙ | ︙ | |||
178 179 180 181 182 183 184 | ;; (define (param-translate param) (or (alist-ref (string->symbol param) '((-tag-expr . "-tagexpr") (-mode-patt . "--modepatt") (-run-name . "-runname") (-test-patt . "-testpatt") | | > | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 | ;; (define (param-translate param) (or (alist-ref (string->symbol param) '((-tag-expr . "-tagexpr") (-mode-patt . "--modepatt") (-run-name . "-runname") (-test-patt . "-testpatt") (-msg . "-m") (-new . "-set-state-status"))) param)) (define (val->alist val) (let ((val-list (string-split-fields ";\\s*" val #:infix))) (if val-list (map (lambda (x) (let ((f (string-split-fields "\\s*=\\s*" x #:infix))) |
︙ | ︙ | |||
258 259 260 261 262 263 264 | (else ;; have some unrecognised junk? spit out error message (print "ERROR: fossil timeline returned unrecognisable junk \"" inl "\"") (loop (get-line) date node time)))) (else ;; no more datat and last node on branch not found (close-input-port timeline-port) (values (common:date-time->seconds (conc date " " time)) node)))))) | < < < < < < < < | 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 | (else ;; have some unrecognised junk? spit out error message (print "ERROR: fossil timeline returned unrecognisable junk \"" inl "\"") (loop (get-line) date node time)))) (else ;; no more datat and last node on branch not found (close-input-port timeline-port) (values (common:date-time->seconds (conc date " " time)) node)))))) ;;====================================================================== ;; GLOBALS ;;====================================================================== ;; process args (define *action* (if (> (length (argv)) 1) (cadr (argv)) #f)) (define remargs (args:get-args (if *action* (cdr (argv)) (argv)) ;; args:get-args dumps first in argv list (the program name) (map car *arg-keys*) |
︙ | ︙ | |||
299 300 301 302 303 304 305 | ;; Add args that use remargs here ;; (if (and (not (null? remargs)) (not (or (args:get-arg "-runstep") (args:get-arg "-envcap") (args:get-arg "-envdelta") | | > | | < | < < | < < < < < < < < < < < | | | | | | | > | > > > | > > > | > > | | > > > > > > | | | | | | | > > > > > | > | > > > > > > | < | < | < < < > > | < < | < | < < | < < > | < | < < > > | < < | < | | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 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 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 | ;; Add args that use remargs here ;; (if (and (not (null? remargs)) (not (or (args:get-arg "-runstep") (args:get-arg "-envcap") (args:get-arg "-envdelta") (member *action* '("db" "tsend" "tlisten")) ;; very loose checks on db and tsend/listen (equal? *action* "show") ;; just keep going if list ))) (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) (if (or (args:any? "-h" "help" "-help" "--help") (member *action* '("-h" "-help" "--help" "help"))) (begin (print help) (exit 1))) ;;====================================================================== ;; Nanomsg transport ;;====================================================================== (define-inline (encode data) (with-output-to-string (lambda () (write data)))) (define-inline (decode data) (with-input-from-string data (lambda () (read)))) (define (is-port-in-use port-num) (let* ((ret #f)) (let-values (((inp oup pid) (process "netstat" (list "-tulpn" )))) (let loop ((inl (read-line inp))) (if (not (eof-object? inl)) (begin (if (string-search (regexp (conc ":" port-num)) inl) (begin ;(print "Output: " inl) (set! ret #t)) (loop (read-line inp))))))) ret)) ;;start a server, returns the connection ;; (define (start-nn-server portnum ) (let ((rep (nn-socket 'rep))) (handle-exceptions exn (let ((emsg ((condition-property-accessor 'exn 'message) exn))) (print "ERROR: Failed to start server \"" emsg "\"") (exit 1)) (nn-bind rep (conc "tcp://*:" portnum))) rep)) ;; open connection to server, send message, close connection ;; (define (open-send-close-nn host-port msg #!key (timeout 3)) ;; default timeout is 3 seconds (let ((req (nn-socket 'req)) (uri (conc "tcp://" host-port)) (res #f)) (handle-exceptions exn (let ((emsg ((condition-property-accessor 'exn 'message) exn))) (print "ERROR: Failed to connect/send to " uri " message was \"" emsg "\"") #f) (nn-connect req uri) (nn-send req msg) ;; NEED timer here! (let* ((th1 (make-thread (lambda () (let ((resp (nn-recv req))) (nn-close req) (set! res (if (equal? resp "ok") #t #f)))) "recv thread")) (th2 (make-thread (lambda () (thread-sleep! timeout) (thread-terminate! th1)) "timer thread"))) (thread-start! th1) (thread-start! th2) (thread-join! th1) res)))) ;;====================================================================== ;; Runs ;;====================================================================== ;; make a runname ;; (define (make-runname pre post) (time->string (seconds->local-time (current-seconds)) "%Yw%V.%w-%H%M")) ;; collect, translate, collate and assemble a pkt from the command-line ;; ;; sched => force the run start time to be recorded as sched Unix ;; epoch. This aligns times properly for triggers in some cases. ;; ;; extra-dat format is ( 'x xval 'y yval .... ) ;; (define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f)(new-ss #f)) (let* ((sched (cond ((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time ((number? sched-in) sched-in) (else (current-seconds)))) (args-data (if args-alist (if (hash-table? args-alist) ;; seriously? (hash-table->alist args-alist) args-alist) (hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline (alldat (apply append (list 'A action 'U (current-user-name) 'D sched) (if area-path (list 'S area-path) ;; the area-path is mapped to the start-dir '()) (if (list? extra-dat) extra-dat |
︙ | ︙ | |||
432 433 434 435 436 437 438 | (meta (if (or pmeta smeta) (cdr (or pmeta smeta)) ;; found it? #f))) (if (or pmeta smeta) ;; construct the switch/param pair. (list meta value) '()))) (filter cdr args-data))))) | | | | | | | > > | > | > | < | | < | < < < | < < < < < < < < | | | > | | > > > > > | > > > > > | > | | > > > > | > | | 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 | (meta (if (or pmeta smeta) (cdr (or pmeta smeta)) ;; found it? #f))) (if (or pmeta smeta) ;; construct the switch/param pair. (list meta value) '()))) (filter cdr args-data))))) (print "Alldat: " alldat " args-data: " args-data) (add-z-card (apply construct-sdat alldat)))) ;; merge/consolidate with common:simple-setup (define (simple-setup start-dir-in) (let* ((start-dir (or start-dir-in ".")) (mtconfig (or (args:get-arg "-config") "megatest.config")) (mtconfdat (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect -> NOPE! Not if pathenvvar is #f mtconfig ;; environ-patt: "env-override" given-toppath: start-dir ;; pathenvvar: "MT_RUN_AREA_HOME" )) (mtconf (if mtconfdat (car mtconfdat) #f))) ;; we set some dynamic data in a section called "scratchdata" (if mtconf (begin (configf:section-var-set! mtconf "scratchdat" "toppath" start-dir))) ;; (print "TOPPATH: " (configf:lookup mtconf "scratchdat" "toppath")) mtconfdat)) ;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db. ;; make a run request pkt from basic data, this seriously needs to be refactored ;; i. Take the code that builds the info to submit to create-run-pkt and have it ;; generate the pkt keys directly. ;; ii. Pass the pkt keys and values to this proc and go from there. ;; iii. Maybe have an abstraction alist with meaningful names for the pkt keys ;; ;; Override the run start time record with sched. Usually #f is fine. ;; (define (create-run-pkt mtconf action area runkey target runname mode-patt tag-expr pktsdir reason contour sched dbdest append-conf runtrans) (let* ((good-val (lambda (inval)(and inval (string? inval)(not (string-null? inval))))) (area-dat (val->alist (or (configf:lookup mtconf "areas" area) ""))) (area-path (alist-ref 'path area-dat)) ;; (area-xlatr (alist-ref 'targtrans area-dat)) ;; (xlatr-key (if area-xlatr (string->symbol area-xlatr) #f)) (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f)) (mapper (if callname (hash-table-ref/default *runname-mappers* callname #f) #f))) ;; (print "callname=" callname " runtrans=" runtrans " mapper=" mapper) (if (and callname (not (equal? callname "auto")) (not mapper)) (print "No mapper " callname " for area " area " using " callname " as the runname")) (if mapper (handle-exceptions exn (begin (print-call-chain) (print "FAILED TO RUN RUNNAME MAPPER " callname " FOR AREA " area) (print " message: " ((condition-property-accessor 'exn 'message) exn)) runname) (print "(mapper " (string-intersperse (list runkey runname area area-path reason contour mode-patt) ", ") ")") (mapper runkey runname area area-path reason contour mode-patt)) (case callname ((auto) runname) (else runtrans))))) (new-target target) ;; I believe we will want target manipulation here .. (map-targets xlatr-key runkey area contour)) (actual-action (if action (if (equal? action "sync-prepend") "sync" action) "run"))) ;; this has gotten a bit ugly. Need a function to handle actions processing. ;; some hacks to remove switches not needed in certain cases (case (string->symbol (or action "run")) ((sync sync-prepend) (set! new-target #f) (set! runame #f))) ;; (print "area-path: " area-path " orig-target: " runkey " new-target: " new-target) (let-values (((uuid pkt) (command-line->pkt actual-action (append `(("-start-dir" . ,area-path) ("-msg" . ,reason) ("-contour" . ,contour)) (if (good-val new-runname) `(("-run-name" . ,new-runname)) '()) (if (good-val new-target) `(("-target" . ,new-target)) '()) (if (good-val mode-patt) `(("-mode-patt" . ,mode-patt)) '()) (if (good-val tag-expr) `(("-tag-expr" . ,tag-expr)) '()) (if (good-val dbdest) `(("-sync-to" . ,dbdest)) '()) (if (good-val append-conf) `(("-append-config" . ,append-conf)) '()) (if (equal? action "sync-prepend") '(("-prepend-contour" . " ")) '()) (if (not (or mode-patt tag-expr)) `(("-testpatt" . "%")) '()) (if (or (not action) (equal? action "run")) `(("-preclean" . " ") ("-rerun-all" . " ")) ;; if run we *always* want preclean set, use single space as placeholder '()) ) sched extra-dat: `(a ,runkey) ;; we need the run key for marking the run as launched ))) (with-output-to-file (conc pktsdir "/" uuid ".pkt") (lambda () (print pkt)))))) ;; look for areas=a1,a2,a3 OR areafn=somefuncname ;; (define (val-alist->areas val-alist) (let ((areas-string (alist-ref 'areas val-alist)) (areas-procname (alist-ref 'areafn val-alist))) (if areas-procname ;; areas-procname take precedence areas-procname (string-split (or areas-string "") ",")))) ;; area - the current area under consideration ;; areas - the list of allowed areas from the contour spec -OR- ;; if it is a string then it is the function to use to ;; lookup in *area-checkers* ;; (define (area-allowed? area areas runkey contour mode-patt) (cond ((not areas) #t) ;; no spec ((string? areas) ;; (let ((check-fn (hash-table-ref/default *area-checkers* (string->symbol areas) #f))) (if check-fn (check-fn area runkey contour mode-patt) #f))) ((list? areas)(member area areas)) (else #f))) ;; shouldn't get here ;; (use trace)(trace create-run-pkt) ;; collect all needed data and create run pkts for contours with changed inputs ;; (define (generate-run-pkts mtconf toppath) (let ((std-runname (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))) (common:with-queue-db mtconf (lambda (pktsdirs pktsdir pdb) (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config"))) (rgconf (car rgconfdat)) (all-areas (map car (configf:get-section mtconf "areas"))) (contours (configf:get-section mtconf "contours")) (torun (make-hash-table)) ;; target => ( ... info ... ) |
︙ | ︙ | |||
590 591 592 593 594 595 596 597 598 599 | (ruletype (if (> len-key 1)(cadr keyparts) #f)) (action (if (> len-key 2)(caddr keyparts) #f)) (optional (if (> len-key 3)(cadddr keyparts) #f)) ;; (val-list (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params (val-alist (val->alist val)) (runname (make-runname "" "")) (runtrans (alist-ref 'runtrans val-alist)) (runstarts (find-pkts pdb '(runstart) `((o . ,contour) (t . ,runkey)))) | > > > > > > > > > | | | | | | | | | | | > > | < < < | | | | > | | | > | | | | > | > > | 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 735 736 737 738 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 | (ruletype (if (> len-key 1)(cadr keyparts) #f)) (action (if (> len-key 2)(caddr keyparts) #f)) (optional (if (> len-key 3)(cadddr keyparts) #f)) ;; (val-list (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params (val-alist (val->alist val)) (runname (make-runname "" "")) (runtrans (alist-ref 'runtrans val-alist)) ;; these may or may not be defined and not all are used in each handler type in the case below (run-name (alist-ref 'run-name val-alist)) (target (alist-ref 'target val-alist)) (crontab (alist-ref 'cron val-alist)) (areas (val-alist->areas val-alist)) ;; areas can be a single string (a reference to call an areas function), or a list of area names. (dbdest (alist-ref 'dbdest val-alist)) (appendconf (alist-ref 'appendconf val-alist)) (file-globs (alist-ref 'glob val-alist)) (runstarts (find-pkts pdb '(runstart) `((o . ,contour) (t . ,runkey)))) (rspkts (common:get-pkt-alists runstarts)) ;; starttimes is for run start times and is used to know when the last run was launched (starttimes (common:get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target (last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max 0 (apply max (map cdr starttimes)))) ;; synctimes is for figuring out the last time a sync was done (syncstarts (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc. (sspkts (common:get-pkt-alists syncstarts)) (synctimes (common:get-pkt-times sspkts)) (last-sync (if (null? synctimes) ;; if '() then it has never been run, else get the max 0 (apply max (map cdr synctimes)))) ) (let ((delta (lambda (x) (round (/ (- (current-seconds) x) 60))))) (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync))) (print "val-alist=" val-alist " runtrans=" runtrans) ;; look in runstarts for matching runs by target and contour ;; get the timestamp for when that run started and pass it ;; to the rule logic here where "ruletype" will be applied ;; if it comes back "changed" then proceed to register the runs (case (string->symbol (or ruletype "no-such-rule")) ((no-such-rule) (print "ERROR: no such rule for " sense)) ;; Handle crontab like rules ;; ((scheduled) (if (not (alist-ref 'cron val-alist)) ;; gotta have cron spec (print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\" params: " val-alist) (let* ( ;; (action (alist-ref 'action val-alist)) (cron-safe-string (string-translate (string-intersperse (string-split crontab) "-") "*" "X")) (runname std-runname)) ;; (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d"))))) ;; (print "last-run: " last-run " need-run: " need-run) ;; (if need-run (case (string->symbol action) ((sync sync-prepend) (if (common:extended-cron crontab #f last-sync) (push-run-spec torun contour runkey `((message . ,(conc ruletype ":sync-" cron-safe-string)) (action . ,action) (dbdest . ,dbdest) (append . ,appendconf) (areas . ,areas))))) ((run) (if (common:extended-cron crontab #f last-run) (push-run-spec torun contour runkey `((message . ,(conc ruletype ":" cron-safe-string)) (runname . ,runname) (runtrans . ,runtrans) (action . ,action) (areas . ,areas) (target . ,target))))) ((remove) (push-run-spec torun contour runkey `((message . ,(conc ruletype ":" cron-safe-string)) (runname . ,runname) (runtrans . ,runtrans) (action . ,action) (areas . ,areas) (target . ,target)))) (else (print "ERROR: action \"" action "\" has no scheduled handler") ))))) ;; script based sensors ;; ((script) ;; syntax is a little different here. It is a list of commands to run, "scriptname = extra_parameters;scriptname = ..." ;; where scriptname may be repeated multiple times. The script must return unix-epoch of last change, new-target-name and new-run-name ;; the script is called like this: scriptname contour runkey std-runname action extra_param1 extra_param2 ... (for-each (lambda (cmd) (print "cmd: " cmd) |
︙ | ︙ | |||
698 699 700 701 702 703 704 | (need-run (> last-change last-run))) (print "last-run: " last-run " need-run: " need-run) (if need-run (let* ((key-msg `((message . ,(conc ruletype ":" message)) (runname . ,runname) (runtrans . ,runtrans) (action . ,action) | > | > > > | | > | > | | > | > | > > < < | | | | > | | | | > | < > > < | | | > | | | | | | > | < | | | | | | | > | | > > | | > | | | | | | > > > > | | | | | | | | > > | | > | | | > > > | | | 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 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 993 | (need-run (> last-change last-run))) (print "last-run: " last-run " need-run: " need-run) (if need-run (let* ((key-msg `((message . ,(conc ruletype ":" message)) (runname . ,runname) (runtrans . ,runtrans) (action . ,action) (areas . ,areas) (target . ,new-target) ;; overriding with result from runing the script ))) (print "key-msg: " key-msg) (push-run-spec torun contour (if optional ;; we need to be able to differentiate same contour, different behavior. (conc runkey ":" optional) ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE runkey) key-msg))))))) val-alist)) ;; iterate over the param split by ;\s* ;; fossil scm based triggers ;; ((fossil) (for-each (lambda (fspec) (print "fspec: " fspec) (let* ((url (symbol->string (car fspec))) ;; THIS COULD BE TROUBLE. Add option to reading line to return as string. (branch (cdr fspec)) (url-is-file (string-match "^(/|file:).*$" url)) (fname (conc (common:get-signature url) ".fossil")) (fdir (conc "/tmp/" (current-user-name) "/mtutil_cache"))) ;; (if (not url-is-file) ;; need to sync first --- for now, clone 'em all. (fossil:clone-or-sync url fname fdir) ;; ) (let-values (((datetime node) (fossil:last-change-node-and-time fdir fname branch))) (if (null? starttimes) (push-run-spec torun contour runkey `((message . ,(conc "fossil:" branch "-neverrun")) (runname . ,(conc runname "-" node)) (runtrans . ,runtrans) (areas . ,areas) ;; (target . ,runkey) )) (if (> datetime last-run) ;; change time is greater than last-run time (push-run-spec torun contour runkey `((message . ,(conc "fossil:" branch "-" node)) (runname . ,(conc runname "-" node)) (runtrans . ,runtrans) (areas . ,areas) ;; (target . ,runkey) )))) (print "Got datetime=" datetime " node=" node)))) val-alist)) ;; sensor looking for one or more files newer than reference ;; ((file file-or) ;; one or more files must be newer than the reference (let* ((youngestdat (common:get-youngest (common:bash-glob file-globs))) (youngestmod (car youngestdat))) ;; (print "youngestmod: " youngestmod " starttimes: " starttimes) (if (null? starttimes) ;; this target has never been run (push-run-spec torun contour runkey `((message . "file:neverrun") (action . ,action) (runtrans . ,runtrans) ;; (target . ,runkey) (areas . ,areas) (runname . ,runname))) ;; (for-each ;; (lambda (starttime) ;; look at the time the last run was kicked off for this contour ;; (if (> youngestmod (cdr starttime)) ;; (begin ;; (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod) (if (> youngestmod last-run) (push-run-spec torun contour runkey `((message . ,(conc ruletype ":" (cadr youngestdat))) (action . ,action) ;; (target . ,runkey) (runtrans . ,runtrans) (areas . ,areas) (runname . ,runname) )))))) ;; all globbed files must be newer than the reference ;; ((file-and) ;; all files must be newer than the reference (let* ((youngestdat (common:get-youngest file-globs)) (youngestmod (car youngestdat)) (success #t)) ;; any cases of not true, set flag to #f for AND ;; (print "youngestmod: " youngestmod " starttimes: " starttimes) (if (null? starttimes) ;; this target has never been run (push-run-spec torun contour runkey `((message . "file:neverrun") (runname . ,runname) (runtrans . ,runtrans) (areas . ,areas) ;; (target . ,runkey) (action . ,action))) ;; NB// I think this is wrong. It should be looking at last-run only. (if (> youngestmod last-run) ;; WAIT!! Shouldn't file-and be looking at the *oldest* file (thus all are younger than ...) ;; (for-each ;; (lambda (starttime) ;; look at the time the last run was kicked off for this contour ;; (if (< youngestmod (cdr starttime)) ;; (set! success #f))) ;; starttimes)) ;; (if success ;; (begin ;; (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod) (push-run-spec torun contour runkey `((message . ,(conc ruletype ":" (cadr youngestdat))) (runname . ,runname) (runtrans . ,runtrans) ;; (target . ,runkey) (areas . ,areas) (action . ,action) )))))) (else (print "ERROR: unrecognised rule \"" ruletype))))) keydats))) ;; sense rules (hash-table-keys rgconf)) ;; now have to run populated (for-each (lambda (contour) (let* ((cval (or (configf:lookup mtconf "contours" contour) "")) (cval-alist (val->alist cval)) ;; BEWARE ... NOT the same val-alist as above! (areas (val-alist->areas cval-alist)) (selector (alist-ref 'selector cval-alist)) (mode-tag (and selector (string-split-fields "/" selector #:infix))) (mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f))) (tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag))))) (print "contour: " contour " areas=" areas " cval=" cval) (for-each (lambda (runkeydatset) ;; (print "runkeydatset: ")(pp runkeydatset) (let ((runkey (car runkeydatset)) (runkeydats (cadr runkeydatset))) (for-each (lambda (runkeydat) (for-each (lambda (area) (if (area-allowed? area areas runkey contour mode-patt) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...) (let* ((aval (or (configf:lookup mtconf "areas" area) "")) (aval-alist (val->alist aval)) (runname (alist-ref 'runname runkeydat)) (runtrans (alist-ref 'runtrans runkeydat)) (reason (alist-ref 'message runkeydat)) (sched (alist-ref 'sched runkeydat)) (action (alist-ref 'action runkeydat)) (dbdest (alist-ref 'dbdest runkeydat)) (append (alist-ref 'append runkeydat)) (targets (or (alist-ref 'target runkeydat) (map-targets mtconf aval-alist runkey area contour)))) ;; override with target if forced ;; NEED TO EXPAND RUNKEY => ALL TARGETS MAPPED AND THEN FOREACH .... (for-each (lambda (target) (print "Creating pkt for runkey=" runkey " target=" target " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt) (if (case (or (and action (string->symbol action)) 'noaction) ;; ensure we have the needed data to run this action ((noaction) #f) ((run) (and runname reason)) ((sync sync-prepend) (and reason dbdest)) (else #f)) ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt (create-run-pkt mtconf action area runkey target runname mode-patt tag-expr pktsdir reason contour sched dbdest append runtrans) (print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest) )) targets)) (print "NOTE: skipping " runkeydat " for area \"" area "\", not in " areas))) all-areas)) runkeydats))) (let ((res (configf:get-section torun contour))) ;; each contour / target ;; (print "res=" res) res)))) (hash-table-keys torun))))))) (define (pkt->cmdline pkta) (let* ((action (or (lookup-action-by-key (alist-ref 'A pkta)) "noaction")) (action-param (case (string->symbol action) ((-set-state-status) (conc (alist-ref 'l pkta) " ")) (else "")))) (fold (lambda (a res) (let* ((key (car a)) ;; get the key name (val (cdr a)) (par (or (lookup-param-by-key key) ;; need to check also if it is a switch (lookup-param-by-key key inlst: *switch-keys*)))) ;; (print "key: " key " val: " val " par: " par) (if par (conc res " " (param-translate par) " " val) (if (alist-ref key *additional-cards*) ;; these cards do not translate to parameters or switches res (begin (print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"") res))))) (conc "megatest " (if (not (member action '("sync"))) (conc action " " action-param) "")) pkta))) ;; (use trace)(trace pkt->cmdline) (define (write-pkt pktsdir uuid pkt) (if pktsdir |
︙ | ︙ | |||
888 889 890 891 892 893 894 | (handle-exceptions exn #f (create-directory "logs") #t) #t) "logs" | | > > > > | | > > > > > > > | | | | | | | | | | | | | > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > | > > | > > > > > > | | | > | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > | 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 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 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 | (handle-exceptions exn #f (create-directory "logs") #t) #t) "logs" "/tmp")) (cpuload (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f))) (maxload (string->number (or (configf:lookup mtconf "setup" "maxload") (configf:lookup mtconf "jobtools" "maxload") ;; respect value used by Megatest calls "1.1")))) (common:with-queue-db mtconf (lambda (pktsdirs pktsdir pdb) (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config"))) (rgconf (car rgconfdat)) (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) (let* ((pkta (alist-ref 'apkt pktdat)) (action (alist-ref 'A pkta)) (cmdline (pkt->cmdline pkta)) (uuid (alist-ref 'Z pkta)) (user (alist-ref 'U pkta)) (area (alist-ref 'G pkta)) (logf (conc logdir "/" uuid "-run.log")) (fullcmd (conc "NBFAKE_LOG=" logf " nbfake " cmdline))) (if (check-access user mtconf action area) (if (and (> cpuload maxload) (member action '("run" "archive"))) ;; do not run archive or run if load is over the specified limit (print "WARNING: cpuload too high, skipping processing of " uuid) (begin (print "RUNNING: " fullcmd) (system fullcmd) ;; replace with process ... (mark-processed pdb (list (alist-ref 'id pktdat))) (let-values (((ack-uuid ack-pkt) (add-z-card (construct-sdat 'P uuid 'T (case (string->symbol action) ((run) "runstart") ((sync) "syncstart") ;; example of translating run -> runstart (else action)) 'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c 't (alist-ref 't pkta))))) (write-pkt pktsdir ack-uuid ack-pkt)))) (begin ;; access denied! Mark as such (mark-processed pdb (list (alist-ref 'id pktdat))) (let-values (((ack-uuid ack-pkt) (add-z-card (construct-sdat 'P uuid 'T "access-denied" 'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c 't (alist-ref 't pkta))))) (write-pkt pktsdir ack-uuid ack-pkt)))))) pkts)))))) (define (check-access user mtconf action area) ;; NOTE: Need control over defaults. E.g. default might be no access (let* ((access-ctrl (hash-table-exists? mtconf "access")) ;; if there is an access section the default is to REQUIRE enablement/access (access-list (map (lambda (x) (string-split x ":")) (string-split (or (configf:lookup mtconf "access" area) ;; userid:rightstype userid2:rightstype2 ... (if access-ctrl "*:none" ;; nobody has access by default "*:all"))))) (access-types-dat (configf:get-section mtconf "accesstypes"))) (debug:print 0 *default-log-port* "Checking access in " access-list " with access-ctrl " access-ctrl " for area " area) (if access-ctrl (let* ((user-access (or (assoc user access-list) (assoc "*" access-list))) (access-type (cadr user-access)) (access-types (let ((res (alist-ref access-type access-types-dat equal?))) (if res (car res) res))) (allowed-actions (string-split (or access-types "")))) (print "Got " allowed-actions " for user " user " where access-types=" access-types " access-type=" access-type) (cond ((and access-types (member action allowed-actions)) ;; (print "Access granted for " user " for " action) #t) (else ;; (print "Access denied for " user " for " action) #f)))))) (define (get-pkts-dir mtconf) (let ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f))) pktsdir)) (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc"))) (if (common:file-exists? debugcontrolf) (load debugcontrolf))) (if *action* (case (string->symbol *action*) ((run remove rerun set-ss archive kill list) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section (areasec (if area (configf:lookup mtconf "areas" area) #f)) (areadat (if areasec (val->alist areasec) #f)) (area-path (if areadat (alist-ref 'path areadat) #f)) (pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)) (adjargs (hash-table-copy args:arg-hash)) (new-ss (args:get-arg "-new"))) ;; check a few things (cond ((and area (not area-path)) (print "ERROR: the specified area was not found in the [areas] table. Area name=" area) (exit 1)) ((not area) (print "ERROR: no area specified. Use -area <areaname>") (exit 1)) (else (let ((user (current-user-name))) (if (check-access user mtconf *action* area);; check rights (print "Access granted for " *action* " action by " user) (begin (print "Access denied for " *action* " action by " user) (exit 1)))))) ;; (for-each ;; (lambda (key) ;; (if (not (member key *legal-params*)) ;; (hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil ;; (hash-table-keys adjargs)) (let-values (((uuid pkt) (command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss))) (write-pkt pktsdir uuid pkt)))) ((dispatch import rungen process) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (toppath (configf:lookup mtconf "scratchdat" "toppath"))) (case (string->symbol *action*) ((process) (begin (common:load-pkts-to-db mtconf) (generate-run-pkts mtconf toppath) (common:load-pkts-to-db mtconf) (dispatch-commands mtconf toppath))) ((import) (common:load-pkts-to-db mtconf)) ;; import pkts ((rungen) (generate-run-pkts mtconf toppath)) ((dispatch) (dispatch-commands mtconf toppath))))) ;; misc ((show) (if (> (length remargs) 0) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (sect-dat (configf:get-section mtconf (car remargs)))) (if sect-dat (for-each (lambda (entry) (if (> (length entry) 1) (print (car entry) " " (cadr entry)) (print (car entry)))) sect-dat) (print "No section \"" (car remargs) "\" found"))) (print "ERROR: list requires section parameter; areas, setup or contours"))) ((gendot) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat))) (common:with-queue-db mtconf (lambda (pktsdirs pktsdir conn) ;; pktspec display-fields (make-report "out.dot" conn '((cmd . ((parent . P) (user . M) (target . t))) (runstart . ((parent . P) (target . t))) (runtype . ((parent . P)))) ;; pktspec '(P U t) ;; ))))) ;; no ptypes listed (ptypes are strings of pkt types to read from db ((db) (if (null? remargs) (print "ERROR: missing sub command for db command") (let ((subcmd (car remargs))) (case (string->symbol subcmd) ((pgschema) (let* ((install-home (common:get-install-area)) (schema-file (conc install-home "/share/db/mt-pg.sql"))) (if (common:file-exists? schema-file) (system (conc "/bin/cat " schema-file))))) ((sqlite3schema) (let* ((install-home (common:get-install-area)) (schema-file (conc install-home "/share/db/mt-sqlite3.sql"))) (if (common:file-exists? schema-file) (system (conc "/bin/cat " schema-file))))) ((junk) (rmt:get-keys)))))) ((tsend) (if (null? remargs) (print "ERROR: missing data to send to trigger listeners") (let* ((msg (car remargs)) (mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (listeners (configf:get-section mtconf "listeners")) (prev-seen (make-hash-table))) ;; catch duplicates (for-each (lambda (listener) (let ((host-port (car listener)) (remdat (cdr listener))) (print "sending " msg " to " host-port) (open-send-close-nn host-port msg timeout: 2))) listeners)))) ((tlisten) (if (null? remargs) (print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"") (let ((portnum (string->number (car remargs)))) (if (not portnum) (print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs)) (begin (if (not (is-port-in-use portnum)) (let* ((rep (start-nn-server portnum)) (mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (script (configf:lookup mtconf "listener" "script"))) (print "Listening on port " portnum " for messages") (let loop ((instr (nn-recv rep))) (print "received " instr ", running \"" script " " instr "\"") (system (conc script " '" instr "'")) (nn-send rep "ok") (loop (nn-recv rep)))) (print "ERROR: Port " portnum " already in use. Try another port"))))))) )) ;; the end ;; If HTTP_HOST is defined then we must be in the cgi environment ;; so run stml and exit ;; (if (get-environment-variable "HTTP_HOST") (begin (stml:main #f) |
︙ | ︙ | |||
1011 1012 1013 1014 1015 1016 1017 | ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines]) (current-input-port (make-readline-port "mtutil> ")) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))))) | > > > > > > | 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 | ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines]) (current-input-port (make-readline-port "mtutil> ")) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))))) #| (define mtconf (car (simple-setup #f))) (define dat (with-queue-db mtconf (lambda (conn)(get-pkts conn '())))) (pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed)) |# |
Modified process.scm from [98aa9e5247] to [e9d50c66de].
︙ | ︙ | |||
11 12 13 14 15 16 17 | ;;====================================================================== ;; Process convience utils ;;====================================================================== (use regex) (declare (unit process)) | < | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | ;;====================================================================== ;; Process convience utils ;;====================================================================== (use regex) (declare (unit process)) (define (process:conservative-read port) (let loop ((res "")) (if (not (eof-object? (peek-char port))) (loop (conc res (read-char port))) res))) |
︙ | ︙ |
Modified rmt.scm from [8ae137f573] to [01d76df641].
︙ | ︙ | |||
9 10 11 12 13 14 15 | ;; PURPOSE. ;;====================================================================== (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) | < < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | ;; PURPOSE. ;;====================================================================== (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) (declare (uses http-transport)) (include "common_records.scm") ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; ;; generate entries for ~/.megatestrc with the following |
︙ | ︙ | |||
814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 | (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (rmt:get-steps-for-test run-id test-id) (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) (define (rmt:read-test-data* run-id test-id categorypatt varpatt #!key (work-area #f)) (rmt:send-receive 'read-test-data* run-id (list run-id test-id categorypatt varpatt))) | > > > < < | < > | 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 | (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (rmt:get-steps-for-test run-id test-id) (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) (define (rmt:get-steps-info-by-id test-step-id) (rmt:send-receive 'get-steps-info-by-id #f (list test-step-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) (define (rmt:read-test-data* run-id test-id categorypatt varpatt #!key (work-area #f)) (rmt:send-receive 'read-test-data* run-id (list run-id test-id categorypatt varpatt))) (define (rmt:get-data-info-by-id test-data-id) (rmt:send-receive 'get-data-info-by-id #f (list test-data-id))) (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record #f (list testname))) (define (rmt:testmeta-get-record testname) (rmt:send-receive 'testmeta-get-record #f (list testname))) |
︙ | ︙ |
Modified rpctest/rpctest-continuous-client.scm from [ea7c1d49cf] to [bb9e39b0dd].
︙ | ︙ | |||
15 16 17 18 19 20 21 | (define operation (string->symbol (car (command-line-arguments)))) (define param (cadr (command-line-arguments))) (print "Operation: " operation ", param: " param) ;; have a pool of db's to pick from (define *dbpool* '()) (define *pool-mutex* (make-mutex)) | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | (define operation (string->symbol (car (command-line-arguments)))) (define param (cadr (command-line-arguments))) (print "Operation: " operation ", param: " param) ;; have a pool of db's to pick from (define *dbpool* '()) (define *pool-mutex* (make-mutex)) (define (get-db) (mutex-lock! *pool-mutex*) (if (null? *dbpool*) (begin (mutex-unlock! *pool-mutex*) (let ((db (open-database param))) (set-busy-handler! db (busy-timeout 10000)) |
︙ | ︙ |
Modified runconfigs.config from [bf5ecdf3ee] to [e2b75d4c3c].
1 2 3 4 5 6 7 8 9 10 11 12 | # To get emacs font highlighing in the various megatest configs do this: # # Install emacs-goodies-el: # sudo apt install emacs-goodies-el # Add to your ~/.emacs file: # (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode)) # # example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config # [a/b/c] all:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config | | > > | | | | | | | | 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 40 41 42 43 44 45 46 47 48 49 50 51 | # To get emacs font highlighing in the various megatest configs do this: # # Install emacs-goodies-el: # sudo apt install emacs-goodies-el # Add to your ~/.emacs file: # (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode)) # # example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config # [a/b/c] all:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config # quick:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config # fast:scheduled:sync-prepend cron= 0/1 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config [scriptinc ./gentargets.sh #{getenv USER}] # [v1.23/45/67] # tip will be replaced with hashkey? # [%/%/%] doesn't work [/.*/] # [v1.63/tip/dev] # file: files changes since last run trigger new run # script: script is called with unix seconds as last parameter (other parameters are preserved) # # contour:sensetype:action params data # commented out for debug quick:file:run runtrans=auto; glob=/home/matt/data/megatest/*.scm foo.touchme # snazy:file:run runtrans=corporate-ww; glob=/home/matt/data/megatest/*.scm # short:file:run runtrans=short; glob=/home/matt/data/megatest/*.scm # script returns change-time (unix epoch), new-target-name, run-name # # quick:script:run checkfossil = http://www.kiatoa.com/fossils/megatest v1.63;\ # checkfossil = http://www.kiatoa.com/fossils/megatest_qa trunk # # fossil based trigger # # # quick:fossil:run http://www.kiatoa.com/fossils/megatest=v1.63;\ # http://www.kiatoa.com/fossils/megatest_qa=trunk;\ # http://www.kiatoa.com/fossils/megatest=v1.64 # field allowed values # ----- -------------- # minute 0-59 # hour 0-23 # day of month 1-31 # month 1-12 (or names, future development) |
︙ | ︙ |
Modified runs.scm from [147cbc54ec] to [80c295fb6f].
1 2 3 4 5 6 7 8 9 10 11 12 | ;; Copyright 2006-2016, 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') | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | ;; Copyright 2006-2016, 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') (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) posix-extras directory-utils pathname-expand typed-records format) (declare (unit runs)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) |
︙ | ︙ |
Modified server.scm from [45bfab59ba] to [33617f45ac].
1 |
| | | < > < < > > > > > > | 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 40 41 42 43 44 45 46 47 48 49 | ;; Copyright 2006-2017, 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. (require-extension (srfi 18) extras tcp s11n) (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils posix-extras matchable ) (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit server)) (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. ;; (declare (uses synchash)) (declare (uses http-transport)) (declare (uses launch)) (declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") (define (server:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) (define *server-loop-heart-beat* (current-seconds)) ;;====================================================================== ;; P K T S S T U F F ;;====================================================================== ;; ??? ;;====================================================================== ;; S E R V E R ;;====================================================================== ;; Call this to start the actual server ;; |
︙ | ︙ | |||
446 447 448 449 450 451 452 453 454 455 456 457 458 459 | (define (server:expiration-timeout) (let ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (and (string? tmo) (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below (* 3600 (string->number tmo)) 60))) ;; moving this here as it needs access to db and cannot be in common. ;; (define (server:writable-watchdog dbstruct) (thread-sleep! 0.05) ;; delay for startup (let ((legacy-sync (common:run-sync?)) (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) (debug-mode (debug:debug-mode 1)) | > > > > > > > > > > > > > | 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 | (define (server:expiration-timeout) (let ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (and (string? tmo) (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below (* 3600 (string->number tmo)) 60))) (define (server:get-best-guess-address hostname) (let ((res #f)) (for-each (lambda (adr) (if (not (eq? (u8vector-ref adr 0) 127)) (set! res adr))) ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) (string-intersperse (map number->string (u8vector->list (if res res (hostname->ip hostname)))) "."))) ;; moving this here as it needs access to db and cannot be in common. ;; (define (server:writable-watchdog dbstruct) (thread-sleep! 0.05) ;; delay for startup (let ((legacy-sync (common:run-sync?)) (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) (debug-mode (debug:debug-mode 1)) |
︙ | ︙ |
Modified tasks.scm from [7cc529f0c6] to [4926b0b4a0].
︙ | ︙ | |||
619 620 621 622 623 624 625 | ((none)(loop (conc (current-user-name) "_" area-name) 'user)) ((user)(loop (conc (substring (common:get-area-path-signature) 0 4) area-name) 'areasig)) (else #f)))))) ;; give up ;; gets mtpg-run-id and syncs the record if different ;; | | | > > | > > > | < < < | | | > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > | > > > | < > > | < > > > | > | > > | > > > | 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 735 736 737 738 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 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 | ((none)(loop (conc (current-user-name) "_" area-name) 'user)) ((user)(loop (conc (substring (common:get-area-path-signature) 0 4) area-name) 'areasig)) (else #f)))))) ;; give up ;; gets mtpg-run-id and syncs the record if different ;; (define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info) (let* ((runs-ht (hash-table-ref cached-info 'runs)) (runinf (hash-table-ref/default runs-ht run-id #f)) (area-id (vector-ref area-info 0))) (if runinf runinf ;; already cached (let* ((run-dat (rmt:get-run-info run-id)) ;; NOTE: get-run-info returns a vector < row header > (run-name (rmt:get-run-name-from-id run-id)) (row (db:get-rows run-dat)) ;; yes, this returns a single row (header (db:get-header run-dat)) (state (db:get-value-by-header row header "state ")) (status (db:get-value-by-header row header "status")) (owner (db:get-value-by-header row header "owner")) (event-time (db:get-value-by-header row header "event_time")) (comment (db:get-value-by-header row header "comment")) (fail-count (db:get-value-by-header row header "fail_count")) (pass-count (db:get-value-by-header row header "pass_count")) (db-contour (db:get-value-by-header row header "contour")) (contour (if (args:get-arg "-prepend-contour") (if (> (string-length db-contour) 0) db-contour (args:get-arg "-contour")))) (keytarg (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) (conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform (target (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) (conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) (rmt:get-target run-id)) (rmt:get-target run-id))) ;; e.g. v1.63/a3e1/ubuntu (spec-id (pgdb:get-ttype dbh keytarg)) (new-run-id (pgdb:get-run-id dbh spec-id target run-name area-id)) ;; (area-id (db:get-value-by-header row header "area_id)")) ) (if new-run-id (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id)) (hash-table-set! runs-ht run-id new-run-id) ;; ensure key fields are up to date (pgdb:refresh-run-info dbh new-run-id state status owner event-time comment fail-count pass-count area-id) new-run-id) (if (handle-exceptions exn (begin (print-call-chain) (print ((condition-property-accessor 'exn 'message) exn)) #f) (pgdb:insert-run dbh spec-id target run-name state status owner event-time comment fail-count pass-count area-id)) (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info) #f)))))) (define (tasks:sync-test-steps dbh cached-info test-step-ids) (let ((test-ht (hash-table-ref cached-info 'tests)) (step-ht (hash-table-ref cached-info 'steps))) (for-each (lambda (test-step-id) (let* ((test-step-info (rmt:get-steps-info-by-id test-step-id)) (step-id (tdb:step-get-id test-step-info)) (test-id (tdb:step-get-test_id test-step-info)) (stepname (tdb:step-get-stepname test-step-info)) (state (tdb:step-get-state test-step-info)) (status (tdb:step-get-status test-step-info)) (event_time (tdb:step-get-event_time test-step-info)) (comment (tdb:step-get-comment test-step-info)) (logfile (tdb:step-get-logfile test-step-info)) (pgdb-test-id (hash-table-ref/default test-ht test-id #f)) (pgdb-step-id (if pgdb-test-id (pgdb:get-test-step-id dbh pgdb-test-id stepname state) #f))) (if step-id (begin (if pgdb-test-id (begin (if pgdb-step-id (begin (print "Updating existing test-step with test-id: " test-id " and step-id " step-id) (pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile)) (begin (print "Inserting test-step with test-id: " test-id " and step-id " step-id) (pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile ) (set! pgdb-step-id (pgdb:get-test-step-id dbh pgdb-test-id stepname state)))) (hash-table-set! step-ht step-id pgdb-step-id )) (print "Error: Test not cashed"))) (print "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug test-step-ids))) (define (tasks:sync-test-gen-data dbh cached-info test-data-ids) (let ((test-ht (hash-table-ref cached-info 'tests)) (data-ht (hash-table-ref cached-info 'data))) (for-each (lambda (test-data-id) (let* ((test-data-info (rmt:get-data-info-by-id test-data-id)) (data-id (db:test-data-get-id test-data-info)) (test-id (db:test-data-get-test_id test-data-info)) (category (db:test-data-get-category test-data-info)) (variable (db:test-data-get-variable test-data-info)) (value (db:test-data-get-value test-data-info)) (expected (db:test-data-get-expected test-data-info)) (tol (db:test-data-get-tol test-data-info)) (units (db:test-data-get-units test-data-info)) (comment (db:test-data-get-comment test-data-info)) (status (db:test-data-get-status test-data-info)) (type (db:test-data-get-type test-data-info)) (pgdb-test-id (hash-table-ref/default test-ht test-id #f)) (pgdb-data-id (if pgdb-test-id (pgdb:get-test-data-id dbh pgdb-test-id category variable) #f))) (if data-id (begin (if pgdb-test-id (begin (if pgdb-data-id (begin (print "Updating existing test-data with test-id: " test-id " and data-id " data-id) (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id category variable value expected tol units comment status type)) (begin (print "Inserting test-data with test-id: " test-id " and data-id " data-id) (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type ) (set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable)))) (hash-table-set! data-ht data-id pgdb-data-id )) (begin (print "Error: Test not in pgdb")))) (print "Error: Could not get test data info for data id " test-data-id )))) ;; this is a wierd senario need to debug test-data-ids))) (define (tasks:sync-tests-data dbh cached-info test-ids area-info) (let ((test-ht (hash-table-ref cached-info 'tests))) (for-each (lambda (test-id) (let* ((test-info (rmt:get-test-info-by-id #f test-id)) (run-id (db:test-get-run_id test-info)) ;; look these up in db_records.scm (test-id (db:test-get-id test-info)) (test-name (db:test-get-testname test-info)) (item-path (db:test-get-item-path test-info)) (state (db:test-get-state test-info)) (status (db:test-get-status test-info)) (host (db:test-get-host test-info)) (cpuload (db:test-get-cpuload test-info)) (diskfree (db:test-get-diskfree test-info)) (uname (db:test-get-uname test-info)) (run-dir (db:test-get-rundir test-info)) (log-file (db:test-get-final_logf test-info)) (run-duration (db:test-get-run_duration test-info)) (comment (db:test-get-comment test-info)) (event-time (db:test-get-event_time test-info)) (archived (db:test-get-archived test-info)) (pgdb-run-id (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)) (pgdb-test-id (if pgdb-run-id (begin ;(print pgdb-run-id) (pgdb:get-test-id dbh pgdb-run-id test-name item-path)) #f))) ;; "id" "run_id" "testname" "state" "status" "event_time" ;; "host" "cpuload" "diskfree" "uname" "rundir" "item_path" ;; "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived" (if pgdb-run-id (begin (if pgdb-test-id ;; have a record (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path))) (print "Updating existing test with run-id: " run-id " and test-id: " test-id) (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived)) (begin (print "Inserting test with run-id: " run-id " and test-id: " test-id) (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived) (set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path)))) (hash-table-set! test-ht test-id pgdb-test-id)) (print "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync.")))) test-ids))) ;; get runs changed since last sync ;; (define (tasks:sync-test-data dbh cached-info area-info) ;; (let* (( (define (tasks:sync-to-postgres configdat dest) (let* ((dbh (pgdb:open configdat dbname: dest)) (area-info (pgdb:get-area-by-path dbh *toppath*)) (cached-info (make-hash-table)) (start (current-seconds))) (for-each (lambda (dtype) (hash-table-set! cached-info dtype (make-hash-table))) '(runs targets tests steps data)) (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this (if area-info (let* ((last-sync-time (vector-ref area-info 3)) (changed (rmt:get-changed-record-ids last-sync-time)) (run-ids (alist-ref 'runs changed)) (test-ids (alist-ref 'tests changed)) (test-step-ids (alist-ref 'test_steps changed)) (test-data-ids (alist-ref 'test_data changed)) (run-stat-ids (alist-ref 'run_stats changed))) (print "area-info: " area-info) (if (not (null? test-ids)) (begin (print "Syncing " (length test-step-ids) " changed tests") ;;Assumption here is that if test-step or test data is changed then the test last update time is changed ;; not syncing run stats at this time as they can be derived from tests table. (tasks:sync-tests-data dbh cached-info test-ids area-info) ;(exit) (tasks:sync-test-steps dbh cached-info test-step-ids) (tasks:sync-test-gen-data dbh cached-info test-data-ids))) (pgdb:write-sync-time dbh area-info start)) (if (tasks:set-area dbh configdat) (tasks:sync-to-postgres configdat dest) (begin (debug:print 0 *default-log-port* "ERROR: unable to create an area record") #f))))) |
Modified testnanomsg/req-rep.scm from [d17a548c7a] to [4b0d8cd65b].
1 2 3 4 | ;; watch nanomsg's pipeline load-balancer in action. (use nanomsg) (define req (nn-socket 'req)) | > < < < | > > > > > | | | 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 | ;; watch nanomsg's pipeline load-balancer in action. (use nanomsg) ;; client (define req (nn-socket 'req)) (nn-connect req "inproc://test") (define (client-send-receive soc msg) (nn-send soc msg) (nn-recv soc)) ;; server (define rep (nn-socket 'rep)) (nn-bind rep "inproc://test") (define ((server soc)) (let loop ((msg-in (nn-recv soc))) (if (not (equal? msg-in "quit")) (begin (nn-send soc (conc "hello " msg-in)) (loop (nn-recv soc)))))) (thread-start! (server rep)) ;; client (print (client-send-receive req "Matt")) (print (client-send-receive req "Tom")) ;; (client-send-receive req "quit") (nn-close req) ;; client (nn-close rep) ;; server (exit) |
Modified tests/Makefile from [3cbc059672] to [ea14a7a617].
︙ | ︙ | |||
171 172 173 174 175 176 177 | mkdir -p mintest/runs mintest/links cd mintest;$(MEGATEST) -stop-server 0 cd mintest;$(MEGATEST) -server - -debug $(DEBUG) > server.log 2> server.log & sleep 3 cd mintest;$(DASHBOARD) -rows 18 & cleanprep : ../*.scm Makefile */*.config build | | | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 | mkdir -p mintest/runs mintest/links cd mintest;$(MEGATEST) -stop-server 0 cd mintest;$(MEGATEST) -server - -debug $(DEBUG) > server.log 2> server.log & sleep 3 cd mintest;$(DASHBOARD) -rows 18 & cleanprep : ../*.scm Makefile */*.config build mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links /tmp/$(USER)/adisk1 fullrun/logs rm -f */logging.db touch cleanprep fullprep : cleanprep cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/% cd fullrun;$(BINPATH)/dashboard -rows 15 & |
︙ | ︙ |
Modified tests/fullrun/megatest.config from [73c3d86962] to [9422e2422a].
︙ | ︙ | |||
45 46 47 48 49 50 51 | # this may save a few milliseconds on launching tests # launchwait no waivercommentpatt ^WW\d+ [a-z].* incomplete-timeout 1 # wait 0.5 seconds between launching every process # | | > > | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | # this may save a few milliseconds on launching tests # launchwait no waivercommentpatt ^WW\d+ [a-z].* incomplete-timeout 1 # wait 0.5 seconds between launching every process # # launch-delay 0.5 launch-delay 0 # wait for runs to completely complete. yes, anything else is no run-wait yes # If set to "default" the old code is used. Otherwise defaults to 200 or uses # numeric value given. # |
︙ | ︙ |
Modified tests/fullrun/runconfigs.config from [cf88798291] to [298d45b09b].
1 2 3 4 | [default] SOMEVAR This should show up in SOMEVAR3 VARNOVAL VARNOVAL_WITHSPACE | | | 1 2 3 4 5 6 7 8 9 10 11 12 | [default] SOMEVAR This should show up in SOMEVAR3 VARNOVAL VARNOVAL_WITHSPACE QUICKPATT test_mt_vars,test2,priority_9 # target based getting of config file, look at afs.config and nfs.config [include #{getenv fsname}.config] [include #{getenv MT_RUN_AREA_HOME}/common_runconfigs.config] # #{system echo 'VACKYVAR #{shell pwd}' > $MT_RUN_AREA_HOME/configs/$USER.config} |
︙ | ︙ |
Modified utils/installall.sh from [5cb897ce36] to [c5681b62d5].
︙ | ︙ | |||
35 36 37 38 39 40 41 | echo You are using PREFIX=$PREFIX echo You are using proxy="$proxy" echo echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :" SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i)-$OPTION | | | | | | | | | | | | | | | | 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 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | echo You are using PREFIX=$PREFIX echo You are using proxy="$proxy" echo echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :" SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i)-$OPTION CHICKEN_VERSION=4.12.0 CHICKEN_BASEVER=4.12.0 # Set up variables # case $SYSTEM_TYPE in Ubuntu-17.04-x86_64-std) KTYPE=32 CDVER=5.11.1 IUPVER=3.22 IMVER=3.12 CHICKEN_VERSION=4.12.0 CHICKEN_BASEVER=4.12.0 ;; Ubuntu-16.04-x86_64-std) KTYPE=32 CDVER=5.11.1 IUPVER=3.22 IMVER=3.12 CHICKEN_VERSION=4.12.0 CHICKEN_BASEVER=4.12.0 ;; Ubuntu-16.04-i686-std) KTYPE=32 CDVER=5.11.1 IUPVER=3.22 IMVER=3.12 CHICKEN_VERSION=4.12.0 CHICKEN_BASEVER=4.12.0 ;; SUSE_LINUX_11-x86_64-std) KTYPE=26g4 CDVER=5.11.1 IUPVER=3.22 IMVER=3.12 ;; CentOS_5.11-x86_64-std) KTYPE=24g3 CDVER=5.4.1 IUPVER=3.5 IMVER=3.6.3 ;; |
︙ | ︙ | |||
174 175 176 177 178 179 180 | cd $BUILDHOME #if [[ ! -e 1.0.0.tar.gz ]];then # wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz # mv 1.0.0 1.0.0.tar.gz #fi if ! [[ -e $PREFIX/lib64/libnanomsg.so.1.0.0 ]]; then wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz | | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 | cd $BUILDHOME #if [[ ! -e 1.0.0.tar.gz ]];then # wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz # mv 1.0.0 1.0.0.tar.gz #fi if ! [[ -e $PREFIX/lib64/libnanomsg.so.1.0.0 ]]; then wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz mv 1.0.0 1.0.0.tar.gz tar xf 1.0.0.tar.gz cd nanomsg-1.0.0 ./configure --prefix=$PREFIX make make install CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX nanomsg fi |
︙ | ︙ | |||
200 201 202 203 204 205 206 | if ! [[ -e $PREFIX/bin/sqlite3 ]] ; then if [[ -e tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz (cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install) fi fi fi | | > > > > > > > > > > > > > | | 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 | if ! [[ -e $PREFIX/bin/sqlite3 ]] ; then if [[ -e tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz (cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install) fi fi fi if ! [[ -e $PREFIX/bin/pg_config ]]; then echo Install Postgresql pgsql_tgz=postgresql-9.6.4.tar.gz if ! [[ -e tgz/$pgsql_tgz ]]; then wget -c https://ftp.postgresql.org/pub/source/v9.6.4/$pgsql_tgz mv $pgsql_tgz tgz fi if ! [[ -e $PREFIX/bin/pg_config ]]; then if [[ -e tgz/$pgsql_tgz ]]; then tar xfz tgz/$pgsql_tgz (cd postgresql-9.6.4; ./configure --prefix=$PREFIX --with-openssl; make; make install) fi fi fi cd $BUILDHOME for egg in "sqlite3" sql-de-lite nanomsg do echo "Installing $egg" CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX -keep-installed $egg #CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX $egg if [ $? -ne 0 ]; then echo "$egg failed to install" exit 1 |
︙ | ︙ | |||
231 232 233 234 235 236 237 | alist-lib ansi-escape-sequences args basic-sequences bindings chicken-doc chicken-doc-cmd \ cock condition-utils debug define-record-and-printer easyffi easyffi-base \ expand-full ezxdisp filepath foof-loop ini-file irc lalr lazy-seq \ locale locale-builtin locale-categories locale-components locale-current locale-posix \ locale-timezone loops low-level-macros procedural-macros refdb rfc3339 scsh-process \ sexp-diff sha1 shell slice srfi-101 srfi-19 srfi-19-core srfi-19-date srfi-19-io \ srfi-19-period srfi-19-support srfi-19-time srfi-19-timezone srfi-29 srfi-37 srfi-78 syslog \ | | < | < < < < < < < < < < < < < < < < < | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 | alist-lib ansi-escape-sequences args basic-sequences bindings chicken-doc chicken-doc-cmd \ cock condition-utils debug define-record-and-printer easyffi easyffi-base \ expand-full ezxdisp filepath foof-loop ini-file irc lalr lazy-seq \ locale locale-builtin locale-categories locale-components locale-current locale-posix \ locale-timezone loops low-level-macros procedural-macros refdb rfc3339 scsh-process \ sexp-diff sha1 shell slice srfi-101 srfi-19 srfi-19-core srfi-19-date srfi-19-io \ srfi-19-period srfi-19-support srfi-19-time srfi-19-timezone srfi-29 srfi-37 srfi-78 syslog \ udp uuid uuid-lib zlib postgresql do echo "Installing $egg" $CHICKEN_INSTALL $PROX -keep-installed $egg #$CHICKEN_INSTALL $PROX $egg if [ $? -ne 0 ]; then echo "$egg failed to install" exit 1 fi done if [[ -e `which mysql_config` ]]; then $CHICKEN_INSTALL $PROX mysql-client fi cd $BUILDHOME cd `$PREFIX/bin/csi -p '(chicken-home)'` curl http://3e8.org/pub/chicken-doc/chicken-doc-repo.tgz | tar zx cd $BUILDHOME # $CHICKEN_INSTALL $PROX sqlite3 cd $BUILDHOME if [[ `uname -a | grep x86_64` == "" ]]; then export ARCHSIZE='' else export ARCHSIZE=64_ fi # export files="cd-5.4.1_Linux${KTYPE}_lib.tar.gz im-3.6.3_Linux${KTYPE}_lib.tar.gz iup-3.5_Linux${KTYPE}_lib.tar.gz" |
︙ | ︙ | |||
337 338 339 340 341 342 343 344 345 346 347 348 349 350 | cp -f hs $PREFIX/bin/hs cd ../mutils $PREFIX/bin/chicken-install cd ../dbi $PREFIX/bin/chicken-install cd ../margs $PREFIX/bin/chicken-install fi cd $BUILDHOME if ! [[ -e $PREFIX/bin/stmlrun ]] ; then #fossil clone http://www.kiatoa.com/fossils/stml stml.fossil wget -c -O stml.tar.gz 'http://www.kiatoa.com/fossils/stml/tarball?name=stml&uuid=trunk' tar -xzf stml.tar.gz | > > | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 | cp -f hs $PREFIX/bin/hs cd ../mutils $PREFIX/bin/chicken-install cd ../dbi $PREFIX/bin/chicken-install cd ../margs $PREFIX/bin/chicken-install cd ../pkts $PREFIX/bin/chicken-install fi cd $BUILDHOME if ! [[ -e $PREFIX/bin/stmlrun ]] ; then #fossil clone http://www.kiatoa.com/fossils/stml stml.fossil wget -c -O stml.tar.gz 'http://www.kiatoa.com/fossils/stml/tarball?name=stml&uuid=trunk' tar -xzf stml.tar.gz |
︙ | ︙ | |||
364 365 366 367 368 369 370 | export CSCLIBS=`echo $LD_LIBRARY_PATH | sed 's/:/ -L/g'` IUPEGGVER='iup' if [[ $IUPVER == "3.5" ]]; then IUPEGGVER='iup:1.2.1' fi #CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web iup | | | 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 | export CSCLIBS=`echo $LD_LIBRARY_PATH | sed 's/:/ -L/g'` IUPEGGVER='iup' if [[ $IUPVER == "3.5" ]]; then IUPEGGVER='iup:1.2.1' fi #CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web iup CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -feature disable-iup-pplot $IUPEGGVER # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup # iup:1.0.2 CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw cd $BUILDHOME |
︙ | ︙ |