Megatest

(declare (uses server))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(include "js-path.scm")


;; Call this one to do all the work and get a standardized list of tests
;;   gets paths from configs and finds valid tests 
;;   returns hash of testname --> fullpath
;;
(define (tests:get-all)
  (let* ((test-search-path   (tests:get-tests-search-path *configdat*)))

	    (append paths (list (conc *toppath* "/tests"))))))

(define (tests:get-valid-tests test-registry tests-paths)
  (if (null? tests-paths) 
      test-registry
      (let loop ((hed (car tests-paths))
		 (tal (cdr tests-paths)))
	(if (common:file-exists? hed)
	    (for-each (lambda (test-path)
			(let* ((tname   (last (string-split test-path "/")))
			       (tconfig (conc test-path "/testconfig")))
			  (if (and (not (hash-table-ref/default test-registry tname #f))
				   (common:file-exists? tconfig))
			      (hash-table-set! test-registry tname test-path))))
		      (glob (conc hed "/*"))))
	(if (null? tal)
	    test-registry
	    (loop (car tal)(cdr tal))))))

(define (tests:filter-test-names test-names test-patts)

      (items:get-items-from-config tconfig))
     (else #f))))                           ;; not iterated


;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry)
   (let* ((config  (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) ;; assuming no problems with immediate evaluation, this could be simplified ('return-procs -> #t)
     (let ((instr (if config 
		      (config-lookup config "requirements" "waiton")
		      (begin ;; No config means this is a non-existant test
			(debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"")
			(exit 1))))
	   (instr2 (if config
		       (config-lookup config "requirements" "waitor")

				  (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x)) 
					 (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt)))))
				    ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt)))))
				    ;; (print "in map, x=" x ", newpatt=" newpatt)
				    newpatt))
				(filter (lambda (x)
					  (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test
					patts)))
         (extended-test-patt   (append patts (if (null? patts-waiton)
                                     (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
                                     patts-waiton)))
         (extended-test-patt-with-toplevels
          (fold (lambda (testpatt-item accum )
                  (let ((my-match (string-match "^([^%\\/]+)\\/.+$" testpatt-item)))
                    (cons testpatt-item
                          (if my-match
                              (cons
                               (conc (cadr my-match) "/")
                               accum)
                              accum))))
                '()
                extended-test-patt)))
    (string-intersperse (delete-duplicates extended-test-patt-with-toplevels) ",")))


  
;; tests:glob-like-match 
(define (tests:glob-like-match patt str) 
  (let ((like (substring-index "%" patt)))
    (let* ((notpatt  (equal? (substring-index "~" patt) 0))

	  (db:test-get-rundir testdat)) ;; )
	 (prev-rundir ;; (sdb:qry 'passstr 
	  (db:test-get-rundir prev-testdat)) ;; )
	 (waivers     (if testconfig (configf:section-vars testconfig "waivers") '()))
	 (waiver-rx   (regexp "^(\\S+)\\s+(.*)$"))
	 (diff-rule   "diff %file1% %file2%")
	 (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html"))
    (if (not (common:file-exists? test-rundir))
	(begin
	  (debug:print-error 0 *default-log-port* "test run directory is gone, cannot propagate waiver")
	  #f)
	(begin
	  (push-directory test-rundir)
	  (let ((result (if (null? waivers)
			    #f
			    (let loop ((hed (car waivers))
				       (tal (cdr waivers)))
			      (debug:print 0 *default-log-port* "INFO: Applying waiver rule \"" hed "\"")
			      (let* ((waiver      (configf:lookup testconfig "waivers" hed))
				     (wparts      (if waiver (string-match waiver-rx waiver) #f))
				     (waiver-rule (if wparts (cadr wparts)  #f))
				     (waiver-glob (if wparts (caddr wparts) #f))
				     (logpro-file (if waiver
						      (let ((fname (conc hed ".logpro")))
							(if (common:file-exists? fname)
							    fname 
							    (begin
							      (debug:print 0 *default-log-port* "INFO: No logpro file " fname " falling back to diff")
							      #f)))
						      #f))
				     ;; if rule by name of waiver-rule is found in testconfig - use it
				     ;; else if waivername.logpro exists use logpro-rule

    ;; (let ((val (hash-table-ref/default otherdat ":first_warn" #f)))
    ;;   (if val
    ;;       (sqlite3:execute db "UPDATE tests SET first_warn=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path)))

    (let ((category (hash-table-ref/default otherdat ":category" ""))
	  (variable (hash-table-ref/default otherdat ":variable" ""))
	  (value    (hash-table-ref/default otherdat ":value"    #f))
	  (expected (hash-table-ref/default otherdat ":expected" "n/a"))
	  (tol      (hash-table-ref/default otherdat ":tol"      "n/a"))
	  (units    (hash-table-ref/default otherdat ":units"    ""))
	  (type     (hash-table-ref/default otherdat ":type"     ""))
	  (dcomment (hash-table-ref/default otherdat ":comment"  "")))
      (debug:print 4 *default-log-port* 
		   "category: " category ", variable: " variable ", value: " value
		   ", expected: " expected ", tol: " tol ", units: " units)
      (if (and value) ;; require only value; BB was- all three required
	  (let ((dat (conc category ","
			   variable ","
			   value    ","
			   expected ","
			   tol      ","
			   units    ","
			   dcomment ",," ;; extra comma for status
			   type     )))
	    ;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment.
	    (rmt:csv->test-data run-id test-id
				dat)
            (thread-sleep! 10) ;; add 10 second delay before quit incase rmt needs time to start a server.
            )))
      
    ;; need to update the top test record if PASS or FAIL and this is a subtest
    ;;;;;; (if (not (equal? item-path ""))
    ;;;;;;     (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status #f) ;;;;;)

    (if (or (and (string? comment)
		 (string-match (regexp "\\S+") comment))

ul.LinkedList { display: block; }
/* ul.LinkedList ul { display: none; } */
.HandCursorStyle { cursor: pointer; cursor: hand; }  /* For IE */
th {background-color: #8c8c8c;}
td.test {background-color: #d9dbdd;}
td.PASS {background-color: #347533;}
td.FAIL {background-color: #cc2812;}

</style>



  <script type="text/JavaScript">

    function filtersome() {
  $("tr").show();
  $(".test").filter(

        }
      }
    }
  </script>
EOF
)

(define tests:css-jscript-block-dynamic 
#<<EOF
           <script src= ./jquery3.1.0.js></script> 
EOF
)

(define  (test:js-block javascript-lib)
   (conc  "<script src=" javascript-lib "></script>" ))


(define tests:css-jscript-block-static (test:js-block *java-script-lib*))

(define (tests:css-jscript-block-cond dynamic) 
      (if (equal? dynamic  #t)
       tests:css-jscript-block-dynamic
       tests:css-jscript-block-static))

       
(define (tests:run-record->test-path run numkeys)
   (append (take (vector->list run) numkeys)
	   (list (vector-ref run (+ 1 numkeys)))))


(define (tests:get-rest-data runs header numkeys)
   (let ((resh (make-hash-table)))

                (if (not (hash-table-ref/default (hash-table-ref/default resh test-name  #f)  test-item  #f))
                       (hash-table-set! (hash-table-ref/default resh test-name  #f) test-item   (make-hash-table))) 
               (hash-table-set!  (hash-table-ref/default (hash-table-ref/default resh test-name  #f) test-item #f) run-id (list test-status test-html-path)))) 
        test-data)))
      runs)
   resh))

;; tests:genrate dashboard body 
;;



(define (tests:dashboard-body page pg-size keys numkeys  total-runs linktree area-name get-prev-links get-next-links flag)










  (let* ((start (* page pg-size)) 
	       (runsdat   (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys)))
	       (header    (vector-ref runsdat 0))
	       (runs      (vector-ref runsdat 1))
               (ctr 0)
               (test-runs-hash (tests:get-rest-data runs header numkeys))
               (test-list (hash-table-keys test-runs-hash))












               ) 
  (s:html tests:css-jscript-block (tests:css-jscript-block-cond flag)
		   (s:title "Summary for " area-name)
		   (s:body 'onload "addEvents();"
                          (get-prev-links page linktree)
                          (get-next-links page linktree total-runs)
                           
			   (s:h1 "Summary for " area-name)
                           (s:h3 "Filter" )
                           (s:input 'type "text"  'name "testname" 'id "testname" 'length "30" 'onkeyup "filtersome()")

			   ;; top list
			   (s:table 'id "LinkedList1" 'border "1"
                            (map (lambda (key)
				 (let* ((res (s:tr 'class "something" 
				  (s:th key )
                                   (map (lambda (run)
                                   (s:th  (vector-ref run ctr)))

  		                             (let* ((res (s:tr  'class item-name
				                         (s:td  item-name 'class "test" )
                                                           (map (lambda (run)
                                                               (let* ((run-test (hash-table-ref/default item-hash item-name  #f))
                                                                      (run-id (db:get-value-by-header run header "id"))
                                                                      (result (hash-table-ref/default run-test run-id "n/a"))
                                                                      (status (if (string? result)
										result
										(car result)))
                                                                        (link (if (string? result)
										result

                                                                                (if (equal? flag #t) 
                                                                                (s:a (car result) 'href (conc "./test_log?runid=" run-id "&testname="  item-name ))
										(s:a (car result) 'href (cadr result))))))
                                                                       (s:td  link 'class status)))
                                                                runs))))
                                                        res))
                                                   item-keys)))
                               test-list)))))) 

;; (tests:create-html-tree "test-index.html")
;;
(define (tests:create-html-tree outf)
   (let* ((lockfile  (conc outf ".lock"))
	 (runs-to-process '())
         (linktree  (common:get-linktree))
          (area-name (common:get-testsuite-name))
	  (keys      (rmt:get-keys))
	  (numkeys   (length keys))
         (total-runs  (rmt:get-num-runs "%"))
         (pg-size 10))
    (if (common:simple-file-lock lockfile)
        (begin
         ;(print total-runs)    
        (let loop ((page 0))
	(let* ((oup       (open-output-file (or outf (conc linktree "/page" page ".html"))))
               (get-prev-links (lambda (page linktree )   
                            (let* ((link  (if (not (eq? page 0))
                                   (s:a "<<prev" 'href (conc  linktree "/page" (- page 1) ".html"))
                                   (s:a "" 'href (conc  linktree "/page"  page ".html")))))
                               link)))
               (get-next-links (lambda (page linktree total-runs)   
                            (let* ((link  (if (> total-runs (+ 10 (* page pg-size)))
                                   (s:a "next>>" 'href (conc  linktree "/page"  (+ page 1) ".html"))
                                   (s:a "" 'href (conc  linktree "/page" page  ".html")))))
                               link))) )
          ;(print (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name))
	  (s:output-new
	   oup
	   (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f))
          (close-output-port oup)
         ; (set! page (+ 1 page))
          (if (> total-runs (* (+ 1 page) pg-size))
           (loop (+ 1  page)))))
	  (common:simple-file-release-lock lockfile))
	            
	#f)))


(define (tests:readlines filename)
  (call-with-input-file filename
    (lambda (p)
      (let loop ((line (read-line p))
                 (result '()))
        (if (eof-object? line)
            (reverse result)
            (loop (read-line p) (cons line result)))))))

(define (tests:get-test-log run-id test-name item-name)
  (let* ((test-data    (rmt:get-tests-for-run
				   (string->number run-id)
                                    test-name      ;; 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))
         (path "")
         (found 0))
    (debug:print-info 0 *default-log-port* "found: " found )

   (let loop ((hed (car test-data))
		 (tal (cdr test-data)))
          (debug:print-info 0 *default-log-port* "item: " (vector-ref hed 11) (vector-ref hed 10) "/" (vector-ref hed 13))

	(if (equal? (vector-ref hed 11) item-name)
            (begin
              (set! found 1) 
	      (set! path (conc (vector-ref hed 10) "/" (vector-ref hed 13)))))
	    (if (and (not (null? tal)) (equal? found 0))
		(loop (car tal)(cdr tal))))
   (if (equal? path "")
     "<H2>Data not found</H2>"
     (string-join (tests:readlines path) "\n"))))


(define (tests:dynamic-dboard page)
;(define (tests:create-html-tree o)
 (let* (
;(page "1")
          (linktree  (common:get-linktree))
         (area-name (common:get-testsuite-name))
	 (keys      (rmt:get-keys))
	 (numkeys   (length keys))
         (total-runs  (rmt:get-num-runs "%"))
         (pg-size 10)
         (pg (if (equal? page #f)
                 0
                 (- (string->number page) 1)))
          (get-prev-links  (lambda (pg linktree)
                           (debug:print-info 0 *default-log-port* "val: " (- 1 pg))
                          (let* ((link  (if (not (eq? pg 0))
                               (s:a  "&lt;&lt;prev " 'href (conc  "dashboard?page="  pg  ))
                               (s:a "" 'href (conc  "dashboard?page=" pg)))))
                               link)))
          (get-next-links   (lambda (pg linktree total-runs)  
                            (debug:print-info 0 *default-log-port* "val: " pg)
                             (debug:print-info 0 *default-log-port* "val: " total-runs " size" pg-size)
 
                            (let* ((link  (if (> total-runs (+ 10 (* pg pg-size)))
                              (s:a  "next&gt;&gt; "  'href (conc  "dashboard?page="  (+ pg 2)  ))
                             (s:a "" 'href (conc  "dashboard?page=" pg  )))))
                             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-tree-old outf)
   (let* ((lockfile  (conc outf ".lock"))
	 (runs-to-process '()))
    (if (common:simple-file-lock lockfile)

				  "Runs"
				  (common:htree->html runs-htree
						      '()
						      (lambda (x p)
							(let* ((targ-path (string-intersperse p "/"))
                                                               (full-path (conc linktree "/" targ-path))
                                                               (run-name  (car (reverse p))))
                                                          (if (and (common:file-exists? full-path)
                                                                   (directory?   full-path)
                                                                   (file-write-access? full-path))
                                                              (s:a run-name 'href (conc targ-path "/run-summary.html"))
                                                              (begin
                                                                (debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html")
                                                                (conc run-name " (Not able to create summary at " targ-path ")")))))))))))
          (close-output-port oup)

                                                (full-name  (db:test-make-full-name test-name item-path))
                                                (path-parts (string-split full-name)))
                                           path-parts))
                                       test-dats))
                    (tests-htree (common:list->htree tests-tree-dat))
                    (html-dir    (conc linktree "/" (string-intersperse run-dir "/")))
                    (html-path   (conc html-dir "/run-summary.html"))
                    (oup         (if (and (common:file-exists? html-dir)
                                          (directory?   html-dir)
                                          (file-write-access? html-dir))
                                     (open-output-file  html-path)
                                     #f)))
               ;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat)
               (if oup
                   (begin

                                                                   (let* ((targ-path (string-intersperse p "/"))
                                                                          (test-name (car p))
                                                                          (item-path ;; (if (> (length p) 2) ;; test-name + run-name
                                                                           (string-intersperse p "/"))
                                                                          (full-targ (conc html-dir "/" targ-path))
                                                                          (std-file  (conc full-targ "/test-summary.html"))
                                                                          (alt-file  (conc full-targ "/megatest-rollup-" test-name ".html"))
                                                                          (html-file (if (common:file-exists? alt-file)
                                                                                         alt-file
                                                                                         std-file))
                                                                          (run-name  (car (reverse p))))
                                                                     (if (and (not (common:file-exists? full-targ))
                                                                              (directory? full-targ)
                                                                              (file-write-access? full-targ))
                                                                         (tests:summarize-test 
                                                                          run-id 
                                                                          (rmt:get-test-id run-id test-name item-path)))
                                                                     (if (common:file-exists? full-targ)
                                                                         (s:a run-name 'href html-file)
                                                                         (begin
                                                                           (debug:print 0 *default-log-port* "ERROR: can't access " full-targ)
                                                                           (conc "No summary for " run-name)))))
                                                                 ))))))
                     (close-output-port oup)))))
           runs)

			      
;;======================================================================
;; Gather data from test/task specifications
;;======================================================================

;; (define (tests:get-valid-tests testsdir test-patts) ;;  #!key (test-names '()))
;;   (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*")))))
;;     (set! tests (filter (lambda (test)(common:file-exists? (conc test "/testconfig"))) tests))
;;     (delete-duplicates
;;      (filter (lambda (testname)
;; 	       (tests:match test-patts testname #f))
;; 	     (map (lambda (testp)
;; 		    (last (string-split testp "/")))
;; 		  tests)))))

(define (tests:get-test-path-from-environment)
  (if (and (getenv "MT_LINKTREE")
	   (getenv "MT_TARGET")
	   (getenv "MT_RUNNAME")
	   (getenv "MT_TEST_NAME")
	   (getenv "MT_ITEMPATH"))
      (conc (getenv "MT_LINKTREE")  "/"
	    (getenv "MT_TARGET")    "/"
	    (getenv "MT_RUNNAME")   "/"
	    (getenv "MT_TEST_NAME")
	    (if (and (getenv "MT_ITEMPATH")
                     (not (string=? "" (getenv "MT_ITEMPATH"))))
		(conc "/" (getenv "MT_ITEMPATH"))
                ""))
      #f))

;; if .testconfig exists in test directory read and return it
;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata"
;; else read the testconfig file
;;   if have path to test directory save the config as .testconfig and return it
;;
(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)(allow-write-cache #t))
  (let* ((use-cache    (common:use-cache?))
	 (cache-path   (tests:get-test-path-from-environment))
	 (cache-file   (and cache-path (conc cache-path "/.testconfig")))
	 (cache-exists (and cache-file
			    (not force-create)  ;; if force-create then pretend there is no cache to read
			    (common:file-exists? cache-file)))
	 (cached-dat   (if (and (not force-create)
				cache-exists
				use-cache)
			   (handle-exceptions
			    exn
			    #f ;; any issues, just give up with the cached version and re-read
			    (configf:read-alist cache-file))

	      dat
	      ;; no cached data available
	      (let* ((treg         (or test-registry
				       (tests:get-all)))
		     (test-path    (or (hash-table-ref/default treg test-name #f)
				       (conc *toppath* "/tests/" test-name)))
		     (test-configf (conc test-path "/testconfig"))
		     (testexists   (and (common:file-exists? test-configf)(file-read-access? test-configf)))
		     (tcfg         (if testexists
				       (read-config test-configf #f system-allowed
						    environ-patt: (if system-allowed
								      "pre-launch-env-vars"
								      #f))
				       #f)))
		(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
		(if tcfg (hash-table-set! *testconfigs* test-full-name tcfg))
		(if (and testexists
			 cache-file
			 (file-write-access? cache-path)
			 allow-write-cache)
		    (let ((tpath (conc cache-path "/.testconfig")))
		      (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
                      (if (not (common:in-running-test?))
                          (configf:write-alist tcfg tpath))))
		tcfg))))))
  
;; sort tests by priority and waiton

;; read data from tmp file or create if not exists
;; if exists regen in background
;;
(define (tests:lazy-dot testrecords  outtype sizex sizey)
  (let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot"))
	(fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat")))
    (tests:write-dot-file testrecords dfile sizex sizey)
    (if (common:file-exists? fname)
	(let ((res (with-input-from-file fname
		     (lambda ()
		       (read-lines)))))
	  (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&"))
	  res)
	(begin
	  (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname))

	   (set! remtries (- remtries 1))
	   (thread-sleep! 10)
	   (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1)))
	 (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
	   (debug:print-error 0 *default-log-port* "tried for over a minute to update meta info and failed. Giving up")
	   (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
	   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	   (debug:print 5 *default-log-port* "exn=" (condition->list exn))
	   (debug:print 0 *default-log-port* " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
	   (print-call-chain (current-error-port))))
     (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
  )))
	 
;;======================================================================
;; A R C H I V I N G