Megatest

;;
;; 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 regex defstruct)

(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))

(defstruct testdat
  (tc-type #f)
  (state   #f)
  (status  #f)
  (overall #f)
  flowid
  tctname
  tname
  (event-time #f)
  details
  comment
  duration
  (printed #f))

(defstruct testrecord
  last-tdat
  

(define (tcmt:print tdat)
  (let* ((comment  (if (testdat-comment tdat)
		       (conc " message='" (testdat-comment tdat))
		       ""))
	 (details  (if (testdat-details tdat)
		       (conc " details='" (testdat-details tdat))
		       ""))
	 (flowid   (conc " flowId='" (testdat-flowid   tdat) "'"))
	 (duration (conc " duration='" (* 1e3 (testdat-duration tdat)) "'"))
	 (tcname   (conc " name='" (testdat-tctname  tdat) "'")))
    (case (string->symbol (testdat-overall tdat)) ;; (testdat-tc-type tdat)
      ((RUNNING)      (print "##teamcity[testStarted "  tcname flowid "]"))
      ((COMPLETED)
       (if (member (testdat-status tdat) '("PASS" "WARN" "SKIP" "WAIVED"))
	   (print "##teamcity[testFinished " tcname flowid comment details duration "]")
	   (print "##teamcity[testFailed "   tcname flowid comment details "]")))
      ((ignore)        #f)
      (else            (print "ERROR: tc-type \"" (testdat-tc-type tdat) "\" not recognised for " tcname)))
    (flush-output)))

;; process the queue of tests gathered so far. List includes one entry for every test so far seen
;; the last record for a test is preserved. Items are only removed from the list if over 15 seconds
;; have passed since it happened. This allows for compression of COMPLETED/FAIL followed by some other
;; state/status
;;
(define (process-queue data flush-mode)
  ;; here we process tqueue and gather those over 15 seconds (configurable?) old
  (let* ((tqueue (reverse (hash-table-ref/default data 'tqueue '()))) ;; need oldest to newest
         (newtq '())
         (pqueue (make-hash-table)) ;; ( tname => ( tdat1 tdat2 ... ) ... )
         ;; (items  '())
         (targtm (- now 15))
         (leftov (if (null? tqueue)
                     '()
                     (let loop ((hed (car tqueue))
                                (tal  (cdr tqueue))
                                (new '()))
                       (let ((event-time (testdat-event-time hed))
                             (tname      (testdat-tname      hed))
                             (state      (testdat-state      hed))
                             (status     (testdat-status     hed)))
                         (cond
                          ((or flush-mode             ;; handle everything if we are in flush mode
                               (> event-time targtm)) ;; print this one
                           ;; (hash-table-set! pqueue tname (cons hed (hash-table-ref/default pqueue tname '())))
                           (set! newtq (cons hed newtq))
                           (if (null? tal)
                               new
                               (loop (car tal)
                                     (cdr tal)
                                     (if (and (equal? state "COMPLETED")
                                              (member? status '("ABORT" "CHECK" "FAIL"))) ;; keep these around
                                         (cons hed new)
                                         new))))
                          (else
                           (if (null? tal)
                               new
                               (loop (car tal)(cdr tal)(cons hed new))))))))))
    (hash-table-set! data '
    
    ;; Now have:
    ;;   leftov - items not processed, put these back in tqueue
    ;;   pqueue - candidates for printing. print but filter for COMPLETED changes
    (hash-table-set! data 'tqueue leftov) ;; handle in the future
    (hash-table-for-each
     pqueue
     (lambda (k v) ;; v is a list of tdats, if only one, just print it!
       (let ((compressed (compress-state-status v)))
         (for-each
          (lambda (tdat)
            (tcmt:print tdat))
          


         ;; (hash-table-set! data k (car (reverse v))) ;; not needed, the pqueue data is thrown away ...
             )))))
    now))




;; ##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']
;; 
;; flush; #f, normal call. #t, last call, print out something for NOT_STARTED, etc.
;;

;;;;;;;   (begin
;;;;;;;     (case (string->symbol newstat)
;;;;;;;       ((UNK)       ) ;; do nothing
;;;;;;;       ((RUNNING)   (print "##teamcity[testStarted name='" tctname "' flowId='" flowid "']"))
;;;;;;;       ((PASS SKIP WARN WAIVED) (print "##teamcity[testFinished name='" tctname "' duration='" (* 1e3 duration) "'" cmtstr details " flowId='" flowid "']"))
;;;;;;;       (else
;;;;;;; 	(print "##teamcity[testFailed name='" tctname "' " cmtstr details " flowId='" flowid "']")))
;;;;;;;     (flush-output)

(define (update-queue-since data run-ids last-update tsname target runname flowid flush) ;; 
  (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 #f last-update #f)))
	   ;; (print "DEBUG: got tests=" tests)
	   (for-each
	    (lambda (test-rec)
	      (let* ((tqueue   (hash-table-ref/default data 'tqueue '())) ;; NOTE: the key is a symbol! This allows keeping disparate info in the one hash, lazy but a quick solution for right now.
		     (tname    (db:test-get-fullname     test-rec))
		     (testname (db:test-get-testname     test-rec))
		     (itempath (db:test-get-item-path    test-rec))
		     (tctname  (if (string=? itempath "") testname (conc testname "." (string-translate itempath "/" "."))))
		     (state    (db:test-get-state        test-rec))
		     (status   (db:test-get-status       test-rec))
		     (duration (or (any->number (db:test-get-run_duration test-rec)) 0))
		     (comment  (db:test-get-comment      test-rec))
		     (logfile  (db:test-get-final_logf   test-rec))

		     (newstat  (cond
				((equal? state "RUNNING")   "RUNNING")
				((equal? state "COMPLETED") status)
				(flush   (conc state "/" status))
				(else "UNK")))
		     (cmtstr   (if (and (not flush) comment)
				   comment
				   (if flush
				       (conc "Test ended in state/status=" state "/" status  (if  (string-match "^\\s*$" comment)
												  ", no Megatest comment found."
												  (conc ", Megatest comment=\"" comment "\""))) ;; special case, we are handling stragglers
				       #f)))
		     (details  (if (string-match ".*html$" logfile)
				   (conc *toppath* "/lt/" target "/" runname "/" testname (if (equal? itempath "") "/" (conc "/" itempath "/")) logfile)
				   #f))
		     ;; (prev-tdat (hash-table-ref/default data tname #f)) 
		     (tdat      (let ((new (make-testdat)))
				  (testdat-flowid-set!     new flowid)
				  (testdat-tctname-set!    new tctname)
				  (testdat-tname-set!      new tname)
				  (testdat-comment-set!    new cmtstr)
				  (testdat-details-set!    new details)
				  (testdat-duration-set!   new duration)
				  (testdat-event-time-set! new (current-seconds))
				  (testdat-overall-set!    new newstat)
				  (hash-table-set! data tname new)
				  new)))

                (hash-table-set! data 'tqueue (cons tdat tqueue))
                (hash-table-set! data tname tdat)))
            tests)))
       run-ids)))

      
(define (monitor pid)
  (let* ((run-ids '())
	 (testdats (make-hash-table))  ;; each entry is a list of testdat structs
	 (keys    #f)
	 (last-update 0)
	 (target  (or (args:get-arg "-target")
		      (args:get-arg "-reqtarg")))
	 (runname (args:get-arg "-runname"))
	 (tsname  #f)
	 (flowid  (conc target "/" runname)))
    (if (and target runname)
	(begin
	  (launch:setup)
	  (set! keys (rmt:get-keys))))
    (set! tsname  (common:get-testsuite-name))
    (print "TCMT: for testsuite=" tsname " found runname=" runname ", target=" target ", keys=" keys " and successfully ran launch:setup. Using " flowid " as the flowId.")
    (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
		  (or (not run-ids)
		      (null? run-ids)))
	     (let* ((runs (rmt:get-runs-by-patt keys
						runname 

				       (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 (eq? pidres 0)
	     (begin
	       (if keys
                   (begin
                     (set! last-update (update-queue-since testdats run-ids last-update tsname target runname flowid #f))
                     (process-queue data #f)))
               (thread-sleep! 3)
	       (loop))
	     (begin
	       ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids)
	       (print "TCMT: processing any tests that did not formally complete.")
	       (print-changes-since testdats run-ids 0 tsname target runname flowid #t) ;; call in flush mode
               (process-queue data #t)
	       (print "TCMT: All done.")
	       ))))))
;;;;; )

;; (trace print-changes-since)

;; (if (not (eq? pidres 0))	  ;; (not exitstatus))
;; 	  (begin
;; 	    (thread-sleep! 3)
;; 	    (loop))
;; 	  (print "Process: megatest " (string-intersperse origargs " ") " is done.")))))
(define (main)