Megatest

;; (if (args:get-arg "-host")
;;     (begin
;;       (set! *runremote* (string-split (args:get-arg "-host" ":")))
;;       (client:launch))
;;     (if (not (args:get-arg "-use-server"))
;; 	(set! *transport-type* 'fs) ;; force fs access
;; 	(client:launch)))
	  (client:launch))

;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db"))))
;; (client:setup *db*)

(define toplevel #f)
(define dlg      #f)

	                       tol         REAL,
                               units       TEXT,
                               comment     TEXT DEFAULT '',
                               status      TEXT DEFAULT 'n/a',
                               type        TEXT DEFAULT '',
                        CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (

                              test_id      INTEGER,








;; L O G G I N G    D B 
;;======================================================================

(define (open-logging-db) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let* ((dbpath    (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
	 (dbexists  (file-exists? dbpath))
	 (db        (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))

;; ;;      (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
;; ;;        (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
;; ;;      db 
;; ;;      qry
;; ;;      )
;; ;;     res))

(define (db:delete-test-records db test-id)
(define (db:delete-test-step-records dbstruct run-id test-id)
  (let ((db (db:get-db dbstruct run-id)))
  (db:general-call db 'delete-test-step-records (list test-id))
  (db:general-call db 'delete-test-data-records (list test-id))
  (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))

(define (db:delete-tests-for-run dbstruct run-id)
  (let ((db (db:get-db dbstruct run-id)))

       (set! res count))
     (db:get-db dbstruct run-id)
     "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART');")
    res))

;; NEW BEHAVIOR: Look only at single run with run-id
;; 
(define (db:get-running-stats dbstruct run-id)
(define (db:get-count-tests-running-for-run-id db run-id)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     db
     "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND id=?;" run-id)
    res))

     (db:get-db dbstruct run-id)
     "SELECT id FROM tests WHERE testname=? AND item_path=?;"
     testname item-path)
    res))

(define db:test-record-qry-selector "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir_id,item_path,run_duration,final_logf,comment,realdir_id")

(define (db:get-all-tests-info-by-run-id db run-id)
  (let ((res '()))
;; NOTE: Use db:test-get* to access records
;; 
;; NOTE: This needs rundir_id decoding? Decide, decode here or where used? For the moment decode where used.



     (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)
       ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14
       (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)
		       res)))
     db 
     "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE run_id=?;"
     run-id)
    res))
;; Get test data using test_id
;;
;; Get test data using test_id
(define (db:get-test-info-by-id dbstruct run-id test-id)
  (let ((res #f))
    (sqlite3:for-each-row
	 (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment pass_count fail_count)
       ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14
	   (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment pass_count fail_count)))
     (db:get-db dbstruct run-id)
	 "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment,pass_count,fail_count FROM tests WHERE id=?;"
     test-id)
    res))

;; Use db:test-get* to access
;;
;; Get test data using test_ids. NB// Only works within a single run!!
;;
(define (db:get-test-info-by-ids dbstruct run-id test-ids)
  (let ((res '()))
    (sqlite3:for-each-row
	 (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment pass_count fail_count)
       ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14
	   (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment pass_count fail_count)
		       res)))
     (db:get-db dbstruct run-id) 
     (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in ("
	   (string-intersperse (map conc test-ids) ",") ");"))
    res))

(define (db:get-test-info dbstruct run-id testname item-path)

    (sqlite3:for-each-row 
     (lambda (p)
       (set! res (cons p res)))
     db 
     qrystr)
    res))

(define (db:test-get-paths-matching-keynames-target-new dbstruct keynames target res 
							testpatt  
							statepatt 
							statuspatt
							runname)
  (let* ((row-ids '())
	 (keystr (string-intersperse 
		  (map (lambda (key val)
			 (conc key " like '" val "'"))
		       keynames 
		       (string-split target "/"))
		  " AND "))
	 (testqry (tests:match->sqlqry testpatt))
	 (runsqry (sqlite3:prepare (db:get-db dbstruct #f)(conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))
	 (tstsqry (conc "SELECT rundir_id FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
	 (tqry    (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))
	 (tstsqry (sqlite3:prepare db tqry)))
    (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n  rqry=" rqry "\n  tqry=" tqry)
    (sqlite3:for-each-row
     (lambda (rid)
       (set! row-ids (cons rid row-ids)))
     runsqry)
    (sqlite3:finalize! runsqry)
    (for-each (lambda (rid)
		(sqlite3:for-each-row 
		 (lambda (p)
		   (set! res (cons p res)))
		 (db:get-db dbstruct rid)
		 tstsqry))
	      row-ids)
    ;; (sqlite3:finalize! tstsqry)
    res))

;; NEVER FINISHED? ;; look through tests from matching runs for a file
;; NEVER FINISHED? (define (db:test-get-first-path-matching dbstruct keynames target fname)
;; NEVER FINISHED?   ;; [refpaths] is the section where references to other megatest databases are stored
;; NEVER FINISHED? ;;
;; NEVER FINISHED? ;; NEED TO REVISIT THIS!!! BUGGISHNESS
;; NEVER FINISHED? ;;
;; NEVER FINISHED?   (let ((mt-paths (configf:get-section "refpaths"))
;; NEVER FINISHED? 	(res       (db:test-get-paths-matching dbstruct keynames target fname)))
;; NEVER FINISHED?     (let loop ((pathdat (if (null? paths) #f (car mt-paths)))
;; NEVER FINISHED? 	       (tal     (if (null? paths) '()(cdr mt-paths))))
;; NEVER FINISHED?       (if (not (null? res))
;; NEVER FINISHED? 	  (car res) ;; return first found
;; NEVER FINISHED? 	  (if path
;; NEVER FINISHED? 	      (let* ((db     (open-db path: (cadr pathdat)))
;; NEVER FINISHED? 		     (newres (db:test-get-paths-matching db keynames target fname)))
;; NEVER FINISHED? 		(debug:print-info 4 "Trying " (car pathdat) " at " (cadr pathdat))
;; NEVER FINISHED? 		(sqlite3:finalize! db)
;; NEVER FINISHED? 		(if (not (null? newres))
;; NEVER FINISHED? 		    (car newres)
;; NEVER FINISHED? 		    (if (null? tal)
;; NEVER FINISHED? 			#f
;; NEVER FINISHED? 			(loop (car tal)(cdr tal))))))))))

;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================

;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj)
  (case *transport-type*

	      (string-substitute 
	       (regexp "_") "=" msg #t))
	   (lambda ()(deserialize)))
	 (vector #f #f #f))) ;; crude reply for when things go awry
    ((zmq)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg)))

(define (db:test-set-status-state db test-id status state msg)

  (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
      (db:general-call db 'set-test-start-time (list test-id)))
  (if msg
      (db:general-call db 'state-status-msg (list state status msg test-id))
      (db:general-call db 'state-status     (list state status test-id))))

(define (db:roll-up-pass-fail-counts db run-id test-name item-path status)
  (if (and (not (equal? item-path ""))
	   (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP")))

      (handle-exceptions
       exn
       (begin 
	 (debug:print 0 "Problem with call to cdb:remote-run, database may be locked and read-only, waiting and trying again ...")
	 (thread-sleep! 10)
	 (apply cdb:remote-run proc db params))
;; 			       ;; get the sender info
;; 			       ;; this should match (client:get-signature)
;; 			       ;; we will need to process "all" messages here some day
;; 			       (receive-message* sub-socket)
;; 			       ;; now get the actual message
;; 			       (let ((myres (db:string->obj (receive-message* sub-socket))))
;; 				 (if (equal? query-sig (vector-ref myres 1))
;; 				     (set! res (vector-ref myres 2))
;; 				     (loop)))))))
;; 	;; (timeout (lambda ()
;; 	;;     	(let loop ((n numretries))
;; 	;;     	  (thread-sleep! 15)
;; 	;;     	  (if (not res)
;; 	;;     	      (if (> numretries 0)
;; 	;;     		  (begin
;; 	;;     		    (debug:print 2 "WARNING: no reply to query " params ", trying resend")
;; 	;;     		    (debug:print-info 11 "re-sending message")
;; 	;;     		    (send-message push-socket zdat)
;; 	;;     		    (debug:print-info 11 "message re-sent")
;; 	;;     		    (loop (- n 1)))
;; 	;;     		  ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params))
;; 	;;     		  (begin
;; 	;;     		    (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.")
;; 	;;     		    (exit 5))))))))
;; 	(debug:print-info 11 "Starting threads")
;; 	(let ((th1 (make-thread send-receive "send receive"))
;; 	      ;; (th2 (make-thread timeout      "timeout"))
;; 	      )
;; 	  (thread-start! th1)
;; 	  ;; (thread-start! th2)
;; 	  (thread-join!  th1)
;; 	  (debug:print-info 11 "cdb:client-call returning res=" res)
;; 	  res))))))
;; NOT NEEDED FOR NOW 
;; NOT NEEDED FOR NOW (define (cdb:login serverdat keyval signature)
;; NOT NEEDED FOR NOW   (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature))
;; NOT NEEDED FOR NOW 
;; NOT NEEDED FOR NOW (define (cdb:logout serverdat keyval signature)
;; NOT NEEDED FOR NOW   (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature))
;; NOT NEEDED FOR NOW 
;; NOT NEEDED FOR NOW (define (cdb:num-clients serverdat)
;; NOT NEEDED FOR NOW   (cdb:client-call serverdat 'numclients #t *default-numtries*))
;; NOT NEEDED FOR NOW 
;;   (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id))

(define (db:tests-register-test dbstruct run-id test-name item-path)
  (sqlite3:execute (db:get-db dbstruct run-id) 'register-test run-id test-name item-path))
       (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params))
      (begin
	(db:general-call db 'update-pass-fail-counts (list run-id test-name run-id test-name run-id test-name))
	(if (equal? status "RUNNING")
	    (db:general-call db 'top-test-set-running (list run-id test-name))
	    (db:general-call db 'top-test-set-per-pf-counts (list run-id test-name run-id test-name run-id test-name)))
	#f)
      #f))
;; 
;; ;; db should be db open proc or #f
;; (define (cdb:remote-run proc db . params)
;;   (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params))
;; 

(define (db:test-get-logfile-info dbstruct run-id test-name)
  (let ((res #f))
    (sqlite3:for-each-row 
     (lambda (path-id final_logf-id)
       (let ((path       (db:get-path   dbstruct path-id))
	     (final_logf (db:get-string dbstruct final_logf-id)))

;;    if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met
;;    if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
;;
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
;;       mode 'toplevel means that tests must be COMPLETED only
;;       mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
;; 
(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path #!mode
(define (db:get-prereqs-not-met db run-id waitons ref-item-path mode)
  (if (or (not waitons)
	  (null? waitons))
      '()
      (let* ((unmet-pre-reqs '())
	     (result         '()))
	(for-each 
	 (lambda (waitontest-name)

;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;;  to extract info from the structure returned
;;
(define (mt:get-runs-by-patt dbstruct keys runnamepatt targpatt)
  (let loop ((runsdat  (db:get-runs-by-patt dbstruct keys runnamepatt targpatt 0 500))
  (let loop ((runsdat  (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500))
	     (res      '())
	     (offset   0)
	     (limit    500))
    ;; (print "runsdat: " runsdat)
    (let* ((header    (vector-ref runsdat 0))
	   (runslst   (vector-ref runsdat 1))
	   (full-list (append res runslst))
	   (have-more (eq? (length runslst) limit)))
      ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more)
      (if have-more 
	  (let ((new-offset (+ offset limit))
		(next-batch (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit)))
		(next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit)))
	    (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.")
	    (debug:print-info 0 "next-batch: " next-batch)
	    (loop next-batch
		  full-list
		  new-offset
		  limit))
	 (vector header full-list)))))

;;======================================================================
;;  T E S T S
;;======================================================================

(define (mt:get-tests-for-run dbstruct run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f))
  (let loop ((testsdat (db:get-tests-for-run dbstruct run-id testpatt states status 0 500 not-in sort-by sort-order qryvals: qryvals))
  (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals))
	     (res      '())
	     (offset   0)
	     (limit    500))
    (let* ((full-list (append res testsdat))
	   (have-more (eq? (length testsdat) limit)))
      (if have-more 
	  (let ((new-offset (+ offset limit)))
	    (debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.")
	    (loop (db:get-tests-for-run dbstruct run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals: qryvals)
	    (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals)
		  full-list
		  new-offset
		  limit))
	  full-list))))

(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))

	(let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode)))
	  (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
	  newres))))

(define (mt:get-run-stats dbstruct run-id)
;;  Get run stats from local access, move this ... but where?
  (db:get-run-stats dbstruct run-id))
  (db:get-run-stats #f))

(define (mt:discard-blocked-tests run-id failed-test tests test-records)
  (if (null? tests)
      tests
      (begin
	(debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test)
	(let loop ((testn (car tests))

		     (conc "/" status)))))))

;;======================================================================
;;  S T A T E   A N D   S T A T U S   F O R   T E S T S 
;;======================================================================

;; ;; speed up for common cases with a little logic
;; (define (mt:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment)
;;   (cond
;;    ((and newstate newstatus newcomment)
    (rmt:general-call 'state-status-msg newstate newstatus newcomment test-id))
;;    ((and newstate newstatus)
    (rmt:general-call 'state-status newstate newstatus test-id))
;;    (else
    (if newstate   (rmt:general-call 'set-test-state   newstate test-id))
    (if newstatus  (rmt:general-call 'set-test-status  newstatus test-id))
    (if newcomment (rmt:general-call 'set-test-comment newcomment test-id))))
;;    (mt:process-triggers test-id newstate newstatus)
;;    #t)

(define (mt:lazy-get-test-info-by-id test-id)
  (let* ((tdat (hash-table-ref/default *test-info* test-id #f)))
    (if (and tdat 
	     (< (current-seconds)(+ (vector-ref tdat 0) 10)))
	(vector-ref tdat 1)
	;; no need to update *test-info* as that is done in cdb:get-test-info-by-id

		 (string-match (regexp "\\S+") comment))
	    waived)
	(let ((cmt  (if waived waived comment)))
	  (rmt:general-call 'set-test-comment cmt test-id)))))

(define (tests:test-set-toplog! run-id test-name logf) 
  (rmt:general-call 'tests:test-set-toplog logf run-id test-name))
		   (db:get-query 'tests:test-set-toplog)
		   (db:save-string dbstruct logf)
		   test-name))

(define (tests:summarize-items run-id test-id test-name force)
  ;; if not force then only update the record if one of these is true:
  ;;   1. logf is "log/final.log
  ;;   2. logf is same as outputfilename
  (let* ((outputfilename (conc "megatest-rollup-" test-name ".html"))
	 (orig-dir       (current-directory))

(define (tests:update-central-meta-info dbstruct run-id test-id cpuload diskfree minutes uname hostname)
  (rmt:general-call 'update-cpuload-diskfree cpuload diskfree test-id)
  (if minutes 
      (rmt:general-call 'update-run-duration minutes test-id))
  (if (and uname hostname)
      (rmt:general-call 'update-uname-host uname hostname test-id)))
  
(define (tests:set-full-meta-info test-id run-id minutes work-area)
  (let* ((num-records 0)
(define (tests:set-full-meta-info dbstruct test-id run-id minutes work-area)
	 (cpuload  (get-cpu-load))
	 (diskfree (get-df (current-directory)))
	 (uname    (get-uname "-srvpio"))
	 (hostname (get-host-name)))
    (tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes)
    (tests:update-central-meta-info dbstruct run-id test-id cpuload diskfree minutes uname hostname)))
	  
(define (tests:set-partial-meta-info test-id run-id minutes work-area)
  (let* ((cpuload  (get-cpu-load))
	 (diskfree (get-df (current-directory))))
    (tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes)))
	 
;;======================================================================
;; A R C H I V I N G