Megatest

# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
PREFIX=$(PWD)
CSCOPTS= 
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
           ods.scm runconfig.scm server.scm configf.scm \
           db.scm keys.scm margs.scm megatest-version.scm \
           process.scm runs.scm tasks.scm tests.scm genexample.scm \
	   fs-transport.scm http-transport.scm \
           client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \
	   tree.scm rmt.scm api.scm

GUISRCF  = dashboard-tests.scm dashboard-guimonitor.scm 

OFILES   = $(SRCFILES:%.scm=%.o)
GOFILES  = $(GUISRCF:%.scm=%.o)

ADTLSCR=mt_laststep mt_runstep mt_ezstep

	(newstatus  #f)
	(newstate   #f))
    (iup:frame
     #:title "Set fields"
     (iup:vbox
      (iup:hbox (iup:label "Comment:")
		(iup:textbox #:action (lambda (val a b)
					(cdb:remote-run db:test-set-state-status-by-id #f test-id #f #f b)
					(set! newcomment b))
			     #:value (db:test-get-comment testdat)
			     #:expand "HORIZONTAL"))
      (apply iup:hbox
	     (iup:label "STATE:" #:size "30x")
	     (let* ((btns  (map (lambda (state)
				  (let ((btn (iup:button state
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (cdb:remote-run db:test-set-state-status-by-id #f test-id state #f #f)
								    (db:test-set-state! testdat state)))))
				    btn))
				(list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ"))))
	       (vector-set! *state-status* 0
			    (lambda (state color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name state) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))
				       (iup:attribute-set! btn "BGCOLOR" newcolor))))
			       btns)))
	       btns))
      (apply iup:hbox
	     (iup:label "STATUS:" #:size "30x")
	     (let* ((btns  (map (lambda (status)
				  (let ((btn (iup:button status
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (cdb:remote-run db:test-set-state-status-by-id #f test-id #f status #f)
								    (db:test-set-status! testdat status)))))
				    btn))
				(list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
	       (vector-set! *state-status* 1
			    (lambda (status color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name status) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))
				       (iup:attribute-set! btn "BGCOLOR" newcolor))))
			       btns)))
	       btns))))))


;;======================================================================
;;
;;======================================================================
(define (examine-test test-id) ;; run-id run-key origtest)
  (let* ((testdat       (cdb:remote-run db:get-test-info-by-id #f test-id))
	 (db-path       (conc *toppath* "/megatest.db"))
	 (db-mod-time   0) ;; (file-modification-time db-path))
	 (last-update   0) ;; (current-seconds))
	 (request-update #t)
	 (db             #f))
    (if (not testdat)
	(begin
	  (debug:print 0 "ERROR: No test data found for test " test-id ", exiting")
	  (exit 1))
	(let* ((run-id        (if testdat (db:test-get-run_id testdat) #f))
	       (keydat        (if testdat (cdb:remote-run db:get-key-val-pairs #f run-id) #f))
	       (rundat        (if testdat (cdb:remote-run db:get-run-info #f run-id) #f))
	       (runname       (if testdat (db:get-value-by-header (db:get-row rundat)
								  (db:get-header rundat)
								  "runname") #f))
	       ;; These next two are intentional bad values to ensure errors if they should not
	       ;; get filled in properly.
	       (logfile       "/this/dir/better/not/exist")
	       (rundir        logfile)
	       (teststeps     (if testdat (db:get-compressed-steps test-id work-area: rundir) '()))
	       (testfullname  (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
	       (testname      (if testdat (db:test-get-testname testdat) "n/a"))
	       (testmeta      (if testdat 
				  (let ((tm (cdb:remote-run db:testmeta-get-record #f testname)))
				    (if tm tm (make-db:testmeta)))
				  (make-db:testmeta)))

	       (keystring  (string-intersperse 
			    (map (lambda (keyval)
				   ;; (conc ":" (car keyval) " " (cadr keyval)))
				   (cadr keyval))

				    (need-update   (or (and (> curr-mod-time db-mod-time)
							    (> (current-seconds) (+ last-update 2))) ;; every two seconds if db touched
						       request-update))
				    (newtestdat (if need-update 
						    (handle-exceptions
						     exn 
						     (debug:print-info 2 "test db access issue: " ((condition-property-accessor 'exn 'message) exn))
						     (cdb:remote-run db:get-test-info-by-id #f test-id )))))
			       (cond
				((and need-update newtestdat)
				 (set! testdat newtestdat)
				 (set! teststeps    (db:get-compressed-steps test-id work-area: rundir))
				 (set! logfile      (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
				 (set! rundir       (db:test-get-rundir testdat))
				 (set! testfullname (db:test-get-fullname testdat))

											      (db:test-data-get-value    x)
											      (db:test-data-get-expected x)
											      (db:test-data-get-tol      x)
											      (db:test-data-get-status   x)
											      (db:test-data-get-units    x)
											      (db:test-data-get-type     x)
											      (db:test-data-get-comment  x)))
										    (cdb:remote-run db:read-test-data #f test-id "%")))
									      "\n")))
							       (if (not (equal? currval newval))
								   (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval)))))
					  test-data))
				       ;;(dashboard:run-controls)
				       )))
				 (iup:attribute-set! tabs "TABTITLE0" "Steps")

		     (cond
		      ((<   (db:step-get-event_time a)(db:step-get-event_time b)) #t)
		      ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) 
		       (<   (db:step-get-id a)        (db:step-get-id b)))
		      (else #f)))))
      res)))

(define (:get-compressed-steps test-id #!key (work-area #f))
  (if (or (not work-area)
	  (file-exists? (conc work-area "/testdat.db")))
      (let* ((comprsteps (open-run-close db:get-steps-table #f test-id work-area: work-area)))
	(map (lambda (x)
	       ;; take advantage of the \n on time->string
	       (vector
		(vector-ref x 0)

;;  PURPOSE.

(require-extension (srfi 18) extras tcp s11n)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
(import (prefix sqlite3 sqlite3:))

(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)

;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048) 

(declare (unit http-transport))

    (vhost-map `(((* any) . ,(lambda (continue)
			       ;; open the db on the first call 
			       (if (not db)(set! db (open-db)))
			       (let* (($   (request-vars source: 'both))
				      (dat ($ 'dat))
				      (res #f))
				 (cond
				  ((equal? (uri-path (request-uri (current-request)))
					   '(/ "api"))
				   (send-response body:    (api:process-request db $) ;; the $ is the request vars proc
						  headers: '((content-type text/plain))))
				  ;; This is the /ctrl path where data is handed to the server and
				  ;; responses 
				  ((equal? (uri-path (request-uri (current-request)))
					   '(/ "ctrl"))
				   (let* ((packet (db:string->obj dat))
					  (qtype  (cdb:packet-get-qtype packet)))
				     (debug:print-info 12 "server=> received packet=" packet)

	 (thread-terminate! th2)
	 (debug:print-info 11 "got res=" res)
	 (let ((match (string-search (regexp "<body>(.*)<.body>") res)))
	   (debug:print-info 11 "match=" match)
	   (let ((final (cadr match)))
	     (debug:print-info 11 "final=" final)
	     final)))))))

;; Send "cmd" with json payload "params" to serverdat and receive result
;;
(define (http-transport:client-api-send-receive serverdat cmd params #!key (numretries 30))
  (let* ((fullurl    (if (list? serverdat)
			 (cadddr serverdat) ;; this is the uri for /api
			 (begin
			   (debug:print 0 "FATAL ERROR: http-transport:client-send-receive called with no server info")
			   (exit 1))))
	 (res        #f))
    (handle-exceptions
     exn
     (begin
       ;; TODO: Send this output to a log file so it isn't lost when running as daemon
       (print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn))
       (thread-sleep! 2)
       (if (> numretries 0)
	   (http-transport:client-api-send-receive serverdat cmd params numretries: (- numretries 1))))
     (begin
       (debug:print-info 11 "fullurl=" fullurl "\n")
       ;; set up the http-client here
       (max-retry-attempts 5)
       ;; consider all requests indempotent
       (retry-request? (lambda (request)
			 #t))   ;;  		 (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10))
       ;; (set! numretries (- numretries 1))
       ;;  		 #t))
       ;; send the data and get the response
       ;; extract the needed info from the http data and 
       ;; process and return it.

       ;; (with-input-from-request "http://localhost/echo-service"
       ;;                  '((test . "value")) read-string)

       (let* ((send-recieve (lambda ()
			      (mutex-lock! *http-mutex*)
			      (set! res (with-input-from-request 
					 fullurl 
					 (list (cons 'key "thekey")
					       (cons 'cmd cmd)
					       (cons 'params params))
					 read-string))
			      (close-all-connections!) 
			      (mutex-unlock! *http-mutex*)))
	      (time-out     (lambda ()
			      (thread-sleep! 45)
			      (if (not res)
				  (begin
				    (debug:print 0 "WARNING: communication with the server timed out.")
				    (mutex-unlock! *http-mutex*)
				    (http-transport:client-api-send-receive serverdat cmd vars numretries: (- numretries 1))
				    (if (< numretries 3) ;; on last try just exit
					(begin
					  (debug:print 0 "ERROR: communication with the server timed out. Giving up.")
					  (exit 1)))))))
	      (th1 (make-thread send-recieve "with-input-from-request"))
	      (th2 (make-thread time-out     "time out")))
	 (thread-start! th1)
	 (thread-start! th2)
	 (thread-join! th1)
	 (thread-terminate! th2)
	 (debug:print-info 11 "got res=" res)
	 res)))))

(define (http-transport:client-connect iface port)
  (let* ((login-res   #f)
	 (uri-dat     (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl"))))
	 (uri-api-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/api"))))
	 (serverdat   (list iface port uri-dat uri-api-dat)))
    (set! login-res (client:login serverdat))
    (if (and (not (null? login-res))
	     (car login-res))
	(begin
	  (debug:print-info 2 "Logged in and connected to " iface ":" port)
	  (set! *runremote* serverdat)
	  serverdat)

(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
(declare (uses daemon))
(declare (uses db))
(declare (uses mt))
(declare (uses api))

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")

	  full-list))))

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

(define (mt:get-run-stats)
  (cdb:remote-run db:get-run-stats #f))

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