Index: .mtutil.scm ================================================================== --- .mtutil.scm +++ .mtutil.scm @@ -23,45 +23,46 @@ (define (str-first-char->number str) (char->integer (string-ref str 0))) ;; example of how to set up and write target mappers ;; -(hash-table-set! *target-mappers* - 'prefix-contour - (lambda (target run-name area area-path reason contour mode-patt) - (conc contour "/" target))) -(hash-table-set! *target-mappers* - 'prefix-area-contour - (lambda (target run-name area area-path reason contour mode-patt) - (conc area "/" contour "/" target))) - -(hash-table-set! *runname-mappers* - '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)))) - -(hash-table-set! *runname-mappers* - 'auto - (lambda (target run-name area area-path reason contour mode-patt) - "auto-eh")) - -;; (print "Got here!") +(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))) + Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -50,11 +50,11 @@ csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard -mtut: $(OFILES) mtut.scm +mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut TCMTOBJS = \ api.o \ archive.o \ @@ -146,10 +146,13 @@ 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 Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -277,14 +277,16 @@ ((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)) Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -7,12 +7,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format md5 message-digest srfi-18) -(import (prefix sqlite3 sqlite3:)) +(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)) Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -98,40 +98,93 @@ ;;====================================================================== ;; 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) - (dbi:get-one dbh "SELECT id FROM runs WHERE ttype_id=? AND target=? AND run_name=?;" - spec-id target run-name)) +(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? +(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)) + 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) +(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=?;" - state status owner event-time comment fail-count pass-count run-id)) + 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) +(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 - "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count) - VALUES (?,?,?,?,?,?,?,?,?,?);" - ttype-id target run-name state status owner event-time comment fail-count pass-count)) + 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 ;;====================================================================== @@ -198,24 +251,93 @@ 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) + +(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,COUNT(*) AS total, + "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;" - ttype-id target-patt target-patt ttype-id)) + (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 @@ -227,31 +349,55 @@ 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) -(dbi:get-rows - dbh - "SELECT r.target, r.run_name,r.event_time, COUNT(*) AS total, +(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;" + 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) @@ -287,18 +433,49 @@ ;; 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))) - ;; (rnums ( - ;; for now just do first => remainder + (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) @@ -379,5 +556,15 @@ (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 Index: cgisetup/pages/filter-defs-template.scm ================================================================== --- /dev/null +++ cgisetup/pages/filter-defs-template.scm @@ -0,0 +1,3 @@ +(define *p* '("a" "b" "c")) +(define *k* '("all" "a")) +(define *d* '("all" 1 2 3 6 5 8 11 12)) Index: cgisetup/pages/home.scm ================================================================== --- cgisetup/pages/home.scm +++ cgisetup/pages/home.scm @@ -9,8 +9,9 @@ ;; PURPOSE. ;;====================================================================== (use regex) (load "models/pgdb.scm") +(include "pages/filter-defs.scm") (include "pages/home_ctrl.scm") (include "pages/home_view.scm") Index: cgisetup/pages/home_ctrl.scm ================================================================== --- cgisetup/pages/home_ctrl.scm +++ cgisetup/pages/home_ctrl.scm @@ -12,29 +12,19 @@ ;; a function -action is called on POST (define (home-action action) (case (string->symbol action) ((filter) - (let ((target-type (s:get-input 'target-type)) - (target-filter (s:get-input 'tfilter)) - (target (s:get-input 'target)) - (row-or-col (s:get-input 'row-or-col))) - ;; - ;; s:set! is a page local var. Better than s:session-var-set! but still not a good idea. - ;; - (s:set! "row-or-col" (if (list? row-or-col) - (string-intersperse row-or-col ",") - row-or-col)) - (s:set! "target-type" target-type) - (s:set! "tfilter" target-filter) - (s:set! "target" target) - (s:set! "target-filter" target-filter))) -((filter2) - (let ((tslice-select (s:get-input 'tslice-select)) - (t-slice-filter (s:get-input 't-slice-filter))) - ;; - ;; s:set! is a page local var. Better than s:session-var-set! but still not a good idea. - ;; - (s:set! "tslice" tslice-select) - (s:set! "t-slice-patt" t-slice-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))))) Index: cgisetup/pages/home_view.scm ================================================================== --- cgisetup/pages/home_view.scm +++ cgisetup/pages/home_view.scm @@ -8,143 +8,100 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (define (pages:home session db shared) + (let* ((dbh (s:db)) - (ttypes (pgdb:get-target-types dbh)) - (selected (string->number (or (s:get "target-type") "-1"))) - (target-slice (pgdb:get-distict-target-slice dbh)) - (selected-slice (or (s:get "tslice") "")) - (curr-trec (filter (lambda (x)(eq? selected (vector-ref x 0))) ttypes)) - (curr-ttype (if (and selected - (not (null? curr-trec))) - (vector-ref (car curr-trec) 1) #f)) - (all-parts (if curr-ttype (append (string-split curr-ttype "/") '("runname" "testname")) '())) - (tfilter (or (s:get "target-filter") "%")) - (tslice-filter (or (s:get "t-slice-patt") "")) - (target-patt (if (or (equal? selected-slice "") (equal? tslice-filter "" )) - "" - (conc selected-slice "/" tslice-filter ))) - (tab2-data (if (equal? target-patt "") - `() - (pgdb:get-all-run-stats-target-slice dbh target-patt))) - (tab2-ordered-data (pgdb:coalesce-runs-by-slice tab2-data selected-slice)) - (targets (pgdb:get-targets-of-type dbh selected tfilter)) - (row-or-col (string-split (or (s:get "row-or-col") "") ",")) - (all-data (if (and selected - (not (eq? selected -1))) - (pgdb:get-latest-run-stats-given-target dbh selected tfilter) - '() + (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) - )) - (ordered-data (pgdb:coalesce-runs dbh all-data all-parts row-or-col 0))) + + (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" - (s:li (s:a 'href "#tabr1" "Sliced Filter")) - (s:li (s:a 'href "#tabr2" "Genral Filter"))) - (s:div 'id "tabr1" 'class "tab-content" - (s:div 'class "col_11" - (s:fieldset "Filter Targets by slice" - (s:form - 'action "home.filter2" 'method "post" - (s:div 'class "col_12" - (s:div 'class "col_6" - (s:select (map (lambda (x) - (let ((t-slice (vector-ref x 0))) - (if (equal? t-slice selected-slice) - (list t-slice t-slice t-slice #t) - (list t-slice t-slice t-slice #f)))) - target-slice) - 'name 'tslice-select)) - (s:div 'class "col_4" - (s:input-preserve 'name "t-slice-filter" 'placeholder "Filter remainder target")) - (s:div 'class "col_2" - (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit"))))) - (s:br) - (s:p "  Result Format:   total / pass / fail / other") - (s:fieldset (conc "Runs data for " target-patt) - (let* ((target-keys (hash-table-keys tab2-ordered-data)) - (run-keys (delete-duplicates (apply append (map (lambda (sub-key) - (let ((subdat (hash-table-ref tab2-ordered-data sub-key))) - (hash-table-keys subdat))) - target-keys))))) - (s:table 'class "striped" - (s:tr (s:th 'class "heading" ) - (map - (lambda (th-key) - (s:th 'class "heading" th-key )) - run-keys)) - (map - (lambda (row-key) - (s:tr (s:td row-key) - (map - (lambda (col-key) - (let ((val (let* ((ht (hash-table-ref/default tab2-ordered-data row-key #f))) - (if ht (hash-table-ref/default ht col-key #f))))) - (if val - (let* ((total (vector-ref val 3)) - (pass (vector-ref val 4)) - (fail (vector-ref val 5)) - (other (vector-ref val 6)) - (passper (round (* (/ pass total) 100))) - (target-param (string-substitute "[/]" "_x_" (conc selected-slice "/" 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 target-param 'run col-key) -(conc total "/" pass "/" fail "/" other)))) - (s:td "")))) - run-keys))) - target-keys)) -)) -)) - (s:div 'id "tabr2" 'class "tab-content" + + (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 "home.filter#tabr2" 'method "post" + 'action (conc "home.filter#" x) 'method "post" (s:div 'class "col_12" - (s:div 'class "col_6" - (s:select (map (lambda (x) - (if x - (let ((tt-id (vector-ref x 0)) - (ttype (vector-ref x 1))) - (if (eq? tt-id selected) - (list ttype tt-id ttype #t) - (list ttype tt-id ttype #f))) - (list "all" -1 "all" (eq? selected -1)))) - (cons #f ttypes)) - 'name 'target-type)) - (s:div 'class "col_4" - (s:input-preserve 'name "tfilter" 'placeholder "Filter targets")) + (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: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") - (s:fieldset (conc "Runs data for " tfilter) - ;; - ;; A very basic display - ;; - (let* ((a-keys (pgdb:ordered-data->a-keys ordered-data)) + (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))) - ;; (c-keys (delete-duplicates b-keys))) - (if #f ;; swap rows/cols - (s:table - (s:tr (s:td "")(map s:tr b-keys)) - (map - (lambda (row-key) - (let ((subdat (hash-table-ref ordered-data row-key))) - (s:tr (s:td row-key) - (map - (lambda (col-key) - (s:td (let ((dat (hash-table-ref/default subdat col-key #f))) - (s:td (if dat - (list (vector-ref dat 0)(vector-ref dat 1)) - ""))))) - b-keys)))) - a-keys)) - (s:table 'class "striped" + (s:table 'class "striped" (s:tr (s:th 'class "heading" ) (map (lambda (th-key) (s:th 'class "heading" th-key )) a-keys)) @@ -154,24 +111,25 @@ (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 1)) - (pass (vector-ref val 2)) - (fail (vector-ref val 3)) - (other (vector-ref val 4)) - (id (vector-ref val 5)) + (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 selected (conc col-key "/" row-key))) + (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) + (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 @@ -189,13 +147,13 @@ (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))) - -)) - )) + history-keys))))))) (s:td "")))) a-keys))) - b-keys))))))) -))) + b-keys)))) +) +(begin +(s:p "")))))) + *process*)))) Index: cgisetup/pages/index.scm ================================================================== --- cgisetup/pages/index.scm +++ cgisetup/pages/index.scm @@ -8,9 +8,10 @@ ;; 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") +(include "pages/index_ctrl.scm") +(include "pages/index_view.scm") Index: cgisetup/pages/index_ctrl.scm ================================================================== --- cgisetup/pages/index_ctrl.scm +++ cgisetup/pages/index_ctrl.scm @@ -62,11 +62,11 @@ EOF )) (define index:javascript #< + EOF ) Index: cgisetup/pages/index_view.scm ================================================================== --- cgisetup/pages/index_view.scm +++ cgisetup/pages/index_view.scm @@ -22,10 +22,17 @@ 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 Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -10,18 +10,13 @@ ;;====================================================================== ;; C L I E N T S ;;====================================================================== -(require-extension (srfi 18) extras tcp s11n) - -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest matchable) -;; (use zmq) - -(use (prefix sqlite3 sqlite3:)) - -(use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils) +(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)) ADDED codescanlib.scm Index: codescanlib.scm ================================================================== --- /dev/null +++ codescanlib.scm @@ -0,0 +1,127 @@ + +;; gotta compile with csc, doesn't work with csi -s for whatever reason + +(use srfi-69) +(use matchable) +(use utils) +(use ports) +(use extras) +(use srfi-1) +(use posix) +(use srfi-12) + +;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define ( ) ) +(define (load-scm-file scm-file) + ;;(print "load "scm-file) + (handle-exceptions + exn + '() + (with-input-from-string + (conc "(" + (with-input-from-file scm-file read-all) + ")" ) + read))) + +;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file +;; -- be advised: +;; * this may be fooled by macros, since this code does not take them into account. +;; * this code does only checks for form (define ( ... ) ) +;; so it excludes from reckoning +;; - generated functions, as in things like foo-set! from defstructs, +;; - define-inline, ( +;; - define procname (lambda .. +;; - etc... +(define (get-toplevel-procs+file+args+body filename) + (let* ((scm-tree (load-scm-file filename)) + (procs + (filter identity + (map + (match-lambda + [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ... + [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ... + [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ... + [('define (defname args ...) body ...) ;; match (define (procname ) ) + (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??) + (list defname filename args body) + #f)] + [else #f] ) scm-tree)))) + procs)) + + +;; given a sexp, return a flat lost of atoms in that sexp +(define (get-atoms-in-body body) + (cond + ((null? body) '()) + ((atom? body) (list body)) + (else + (apply append (map get-atoms-in-body body))))) + +;; given a file, return a list of procname, file, list of atoms in said procname +(define (get-procs+file+atoms file) + (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file)) + (res + (map + (lambda (item) + (let* ((proc (car item)) + (file (cadr item)) + (args (caddr item)) + (body (cadddr item)) + (atoms (append (get-atoms-in-body args) (get-atoms-in-body body)))) + (list proc file atoms))) + toplevel-proc-items))) + res)) + +;; uniquify a list of atoms +(define (unique-atoms lst) + (let loop ((lst (flatten lst)) (res '())) + (if (null? lst) + (reverse res) + (let ((c (car lst))) + (loop (cdr lst) (if (member c res) res (cons c res))))))) + +;; given a list of procname, filename, list of procs called from procname, cross reference and reverse +;; returning alist mapping procname to procname that calls said procname +(define (get-callers-alist all-procs+file+calls) + (let* ((all-procs (map car all-procs+file+calls)) + (caller-ht (make-hash-table))) + ;; let's cross reference with a hash table + (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs) + (for-each (lambda (item) + (let* ((proc (car item)) + (file (cadr item)) + (calls (caddr item))) + (for-each (lambda (callee) + (hash-table-set! caller-ht callee + (cons proc + (hash-table-ref caller-ht callee)))) + calls))) + all-procs+file+calls) + (map (lambda (x) + (let ((k (car x)) + (r (unique-atoms (cdr x)))) + (cons k r))) + (hash-table->alist caller-ht)))) + +;; create a handy cross-reference of callees to callers in the form of an alist. +(define (get-xref all-scm-files) + (let* ((all-procs+file+atoms + (apply append (map get-procs+file+atoms all-scm-files))) + (all-procs (map car all-procs+file+atoms)) + (all-procs+file+calls ; proc calls things in calls list + (map (lambda (item) + (let* ((proc (car item)) + (file (cadr item)) + (atoms (caddr item)) + (calls + (filter identity + (map + (lambda (x) + (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self + (member x all-procs)) + x + #f)) + atoms)))) + (list proc file calls))) + all-procs+file+atoms)) + (callers (get-callers-alist all-procs+file+calls))) + callers)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -8,15 +8,12 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (use srfi-1 data-structures posix regex-case (prefix base64 base64:) - format dot-locking csv-xml z3 ;; sql-de-lite - hostinfo md5 message-digest typed-records directory-utils stack - matchable regex posix (srfi 18) extras ;; tcp - (prefix nanomsg nmsg:) - (prefix sqlite3 sqlite3:) + matchable regex posix srfi-18 extras pkts (prefix dbi dbi:) + (prefix sqlite3 sqlite3:) typed-records directory-utils ) (declare (unit common)) (include "common_records.scm") @@ -640,11 +637,11 @@ ;; WARNING: This code falls back to using the global Megatest ;; variable *toppath* ;; (define (common:get-db-tmp-area #!key (dbstruct #f)) (if (and dbstruct (dbr:dbstruct-tmpdb-path dbstruct)) ;; *db-cache-path* - (dbr:dbstruct-tmpdb-path) ;; *db-cache-path* + (dbr:dbstruct-tmpdb-path dbstruct) ;; *db-cache-path* (let ((toppath (or (and dbstruct (dbr:dbstruct-area-path dbstruct)) *toppath*)) (tsname (or (and dbstruct (dbr:dbstruct-area-name dbstruct))(common:get-testsuite-name)))) (if toppath ;; common:get-create-writeable-dir (handle-exceptions exn @@ -865,12 +862,14 @@ (tal (cdr dirs))) (let ((res (or (and (directory? hed) (file-write-access? hed) hed) (handle-exceptions - exn - #f + 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) @@ -1014,13 +1013,17 @@ (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*) (keys:config-get-fields *configdat*) '())) + (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) '())) @@ -1548,15 +1551,19 @@ (set! best-load load) (set! best-host hostname))))) hosts) best-host)) -(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f)) +(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 numcpus)) + (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 "")) @@ -1673,11 +1680,11 @@ ;; (define (common:check-db-dir-space) (let* ((required (string->number (or (configf:lookup *configdat* "setup" "dbdir-space-required") "100000"))) - (dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir)) + (dbdir (common:get-db-tmp-area #f)) ;; (db:get-dbdir)) (tdbspace (common:check-space-in-dir dbdir required)) (mdbspace (common:check-space-in-dir *toppath* required))) (sort (list tdbspace mdbspace) (lambda (a b) (< (cadr a)(cadr b)))))) @@ -2188,93 +2195,81 @@ ((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 (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)))) "."))) - - -(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;")))) +;; ;;====================================================================== +;; ;; 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 ;;====================================================================== ;; @@ -2385,10 +2380,111 @@ (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 ;;====================================================================== Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -15,10 +15,11 @@ (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)) @@ -400,11 +401,11 @@ (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 (keys:config-get-fields ht) '())) + (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)) Index: dashboard-areas.scm ================================================================== --- dashboard-areas.scm +++ dashboard-areas.scm @@ -5,11 +5,11 @@ (define (dashboard:areas-summary-updater commondat tabdat tb cell-lookup run-matrix) ;; maps data from tabdat view-dat to the matrix ;; if input databases have changed, refresh view-dat ;; if filters have changed, refresh view-dat from input databases ;; if pivots have changed, refresh view-dat from input databases - (let* ((runs-hash (dashboard:areas-get-runs-hash tabdat)) + (let* ((runs-hash (dashboard:areas-get-runs-hash commondat tabdat)) (runs-header '("contour_name" "release" "iteration" "testsuite_mode" "id" "runname" "state" "status" "owner" "event_time")) (tree-path (dboard:tabdat-tree-path tabdat))) (dboard:areas-update-tree tabdat runs-hash runs-header tb) (print "Tree path: " tree-path) (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS @@ -23,14 +23,14 @@ ;; (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) (iup:attribute-set! run-matrix "NUMLIN" 10) ;; effective-max-row ))) (iup:attribute-set! run-matrix "1:1" (conc tree-path)) (iup:attribute-set! run-matrix "REDRAW" "ALL"))) - ;; (dashboard:areas-do-update-rundat tabdat) ;; ) + ;; (dashboard:areas-do-update-rundat commondat tabdat) ;; ) ;; (dboard:areas-summary-control-panel-updater tabdat) ;; (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) - ;; (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + ;; (runs-dat (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) ;; (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records ;; (runs (vector-ref runs-dat 1)) ;; (run-id (dboard:tabdat-curr-run-id tabdat)) ;; (runs-hash (dashboard:areas-get-runs-hash tabdat)) ;; ;; (runs-hash (let ((ht (make-hash-table))) @@ -147,28 +147,29 @@ ;; (let* ((modkeys (iup:global "MODKEYSTATE"))) ;; (BB> "modkeys="modkeys)) (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status) ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES - (let* ((toolpath (car (argv))) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (run-id (dboard:tabdat-curr-run-id tabdat)) - (run-info (mrmt:get-run-info run-id)) - (target (mrmt:get-target run-id)) + (run-info (db:get-run-info dbstruct run-id)) + (target (db:get-target dbstruct run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) - (test-info (mrmt:get-test-info-by-id run-id test-id)) + (test-info (db:get-test-info-by-id dbstruct run-id test-id)) (test-name (db:test-get-testname test-info)) - (testpatt (let ((tlast (mrmt:tasks-get-last target runname))) + (testpatt (let ((tlast (db:tasks-get-last dbstruct target runname))) (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" tpatt)) "%"))) - (item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id))) + (item-path (db:test-get-item-path (db:get-test-info-by-id dbstruct run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path))) (status-chars (char-set->list (string->char-set status))) (testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &"))) @@ -255,11 +256,11 @@ (if areas-matrix (dashboard:areas-summary-updater commondat tabdat tb cell-lookup areas-matrix))) "dashboard:areas-summary-updater") ) (mutex-unlock! update-mutex))) - (runs-summary-control-panel (dashboard:areas-summary-control-panel tabdat))) + (runs-summary-control-panel (dashboard:areas-summary-control-panel commondat tabdat))) (dboard:commondat-add-updater commondat areas-summary-updater tab-num: tab-num) (dboard:tabdat-runs-tree-set! tabdat tb) (iup:vbox (iup:split #:value 200 @@ -270,17 +271,18 @@ ;; this calls dboard:get-tests-for-run-duplicate for each run ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; -(define (dboard:areas-update-rundat tabdat runnamepatt numruns testnamepatt keypatts) +(define (dboard:areas-update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (dbstruct (dboard:get-dbstruct commondat #f)) (keys (dboard:tabdat-keys tabdat)) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + (allruns (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (mrmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") + (allruns-tree (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -305,11 +307,11 @@ (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) - (key-vals (mrmt:get-key-vals run-id)) + (key-vals (db:get-key-vals dbstruct run-id)) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) @@ -358,12 +360,13 @@ (dboard:tabdat-filters-changed-set! tabdat #f) (dboard:areas-update-tree tabdat runs-hash header tb))) ;; runs update-rundat using the various filters from the gui ;; -(define (dashboard:areas-do-update-rundat tabdat) +(define (dashboard:areas-do-update-rundat commondat tabdat) (dboard:areas-update-rundat + commondat tabdat (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") (dboard:tabdat-numruns tabdat) (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") ;; generate key patterns from the target stored in tabdat @@ -378,14 +381,15 @@ (if val (set! res (cons (list key val) res)))))) dbkeys) res)))) fres)))) -(define (dashboard:areas-get-runs-hash tabdat) +(define (dashboard:areas-get-runs-hash commondat tabdat) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (dbstruct (dboard:get-dbstruct commondat #f)) (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) - (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-dat (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) @@ -414,11 +418,11 @@ ;; (define (dboard:areas-open-areas commondat tabdat areas) (let ((areas-ht (dboard:commondat-areas commondat))) (for-each (lambda (area-dat) - (db:dashboard-open-db areas (car area-dat)(cdr area-dat))) + (db:dashboard-open-dbstruct areas (car area-dat)(cdr area-dat))) areas))) (define (dboard:areas-update-tree tabdat runs-hash runs-header tb) @@ -473,13 +477,13 @@ ;; ;; (set! colnum (+ colnum 1)) ;; )))) ;; (append new-run-ids run-ids)))) ;; for-each run-id )) -(define (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash) +(define (dashboard:areas-run-id->tests-mindat dbstruct run-id tabdat runs-hash) (let* ((run (hash-table-ref/default runs-hash run-id #f)) - (key-vals (mrmt:get-key-vals run-id)) + (key-vals (db:get-key-vals dbstruct run-id)) (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) @@ -489,17 +493,18 @@ (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id) (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash)) ) tests-mindat)) -(define (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f)) - (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat)) +(define (dashboard:areas-runs-summary-xor-matrix-content commondat tabdat runs-hash #!key (hide-clean #f)) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (src-run-id (dboard:tabdat-prev-run-id tabdat)) (dest-run-id (dboard:tabdat-curr-run-id tabdat))) (if (and src-run-id dest-run-id) (dcommon:xor-tests-mindat - (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash) - (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) + (dashboard:run-id->tests-mindat dbstruct src-run-id tabdat runs-hash) + (dashboard:run-id->tests-mindat dbstruct dest-run-id tabdat runs-hash) hide-clean: hide-clean) #f))) (define (dashboard:areas-popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) (iup:menu @@ -559,11 +564,10 @@ (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) - ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) @@ -632,11 +636,10 @@ " -preclean -clean-cache")))) (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) - ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) @@ -699,11 +702,11 @@ (> modtime (- last-db-update-time 3)) ;; add three seconds of margin (> (current-seconds)(+ last-db-update-time 1))))) ;; setup buttons and callbacks to switch between modes in runs summary tab ;; -(define (dashboard:areas-summary-control-panel tabdat) +(define (dashboard:areas-summary-control-panel commondat tabdat) (let* ((summary-buttons ;; build buttons (map (lambda (mode-item) (let* ((this-mode (car mode-item)) (this-mode-label (cdr mode-item))) @@ -711,11 +714,11 @@ #:action (lambda (obj) (debug:catch-and-dump (lambda () (dboard:tabdat-runs-summary-mode-set! tabdat this-mode) - (dboard:areas-summary-control-panel-updater tabdat)) + (dboard:areas-summary-control-panel-updater commondat tabdat)) "runs summary control panel updater"))))) (dboard:tabdat-runs-summary-modes tabdat))) (summary-buttons-hbox (apply iup:hbox summary-buttons)) (xor-runname-labels-hbox (iup:hbox @@ -730,32 +733,33 @@ temp-label)))) (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons) ;; maybe wrap in a frame (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox ))) - (dboard:areas-summary-control-panel-updater tabdat) + (dboard:areas-summary-control-panel-updater commondat tabdat) res ))) -(define (dboard:areas-summary-control-panel-updater tabdat) - (dboard:areas-summary-xor-labels-updater tabdat) +(define (dboard:areas-summary-control-panel-updater commondat tabdat) + (dboard:areas-summary-xor-labels-updater commondat tabdat) (dboard:areas-summary-buttons-updater tabdat)) -(define (dboard:areas-summary-xor-labels-updater tabdat) +(define (dboard:areas-summary-xor-labels-updater commondat tabdat) (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat)) - (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) - (mode (dboard:tabdat-runs-summary-mode tabdat))) + (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) + (mode (dboard:tabdat-runs-summary-mode tabdat)) + (dbstruct (dboard:get-dbstruct commondat #f))) (when (and source-runname-label dest-runname-label) (case mode ((xor-two-runs xor-two-runs-hide-clean) (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) (prev-run-id (dboard:tabdat-prev-run-id tabdat)) (curr-runname (if curr-run-id - (mrmt:get-run-name-from-id curr-run-id) + (db:get-run-name-from-id dbstruct curr-run-id) "None")) (prev-runname (if prev-run-id - (mrmt:get-run-name-from-id prev-run-id) + (db:get-run-name-from-id dbstruct prev-run-id) "None"))) (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" ")) (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" ")))) (else (iup:attribute-set! source-runname-label "TITLE" "") Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -40,16 +40,26 @@ ;;====================================================================== (define *dashboard-comment-share-slot* #f) (define (dtests:get-pre-command #!key (default-override #f)) - (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) - (or cfg-ovrd default-override "viewscreen "))) ;; "xterm -geometry 180x20 -e \""))) + (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 ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) - (or cfg-ovrd default-override " &"))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (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" Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -48,17 +48,16 @@ (include "vg_records.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " - license GPL, Copyright (C) Matt Welland 2012-2016 + license GPL, Copyright (C) Matt Welland 2012-2017 Usage: dashboard [options] -h : this help -test run-id,test-id : control test identified by testid -skip-version-check : skip the version check - -use-db-cache : access database via cache Misc -rows R : set number of rows -cols C : set number of columns ")) @@ -83,11 +82,11 @@ "-use-server" "-guimonitor" "-main" "-v" "-q" - "-use-db-cache" + ;; "-use-db-cache" "-skip-version-check" "-repl" "-rh5.11" ;; fix to allow running on rh5.11 ) args:arg-hash @@ -147,14 +146,24 @@ (update-mutex (make-mutex)) (updaters (make-hash-table)) (updating #f) uidat ;; needs to move to tabdat at some time (hide-not-hide-tabs #f) - (current-area-path #f) ;; the area of the path where the dashboard was started, if it is a megatest area + (default-area-path #f) ;; the area of the path where the dashboard was started, if it is a megatest area (areas (make-hash-table)) ;; area-name ==> dbstruct ;; (area-dbs #f) ;; use db:dashboard-open-db to add areas to the areas hash ) + +;; general "db getter" +;; +(define (dboard:get-dbstruct commondat area-path-in) ;; area-path=#f gets local connection + (let ((areas (dboard:commondat-areas commondat)) + (apath (or area-path-in (current-directory)))) + (or (db:dashboard-open-dbstruct areas "local" apath) + (begin + (debug:print 0 *default-debug-port* "Failed to open db in directory " apath ", are you staring dashboard in a Megatest area? Exiting...") + (exit 1))))) ;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary) ;; (define (dboard:common-get-tabdat commondat #!key (tab-num #f)) (let* ((tnum (or tab-num @@ -161,11 +170,11 @@ (dboard:commondat-curr-tab-num commondat) 0)) ;; tab-num value is curr-tab-num value in passed commondat (ht (dboard:commondat-tabdats commondat)) (res (hash-table-ref/default ht tnum #f))) (or res - (let ((new-tabdat (dboard:tabdat-make-data))) + (let ((new-tabdat (dboard:tabdat-make-data commondat))) (hash-table-set! ht tnum new-tabdat) new-tabdat)))) ;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table ;; @@ -335,30 +344,31 @@ ;; additional setters for dboard:data (define (dboard:tabdat-test-patts-set!-use vec val) (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) -(define (dboard:tabdat-make-data) +(define (dboard:tabdat-make-data commondat) (let ((dat (make-dboard:tabdat))) - (dboard:setup-tabdat dat) + (dboard:setup-tabdat commondat dat) (dboard:setup-num-rows dat) dat)) -(define (dboard:setup-tabdat tabdat) +(define (dboard:setup-tabdat commondat tabdat) ;; (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) ;; (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path)) ;; (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) - ;; HACK ALERT: this is a hack, please fix. - (if #f - (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) - (print "FIXME on line 350")) - - (dboard:tabdat-keys-set! tabdat (mrmt:get-keys)) - (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) - (dboard:tabdat-tot-runs-set! tabdat (mrmt:get-num-runs "%")) - ) + (let ((dbstruct (dboard:get-dbstruct commondat #f))) + ;; HACK ALERT: this is a hack, please fix. + (if #f + (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) + (print "FIXME on line 350")) + + (dboard:tabdat-keys-set! tabdat (db:get-keys dbstruct)) + (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) + (dboard:tabdat-tot-runs-set! tabdat (db:get-num-runs dbstruct "%")) + )) ;; RADT => Matrix defstruct addition (defstruct dboard:graph-dat ((id #f) : string) ((color #f) : vector) @@ -379,11 +389,11 @@ (make-dboard:runsdat runs-index: (make-hash-table) tests-index: (make-hash-table) matrix-dat: (make-sparse-array))) -;; used to keep the rundata from mrmt:get-tests-for-run +;; used to keep the rundata from db:get-tests-for-run ;; in sync. ;; (defstruct dboard:rundat run tests-drawn ;; list of id's already drawn on screen @@ -539,12 +549,13 @@ ;; ;; gets all the tests for run-id that match testnamepatt and key-vals, merges them ;; ;; NOTE: Yes, this is used ;; -(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) - (let* ((start-time (current-seconds)) +(define (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (start-time (current-seconds)) (access-mode (dboard:tabdat-access-mode tabdat)) (num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get") "200"))) (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) @@ -569,21 +580,21 @@ (dboard:rundat-last-update run-dat))) (last-db-time (if do-not-use-db-file-timestamps 0 (dboard:rundat-last-db-time run-dat))) (db-path (or (dboard:rundat-db-path run-dat) - (let* ((db-dir (common:get-db-tmp-area)) + (let* ((db-dir (common:get-db-tmp-area dbstruct)) (db-pth (conc db-dir "/megatest.db"))) (dboard:rundat-db-path-set! run-dat db-pth) db-pth))) (db-mod-time (common:lazy-sqlite-db-modification-time db-path)) (db-modified (>= db-mod-time last-db-time)) (multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress (tmptests (if (or do-not-use-db-file-timestamps (dboard:tabdat-filters-changed tabdat) db-modified) - (mrmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses + (db:get-tests-for-run dbstruct run-id testnamepatt states statuses ;; run-id testpatt states statuses (dboard:rundat-run-data-offset run-dat) ;; query offset num-to-get (dboard:tabdat-hide-not-hide tabdat) ;; no-in sort-by ;; sort-by sort-order ;; sort-order @@ -651,17 +662,17 @@ ;; this calls dboard:get-tests-for-run-duplicate for each run ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; -(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) - (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (keys (mrmt:get-keys)) +(define (update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) ;; get access to local area + (access-mode (dboard:tabdat-access-mode tabdat)) + (keys (db:get-keys dbstruct)) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) - ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (mrmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname") + (allruns (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + (allruns-tree (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -688,12 +699,12 @@ (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) - (key-vals (mrmt:get-key-vals run-id)) - (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + (key-vals (db:get-key-vals dbstruct run-id)) + (tests-ht (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals)) ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) (num-tests (length all-test-ids))) @@ -730,17 +741,18 @@ ;; this calls dboard:get-tests-for-run-duplicate for each run ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; -(define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts) - (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (keys (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode mrmt:get-keys db:get-keys))) +(define (dboard:update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (access-mode (dboard:tabdat-access-mode tabdat)) + (keys (dboard:tabdat-keys tabdat)) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) - ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (mrmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") + (allruns (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + ;;(allruns-tree (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) + (allruns-tree (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -765,12 +777,12 @@ (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) - (key-vals (mrmt:get-key-vals run-id)) - (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + (key-vals (db:get-key-vals dbstruct run-id)) + (tests-ht (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals)) ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) (num-tests (length all-test-ids))) @@ -1154,14 +1166,15 @@ (if (not (null? values)) (let ((newval (car values))) (iup:attribute-set! lb "VALUE" newval) newval)))))) -(define (dashboard:update-target-selector tabdat #!key (action-proc #f)) - (let* ((runconf-targs (common:get-runconfig-targets)) +(define (dashboard:update-target-selector commondat tabdat #!key (action-proc #f)) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (runconf-targs (common:get-runconfig-targets)) (key-lbs (dboard:tabdat-key-listboxes tabdat)) - (db-target-dat (mrmt:get-targets)) + (db-target-dat (db:get-targets dbstruct)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. (list->vector (take (append (string-split x "/") @@ -1312,14 +1325,14 @@ ;;====================================================================== ;; ;; A gui for launching tests ;; -(define (dboard:target-updater tabdat) ;; key-listboxes) +(define (dboard:target-updater commondat tabdat) ;; key-listboxes) (let ((targ (map (lambda (x) (iup:attribute x "VALUE")) - (car (dashboard:update-target-selector tabdat)))) + (car (dashboard:update-target-selector commondat tabdat)))) (curr-runname (dboard:tabdat-run-name tabdat))) (dboard:tabdat-target-set! tabdat targ) ;; (if (dboard:tabdat-updater-for-runs tabdat) ;; ((dboard:tabdat-updater-for-runs tabdat))) (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat))) @@ -1327,14 +1340,15 @@ (dboard:tabdat-run-name-set! tabdat curr-runname)) (dashboard:update-run-command tabdat))) ;; used by run-controls ;; -(define (dashboard:update-tree-selector tabdat #!key (action-proc #f)) - (let* ((tb (dboard:tabdat-runs-tree tabdat)) +(define (dashboard:update-tree-selector commondat tabdat #!key (action-proc #f)) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (tb (dboard:tabdat-runs-tree tabdat)) (runconf-targs (common:get-runconfig-targets)) - (db-target-dat (mrmt:get-targets)) + (db-target-dat (db:get-targets dbstruct)) (runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. (take (append (string-split x "/") @@ -1368,11 +1382,11 @@ (action "-run") (cmdln "") (runlogs (make-hash-table)) ;;; (key-listboxes #f) (update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc" - (dboard:target-updater (dboard:tabdat-key-listboxes tabdat)))) + (dboard:target-updater commondat (dboard:tabdat-key-listboxes tabdat)))) (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas (test-patterns-textbox #f)) (hash-table-set! tests-draw-state 'first-time #t) ;; (hash-table-set! tests-draw-state 'scalef 1) (tests:get-full-data test-names test-records '() all-tests-registry) @@ -1402,11 +1416,11 @@ (tb (dboard:tabdat-runs-tree tabdat))) (dboard:commondat-add-updater commondat (lambda () (if (dashboard:database-changed? commondat tabdat context-key: 'run-control) - (dashboard:update-tree-selector tabdat))) + (dashboard:update-tree-selector commondat tabdat))) tab-num: tab-num) result))) ;;(iup:frame ;; #:title "Logs" ;; To be replaced with tabs @@ -1501,11 +1515,11 @@ "run-times-tab-layout-updater"))) )))))) "dashboard:run-times-tab-updater"))) (key-listboxes #f) ;; (update-keyvals (lambda () - (dboard:target-updater tabdat)))) + (dboard:target-updater commondat tabdat)))) (dboard:tabdat-drawing-set! tabdat drawing) (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num) (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" #:value 150 @@ -1636,36 +1650,10 @@ (define (tree-path->run-id tabdat path) (if (not (null? path)) (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) #f)) -;; (define (dboard:get-tests-dat tabdat run-id last-update) -;; (let* ((access-mode (dboard:tabdat-access-mode tabdat)) -;; (tdat (if run-id (db:dispatch-query access-mode mrmt:get-tests-for-run db:get-tests-for-run -;; run-id -;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") -;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() -;; (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() -;; #f #f ;; offset limit -;; (dboard:tabdat-hide-not-hide tabdat) ;; not-in -;; #f #f ;; sort-by sort-order -;; #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval -;; (if (dboard:tabdat-filters-changed tabdat) -;; 0 -;; last-update) -;; *dashboard-mode*) -;; '()))) ;; get 'em all -;; ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) -;; (sort tdat (lambda (a b) -;; (let* ((aval (vector-ref a 2)) -;; (bval (vector-ref b 2)) -;; (anum (string->number aval)) -;; (bnum (string->number bval))) -;; (if (and anum bnum) -;; (< anum bnum) -;; (string<= aval bval))))))) - (define (dashboard:safe-cadr-assoc name lst) (let ((res (assoc name lst))) (if (and res (> (length res) 1)) (cadr res) @@ -1680,11 +1668,11 @@ (time-a (db:get-value-by-header record-a runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) (< time-a time-b))))) (changed #f) (last-runs-update (dboard:tabdat-last-runs-update tabdat))) - ;; (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) + ;; (runs-dat (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) @@ -1721,15 +1709,16 @@ ((> 0 (string-compare3 a-test-name b-test-name)) #f) ((< 0 (string-compare3 a-item-path b-item-path)) #t) (else #f))))))) -(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) +(define (dashboard:run-id->tests-mindat commondat run-id tabdat runs-hash) (let* ((run (hash-table-ref/default runs-hash run-id #f)) - (key-vals (mrmt:get-key-vals run-id)) + (dbstruct (dboard:get-dbstruct commondat #f)) + (key-vals (db:get-key-vals dbstruct run-id)) (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) - (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + (tests-ht (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals)) (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) @@ -1737,25 +1726,27 @@ (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id) (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash)) ) tests-mindat)) -(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f)) - (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat)) +(define (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash #!key (hide-clean #f)) + (let* (;; (dbstruct (dboard:get-dbstruct commondat #f)) + (src-run-id (dboard:tabdat-prev-run-id tabdat)) (dest-run-id (dboard:tabdat-curr-run-id tabdat))) (if (and src-run-id dest-run-id) (dcommon:xor-tests-mindat - (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash) - (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) + (dashboard:run-id->tests-mindat commondat src-run-id tabdat runs-hash) + (dashboard:run-id->tests-mindat commondat dest-run-id tabdat runs-hash) hide-clean: hide-clean) #f))) -(define (dashboard:get-runs-hash tabdat) +(define (dashboard:get-runs-hash commondat tabdat) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (dbstruct (dboard:get-dbstruct commondat #f)) (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) - (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-dat (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) @@ -1764,44 +1755,38 @@ runs-hash)) (define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix) ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat) - (dashboard:do-update-rundat tabdat) ;; ) - (dboard:runs-summary-control-panel-updater tabdat) - (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) - (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (runs (vector-ref runs-dat 1)) - (run-id (dboard:tabdat-curr-run-id tabdat)) - (runs-hash (dashboard:get-runs-hash tabdat)) - ;; (runs-hash (let ((ht (make-hash-table))) - ;; (for-each (lambda (run) - ;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - ;; runs) - ;; ht)) - ) + (dashboard:do-update-rundat commondat tabdat) ;; ) + (dboard:runs-summary-control-panel-updater commondat tabdat) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (runs-dat (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (runs (vector-ref runs-dat 1)) + (run-id (dboard:tabdat-curr-run-id tabdat)) + (runs-hash (dashboard:get-runs-hash commondat tabdat))) (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-tree) (dboard:update-tree tabdat runs-hash runs-header tb)) (if run-id (let* ((matrix-content (case (dboard:tabdat-runs-summary-mode tabdat) - ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash)) - ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash)) - ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t)) - (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash))))) + ((one-run) (dashboard:run-id->tests-mindat commondat run-id tabdat runs-hash)) + ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash)) + ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash hide-clean: #t)) + (else (dashboard:run-id->tests-mindat commondat run-id tabdat runs-hash))))) (when matrix-content (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell)) (row-indices (cadr indices)) (col-indices (car indices)) (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window (numrows 1) (numcols 1) - (changed #f) - ) + (changed #f)) (dboard:tabdat-filters-changed-set! tabdat #f) (let loop ((pass-num 0) (changed #f)) ;; Update the runs tree @@ -1883,11 +1868,14 @@ ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area (define (dashboard:summary commondat tabdat #!key (tab-num #f)) - (let* ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (configdat (dbr:dbstruct-configdat dbstruct)) + (rawconfig configdat) + ;; (rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) (changed #f)) (iup:vbox (iup:split #:value 300 (iup:frame @@ -1991,39 +1979,40 @@ (if (eq? this-mode current-mode) (iup:attribute-set! this-button "BGCOLOR" sel-color) (iup:attribute-set! this-button "BGCOLOR" nonsel-color)) (loop (cdr buttons-left) (cdr modes-left)))))) -(define (dboard:runs-summary-xor-labels-updater tabdat) +(define (dboard:runs-summary-xor-labels-updater commondat tabdat) (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat)) - (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) - (mode (dboard:tabdat-runs-summary-mode tabdat))) + (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) + (mode (dboard:tabdat-runs-summary-mode tabdat)) + (dbstruct (dboard:get-dbstruct commondat #f))) (when (and source-runname-label dest-runname-label) (case mode ((xor-two-runs xor-two-runs-hide-clean) (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) (prev-run-id (dboard:tabdat-prev-run-id tabdat)) (curr-runname (if curr-run-id - (mrmt:get-run-name-from-id curr-run-id) + (db:get-run-name-from-id dbstruct curr-run-id) "None")) (prev-runname (if prev-run-id - (mrmt:get-run-name-from-id prev-run-id) + (db:get-run-name-from-id dbstruct prev-run-id) "None"))) (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" ")) (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" ")))) (else (iup:attribute-set! source-runname-label "TITLE" "") (iup:attribute-set! dest-runname-label "TITLE" "")))))) -(define (dboard:runs-summary-control-panel-updater tabdat) - (dboard:runs-summary-xor-labels-updater tabdat) +(define (dboard:runs-summary-control-panel-updater commondat tabdat) + (dboard:runs-summary-xor-labels-updater commondat tabdat) (dboard:runs-summary-buttons-updater tabdat)) ;; setup buttons and callbacks to switch between modes in runs summary tab ;; -(define (dashboard:runs-summary-control-panel tabdat) +(define (dashboard:runs-summary-control-panel commondat tabdat) (let* ((summary-buttons ;; build buttons (map (lambda (mode-item) (let* ((this-mode (car mode-item)) (this-mode-label (cdr mode-item))) @@ -2031,11 +2020,11 @@ #:action (lambda (obj) (debug:catch-and-dump (lambda () (dboard:tabdat-runs-summary-mode-set! tabdat this-mode) - (dboard:runs-summary-control-panel-updater tabdat)) + (dboard:runs-summary-control-panel-updater commondattabdat)) "runs summary control panel updater"))))) (dboard:tabdat-runs-summary-modes tabdat))) (summary-buttons-hbox (apply iup:hbox summary-buttons)) (xor-runname-labels-hbox (iup:hbox @@ -2050,11 +2039,11 @@ temp-label)))) (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons) ;; maybe wrap in a frame (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox ))) - (dboard:runs-summary-control-panel-updater tabdat) + (dboard:runs-summary-control-panel-updater commondat tabdat) res ))) ;;====================================================================== ;; R U N @@ -2063,11 +2052,12 @@ ;; display and manage a single run at a time ;; This is the Run Summary tab ;; (define (dashboard:runs-summary commondat tabdat #!key (tab-num #f)) - (let* ((update-mutex (dboard:commondat-update-mutex commondat)) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (update-mutex (dboard:commondat-update-mutex commondat)) (tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "YES" @@ -2110,24 +2100,24 @@ ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (run-id (dboard:tabdat-curr-run-id tabdat)) - (run-info (mrmt:get-run-info run-id)) - (target (mrmt:get-target run-id)) + (run-info (db:get-run-info dbstruct run-id)) + (target (db:get-target dbstruct run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) - (test-info (mrmt:get-test-info-by-id run-id test-id)) + (test-info (db:get-test-info-by-id dbstruct run-id test-id)) (test-name (db:test-get-testname test-info)) - (testpatt (let ((tlast (mrmt:tasks-get-last target runname))) + (testpatt (let ((tlast (db:tasks-get-last dbstruct target runname))) (if tlast - (let ((tpatt (tasks:task-get-testpatt tlast))) + (let ((tpatt (tasks:task-get-testpatt tlast))) ;; tasks:task-get-testpatt is an accessor defined in task_records.scm (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" tpatt)) "%"))) - (item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id))) + (item-path (db:test-get-item-path (db:get-test-info-by-id dbstruct run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path))) (status-chars (char-set->list (string->char-set status))) (testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &"))) @@ -2164,11 +2154,11 @@ (if run-matrix (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix))) "dashboard:runs-summary-updater") ) (mutex-unlock! update-mutex))) - (runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat)) + (runs-summary-control-panel (dashboard:runs-summary-control-panel commondat tabdat)) ) (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num) (dboard:tabdat-runs-tree-set! tabdat tb) (iup:vbox (iup:split @@ -2457,11 +2447,10 @@ (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) - ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) @@ -2530,11 +2519,10 @@ " -preclean -clean-cache")))) (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) - ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) @@ -2579,16 +2567,17 @@ " " tconfig " &"))) (system cmd)))) )))) (define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) - (let* ((stats-dat (dboard:tabdat-make-data)) - (runs-dat (dboard:tabdat-make-data)) - (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure - (runcontrols-dat (dboard:tabdat-make-data)) - (runtimes-dat (dboard:tabdat-make-data)) - (areas-dat (dboard:tabdat-make-data)) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (stats-dat (dboard:tabdat-make-data commondat)) + (runs-dat (dboard:tabdat-make-data commondat)) + (onerun-dat (dboard:tabdat-make-data commondat)) ;; name for run-summary structure + (runcontrols-dat (dboard:tabdat-make-data commondat)) + (runtimes-dat (dboard:tabdat-make-data commondat)) + (areas-dat (dboard:tabdat-make-data commondat)) (nruns (dboard:tabdat-numruns runs-dat)) (ntests (dboard:tabdat-num-tests runs-dat)) (keynames (dboard:tabdat-dbkeys runs-dat)) (nkeys (length keynames)) (runsvec (make-vector nruns)) @@ -2629,11 +2618,11 @@ (cond ((>= testnum ntests) ;; now lftlst will be an hbox with the test keys and the test name labels (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL" (iup:valuator #:valuechanged_cb (lambda (obj) - (let ((val (string->number (iup:attribute obj "VALUE"))) + 668 (let ((val (string->number (iup:attribute obj "VALUE"))) (oldmax (string->number (iup:attribute obj "MAX"))) (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat))))) (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10)))) (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax) @@ -2699,24 +2688,24 @@ (if (eq? pressed 1) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) (run-id (db:test-get-run_id (vector-ref buttndat 3))) - (run-info (mrmt:get-run-info run-id)) - (target (mrmt:get-target run-id)) + (run-info (db:get-run-info dbstruct run-id)) + (target (db:get-target dbstruct run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) - (test-info (mrmt:get-test-info-by-id run-id test-id)) + (test-info (db:get-test-info-by-id dbstruct run-id test-id)) (test-name (db:test-get-testname test-info)) - (testpatt (let ((tlast (mrmt:tasks-get-last target runname))) + (testpatt (let ((tlast (db:tasks-get-last dbstruct target runname))) (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" tpatt)) "%"))) - (item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id))) + (item-path (db:test-get-item-path (db:get-test-info-by-id dbstruct run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path)))) (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu #:x 'mouse @@ -3004,29 +2993,30 @@ ;; run times tab data updater ;; (define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (dbstruct (dboard:get-dbstruct commondat #f)) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) - (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (runs-hash (let ((ht (make-hash-table))) - (for-each (lambda (run) - (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - (vector-ref runs-dat 1)) - ht)) - (run-ids (sort (filter number? (hash-table-keys runs-hash)) - (lambda (a b) - (let* ((record-a (hash-table-ref runs-hash a)) - (record-b (hash-table-ref runs-hash b)) - (time-a (db:get-value-by-header record-a runs-header "event_time")) - (time-b (db:get-value-by-header record-b runs-header "event_time"))) - (< time-a time-b))))) - (tb (dboard:tabdat-runs-tree tabdat)) - (num-runs (length (hash-table-keys runs-hash))) + (runs-dat (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) + (vector-ref runs-dat 1)) + ht)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) + (lambda (a b) + (let* ((record-a (hash-table-ref runs-hash a)) + (record-b (hash-table-ref runs-hash b)) + (time-a (db:get-value-by-header record-a runs-header "event_time")) + (time-b (db:get-value-by-header record-b runs-header "event_time"))) + (< time-a time-b))))) + (tb (dboard:tabdat-runs-tree tabdat)) + (num-runs (length (hash-table-keys runs-hash))) (update-start-time (current-seconds)) - (inc-mode #f)) + (inc-mode #f)) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) ;; fill in the tree (if (and tb (not inc-mode)) (for-each @@ -3077,11 +3067,12 @@ (vg:drawing-cache-set! dwg '()) (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) ;; (dboard:tabdat-allruns-set! tabdat '()) (dboard:tabdat-max-row-set! tabdat 0) (dboard:tabdat-last-filter-str-set! tabdat filtrstr))) - (update-rundat tabdat + (update-rundat commondat + tabdat runpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") (dboard:tabdat-numruns tabdat) testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%") @@ -3546,12 +3537,13 @@ ;; ;; (define (tabdat-values tabdat) ;; runs update-rundat using the various filters from the gui ;; -(define (dashboard:do-update-rundat tabdat) +(define (dashboard:do-update-rundat commondat tabdat) (dboard:update-rundat + commondat tabdat (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") (dboard:tabdat-numruns tabdat) (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") ;; generate key patterns from the target stored in tabdat @@ -3575,11 +3567,11 @@ (dbkeys (dboard:tabdat-dbkeys tabdat))) ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num) ;;(tabdat-values tabdat) ;;RA added ;; (pp (dboard:tabdat->alist tabdat)) ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat) - (dashboard:do-update-rundat tabdat) + (dashboard:do-update-rundat commondat tabdat) ;;(debug:print-info 13 *default-log-port* "dashboard:runs-tab-updater") ;;(inspect tabdat) (let ((uidat (dboard:commondat-uidat commondat))) ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -86,11 +86,11 @@ ;; ;; NOTE: loose ends!! ;; db:open-db -> not properly using tmpdb path ;; common:get-db-tmp-area -> using *toppath* and common:get-testsuite-area ;; -(define (db:dashboard-open-db areas area-name area-path) +(define (db:dashboard-open-dbstruct areas area-name area-path) ;; 0. check for already existing dbstruct in areas hash, return it if found ;; 1. do minimal read of megatest.config, store configdat, keys in dbstruct ;; 2. get homehost ;; 3. create /tmp db area (if needed) ;; 4. sync data to /tmp db (or update if exists) @@ -3167,10 +3167,25 @@ (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 @@ -3186,10 +3201,26 @@ (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. Index: docs/Makefile ================================================================== --- docs/Makefile +++ docs/Makefile @@ -13,5 +13,7 @@ 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 Index: docs/pkts.dot ================================================================== --- /dev/null +++ docs/pkts.dot @@ -0,0 +1,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 Index: docs/pkts.pdf ================================================================== --- /dev/null +++ docs/pkts.pdf cannot compute difference between binary files Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -8,12 +8,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking directory-utils) -(import (prefix sqlite3 sqlite3:)) +(use srfi-1 posix regex srfi-69 directory-utils) (declare (unit ezsteps)) (declare (uses db)) (declare (uses common)) (declare (uses items)) ADDED get-config-settings.sh Index: get-config-settings.sh ================================================================== --- /dev/null +++ get-config-settings.sh @@ -0,0 +1,2 @@ + grep configf:lookup *.scm | sed 's/^.*:lookup//; s/^-number//; s/^ //' | grep -v '^\(section\|test-conf\|tconfig\|testconfig\|dat\|config\|views-cfgdat\)' | perl -pe 's/^\s*(\*configdat\*|configdat|mtconf)//; s/^\s+//; s/\).*$//; s/"//g' | awk '{print $1,$2}' | sort | grep -v section | sort | uniq + Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -8,12 +8,11 @@ ;; 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) ;; sqlite3 -;; (import (prefix sqlite3 sqlite3:)) +(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) Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -64,14 +64,11 @@ ;;====================================================================== ;; config file related routines ;;====================================================================== -(define (keys:config-get-fields confdat) - (let ((fields (hash-table-ref/default confdat "fields" '()))) - (map car fields))) - +(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) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -21,13 +21,10 @@ (declare (unit launch)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) -;; (declare (uses sdb)) -(declare (uses tdb)) -;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -451,11 +448,11 @@ (keyvals #f) (fullrunscript (if (not runscript) #f (if (substring-index "/" runscript) runscript ;; use unadultered if contains slashes - (let ((fulln (conc testpath "/" runscript))) + (let ((fulln (conc work-area "/" runscript))) (if (and (common:file-exists? fulln) (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path ) ;; (rollup-status 0) @@ -517,17 +514,45 @@ ;; (debug:print 0 *default-log-port* "Failed to create directory " logdir " expect problems, message: " ((condition-property-accessor 'exn 'message) exn)) ;; (create-directory logdir #t))))) ;; ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) - (if (or (common:file-exists? top-path) + (if (or (common:directory-exists? work-area) (> count 10)) - (change-directory top-path) + (change-directory work-area) (begin - (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " top-path " not found") + (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") (thread-sleep! 10) (loop (+ count 1))))) + + (if (not (string=? (common:real-path work-area)(common:real-path (current-directory)))) + (begin + (debug:print 0 *default-log-port* + "INFO: we are expecting to be in directory " work-area "\n" + " but we are actually in the directory " (current-directory) "\n" + " doing another change dir.") + (change-directory work-area))) + + ;; spot check that the files in testpath are available. Too often NFS delays cause problems here. + (let ((files (glob (conc testpath "/*"))) + (bad-files '())) + (for-each + (lambda (fullname) + (let* ((fname (pathname-strip-directory fullname)) + (targn (conc work-area "/" fname))) + (if (not (file-exists? targn)) + (set! bad-files (cons fname bad-files))))) + files) + (if (not (null? bad-files)) + (begin + (debug:print 0 *default-log-port* "INFO: test data from " testpath " not copied properly or filesystem problems causing data to not be found. Re-running the copy command.") + (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", ")) + (launch:test-copy testpath work-area)))) + + ;; one more time, change to the work-area directory + (change-directory work-area) + (launch:setup) ;; should be properly in the top-path now (set! tconfigreg (tests:get-all)) (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (if (eq? signum signal/stop) @@ -559,11 +584,12 @@ (begin (debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.") (exit)))) (test-pid (db:test-get-process_id test-info))) (cond - ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun + ;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag. + ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) ) ;; prime it for running ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART")) @@ -1069,10 +1095,26 @@ (cdr res) (begin (if (common:low-noise-print 20 "No valid disks or no disk with enough space") (debug:print-error 0 *default-log-port* "No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace)) (exit 1))))))) ;; TODO - move the exit to the calling location and return #f + +(define (launch:test-copy test-src-path test-path) + (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd"))) + (if cmd + ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH + (string-substitute "TEST_TARG_PATH" test-path + (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t) + #f))) + (cmd (if ovrcmd + ovrcmd + (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/" + " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log"))) + (status (system cmd))) + (if (not (eq? status 0)) + (debug:print 2 *default-log-port* "ERROR: problem with running \"" cmd "\"")))) + ;; Desired directory structure: ;; ;; - - -. ;; | @@ -1234,23 +1276,11 @@ (if (not (directory? test-path)) (create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes (if (and test-src-path (directory? test-path)) (begin - (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd"))) - (if cmd - ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH - (string-substitute "TEST_TARG_PATH" test-path - (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t) - #f))) - (cmd (if ovrcmd - ovrcmd - (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/" - " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log"))) - (status (system cmd))) - (if (not (eq? status 0)) - (debug:print 2 *default-log-port* "ERROR: problem with running \"" cmd "\""))) + (launch:test-copy test-src-path test-path) (list lnkpathf lnkpath )) (if (and test-src-path (> remtries 0)) (begin (debug:print-error 0 *default-log-port* "Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) ;; Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ lock-queue.scm @@ -5,12 +5,11 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. -(use sqlite3 srfi-18) -(import (prefix sqlite3 sqlite3:)) +(use (prefix sqlite3 sqlite3:) srfi-18) (declare (unit lock-queue)) (declare (uses common)) (declare (uses tasks)) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,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.6428) +(define megatest-version 1.6502) Index: megatest.config ================================================================== --- megatest.config +++ megatest.config @@ -2,28 +2,56 @@ ## 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/pkts /some/other/source +pktsdirs /tmp/mt_pkts /some/other/source [areas] # path=path-to-area;targtrans=script_to_transform_target local path=. -fullrun path=tests/fullrun +# 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 selector=QUICKPATT/quick -full areas=fullrun,ext-tests; selector=MAXPATT/ -all areas=fullrun,ext-tests -snazy areas=%; selector=QUICKPATT/ +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 Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -11,20 +11,18 @@ ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) - http-client srfi-18 extras format) ;; zmq extras) +(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) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) -(import (prefix rpc rpc:)) (require-library mutils) ;; (use zmq) (declare (uses common)) @@ -90,11 +88,11 @@ (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2017 - + Usage: megatest [options] -h : this help -manual : show the Megatest user manual -version : print megatest version (currently " megatest-version ") @@ -114,10 +112,11 @@ -get-run-status : gets status for run specified by target and runname -run-wait : wait on run specified by target and runname -preclean : remove the existing test directory before running the test -clean-cache : remove the cached megatest.config and runconfigs.config files -no-cache : do not use the cached config files. + -one-pass : launch as many tests as you can but do not wait for more to be ready Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) -target key1/key2/... : run for key1, key2, etc. -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfigs -testpatt patt1/patt2,patt3/... : % is wildcard @@ -347,10 +346,11 @@ "-lock" "-unlock" "-list-servers" "-kill-servers" "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) + "-one-pass" ;; "-local" ;; run some commands using local db access "-generate-html" ;; misc queries "-list-disks" ADDED minimt/Makefile Index: minimt/Makefile ================================================================== --- /dev/null +++ minimt/Makefile @@ -0,0 +1,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 Index: minimt/db.scm ================================================================== --- /dev/null +++ minimt/db.scm @@ -0,0 +1,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 Index: minimt/direct.scm ================================================================== --- /dev/null +++ minimt/direct.scm @@ -0,0 +1,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 Index: minimt/minimt.scm ================================================================== --- /dev/null +++ minimt/minimt.scm @@ -0,0 +1,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 Index: minimt/queued.scm ================================================================== --- /dev/null +++ minimt/queued.scm @@ -0,0 +1,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 Index: minimt/setup.scm ================================================================== --- /dev/null +++ minimt/setup.scm @@ -0,0 +1,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 + ) Index: mlaunch.scm ================================================================== --- mlaunch.scm +++ mlaunch.scm @@ -15,12 +15,11 @@ ;; 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 dot-locking format) -(import (prefix sqlite3 sqlite3:)) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 format) (declare (unit mlaunch)) (declare (uses db)) (declare (uses common)) Index: mt-pg.sql ================================================================== --- mt-pg.sql +++ mt-pg.sql @@ -61,11 +61,11 @@ 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)); + 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, @@ -208,9 +208,27 @@ 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; Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -1,6 +1,6 @@ -;; Copyright 2006-2017, Matthew Welland. +; 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 @@ -12,13 +12,13 @@ ;; 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 pkts regex regex-case + srfi-18 extras format pkts regex regex-case (prefix dbi dbi:) - (prefix nanomsg nmsg:)) + nanomsg) (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses configf)) @@ -26,13 +26,58 @@ (include "megatest-fossil-hash.scm") (require-library stml) -(define *target-mappers* (make-hash-table)) ;; '()) -(define *runname-mappers* (make-hash-table)) ;; '()) +;; 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? @@ -41,11 +86,11 @@ ;; (if (common:file-exists? "megatest.config") (if (common:file-exists? ".mtutil.so") (load ".mtutil.so") (if (common:file-exists? ".mtutil.scm") - (load ".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 @@ -57,50 +102,55 @@ 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 + -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 - -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 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\" + 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 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 @@ -114,50 +164,78 @@ ;; args and pkt key specs ;; (define *arg-keys* ;; used keys ;; a - action - '(("-area" . G) ;; maps to group - ("-target" . t) - ("-run-name" . n) - ("-state" . e) - ("-status" . s) - ("-contour" . c) - ("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt" - ("-mode-patt" . o) - ("-tag-expr" . x) - ("-item-patt" . i) - ("-sync-to" . k) - ("-append-config" . d) + '( + ("-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 - ("-start-dir" . S) - ("-msg" . M) - ("-set-vars" . v) - ("-debug" . #f) ;; for *verbosity* > 2 - ("-load" . #f) ;; load and exectute a scheme file - ("-log" . #f) + ("-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) + '( + ("-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) @@ -180,11 +258,12 @@ (or (alist-ref (string->symbol param) '((-tag-expr . "-tagexpr") (-mode-patt . "--modepatt") (-run-name . "-runname") (-test-patt . "-testpatt") - (-msg . "-m"))) + (-msg . "-m") + (-new . "-set-state-status"))) param)) (define (val->alist val) (let ((val-list (string-split-fields ";\\s*" val #:infix))) (if val-list @@ -260,22 +339,14 @@ (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 ;;====================================================================== -;; Card types: -;; -;; a action -;; u username (Unix) -;; D timestamp -;; T card type - ;; process args (define *action* (if (> (length (argv)) 1) (cadr (argv)) #f)) (define remargs (args:get-args @@ -301,11 +372,12 @@ (if (and (not (null? remargs)) (not (or (args:get-arg "-runstep") (args:get-arg "-envcap") (args:get-arg "-envdelta") - (member *action* '("db")) ;; very loose checks on db. + (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"))) @@ -312,79 +384,80 @@ (begin (print help) (exit 1))) ;;====================================================================== -;; pkts +;; Nanomsg transport ;;====================================================================== -(define (with-queue-db mtconf proc) - (let* ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) - (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)) - (toppath (configf:lookup mtconf "dyndat" "toppath")) - (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 (load-pkts-to-db mtconf) - (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 - (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))))) - (string-split pktsdirs))))) - -(define (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 (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 +(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 ;;====================================================================== @@ -399,11 +472,11 @@ ;; 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)) +(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 @@ -410,12 +483,11 @@ (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 'T "cmd" - 'a action + (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 '()) @@ -434,12 +506,12 @@ #f))) (if (or pmeta smeta) ;; construct the switch/param pair. (list meta value) '()))) (filter cdr args-data))))) -;; (print "Alldat: " alldat -;; " args-data: " 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) @@ -450,15 +522,15 @@ ;; 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 "dyndata" + ;; we set some dynamic data in a section called "scratchdata" (if mtconf (begin - (configf:section-var-set! mtconf "dyndat" "toppath" start-dir))) - ;; (print "TOPPATH: " (configf:lookup mtconf "dyndat" "toppath")) + (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. @@ -469,16 +541,19 @@ ;; 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 runname mode-patt tag-expr pktsdir reason contour sched dbdest append-conf runtrans) +(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)) - (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f)) + ;; (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)) @@ -494,37 +569,25 @@ (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 (if area-xlatr - (let ((xlatr-key (string->symbol area-xlatr))) - (if (hash-table-exists? *target-mappers* xlatr-key) - (begin - (print "Using target mapper: " area-xlatr) - (handle-exceptions - exn - (begin - (print "FAILED TO RUN TARGET MAPPER FOR " area ", called " area-xlatr) - (print " function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) ) - (print " message: " ((condition-property-accessor 'exn 'message) exn)) - runkey) - ((hash-table-ref *target-mappers* xlatr-key) - runkey new-runname area area-path reason contour mode-patt))) - (begin - (print "ERROR: Failed to find named target translator " xlatr-key ", using original target.") - runkey))) - runkey))) + (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 sync-prepend) (set! new-target #f) (set! runame #f))) - (print "area-path: " area-path " area-xlatr: " area-xlatr " orig-target: " runkey " new-target: " new-target) + ;; (print "area-path: " area-path " orig-target: " runkey " new-target: " new-target) (let-values (((uuid pkt) (command-line->pkt - (if action action "run") + actual-action (append `(("-start-dir" . ,area-path) ("-msg" . ,reason) ("-contour" . ,contour)) (if (good-val new-runname) `(("-run-name" . ,new-runname)) '()) @@ -531,10 +594,11 @@ (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")) @@ -541,33 +605,49 @@ `(("-preclean" . " ") ("-rerun-all" . " ")) ;; if run we *always* want preclean set, use single space as placeholder '()) ) sched - extra-dat: `(y ,runkey) ;; we need the run key for marking the run as launched + 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) - (string-split (or (alist-ref '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 "") ",")))) -(define (area-allowed? area areas) - (or (not areas) - (null? areas) - (member area areas))) +;; 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")))) - (with-queue-db + (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"))) @@ -592,26 +672,35 @@ (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 (get-pkt-alists runstarts)) + (rspkts (common:get-pkt-alists runstarts)) ;; starttimes is for run start times and is used to know when the last run was launched - (starttimes (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)))) + (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 (get-pkt-alists syncstarts)) - (synctimes (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)))) + (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))) @@ -625,49 +714,53 @@ (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* ((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)) + (let* ( ;; (action (alist-ref 'action val-alist)) - (cron-safe-string (string-translate (string-intersperse (string-split (alist-ref 'cron val-alist)) "-") "*" "X")) + (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 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 . ,(alist-ref 'dbdest val-alist)) - (append . ,(alist-ref 'appendconf val-alist)))))) + (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) + `((message . ,(conc ruletype ":" cron-safe-string)) + (runname . ,runname) (runtrans . ,runtrans) - (action . ,action) - (target . ,target))))) + (action . ,action) + (areas . ,areas) + (target . ,target))))) ((remove) (push-run-spec torun contour runkey - `((message . ,(conc ruletype ":" cron-safe-string)) - (runname . ,runname) + `((message . ,(conc ruletype ":" cron-safe-string)) + (runname . ,runname) (runtrans . ,runtrans) - (action . ,action) - (target . ,target)))) + (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 @@ -700,19 +793,23 @@ (if need-run (let* ((key-msg `((message . ,(conc ruletype ":" message)) (runname . ,runname) (runtrans . ,runtrans) (action . ,action) - (target . ,new-target)))) + (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. @@ -724,66 +821,73 @@ (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)) + `((message . ,(conc "fossil:" branch "-neverrun")) + (runname . ,(conc runname "-" node)) (runtrans . ,runtrans) - (target . ,runkey))) + (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)) + `((message . ,(conc "fossil:" branch "-" node)) + (runname . ,(conc runname "-" node)) (runtrans . ,runtrans) - (target . ,runkey))))) + (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* ((file-globs (alist-ref 'glob val-alist)) - (areas (val-alist->areas val-alist)) - (youngestdat (common:get-youngest (common:bash-glob file-globs))) + (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) + `((message . "file:neverrun") + (action . ,action) (runtrans . ,runtrans) - (target . ,runkey) - (runname . ,runname))) + ;; (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) + `((message . ,(conc ruletype ":" (cadr youngestdat))) + (action . ,action) + ;; (target . ,runkey) (runtrans . ,runtrans) - (runname . ,runname) + (areas . ,areas) + (runname . ,runname) )))))) - ;; starttimes)) + ;; all globbed files must be newer than the reference + ;; ((file-and) ;; all files must be newer than the reference - (let* ((file-globs (alist-ref 'glob val-alist)) - (youngestdat (common:get-youngest file-globs)) + (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) + `((message . "file:neverrun") + (runname . ,runname) (runtrans . ,runtrans) - (target . ,runkey) - (action . ,action))) + (areas . ,areas) + ;; (target . ,runkey) + (action . ,action))) ;; NB// I think this is wrong. It should be looking at last-run only. - (if (> youngestmod last-run) + (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))) @@ -790,84 +894,98 @@ ;; 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) + `((message . ,(conc ruletype ":" (cadr youngestdat))) + (runname . ,runname) (runtrans . ,runtrans) - (target . ,runkey) - (action . ,action) + ;; (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) - (print "contour: " contour) - (let* ((val (or (configf:lookup mtconf "contours" contour) "")) - (val-alist (val->alist val)) - (areas (val-alist->areas val-alist)) - (selector (alist-ref 'selector val-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))))) + (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) + (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) ;; is this area to be handled (from areas=a,b,c ...) - (let ((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)) - (target (or (alist-ref 'target runkeydat) runkey))) ;; override with target if forced - (print "Have: runkey=" runkey " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt " target=" target) - (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) (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 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) - )) - (print "NOTE: skipping " runkeydat " for area, not in " areas))) - all-areas)) + (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"))) + (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 (member key '(a Z U D T)) ;; a is the action + (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 " ") + (conc action " " action-param) "")) pkta))) ;; (use trace)(trace pkt->cmdline) @@ -890,12 +1008,16 @@ #f (create-directory "logs") #t) #t) "logs" - "/tmp"))) - (with-queue-db + "/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")) @@ -904,30 +1026,73 @@ (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)) + (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))) - (print "RUNNING: " fullcmd) - (system fullcmd) - (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)))) + (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)) @@ -935,47 +1100,89 @@ (if (common:file-exists? debugcontrolf) (load debugcontrolf))) (if *action* (case (string->symbol *action*) - ((run remove rerun set-ss archive kill) + ((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))) + (adjargs (hash-table-copy args:arg-hash)) + (new-ss (args:get-arg "-new"))) ;; check a few things - (if (and area - (not area-path)) - (begin - (print "ERROR: the specified area was not found in the [areas] table. Area name=" area) - (exit 1))) + (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 ") + (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))) + (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 "dyndat" "toppath"))) + (toppath (configf:lookup mtconf "scratchdat" "toppath"))) (case (string->symbol *action*) ((process) (begin - (load-pkts-to-db mtconf) + (common:load-pkts-to-db mtconf) (generate-run-pkts mtconf toppath) - (load-pkts-to-db mtconf) + (common:load-pkts-to-db mtconf) (dispatch-commands mtconf toppath))) - ((import) (load-pkts-to-db mtconf)) ;; import pkts + ((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) @@ -989,11 +1196,48 @@ (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") @@ -1013,5 +1257,11 @@ (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)) +|# Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -13,11 +13,10 @@ ;; Process convience utils ;;====================================================================== (use regex) (declare (unit process)) -;;(declare (uses common)) (define (process:conservative-read port) (let loop ((res "")) (if (not (eof-object? (peek-char port))) (loop (conc res (read-char port))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -11,13 +11,11 @@ (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) -;; (declare (uses tdb)) (declare (uses http-transport)) -;;(declare (uses nmsg-transport)) (include "common_records.scm") ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; @@ -816,23 +814,24 @@ (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))) -;; (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) -;; (if tdb -;; (tdb:read-test-data tdb test-id categorypatt) -;; '()))) +(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) Index: rpctest/rpctest-continuous-client.scm ================================================================== --- rpctest/rpctest-continuous-client.scm +++ rpctest/rpctest-continuous-client.scm @@ -17,11 +17,11 @@ (print "Operation: " operation ", param: " param) ;; have a pool of db's to pick from (define *dbpool* '()) (define *pool-mutex* (make-mutex)) -1 + (define (get-db) (mutex-lock! *pool-mutex*) (if (null? *dbpool*) (begin (mutex-unlock! *pool-mutex*) Index: runconfigs.config ================================================================== --- runconfigs.config +++ runconfigs.config @@ -8,11 +8,12 @@ # 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 +# 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? @@ -24,24 +25,25 @@ # [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 -quick:file:run runtrans=auto; glob=/home/matt/data/megatest/*.scm +# 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 +# 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 +# # 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 Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -8,13 +8,12 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) +(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) posix-extras directory-utils pathname-expand typed-records format) -(import (prefix sqlite3 sqlite3:)) (declare (unit runs)) (declare (uses db)) (declare (uses common)) (declare (uses items)) @@ -266,10 +265,49 @@ (debug:print-info 0 *default-log-port* "running run-pre-hook: \"" run-pre-hook "\", log is " actual-logf) (system (conc run-pre-hook " >> " actual-logf " 2>&1")) (debug:print-info 0 *default-log-port* "pre-hook \"" run-pre-hook "\" took " (- (current-seconds) start-time) " seconds to run."))) (debug:print 0 *default-log-port* "Skipping pre-hook call \"" run-pre-hook "\" as there are existing tests for this run."))))) +(define (runs:run-post-hook run-id) + (let* ((run-post-hook (configf:lookup *configdat* "runs" "post-hook")) + (existing-tests (if run-post-hook + (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses + #f #f ;; offset limit + #f ;; not-in + #f ;; sort-by + #f ;; sort-order + #f ;; get full data (not 'shortlist) + 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time + 'dashboard) + '())) + (log-dir (conc *toppath* "/logs")) + (log-file (conc "post-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log")) + (full-log-fname (conc log-dir "/" log-file))) + (if run-post-hook + ;; (if (null? existing-tests) + ;; (debug:print 0 *default-log-port* "Skipping post-hook call \"" run-post-hook "\" as there are existing tests for this run."))))) + (let* ((use-log-dir (if (not (directory-exists? log-dir)) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir) + #f) + (create-directory log-dir #t) + #t) + #t)) + (start-time (current-seconds)) + (actual-logf (if use-log-dir full-log-fname log-file))) + (handle-exceptions + exn + (begin + (print-call-chain *default-log-port*) + (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "ERROR: failed to run post-hook " run-post-hook ", check the log " log-file)) + (debug:print-info 0 *default-log-port* "running run-post-hook: \"" run-post-hook "\", log is " actual-logf) + (system (conc run-post-hook " >> " actual-logf " 2>&1")) + (debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))))) + ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; (define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names @@ -521,20 +559,10 @@ (begin (print-call-chain) (print " message: " ((condition-property-accessor 'exn 'message) exn))) (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))) - ;; (handle-exceptions - ;; exn - ;; (begin - ;; (print-call-chain (current-error-port)) - ;; (debug:print-error 0 *default-log-port* "failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) - ;; (if (> run-queue-retries 0) - ;; (begin - ;; (set! run-queue-retries (- run-queue-retries 1)) - ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))) - ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))) "runs:run-tests-queue")) (th2 (make-thread (lambda () ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ... (let ((run-ids (rmt:get-all-run-ids))) (for-each (lambda (run-id) @@ -594,10 +622,18 @@ (cdr reg) (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal '() reg))) +;; this is the list of parameters to the named loop "loop" near the top of runs:run-tests-queue, look around line 1216 +;; +(define (runs:loop-values tal reg reglen regfull reruns) + (list (runs:queue-next-hed tal reg reglen regfull) ;; hed + (runs:queue-next-tal tal reg reglen regfull) ;; tal + (runs:queue-next-reg tal reg reglen regfull) ;; reg + reruns)) ;; reruns + (define runs:nothing-left-in-queue-count 0) ;; BB: for future reference - suspect target vars are not expanded to env vars at this point (item expansion using [items]\nwhatever [system echo $TARGETVAR] doesnt work right whereas [system echo #{targetvar}] does.. Tal and Randy have tix on this. on first pass, var not set, on second pass, ok. (define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps) (let* ((loop-list (list hed tal reg reruns)) @@ -636,14 +672,11 @@ (member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a) '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here (debug:print-info 1 *default-log-port* "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue") (if (or (not (null? tal)) (not (null? reg))) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns) + (runs:loop-values tal reg reglen regfull reruns) (begin (debug:print-info 0 *default-log-port* "Nothing left in the queue!") ;; If get here twice then we know we've tried to expand all items ;; since there must be a logic issue with the handling of loops in the ;; items expand phase we will brute force an exit here. @@ -712,14 +745,12 @@ (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites"))) (if (and (null? trimmed-tal) (null? trimmed-reg)) #f - (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull) - (runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull) - (runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull) - reruns))) + (runs:loop-values trimmed-tal trimmed-reg reglen regfull reruns) + )) (list (car newtal)(append (cdr newtal) reg) '() reruns)))) ((and (null? fails) (null? prereq-fails) (null? non-completed)) @@ -734,14 +765,12 @@ (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met? (begin (debug:print-info 1 *default-log-port* "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while."))) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns)))) + (runs:loop-values tal reg reglen regfull reruns) + ))) ((and (or (not (null? fails)) (not (null? prereq-fails))) (member 'normal testmode)) @@ -754,27 +783,21 @@ (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites") (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) (if (or (not (null? reg))(not (null? tal))) (begin (hash-table-set! test-registry hed 'CANNOTRUN) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - (cons hed reruns))) + (runs:loop-values tal reg reglen regfull (cons hed reruns)) + ) #f)) ;; #f flags do not loop ((and (not (null? fails))(member 'toplevel testmode)) (if (or (not (null? reg))(not (null? tal))) (list (car newtal)(append (cdr newtal) reg) '() reruns) #f)) ((null? runnables) #f) ;; if we get here and non-completed is null then it is all over. (else (debug:print 0 *default-log-port* "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now") - ;; (list (runs:queue-next-hed tal reg reglen regfull) - ;; (runs:queue-next-tal tal reg reglen regfull) - ;; (runs:queue-next-reg tal reg reglen regfull) - ;; reruns) (list (car newtal)(cdr newtal) reg reruns))))) (define (runs:mixed-list-testname-and-testrec->list-of-strings inlst) (if (null? inlst) '() @@ -874,14 +897,11 @@ ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run ;; else the run is stuck, temporarily or permanently ;; but should check if it is due to lack of resources vs. prerequisites (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) (if (or (not (null? tal))(not (null? reg))) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns) + (runs:loop-values tal reg reglen regfull reruns) #f)) ;; Register tests ;; ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) @@ -902,11 +922,11 @@ (if (rmt:get-test-id run-id test-name "") (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) (if (and (null? tal)(null? reg)) (list hed tal (append reg (list hed)) reruns) - (list (runs:queue-next-hed tal reg reglen regfull) + (list (runs:queue-next-hed tal reg reglen regfull) ;; cannot replace with a call to runs:loop-values as the logic is different for reg (runs:queue-next-tal tal reg reglen regfull) ;; NB// Here we are building reg as we register tests ;; if regfull we must pop the front item off reg (if regfull (append (cdr reg) (list hed)) @@ -959,14 +979,11 @@ (runs:incremental-print-results run-id) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (or (not (null? tal))(not (null? reg))) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns) + (runs:loop-values tal reg reglen regfull reruns) #f)) ;; must be we have unmet prerequisites ;; (else @@ -998,25 +1015,18 @@ (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) ;; This next is for the items (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns ;; WAS: (cons hed reruns) ;; but that makes no sense? - )) + (runs:loop-values tal reg reglen regfull reruns)) (let ((nth-try (hash-table-ref/default test-registry hed 0))) (cond ((member "RUNNING" (map db:test-get-state prereqs-not-met)) (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60) (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) (thread-sleep! 4) - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns)) + (runs:loop-values tal reg reglen regfull reruns)) ((or (not nth-try) (and (number? nth-try) (< nth-try 10))) (hash-table-set! test-registry hed (if (number? nth-try) (+ nth-try 1) @@ -1023,17 +1033,11 @@ 0)) (if (runs:lownoise (conc "not removing test " hed) 60) (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) - ;; (list hed tal reg reruns) - ;; (list (car newtal)(cdr newtal) reg reruns) - ;; (hash-table-set! test-registry hed 'removed) - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns)) + (runs:loop-values newtal reg reglen regfull reruns)) ((symbol? nth-try) (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW (if (null? tal) #f ;; yes, really (list (car tal)(cdr tal) reg reruns)) @@ -1040,14 +1044,11 @@ (begin (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60) (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry.")) (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f) (hash-table-set! test-registry hed 0) - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns)))) + (runs:loop-values newtal reg reglen regfull)))) (else (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60) (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) ;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met) (hash-table-set! test-registry hed 'removed) @@ -1057,17 +1058,14 @@ (list (if (null? tal)(car newtal)(car tal)) tal reg reruns))))) ;; can't drop this - maybe running? Just keep trying - (let ((runable-tests (runs:runable-tests prereqs-not-met))) + (let ((runable-tests (runs:runable-tests prereqs-not-met))) ;; SUSPICIOUS: Should look at more than just prereqs-not-met? (if (null? runable-tests) #f ;; I think we are truly done here - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns))))))))) + (runs:loop-values newtal reg reglen regfull reruns))))))))) ;; scan a list of tests looking to see if any are potentially runnable ;; (define (runs:runable-tests tests) (filter (lambda (t) @@ -1468,10 +1466,11 @@ (thread-sleep! 5) ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) ;; LET* ((test-record ;; we get here on "drop through". All done! + (runs:run-post-hook run-id) (debug:print-info 1 *default-log-port* "All tests launched"))) (define (runs:calc-fails prereqs-not-met) (filter (lambda (test) (and (vector? test) ;; not (string? test)) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -1,7 +1,7 @@ -;; Copyright 2006-2012, Matthew Welland. +;; 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 @@ -8,12 +8,12 @@ ;; 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 zmq) +(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)) @@ -20,12 +20,10 @@ (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 rpc-transport)) -;;(declare (uses nmsg-transport)) (declare (uses launch)) (declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") @@ -34,10 +32,16 @@ (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 ;;====================================================================== @@ -448,10 +452,23 @@ (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?)) ADDED show-uncalled-procedures.scm Index: show-uncalled-procedures.scm ================================================================== --- /dev/null +++ show-uncalled-procedures.scm @@ -0,0 +1,13 @@ +(include "codescanlib.scm") + +(define (show-danglers) + (let* ((all-scm-files (glob "*.scm")) + (xref (get-xref all-scm-files)) + (dangling-procs + (map car (filter (lambda (x) (equal? 1 (length x))) xref)))) + (for-each print dangling-procs) ;; our product. + )) + +(show-danglers) + + Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -621,13 +621,14 @@ 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) +(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))) + (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 @@ -637,41 +638,122 @@ (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")) - (contour (if (args:get-arg "-prepend-contour") (db:get-value-by-header row header "contour"))) + (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)) - - - + (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 + (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) + state status owner event-time comment fail-count pass-count area-id) new-run-id) (if (handle-exceptions exn - (begin (print-call-chain) #f) + (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) + 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-tests-data dbh cached-info test-ids) + +(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 @@ -688,22 +770,32 @@ (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)) - (pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path))) + (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-test-id ;; have a record + (if pgdb-run-id + (begin + (if pgdb-test-id ;; have a record (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path))) - (hash-table-set! test-ht test-id pgdb-test-id) (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)) - (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)) - )) + (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* (( @@ -713,11 +805,11 @@ (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)) + '(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)) @@ -724,16 +816,22 @@ (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-ids) " changed tests") - (tasks:sync-tests-data dbh cached-info test-ids))) + (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))))) Index: tcmt.scm ================================================================== --- tcmt.scm +++ tcmt.scm @@ -95,13 +95,13 @@ (begin (print "##teamcity[testStarted " tcname flowid tstmp "]") (testdat-start-printed-set! tdat #t))) (if (not endp) (begin - (if (member status '(PASS WARN SKIP WAIVED)) - (print "##teamcity[testFinished" tcname flowid comment details duration "]") + (if (not (member status '(PASS WARN SKIP WAIVED))) (print "##teamcity[testFailed " tcname flowid comment details "]")) + (print "##teamcity[testFinished" tcname flowid comment details duration "]") (testdat-end-printed-set! tdat #t)))) (else (if flush-mode (begin (if (not startp) @@ -109,10 +109,11 @@ (print "##teamcity[testStarted " tcname flowid tstmp "]") (testdat-start-printed-set! tdat #t))) (if (not endp) (begin (print "##teamcity[testFailed " tcname flowid comment details "]") + (print "##teamcity[testFinished" tcname flowid comment details duration "]") (testdat-end-printed-set! tdat #t))))))) ;; (print "ERROR: tc-type \"" (testdat-tc-type tdat) "\" not recognised for " tcname))) (flush-output))) ;; ;; returns values: flag newlst Index: testnanomsg/req-rep.scm ================================================================== --- testnanomsg/req-rep.scm +++ testnanomsg/req-rep.scm @@ -1,30 +1,33 @@ ;; watch nanomsg's pipeline load-balancer in action. (use nanomsg) +;; client (define req (nn-socket 'req)) -(define rep (nn-socket 'rep)) - -(nn-bind rep "inproc://test") -(nn-connect req "inproc://test") +(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) -(nn-close rep) +(nn-close req) ;; client +(nn-close rep) ;; server (exit) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -173,11 +173,11 @@ 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 + 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 %/% Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -47,11 +47,13 @@ waivercommentpatt ^WW\d+ [a-z].* incomplete-timeout 1 # wait 0.5 seconds between launching every process # -launch-delay 0.5 +# 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 Index: tests/fullrun/runconfigs.config ================================================================== --- tests/fullrun/runconfigs.config +++ tests/fullrun/runconfigs.config @@ -1,10 +1,10 @@ [default] SOMEVAR This should show up in SOMEVAR3 VARNOVAL VARNOVAL_WITHSPACE -QUICK % +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] ADDED trackback.scm Index: trackback.scm ================================================================== --- /dev/null +++ trackback.scm @@ -0,0 +1,36 @@ +(include "codescanlib.scm") + +;; show call paths for named procedure +(define (traceback-proc in-procname) + (letrec* ((all-scm-files (glob "*.scm")) + (xref (get-xref all-scm-files)) + (have (alist-ref (string->symbol in-procname) xref eq? #f)) + (lookup (lambda (path procname depth) + (let* ((upcone-temp (filter (lambda (x) + (eq? procname (car x))) + xref)) + (upcone-temp2 (cond + ((null? upcone-temp) '()) + (else (cdar upcone-temp)))) + (upcone (filter + (lambda (x) (not (eq? x procname))) + upcone-temp2)) + (uppath (cons procname path)) + (updepth (add1 depth))) + (if (null? upcone) + (print uppath) + (for-each (lambda (x) + (if (not (member procname path)) + (lookup uppath x updepth) )) + upcone)))))) + (if have + (lookup '() (string->symbol in-procname) 0) + (print "no such func - "in-procname)))) + + +(if (eq? 1 (length (command-line-arguments))) + (traceback-proc (car (command-line-arguments))) + (print "Usage: trackback ")) + +(exit 0) + Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -37,45 +37,45 @@ 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.11.0 -CHICKEN_BASEVER=4.11.0 +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.10 - IUPVER=3.17 - IMVER=3.11 + 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.10 - IUPVER=3.17 - IMVER=3.11 + 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.10 - IUPVER=3.17 - IMVER=3.11 + 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.10 - IUPVER=3.17 - IMVER=3.11 + 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 @@ -176,11 +176,11 @@ # 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 + 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 @@ -202,15 +202,28 @@ 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 +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 @@ -233,11 +246,11 @@ 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 + udp uuid uuid-lib zlib postgresql do echo "Installing $egg" $CHICKEN_INSTALL $PROX -keep-installed $egg #$CHICKEN_INSTALL $PROX $egg @@ -244,39 +257,21 @@ if [ $? -ne 0 ]; then echo "$egg failed to install" exit 1 fi done - if [[ -e `which mysql_config` ]]; then - $CHICKEN_INSTALL $PROX -keep-installed mysql-client + $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 -# # IUP versions -# if [[ x$USEOLDIUP == "x" ]];then -# CDVER=5.10 -# IUPVER=3.17 -# IMVER=3.11 -# else -# CDVER=5.10 -# IUPVER=3.17 -# IMVER=3.11 -# fi -# if [[ x$KTYPE == "x24g3" ]];then -# CDVER=5.4.1 -# IUPVER=3.5 -# IMVER=3.6.3 -# fi if [[ `uname -a | grep x86_64` == "" ]]; then export ARCHSIZE='' else export ARCHSIZE=64_ @@ -339,10 +334,12 @@ $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 @@ -366,11 +363,11 @@ 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 $IUPEGGVER +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 Index: utils/plot-code.scm ================================================================== --- utils/plot-code.scm +++ utils/plot-code.scm @@ -5,21 +5,31 @@ ;; dot -Tpdf plot.dot > plot.pdf ;; first param is comma separated list of files to include in the map, use - to do all ;; second param is list of regexs for functions to include in the map ;; third param is list of files to scan -(use regex srfi-69 srfi-13) +(use regex srfi-69 srfi-13 srfi-1 data-structures posix) + +;; 1 2 remainder +;; plot-code file1.scm,file2.scm... fn-regex file1.scm file2.scm ... + +(define targs #f) + +(define args (argv)) +(if (< (length args) 2) ;; no args provided + (begin + (print "Usage: plot-code file1.scm,file2.scm... 'your.*regex' file3.scm file4.scm file5.scm ...") + (exit))) -(define targs #f) -(define files (cdr (cddddr (argv)))) +(define files (cdddr args)) -(let ((targdat (cadddr (argv)))) +(let ((targdat (cadr args))) (if (equal? targdat "-") (set! targs files) (set! targs (string-split targdat ",")))) -(define function-patt (car (cdr (cdddr (argv))))) +(define function-patt (caddr args)) (define function-rx (regexp function-patt)) (define filedat-defns (make-hash-table)) (define filedat-usages (make-hash-table)) (define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*")) ADDED utils/whodunit.scm Index: utils/whodunit.scm ================================================================== --- /dev/null +++ utils/whodunit.scm @@ -0,0 +1,48 @@ +(use posix srfi-69) + +(define *numsamples* (or (and (> (length (argv)) 1) + (string->number (cadr (argv)))) + 3)) + +(define (topdata) + (with-input-from-pipe + (conc "top -b -n " *numsamples* " -d 0.1") + read-lines)) + +(define (cleanup-data topdat)list + (let loop ((hed (car topdat)) + (tal (cdr topdat)) + (res '())) + (let* ((line-list (string-split hed)) + (nums (map (lambda (indat)(or (string->number indat) indat)) line-list)) + (not-data (or (null? nums) + (not (number? (car nums))))) + (new-res (if not-data res (cons nums res)))) + (if (null? tal) + new-res + (loop (car tal)(cdr tal) new-res))))) + +(print "Getting " *numsamples* " samples of cpu usage data.") +(define data (cleanup-data (topdata))) +(define pidhash (make-hash-table)) +(define userhash (make-hash-table)) + +;; sum up and normalize the +(for-each + (lambda (indat) + (let ((pid (car indat)) + (usr (cadr indat)) + (cpu (list-ref indat 8))) + (hash-table-set! userhash usr (+ cpu (hash-table-ref/default userhash usr 0))))) + data) + +(for-each + (lambda (usr) + (print usr + (if (< (string-length usr) 8) "\t\t" "\t") + (inexact->exact (round (/ (hash-table-ref userhash usr) *numsamples*))))) + (sort (hash-table-keys userhash) + (lambda (a b) + (> (hash-table-ref userhash a) + (hash-table-ref userhash b))))) +