Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -23,10 +23,12 @@ get-var get-keys get-key-vals test-toplevel-num-items get-test-info-by-id + get-steps-info-by-id + get-data-info-by-id test-get-rundir-from-test-id get-count-tests-running-for-testname get-count-tests-running get-count-tests-running-in-jobgroup get-previous-test-run-record @@ -66,10 +68,11 @@ login tasks-get-last testmeta-get-record have-incompletes? synchash-get + get-changed-record-ids )) (define api:write-queries '( get-keys-write ;; dummy "write" query to force server start Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -193,10 +193,23 @@ 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) + ; (print "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) + (if (not (string? units)) + (set! units "" )) + (if (not (string? variable)) + (set! variable "" )) + (if (not (real? value)) + (set! value 0 )) + (if (not (real? expected)) + (set! expected 0 )) +(if (not (real? tol)) + (set! tol 0 )) + (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)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -801,16 +801,26 @@ (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) ;;(debug:print-info 13 *default-log-port* "got signal "signum) - (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly") + (debug:print-error 0 *default-log-port* "Received signal " signum " aaa exiting promptly") + ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway + (exit)) + +(define (special-signal-handler signum) + ;; (signal-mask! signum) + (set! *time-to-exit* #t) + ;;(debug:print-info 13 *default-log-port* "got signal "signum) + (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting!!") ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) + (set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) + ;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! ;;====================================================================== ;; M I S C U T I L S ;;====================================================================== Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -214,11 +214,12 @@ multiple sheets) -o : output file for refdb2dat (defaults to stdout) -archive cmd : archive runs specified by selectors to one of disks specified in the [archive-disks] section. cmd: keep-html, restore, save, save-remove - -generate-html : create a simple html tree for browsing your runs + -generate-html : create a simple html dashboard for browsing your runs + -generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory. -list-run-time : list time requered to complete runs. It supports following switches -run-patt -target-patt -dumpmode -list-test-time : list time requered to complete each test in a run. It following following arguments -runname -target -dumpmode @@ -374,11 +375,12 @@ "-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" + "-generate-html" + "-generate-html-structure" "-list-run-time" "-list-test-time" ;; misc queries "-list-disks" "-list-targets" @@ -2255,11 +2257,17 @@ (let* ((toppath (launch:setup))) (if (tests:create-html-tree #f) (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page#.html") (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) (set! *didsomething* #t))) - +(if (args:get-arg "-generate-html-structure") + (let* ((toppath (launch:setup))) + ;(if (tests:create-html-tree #f) + (if (tests:create-html-summary #f) + (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html") + (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) + (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if (not *didsomething*) Index: mt-pg.sql ================================================================== --- mt-pg.sql +++ mt-pg.sql @@ -1,11 +1,11 @@ -- CREATE TABLE IF NOT EXISTS keys ( -- id SERIAL PRIMARY KEY, -- fieldname TEXT, -- fieldtype TEXT, -- CONSTRAINT keyconstraint UNIQUE (fieldname)); - +DROP VIEW IF EXISTS area_tag_view; DROP TABLE IF EXISTS areas; DROP TABLE IF EXISTS ttype; DROP TABLE IF EXISTS runs; DROP TABLE IF EXISTS run_stats; DROP TABLE IF EXISTS test_meta; @@ -25,10 +25,14 @@ DROP TABLE IF EXISTS sessions; DROP TABLE IF EXISTS tags; DROP TABLE IF EXISTS users; DROP TABLE IF EXISTS webviews; DROP TABLE IF EXISTS area_tags; + +DROP TABLE IF EXISTS users_webviews; + + CREATE TABLE IF NOT EXISTS session_vars ( id SERIAL PRIMARY KEY, session_id INTEGER, page TEXT, @@ -56,10 +60,14 @@ id SERIAL PRIMARY KEY, tag_id INTEGER DEFAULT 0, area_id INTEGER DEFAULT 0, CONSTRAINT areatagconstraint UNIQUE (tag_id, area_id)); +CREATE VIEW area_tag_view as +select a.id as aid, t.id as tid,area_name,tag_name from areas as a inner join area_tags as at on at.area_id = a.id +inner join tags as t on t.id = at.tag_id ; + INSERT INTO areas (id,area_name,area_path) VALUES (0,'local','.'); CREATE TABLE IF NOT EXISTS ttype ( id SERIAL PRIMARY KEY, target_spec TEXT DEFAULT ''); @@ -225,13 +233,14 @@ du INTEGER, archive_path TEXT); CREATE TABLE IF NOT EXISTS users( id SERIAL PRIMARY KEY , - usename TEXT NOT NULL, + username TEXT NOT NULL, fullname TEXT NOT NULL, email TEXT NOT NULL, + default_view TEXT default '', deleted INTEGER default 0 ); CREATE TABLE IF NOT EXISTS webviews( id SERIAL PRIMARY KEY , @@ -239,11 +248,23 @@ name TEXT NOT NULL, ttype_id INTEGER DEFAULT 0, view_specifics TEXT , col TEXT NOT NULL, row TEXT NOT NULL, + public INTEGER DEFAULT 0, deleted INTEGER default 0 ); + + + +CREATE TABLE IF NOT EXISTS users_webviews( + id SERIAL PRIMARY KEY , + user_id INTEGER NOT NULL, + webview_id INTEGER NOT NULL, + deleted INTEGER default 0, + searchpattern TEXT Default '' +); + -- 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 @@ -1226,11 +1226,14 @@ (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))) + (set-signal-handler! signal/int special-signal-handler) + (set-signal-handler! signal/term special-signal-handler) + + (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"))))))) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -849,16 +849,26 @@ (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 test id: " pgdb-test-id) + (print "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-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 test id: " pgdb-test-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)))) + (if (handle-exceptions + exn + (begin (print-call-chain) + (print ((condition-property-accessor 'exn 'message) exn)) + #f) + + (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )) + ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info) + (begin + ;(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))) + (exit)))) (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 Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -937,10 +937,177 @@ link))) (html-body (tests:dashboard-body pg pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #t))) ;(print (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name)) html-body)) +(define (tests:create-html-summary outf) + (let* ((lockfile (conc outf ".lock")) + (linktree (common:get-linktree)) + (keys (rmt:get-keys)) + (area-name (common:get-testsuite-name))) + (if (common:simple-file-lock lockfile) + (begin + (let* ((runsdat (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys))) + (runs (vector-ref runsdat 1)) + (header (vector-ref runsdat 0)) + (oup (open-output-file (or outf (conc linktree "/targets.html")))) + (target-hash (test:create-target-hash runs header (length keys)))) + (test:create-target-html target-hash oup area-name linktree) + (test:create-run-html runs area-name linktree (length keys) header)) + (common:simple-file-release-lock lockfile)) + #f))) + +(define (test:get-test-hash test-data) + (let ((resh (make-hash-table))) + (map (lambda (test) + (let* ((test-name (vector-ref test 2)) + (test-html-path (if (file-exists? (conc (vector-ref test 10) "/test-summary.html")) + (conc (vector-ref test 10) "/test-summary.html" ) + (conc (vector-ref test 10) "/" (vector-ref test 13)))) + (test-item (vector-ref test 11)) + (test-status (vector-ref test 4))) + (if (not (hash-table-ref/default resh test-item #f)) + (hash-table-set! resh test-item (make-hash-table))) + (hash-table-set! (hash-table-ref/default resh test-item #f) test-name (list test-status test-html-path)))) + test-data) +resh)) + +(define (test:get-data->b-keys ordered-data a-keys) + (delete-duplicates + (sort (apply + append + (map (lambda (sub-key) + (let ((subdat (hash-table-ref ordered-data sub-key))) + (hash-table-keys subdat))) + a-keys)) + string>=?))) + + +(define (test:create-run-html runs area-name linktree numkeys header) + (map (lambda (run) + (let* ((target (string-join (take (vector->list run) numkeys) "/")) + (run-name (db:get-value-by-header run header "runname")) + (oup (open-output-file (conc linktree "/" target "/" run-name "/run.html"))) + (run-id (db:get-value-by-header run header "id")) + (test-data (rmt:get-tests-for-run + run-id + "%" ;; testnamepatt + '() ;; states + '() ;; statuses + #f ;; offset + #f ;; num-to-get + #f ;; hide/not-hide + #f ;; sort-by + #f ;; sort-order + #f ;; 'shortlist ;; qrytype + 0 ;; last update + #f)) + (item-test-hash (test:get-test-hash test-data)) + (items (hash-table-keys item-test-hash)) + (test-names (test:get-data->b-keys item-test-hash items))) + (s:output-new + oup + (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f) + + (s:title "Runs View " run-name) + (s:body + (s:h1 "Runs View " ) + (s:h2 "Target" target) + (s:h2 "Run name" run-name) + (s:table 'border 1 + (s:tr + (s:td "Items") + (map (lambda (test) + (s:td test)) + test-names)) + (map (lambda (item) + (let* ((test-hash (hash-table-ref/default item-test-hash item #f))) + (if test-hash + (begin + (s:tr + (s:td item) + (map (lambda (test) + (let* ((test-details (hash-table-ref/default test-hash test #f)) + (status (if test-details + (car test-details))) + (link (if test-details + (cadr test-details)))) + (if test-details + (s:td 'class status + (s:a 'href link status )) + (s:td "")))) + test-names)))))) + (sort items string<=?)))))) + (close-output-port oup))) +runs)) + +(define (test:create-target-hash runs header numkeys) + (let ((resh (make-hash-table))) + (for-each + (lambda (run) + (let* ((run-name (db:get-value-by-header run header "runname")) + (target (string-join (take (vector->list run) numkeys) "/")) + (run-list (hash-table-ref/default resh target #f))) + + (if (not run-list) + (hash-table-set! resh target (list run-name)) + (hash-table-set! resh target (cons run-name run-list))))) + runs) + resh)) + +(define (test:get-max-run-cnt target-hash targets) + (let* ((cnt 0 )) + (map (lambda (target) + (let* ((runs (hash-table-ref/default target-hash target #f)) + (run-length (if runs + (length runs) + 0))) + + (if (< cnt run-length) + (set! cnt run-length)))) + targets) +cnt)) + +(define (test:pad-runs target-hash targets max-row-length) + (map (lambda (target) + (let loop ((run-list (hash-table-ref/default target-hash target #f))) + (if (< (length run-list) max-row-length) + (begin + (hash-table-set! target-hash target (cons "" run-list)) + (loop (hash-table-ref/default target-hash target #f) ))))) + targets) + target-hash) + +(define (test:create-target-html target-hash oup area-name linktree) + (let* ((targets (hash-table-keys target-hash)) + (max-row-length (test:get-max-run-cnt target-hash targets)) + (pad-runs-hash (test:pad-runs target-hash targets max-row-length))) + (s:output-new + oup + (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f) + + (s:title "Target View " area-name) + (s:body + (s:h1 "Target View " area-name) + (s:table 'id "LinkedList1" 'border "1" + (s:tr 'class "something" + (s:td "Target") + (s:td 'colspan max-row-length "Runs")) + (let* ((tbl (map (lambda (target) + (s:tr + (s:td target) + (let* ((runs (hash-table-ref/default target-hash target #f)) + (rest-row (map (lambda (run) + (if (equal? run "") + (s:td run) + (s:td + (s:a 'href (conc linktree "/" target "/" run "/run.html") run)))) + (reverse runs)))) + rest-row))) + targets))) + tbl))))) + (close-output-port oup))) (define (tests:create-html-tree-old outf) (let* ((lockfile (conc outf ".lock")) (runs-to-process '()))