Megatest

ndboard : newdashboard.scm $(OFILES) $(GOFILES)
	csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard

mtut: $(OFILES) mtut.scm
	csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut

TCMTOBJS = \
	api.o \
	archive.o \
	cgisetup/models/pgdb.o \
	client.o \
	common.o \
	configf.o \
	daemon.o \
	db.o \
	env.o \
	http-transport.o \
	items.o \
	keys.o \
	launch.o \
	lock-queue.o \
	margs.o \
	mt.o \
	megatest-version.o \
	ods.o \
	portlogger.o \
	process.o \
	rmt.o \
	rpc-transport.o \
	runconfig.o \
	runs.o \
	server.o \
	tasks.o \
	tdb.o \
	tests.o \


tcmt : $(TCMTOBJS) tcmt.scm
	csc $(CSCOPTS) $(TCMTOBJS) tcmt.scm -o tcmt

# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS
#
$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html
	mkdir -p $(PREFIX)/share/docs
	$(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html
	for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done

$(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut
	$(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut

$(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil
	chmod a+x $(PREFIX)/bin/mtutil

$(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt
	$(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt

$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt
	chmod a+x $(PREFIX)/bin/tcmt

# $(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard
#	$(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard

# $(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard  utils/mk_wrapper
# 	utils/mk_wrapper $(PREFIX) mdboard $(PREFIX)/bin/mdboard
# 	chmod a+x $(PREFIX)/bin/mdboard

	chmod a+x $(PREFIX)/bin/dashboard
	$(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard

install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
          $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
	  $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
          $(PREFIX)/share/db/mt-pg.sql $(PREFIX)/bin/.$(ARCHSTR)/ndboard  $(PREFIX)/bin/tcmt

# $(PREFIX)/bin/newdashboard

$(PREFIX)/bin/.$(ARCHSTR) : 
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib

test: tests/tests.scm
	cd tests;csi -I .. -b -n tests.scm

;;  PURPOSE.
;;======================================================================

(use format typed-records) ;; RADT => purpose of json format??

(declare (unit rmt))
(declare (uses api))
;; (declare (uses tdb))
(declare (uses http-transport))
;;(declare (uses nmsg-transport))
(include "common_records.scm")

;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;

;; Copyright 2006-2017, 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.
;;
;;======================================================================
;;
;; Wrapper to enable running Megatest flows under teamcity
;;
;;  1. Run the megatest process and pass it all the needed parameters
;;  2. Every five seconds check for state/status changes and print the info
;;

(use srfi-1 posix srfi-69 srfi-18)

(declare (uses margs))
(declare (uses rmt))
(declare (uses common))
(declare (uses megatest-version))

(include "megatest-fossil-hash.scm")
(include "db_records.scm")

(define origargs (cdr (argv)))
(define remargs (args:get-args
		 (argv)
		 `( "-target"
		    "-reqtarg"
		    "-runname"
		    )
		 `("-tc-repl"
		   )
		 args:arg-hash
		 0))

;; ##teamcity[testStarted name='suite.testName']
;; ##teamcity[testStdOut name='suite.testName' out='text']
;; ##teamcity[testStdErr name='suite.testName' out='error text']
;; ##teamcity[testFailed name='suite.testName' message='failure message' details='message and stack trace']
;; ##teamcity[testFinished name='suite.testName' duration='50']
;; 

(define (print-changes-since data run-ids last-update tsname target runname)
  (let ((now   (current-seconds)))
    (handle-exceptions
     exn
     (begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn)))
     (for-each
      (lambda (run-id)
	(let* ((tests (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f 'shortlist last-update #f)))
	  ;; (print "DEBUG: got tests=" tests)
	  (for-each
	   (lambda (testdat)
	     (let* ((testn    (db:test-get-fullname     testdat))
		    (testname (db:test-get-testname     testdat))
		    (itempath (db:test-get-item-path    testdat))
		    (tctname  (if (string=? itempath "") testname (conc testname "." itempath)))
		    (state    (db:test-get-state        testdat))
		    (status   (db:test-get-status       testdat))
		    (duration (db:test-get-run_duration testdat))
		    (comment  (db:test-get-comment      testdat))
		    (logfile  (db:test-get-final_logf   testdat))
		    (prevstat (hash-table-ref/default data testn #f))
		    (newstat  (if (equal? state "RUNNING")
				  "RUNNING"
				  (if (equal? state "COMPLETED")
				      status
				      "UNK"))))
	       ;; (print "DEBUG: testn=" testn " state=" state " status=" status " prevstat=" prevstat " newstat=" newstat)
	       (if (or (not prevstat)
		       (not (equal? prevstat newstat)))
		   (begin
		     (case (string->symbol newstat)
		       ((RUNNING)   (print "##teamcity[testStarted name='" tctname "']"))
		       ((PASS SKIP) (print "##teamcity[testFinished name='" tctname "' duration='" duration "']"))
		       (else
			(print "##teamcity[testFailed name='" tctname "' message='" comment "' details='" logfile "']")))
		     (hash-table-set! data testn newstat)))))
	   tests)))
      run-ids))
    now))

(define (monitor pid)
  (let ((run-ids #f)
	(testdat (make-hash-table))
	(keys    #f)
	(last-update 0)
	(target  (or (args:get-arg "-target")
		     (args:get-arg "-reqtarg")))
	(runname (args:get-arg "-runname"))
	(tsname  (common:get-testsuite-name)))
    (if (and target runname)
	(begin
	  (launch:setup)
	  (set! keys (rmt:get-keys))))
    (let loop ()
      (handle-exceptions
       exn
       ;; (print "Process done.")
       (begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn)))
       (let-values (((pidres exittype exitstatus)
		     (process-wait pid #t)))
	 (if (and keys
		  (not run-ids))
	     (let* ((runs (rmt:get-runs-by-patt keys
						(args:get-arg "-runname")
						(or (args:get-arg "-target")(args:get-arg "-reqtarg"))
						#f ;; offset
						#f ;; limit
						#f ;; fields
						0  ;; last-update
						))
		    (header (db:get-header runs))
		    (rows   (db:get-rows   runs))
		    (run-ids-in (map (lambda (row)
				       (db:get-value-by-header row header "id"))
				     rows)))
	       (set! run-ids run-ids-in)))
	 ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids)
	 (if keys
	     (set! last-update (print-changes-since testdat run-ids last-update tsname target runname)))
	 (if (eq? pidres 0)
	     (begin
	       (thread-sleep! 3)
	       (loop))
	     (begin
	       ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids)
	       (print "TCMT: All done.")
	       )))))))

;; (if (not (eq? pidres 0))	  ;; (not exitstatus))
;; 	  (begin
;; 	    (thread-sleep! 3)
;; 	    (loop))
;; 	  (print "Process: megatest " (string-intersperse origargs " ") " is done.")))))
(define (main)
  (let* ((mt-done #f)
	 (pid     #f)
	 (th1     (make-thread (lambda ()
				 (print "Running megatest " (string-intersperse origargs " "))
				 (set! pid (process-run "megatest" origargs)))
			       "Megatest job"))
	 (th2     (make-thread (lambda ()
				 (monitor pid))
			       "Monitor job")))
    (thread-start! th1)
    (thread-sleep! 1) ;; give the process time to get going
    (thread-start! th2)
    (thread-join! th2)))

(if (args:get-arg "-tc-repl")
    (repl)
    (main))

;; (process-wait)