Megatest

tcmt.scm at [60b31fb56a]
Login

File tcmt.scm artifact 2cd967b1fa part of check-in 60b31fb56a


;; Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================
;;
;; 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
;;

(declare (uses mtargs))
(declare (uses rmt))
(declare (uses rmtmod))
(declare (uses common))
;; (declare (uses megatest-version))
(declare (uses commonmod))

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

(use trace)
;; (trace-call-sites #t)

(import commonmod
	rmtmod
	(prefix mtargs args:))

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

(define origargs (cdr (argv)))
(define remargs (args:get-args
		 (argv)
		 `( "-target"
		    "-reqtarg"
		    "-runname"
		    "-delay"   ;; how long to wait for unexpected changes to 
		    )
		 `("-tc-repl"
		   )
		 args:arg-hash
		 0))

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

;;======================================================================
;; GLOBALS
;;======================================================================

;; Gotta have a global? Stash it in the *global* hash table.
;;
(define *global* (make-hash-table))

(define (tcmt:print tdat flush-mode)
  (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) "'"))
	 (state    (string->symbol (testdat-state tdat)))
	 (status   (string->symbol (testdat-status tdat)))
	 (startp   (testdat-start-printed tdat))
	 (endp     (testdat-end-printed   tdat))
	 (etime    (testdat-event-time    tdat))
	 (overall  (case state
		     ((RUNNING)   state)
		     ((COMPLETED) state)
		     (else 'UNK)))
	 (tstmp    (conc " timestamp='" (time->string (seconds->local-time etime) "%FT%T.000") "'")))
    (case overall
      ((RUNNING)
       (if (not startp)
	   (begin
	     (print "##teamcity[testStarted "  tcname flowid tstmp "]")
	     (testdat-start-printed-set! tdat #t))))
      ((COMPLETED)
       (if (not startp) ;; start stanza never printed
	   (begin
	     (print "##teamcity[testStarted " tcname flowid tstmp "]")
	     (testdat-start-printed-set! tdat #t)))
       (if (not endp)
	   (begin
	     (if (not (member status '(PASS WARN SKIP WAIVED)))
		 (print "##teamcity[testFailed  " tcname flowid comment details "]"))
             (print "##teamcity[testFinished" tcname flowid comment details duration "]")
	     (testdat-end-printed-set! tdat #t))))
      (else
       (if flush-mode
	   (begin
	     (if (not startp)
		 (begin
		   (print "##teamcity[testStarted " tcname flowid tstmp "]")
		   (testdat-start-printed-set! tdat #t)))
	     (if (not endp)
		 (begin
		   (print "##teamcity[testFailed  " tcname flowid comment details "]")
                   (print "##teamcity[testFinished" tcname flowid comment details duration "]")
		   (testdat-end-printed-set! tdat #t)))))))
    ;; (print "ERROR: tc-type \"" (testdat-tc-type tdat) "\" not recognised for " tcname)))
    (flush-output)))

;; ;; returns values: flag newlst
;; (define (remove-duplicate-completed  tdats)
;;   (let* ((flag       #f)
;;          (state      (testdat-state      tdat))
;;          (status     (testdat-status     tdat))
;;          (event-time (testdat-event-time tdat))
;;          (tname      (testdat-tname      tdat)))
;;     (let loop ((hed (car tdats))
;;                (tal (cdr tdats))
;;                (new '()))
;;       (if (and (equal? state "COMPLETED")
;;                (equal? tname (testdat-tname hed))
;;                (equal? state (testdat-state hed))) ;; we have a duplicate COMPLETED call
;;           (begin
;;             (set! flag #t) ;; A changed completed
            
;; 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 age flush-mode)
  ;; here we process tqueue and gather those over 15 seconds (configurable?) old
  (let* ((print-time (- (current-seconds) age)) ;; print stuff over 15 seconds old
         (tqueue-raw (hash-table-ref/default data 'tqueue '()))
         (tqueue     (reverse (delete-duplicates tqueue-raw     ;; REMOVE duplicates by testname and state
                                                 (lambda (a b)
                                                   (and (equal? (testdat-tname a)(testdat-tname b))        ;; need oldest to newest
                                                        (equal? (testdat-state a) (testdat-state b)))))))) ;; "COMPLETED")
    ;; (equal? (testdat-state b) "COMPLETED")))))))
    (if (not (null? tqueue))
        (hash-table-set!
         data
         'tqueue
         (let loop ((hed (car tqueue)) ;; by this point all duplicates by state COMPLETED are removed
                    (tal (cdr tqueue))
                    (rem '()))
           (if (> print-time (testdat-event-time hed)) ;; event happened over 15 seconds ago
               (begin
                 (tcmt:print hed flush-mode)
                 (if (null? tal)
                     rem ;; return rem to be processed in the future
                     (loop (car tal)(cdr tal) rem)))
               (if (null? tal)
                   (cons hed rem) ;; return rem + hed for future processing
                   (loop (car tal)(cdr tal)(cons hed rem)))))))))

;; ##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)

;; (trace rmt:get-tests-for-run)

(define (update-queue-since data run-ids last-update tsname target runname flowid flush #!key (delay-flag #t)) ;; 
  (let ((now           (current-seconds))
	(still-running #f))
;; (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.
		     (is-top   (db:test-get-is-toplevel  test-rec))
		     (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))
		     (etime    (db:test-get-event_time   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))
                     (hostn    (db:test-get-host         test-rec))
                     (pid      (db:test-get-process_id   test-rec))
		     (test-cont (> (+ etime duration 40) (current-seconds))) ;; test has not been over for more than 20 seconds
		     (adj-state (if delay-flag
				    (if test-cont
					(begin
					  (set! still-running #t)
					  "RUNNING")
					state)
				    state))
		     (newstat  (cond
                                ;; ((or (not delay-flag)
				;;      (< (+ etime duration)
				;; 	(- (current-seconds) 10)))
				;; 	(print "Skipping as delay hasn't hit") "RUNNING") 
				((equal? adj-state "RUNNING")
				 (set! still-running #t)
				 "RUNNING")
				((equal? adj-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      (if is-top
				    #f
				    (let ((new (or prev-tdat (make-testdat)))) ;; recycle the record so we keep track of already printed items
				      (testdat-flowid-set!     new (or (testdat-flowid new)
                                                                       (if (eq? pid 0)
                                                                           tctname
                                                                           (conc hostn "-" pid))))
				      (testdat-tctname-set!    new tctname)
				      (testdat-tname-set!      new tname)
				      (testdat-state-set!      new adj-state)
				      (testdat-status-set!     new status)
				      (testdat-comment-set!    new cmtstr)
				      (testdat-details-set!    new details)
				      (testdat-duration-set!   new duration)
				      (testdat-event-time-set! new etime) ;; (current-seconds))
				      (testdat-overall-set!    new newstat)
				      (hash-table-set! data tname new)
				      new))))
		(if (not is-top)
		    (hash-table-set! data 'tqueue (cons tdat tqueue))) 
                (hash-table-set! data tname tdat)
                ))
            tests)))
       run-ids)
      (list now still-running)))

(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))
	 (tdelay  (string->number (or (args:get-arg "-delay") "15"))))
    (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 
						target
						#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 (eq? pidres 0)
	     (begin
	       (if keys
                   (begin
                     (set! last-update (- (car (update-queue-since testdats run-ids last-update tsname target runname flowid #f delay-flag: #t)) 5))
                     (process-queue testdats tdelay #f)))
               (thread-sleep! 3)
	       (loop)))))
    ;; the megatest runner is done - now wait for all processes to be COMPLETED or NO Processes to be RUNNING > 1 minute
    (let loop ()
      (let* ((new-last-update-info (update-queue-since testdats run-ids last-update tsname target runname flowid #f delay-flag: #t))
	     (still-running        (cadr new-last-update-info))
	     (new-last-update      (- (car new-last-update-info) 5)))
	(process-queue testdats tdelay #f)
	(if still-running
	    (begin
	      (print "TCMT: Tests still running, keep watching...")
	      (thread-sleep! 3)
	      (loop)))))
    
    ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids)
    (print "TCMT: processing any tests that did not formally complete.")
    (update-queue-since testdats run-ids 0 tsname target runname flowid #t #f delay-flag: #f) ;; call in flush mode
    (process-queue testdats 0 #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.")))))

(if (file-exists? ".tcmtrc")
    (load ".tcmtrc"))

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