Megatest

;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(use srfi-1 data-structures posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack
     matchable pkts (prefix dbi dbi:)
     regex)

(import (prefix sqlite3 sqlite3:))
(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:)
(import (prefix base64 base64:))
     pkts)

(declare (unit common))

(include "common_records.scm")

;; (require-library margs)
;; (include "margs.scm")

(define (common:args-get-status)
  (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 "--modepatt") (args:get-arg "--modepatt") "TESTPATT"))
         (testpatt-key  (or (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
     ((args:get-arg "--modepatt") ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
      (if rconf
	  (runconfigs-get rconf testpatt-key)
	  #f))     ;; We do NOT fall back to "%"

				    fallback-launcher
				    (loop (car tal)(cdr tal)))))))
		      ;; no match, try again
		      (if (null? tal)
			  fallback-launcher
			  (loop (car tal)(cdr tal))))))))
	fallback-launcher)))
  

;;======================================================================
;; NMSG AND NEW API
;;======================================================================

;; nm based server experiment, keep around for now.
;;
(define (nm: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 (save for second round of development)
    ;;
    (thread-start! (make-thread! (lambda ()(queue-processor 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)))
  


;;======================================================================
;; D A S H B O A R D   U S E R   V I E W S
;;======================================================================

;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists
;;
(define (common:load-views-config)
  (let* ((view-cfgdat    (make-hash-table))
	 (home-cfgfile   (conc (get-environment-variable "HOME") "/.mtviews.config"))
	 (mthome-cfgfile (conc *toppath* "/.mtviews.config")))
    (if (common:file-exists? mthome-cfgfile)
	(read-config mthome-cfgfile view-cfgdat #t))
    ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas
    (if (common:file-exists? home-cfgfile)
	(read-config home-cfgfile view-cfgdat #t))
    view-cfgdat))

;;======================================================================
;; H I E R A R C H I C A L   H A S H   T A B L E S
;;======================================================================

;; Every element including top element is a vector:
;;   <vector subhash value>

(define (hh:make-hh #!key (ht #f)(value #f))
  (vector (or ht    (make-hash-table)) value))

;; used internally
(define-inline (hh:set-ht! hh ht)       (vector-set! hh 0 ht))
(define-inline (hh:get-ht hh)           (vector-ref  hh 0))
(define-inline (hh:set-value! hh value) (vector-set! hh 1 value))
(define-inline (hh:get-value  hh value) (vector-ref  hh 1))

;; given a hierarchial hash and some keys look up the value ...
;;
(define (hh:get hh . keys)
  (if (null? keys)
      (vector-ref hh 1) ;; we have reached the end of the line, return the value sought
      (let ((sub-ht (hh:get-ht hh)))
	(if sub-ht ;; yes, there is more hierarchy
	    (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f)))
	      (if sub-hh
		  (apply hh:get sub-hh (cdr keys))
		  #f))
	    #f))))

;; given a hierarchial hash, a value and some keys, add needed hierarcy and insert the value
;;
(define (hh:set! hh value . keys)
  (if (null? keys)
      (hh:set-value! hh value) ;; we have reached the end of the line, store the value
      (let ((sub-ht (hh:get-ht hh)))
	(if sub-ht ;; yes, there is more hierarchy
	    (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f)))
	      (if (not sub-hh) ;; we'll need to add the next level of hierarchy
		  (let ((new-sub-hh (hh:make-hh)))
		    (hash-table-set! sub-ht (car keys) new-sub-hh)
		    (apply hh:set! new-sub-hh value (cdr keys)))
		  (apply hh:set! sub-hh value (cdr keys))))    ;; call the sub-hierhash with remaining keys
	    (begin
	      (hh:set-ht! hh (make-hash-table))
	      (apply hh:set! hh value keys))))))
  
;; Manage pkts, used in servers, tests and likely other contexts so put
;; in common
;;======================================================================

(define common:pkts-spec
  '((default . ((parent    . P)
                (action    . a)

<div class="imageblock">
<div class="content">
<img src="complex-itemmap.png" alt="complex-itemmap.png">
</div>
</div>
<div class="paragraph"><p>We accomplish this by configuring the testconfigs of our tests C D and E as follows:</p></div>
<div class="listingblock">
<div class="title">Testconfig for Test C</div>
<div class="title">Testconfig for Test E has</div>
<div class="content monospaced">
<pre>[requirements]
waiton A B
waiton C

[itemmap]
itemmap (\d+)/res \1/bb</pre>
A (\d+)/aa aa/\1
B (\d+)/bb</pre>
</div></div>
<div class="listingblock">
<div class="title">Testconfig for Test D</div>
<div class="title">Testconfig for Test D has</div>
<div class="content monospaced">
<pre>[requirements]
waiton C
itemmap (\d+)/res \1/aa</pre>
</div></div>
<div class="listingblock">
<div class="title">Testconfig for Test E</div>
<div class="title">Testconfig for Test C has</div>
<div class="content monospaced">
<pre>[requirements]
waiton C
itemmap (\d+)/res \1/bb</pre>
waiton A B

[itemmap]
A (\d+)/aa aa/\1
B (\d+)/bb bb/\1</pre>
</div></div>
<div class="paragraph"><p>Example from image just above, we want the following to occur:</p></div>
<div class="olist arabic"><ol class="arabic">
<div class="listingblock">
<div class="title">Testconfigs for Test B and Test A have no waiton or itemmap configured</div>
<div class="content monospaced">
<pre></pre>
</div></div>
<div class="olist arabic"><div class="title">Walk through one item&#8201;&#8212;&#8201;we want the following to happen for testpatt <span class="monospaced">D/1/res</span> (see blue boxes in complex itemmaping figure above):</div><ol class="arabic">
<li>
<p>
We want the above to execute when we request pattern <span class="monospaced">D/1/res</span>, eg from command line <span class="monospaced">megatest -run -testpatt D/1/res -target &#8230; -runname &#8230;</span>
eg from command line <span class="monospaced">megatest -run -testpatt D/1/res -target mytarget -runname myrunname</span>
</p>
</li>
<li>
<p>
Full list to be run is now: <span class="monospaced">D/1/res</span>
</p>
</li>
<li>
<p>
Test D has a waiton - test C.  Test D&#8217;s itemmap rule <span class="monospaced">itemmap (\d&plus;)/res \1/aa</span> &#8594;  causes <span class="monospaced">C/1/aa</span> to run before <span class="monospaced">D/1/res</span>
</p>
</li>
<li>
<p>
Full list to be run is now: <span class="monospaced">D/1/res</span>, <span class="monospaced">C/1/aa</span>
</p>
</li>
<li>
<p>
"(\d+)/res" &#8594; "\1/aa" to require <span class="monospaced">C/1/aa</span> be executed before <span class="monospaced">D/1/res</span>
Test C was a waiton - test A. Test C&#8217;s rule <span class="monospaced">A (\d&plus;)/aa aa/\1</span> &#8594; causes <span class="monospaced">A/aa/1</span> to run before <span class="monospaced">C/1/aa</span>
</p>
</li>
<li>
<p>
Full list to be run is now: D/1/res, C/1/aa
</p>
</li>
<li>
<p>
"(\d+)/aa" &#8594; "aa/\1" to create item <span class="monospaced">A/aa/1</span>
</p>
</li>
<li>
<p>
Full list to be run is now: <span class="monospaced">D/1/res</span>, <span class="monospaced">C/1/aa</span>, <span class="monospaced">A/aa/1</span>
</p>
</li>
<li>
<p>
Test A has no waitons.  All waitons of all tests in full list have been processed.  Full list is finalized.
</p>
</li>
</ol></div>
</div>
<div class="sect3">
<h4 id="_dynamic_flow_dependency_tree">Dynamic Flow Dependency Tree</h4>
<div class="listingblock">
<div class="title">Autogeneration waiton list for dynamic flow dependency trees</div>

// image::itemmap.png[]
image::complex-itemmap.png[]


We accomplish this by configuring the testconfigs of our tests C D and E as follows:

.Testconfig for Test C
.Testconfig for Test E has
----------------------
[requirements]
waiton A B
waiton C

[itemmap]
itemmap (\d+)/res \1/bb
A (\d+)/aa aa/\1
B (\d+)/bb 
----------------------

.Testconfig for Test D
.Testconfig for Test D has
----------------------
[requirements]
waiton C
itemmap (\d+)/res \1/aa
----------------------

.Testconfig for Test E
.Testconfig for Test C has
----------------------
[requirements]
waiton C
itemmap (\d+)/res \1/bb
waiton A B

[itemmap]
A (\d+)/aa aa/\1
B (\d+)/bb bb/\1
----------------------

.Testconfigs for Test B and Test A have no waiton or itemmap configured
-------------------
-------------------
Example from image just above, we want the following to occur:

.Walk through one item -- we want the following to happen for testpatt +D/1/res+ (see blue boxes in complex itemmaping figure above):

. We want the above to execute when we request pattern +D/1/res+, eg from command line +megatest -run -testpatt D/1/res -target ... -runname ...+
. "(\d+)/res" -> "\1/aa" to require +C/1/aa+ be executed before +D/1/res+
. Full list to be run is now: D/1/res, C/1/aa
. eg from command line +megatest -run -testpatt D/1/res -target mytarget -runname myrunname+
. Full list to be run is now: +D/1/res+
. Test D has a waiton - test C.  Test D's itemmap rule +itemmap (\d+)/res \1/aa+ ->  causes +C/1/aa+ to run before +D/1/res+
. Full list to be run is now: +D/1/res+, +C/1/aa+
. "(\d+)/aa" -> "aa/\1" to create item +A/aa/1+
. Test C was a waiton - test A. Test C's rule +A (\d+)/aa aa/\1+ -> causes +A/aa/1+ to run before +C/1/aa+
. Full list to be run is now: +D/1/res+, +C/1/aa+, +A/aa/1+
. Test A has no waitons.  All waitons of all tests in full list have been processed.  Full list is finalized.


Dynamic Flow Dependency Tree
^^^^^^^^^^^^^^^^^^^^^^^^^^^^

.Autogeneration waiton list for dynamic flow dependency trees
-------------------

;; 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.6504)
(define megatest-version 1.6505)

  -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
  -remove-keep N action   : remove all but N most recent runs per target
                            * Use -actions print,remove-runs,archive to specify action to take
                            * Add param -age 120d,3h,20m to apply only to runs older than the 
                                 specified age
                                 specified age. NB// M=month, m=minute
                            * Add -precmd to insert a wrapper command in front of the commands run

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
  -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
  --modepatt key          : load testpatt from <key> in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
  -modepatt key           : load testpatt from <key> 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)
  -setlog logfname        : set the path/filename to the final log relative to the test

			"-state"
			":status"
			"-status"
			"-list-runs"
                        "-testdata-csv"
			"-testpatt"
                        "--modepatt"
                        "-modepatt"
                        "-tagexpr"
			"-itempatt"
			"-setlog"
			"-set-toplog"
			"-runstep"
			"-logpro"
			"-m"

;;======================================================================

;; given a mtutil param, return the old megatest equivalent
;;
(define (param-translate param)
  (or (alist-ref (string->symbol param)
		 '((-tag-expr  . "-tagexpr")
		   (-mode-patt . "--modepatt")
		   (-mode-patt . "-modepatt")
		   (-run-name  . "-runname")
		   (-test-patt . "-testpatt")
		   (-msg       . "-m")
		   (-new       . "-set-state-status")))
      param))

(define (val->alist val)