Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -10,11 +10,11 @@ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm filedb.scm \ client.scm synchash.scm daemon.scm mt.scm \ ezsteps.scm lock-queue.scm sdb.scm \ rmt.scm api.scm tdb.scm rpc-transport.scm \ - portlogger.scm archive.scm env.scm + portlogger.scm archive.scm env.scm diff-report.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 \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -821,11 +821,11 @@ (or (args:get-arg "-status")(args:get-arg ":status"))) (define (common:args-get-testpatt rconf) (let* ((tagexpr (args:get-arg "-tagexpr")) (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f)) - (testpatt-key (if (args:get-arg "-mode") (args:get-arg "-mode") "TESTPATT")) + (testpatt-key (if (args:get-arg "--modepatt") (args:get-arg "--modepatt") "TESTPATT")) (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f))) (cond (tags-testpatt (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -517,16 +517,12 @@ ;; NOTE: Yes, this is used ;; (define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) (let* ((start-time (current-seconds)) (access-mode (dboard:tabdat-access-mode tabdat)) - (num-to-get (let ((num-tests-from-config (configf:lookup *configdat* "setup" "num-tests-to-get"))) - (if num-tests-from-config - (begin - (BB> "override num-tests 100 -> "num-tests-from-config) - (string->number num-tests-from-config)) - 100))) + (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))) (do-not-use-db-file-timestamps #f) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab (do-not-use-query-timestamps #f) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab (sort-info (get-curr-sort)) @@ -587,11 +583,11 @@ ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset ;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the ;; data has been read ;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above ;; - (debug:print 0 *default-log-port* "got-all: " got-all " multi-get: " multi-get " num-to-get: " num-to-get " (length tmptests): " (length tmptests) " db-modified: " db-modified " db-mod-time: " db-mod-time " db-path: " db-path) + ;; (debug:print 0 *default-log-port* "got-all: " got-all " multi-get: " multi-get " num-to-get: " num-to-get " (length tmptests): " (length tmptests) " db-modified: " db-modified " db-mod-time: " db-mod-time " db-path: " db-path) (if got-all (begin (dboard:rundat-last-update-set! run-dat (- start-time 2)) (dboard:rundat-run-data-offset-set! run-dat 0)) (begin @@ -2714,11 +2710,11 @@ (define (dashboard:get-youngest-run-db-mod-time dbdir) (handle-exceptions exn (begin - (debug:print 0 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir) (current-seconds)) ;; something went wrong - just print an error and return current-seconds (common:max (map (lambda (filen) (file-modification-time filen)) (glob (conc dbdir "/*.db*")))))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -142,11 +142,11 @@ dbstruct)) (use-mutex (> *api-process-request-count* 25))) (if (and use-mutex (common:low-noise-print 120 "over-50-parallel-api-requests")) (debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access")) - (if (common:low-noise-print 120 (conc "parallel-api-requests" *max-api-process-requests*)) + (if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*)) (debug:print-info 0 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*)) (handle-exceptions exn (begin (print-call-chain (current-error-port)) Index: diff-report.scm ================================================================== --- diff-report.scm +++ diff-report.scm @@ -1,22 +1,11 @@ -;; #!/bin/bash - -;; #;; rmt:get-tests-for-run - - -;; #;; (let* ((dbstruct (db:get-db - - -;; #;; (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) - -;; #;; (rmt:get-test-info-by-id run-id test-id) -;; #;; (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) - -;; megatest -repl << EOF - -;; TODO:dashboard not on homehost message exit - + +(declare (unit diff-report)) +(declare (uses common)) +(declare (uses rmt)) + +(include "common_records.scm") (use matchable) (use fmt) (use ducttape-lib) (define css "") @@ -134,10 +123,27 @@ run-name (let* ((qry-res (rmt:get-runs run-name 1 0 '()))) (if (eq? 2 (vector-length qry-res)) (vector-ref (car (vector-ref qry-res 1)) 1) #f)))) + +(define (diff:target+run-name->run-id target run-name) + (let* ((keys (rmt:get-keys)) + (target-parts (if target (string-split target "/") (map (lambda (x) "%") keys)))) + (if (not (eq? (length keys) (length keys))) + (begin + (print "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys) + #f) + (let* ((target-map (zip keys target-parts)) + (qry-res (rmt:get-runs run-name 1 0 target-map))) + + (if (eq? 2 (vector-length qry-res)) + (let ((first-ent (vector-ref qry-res 1))) + (if (> (length first-ent) 0) + (vector-ref (car first-ent) 1) + #f)) + #f))))) (define (diff:run-id->tests-mindat run-id #!key (testpatt "%/%")) (let* ((states '()) (statuses '()) (offset #f) @@ -201,10 +207,14 @@ (lambda (state) (list state (length (diff:rundiff-find-by-state run-diff state)))) diff-states))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Presentation code below, business logic above ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define (diff:stml->string in-stml) (with-output-to-string (lambda () (s:output-new (current-output-port) @@ -260,20 +270,26 @@ (zip (vector-ref runinfo 0) (vector->list (vector-ref runinfo 1)))))) (run-name (hash-table-ref/default info-hash "runname" "N/A")) (start-time (hash-table-ref/default info-hash "event_time" 0))) (list target run-name start-time))) -(define (diff:run-diff->diff-report src-run-id dest-run-id run-diff) +(define (diff:deliver-diff-report src-run-id dest-run-id + #!key + (html-output-file #f) + (email-subject-prefix "[MEGATEST DIFF]") + (email-recipients-list '()) ) (let* ((src-info (diff:run-id->target+run-name+starttime src-run-id)) (src-target (car src-info)) (src-run-name (cadr src-info)) (src-start (conc (seconds->string (caddr src-info)) " " (local-timezone-abbreviation))) (dest-info (diff:run-id->target+run-name+starttime dest-run-id)) (dest-target (car dest-info)) (dest-run-name (cadr dest-info)) (dest-start (conc (seconds->string (caddr dest-info)) " " (local-timezone-abbreviation))) - + + + (run-diff (diff:diff-runs src-run-id dest-run-id )) (test-count (length run-diff)) (summary-table (apply s:table 'cellspacing "0" 'border "1" (s:tr (s:th "Diff type") @@ -328,12 +344,13 @@ (filter (lambda (run-diff-item) (match run-diff-item ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status))) (not (equal? diff-state "CLEAN"))) (else #f))) - run-diff))))) - (diff:stml->string (s:body + run-diff)))) + (email-subject (conc email-subject-prefix " " src-target "/" src-run-name" vs. "dest-target"/"dest-run-name)) + (html-body (diff:stml->string (s:body (diff:megatest-html-diff-logo) (s:h2 "Summary") (s:table 'border "0" (s:tr (s:td "Diff calculated at") @@ -342,29 +359,50 @@ (s:td "MT_RUN_AREA_HOME" ) (s:td *toppath*)) (s:tr 'valign "TOP" (s:td summary-table) (s:td meta-table))) (s:h2 "Diffs + consistently failing tests") - main-table)))) - - -(let* ((src-run-name "all57") - (dest-run-name "all60") - (src-run-id (diff:run-name->run-id src-run-name)) - (dest-run-id (diff:run-name->run-id dest-run-name)) - (to "bjbarcla") - (subj (conc "[MEGATEST DIFF] "src-run-name" vs. "dest-run-name)) - (run-diff - (diff:diff-runs src-run-id dest-run-id )) - (diff-summary - (diff:summarize-run-diff run-diff)) - (email-body - (diff:run-diff->diff-report src-run-id dest-run-id run-diff))) - ;;(pretty-print run-diff) - ;;(pretty-print diff-summary) - ;;(with-output-to-file "/tmp/bjbarcla/foo.html" (lambda () (print email-body))) - (sendmail to subj email-body use_html: #t) - - ;;(print html-report) - ) - - + main-table))) + + ) + (if html-output-file + (with-output-to-file html-output-file (lambda () (print html-body)))) + (when (and email-recipients-list (> (length email-recipients-list) 0)) + (sendmail (string-join email-recipients-list ",") email-subject html-body use_html: #t)) + html-body)) + + + + + +;; (let* ((src-run-name "all57") +;; (dest-run-name "all60") +;; (src-run-id (diff:run-name->run-id src-run-name)) +;; (dest-run-id (diff:run-name->run-id dest-run-name)) +;; (to-list (list "bjbarcla"))) +;; (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: "/tmp/bjbarcla/zippy.html") +;; ) + +(define (do-diff-report src-target src-runname dest-target dest-runname html-file to-list-raw) + (let* (;;(src-target "nope%") + ;;(src-runname "all57") + ;;(dest-target "%") + ;;(dest-runname "all60") + (src-run-id (diff:target+run-name->run-id src-target src-runname)) + (dest-run-id (diff:target+run-name->run-id dest-target dest-runname)) + ;(html-file "/tmp/bjbarcla/zippy.html") + (to-list (if (string? to-list-raw) (string-split to-list-raw ",:") #f)) + ) + + (cond + ((not src-run-id) + (print "No match for source target/runname="src-target"/"src-runname) + (print "Cannot proceed.") + #f) + ((not dest-run-id) + (print "No match for source target/runname="dest-target"/"dest-runname) + (print "Cannot proceed.") + #f) + (else + (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: html-file))))) + + Index: ducttape/ducttape-lib.scm ================================================================== --- ducttape/ducttape-lib.scm +++ ducttape/ducttape-lib.scm @@ -495,11 +495,13 @@ (from_addr "admin") cc_addr bcc_addr more-headers use_html - (attach-files-list '())) + (attach-files-list '()) + (images-with-content-id-alist '()) + ) (define (sendmail-proc sendmail-port) (define (wl line-str) (write-line line-str sendmail-port)) @@ -531,10 +533,11 @@ (wl "") (boundary) (wl (conc "Content-Type: multipart/alternative; boundary=\"" mailpart-body-uuid "\"")) (wl "") ) + (define (email-text-body) (body-boundary) (wl "Content-Type: text/plain; charset=ISO-8859-1") (wl "Content-Disposition: inline") @@ -551,12 +554,12 @@ (wl "Content-Type: text/html; charset=ISO-8859-1") (wl "Content-Disposition: inline") (wl "") (wl body) (body-boundary)) - - (define (attach-file file) + + (define (attach-file file #!key (content-id #f)) (let* ((filename (filepath:take-file-name file)) (ext-with-dot (filepath:take-extension file)) (ext (string-take-right @@ -565,24 +568,32 @@ (mimetype (ext->mimetype ext)) (uuencode-command (conc "uuencode " file " " filename))) (boundary) (wl (conc "Content-Type: " mimetype "; name=\"" filename "\"")) (wl "Content-Transfer-Encoding: uuencode") + (if content-id + (wl (conc "Content-Id: " content-id))) (wl (conc "Content-Disposition: attachment; filename=\"" filename "\"")) (wl "") (do-or-die uuencode-command foreach-stdout: (lambda (line) (wl line))))) + + (define (embed-image file+content-id) + (let ((file (car file+content-id)) + (content-id (cdr file+content-id))) + (attach-file file content-id: content-id))) ;; send the email (email-mime-header) (if use_html (email-html-body) (email-text-body)) (for-each attach-file attach-files-list) + (for-each embed-image images-with-content-id-alist) (boundary) (close-output-port sendmail-port))) (do-or-die "/usr/sbin/sendmail -t" stdin-proc: sendmail-proc)) Index: ducttape/test_ducttape.scm ================================================================== --- ducttape/test_ducttape.scm +++ ducttape/test_ducttape.scm @@ -112,10 +112,12 @@ (test-assert "mktemp: temp file created" (file-exists? tmpfile)) (if (file-exists? tmpfile) (delete-file tmpfile)) ))) + + (define (test-systemstuff) (test-group "system commands" @@ -335,11 +337,19 @@ (test-misc) (test-wwdate) ) ; end main() (main) -(sendmail "brandon.j.barclay@intel.com" "6hello subject" "test body") +(sendmail "brandon.j.barclay@intel.com" "6hello subject" "test body" ) + +(let* ((image-file "/nfs/site/home/bjbarcla/megatest-logo.png") + (cid "mtlogo") + (image-alist (list (cons image-file cid))) + (body (conc "Hello world
\"test
bye!"))) + + (sendmail "brandon.j.barclay@intel.com" "7hello subject" body use_html: #t images-with-content-id-alist: image-alist) + (print "sent image mail")) ;(sendmail "bjbarcla" "2hello subject html" "test body

hello

italics" use_html: #t) ;(sendmail "bb" "4hello attach subject html" "

hmm

" use_html: #t attach-files-list: '( "/Users/bb/Downloads/wdmycloud-manual-4779-705103.pdf" ) ) ;(launch-repl) (test-exit) 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.6304) +(define megatest-version 1.6305) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -43,10 +43,11 @@ (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. (declare (uses env)) +(declare (uses diff-report)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") @@ -67,10 +68,11 @@ version " megatest-version " license GPL, Copyright Matt Welland 2006-2015 Usage: megatest [options] -h : this help + -manual : show the Megatest user manual -version : print megatest version (currently " megatest-version ") Launching and managing runs -runall : run all tests or as specified by -testpatt -remove-runs : remove the data for a run, requires -runname and -testpatt @@ -93,11 +95,11 @@ -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig -testpatt patt1/patt2,patt3/... : % is wildcard -runname : required, name for this particular test run -state : Applies to runs, tests or steps depending on context -status : Applies to runs, tests or steps depending on context - -mode key : load testpatt from in runconfigs instead of default TESTPATT + --modepatt key : load testpatt from in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified -tagexpr tag1,tag2%,.. : select tests with tags matching expression Test helpers (for use inside tests) -step stepname -test-status : set the state and status of a test (use :state and :status) @@ -174,10 +176,18 @@ -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 +Diff report + -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname + and either -diff-email or -diff-html) + -src-target + -src-runname + -diff-email : comma separated list of email addresses to send diff report + -diff-html : path to html file to generate + Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database -pathmod path : insert path, i.e. path/runame/itempath/logfile.html will clear the field if no rundir/testname/itempath/logfile if it contains forward slashes the path will be converted @@ -212,11 +222,11 @@ "-state" ":status" "-status" "-list-runs" "-testpatt" - "-mode" + "--modepatt" "-tagexpr" "-itempatt" "-setlog" "-set-toplog" "-runstep" @@ -266,10 +276,15 @@ "-fields" "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state "-sort" "-target-db" "-source-db" + + "-src-target" + "-src-runname" + "-diff-email" + "-diff-html" ) (list "-h" "-help" "--help" "-manual" "-version" "-force" @@ -325,11 +340,13 @@ "-sync-to-megatest.db" "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only - ) + + "-diff-rep" + ) args:arg-hash 0)) ;; Add args that use remargs here ;; @@ -1867,10 +1884,30 @@ ;;====================================================================== ;; fakeout readline (include "readline-fix.scm") + +(when (args:get-arg "-diff-rep") + (when (and + (not (args:get-arg "-diff-html")) + (not (args:get-arg "-diff-email"))) + (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep") + (set! *didsomething* 1) + (exit 1)) + + (let* ((toppath (launch:setup))) + (do-diff-report + (args:get-arg "-src-target") + (args:get-arg "-src-runname") + (args:get-arg "-target") + (args:get-arg "-runname") + (args:get-arg "-diff-html") + (args:get-arg "-diff-email")) + (set! *didsomething* #t) + (exit 0))) + (if (or (getenv "MT_RUNSCRIPT") (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup)) (dbstruct (if (and toppath Index: utils/mk_wrapper ================================================================== --- utils/mk_wrapper +++ utils/mk_wrapper @@ -27,10 +27,22 @@ # echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target echo "#!/bin/bash" > $target if [[ $cmd =~ dboard ]]; then cat >> $target <<'EOF' + +# disable if not running on homehost +if [[ -e .homehost ]]; then + homehostname=$( host `cat .homehost` | awk '{print $NF}' | sed 's/\.$//' ) + hostname=$( hostname -f ) + + if [[ ! ($homehostname == $hostname) ]]; then + echo "ERROR: this host ($hostname) is not the homehost ($homehostname) for this megatest run area. Cannot start dashboard." + echo " Please log into homehost before launching dashboard." + exit 1 + fi +fi # check that $DISPLAY is set if [[ -z $DISPLAY ]]; then echo 'ERROR: $DISPLAY environment variable is not set; megatest dashboard requires X display address to be set in $DISPLAY.' exit 1