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 @@ -6,14 +6,14 @@ INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ - http-transport.scm filedb.scm \ + http-transport.scm filedb.scm tdb.scm \ client.scm daemon.scm mt.scm \ ezsteps.scm lock-queue.scm sdb.scm \ - rmt.scm api.scm tdb.scm rpc-transport.scm \ + rmt.scm api.scm \ portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -154,11 +154,26 @@ ;; SERVERS ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) ;; TESTS - ((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) + + ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) + ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. + ((test-set-state-status-by-id) + + ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) + (db:set-state-status-and-roll-up-items + dbstruct + (list-ref params 0) ; run-id + (list-ref params 1) ; test-name + #f ; item-path + (list-ref params 2) ; state + (list-ref params 3) ; status + (list-ref params 4) ; comment + )) + ((delete-test-records) (apply db:delete-test-records dbstruct params)) ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items 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 @@ -198,24 +198,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 +296,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 +380,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 +503,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)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -8,14 +8,12 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack - matchable) -(require-extension regex posix) - -(require-extension (srfi 18) extras tcp rpc) + matchable regex posix srfi-18 extras + pkts (prefix dbi dbi:)) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit common)) @@ -246,21 +244,22 @@ (substring (conc (common:get-last-run-version)) 0 4)))) ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma ;; -(define (common:cleanup-db dbstruct) - (db:multi-db-sync +(define (common:cleanup-db dbstruct #!key (full #f)) + (apply db:multi-db-sync dbstruct 'schema ;; 'new2old 'killservers - 'dejunk 'adj-target ;; 'old2new 'new2old - ) + (if full + '(dejunk) + '())) (if (common:api-changed?) (common:set-last-run-version))) ;; Rotate logs, logic: ;; if > 500k and older than 1 week: @@ -336,14 +335,14 @@ (read-only (debug:print 0 *default-log-port* " You have read-only access to this area. Cannot proceed with megatest version migration.") (exit 1)) (else (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"") - (exit 1))))) - (begin - (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.") - (exit 1)))) + (exit 1))))))) +;; (begin +;; (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.") +;; (exit 1)))) ;;====================================================================== ;; S P A R S E A R R A Y S ;;====================================================================== @@ -975,13 +974,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) '())) @@ -1480,31 +1483,36 @@ (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)) (let* ((loadavg (common:get-cpu-load remote-host)) (first (car loadavg)) (next (cadr loadavg)) (adjload (* maxload numcpus)) (loadjmp (- first next))) (cond ((and (> first adjload) (> count 0)) - (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload (if msg msg "")) + (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload " " (if msg msg "")) (thread-sleep! waitdelay) (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) ((and (> loadjmp numcpus) (> count 0)) (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg "")) (thread-sleep! waitdelay) (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))))) +(define (common:wait-for-homehost-load maxload msg) + (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. + #f + (common:get-homehost))) + (hh (if hh-dat (car hh-dat) #f)) + (numcpus (common:get-num-cpus hh))) + (common:wait-for-normalized-load maxload msg: msg remote-host: hh))) + (define (common:get-num-cpus remote-host) (let ((proc (lambda () (let loop ((numcpu 0) (inl (read-line))) (if (eof-object? inl) @@ -1521,11 +1529,11 @@ ;; wait for normalized cpu load to drop below maxload ;; (define (common:wait-for-normalized-load maxload #!key (msg #f)(remote-host #f)) (let ((num-cpus (common:get-num-cpus remote-host))) - (common:wait-for-cpuload maxload num-cpus 15 msg: msg))) + (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host))) (define (get-uname . params) (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) (if (null? (car uname-res)) @@ -2101,93 +2109,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 ;;====================================================================== ;; @@ -2258,6 +2254,107 @@ (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 + + 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: 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 Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1,10 +1,10 @@ - + The Megatest Users Manual