Megatest

			      (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
			      (if *task-db*    
				  (let ((db (cdr *task-db*)))
				    (if (sqlite3:database? db)
					(begin
					  (sqlite3:interrupt! db)
					  (sqlite3:finalize! db #t)
					  (vector-set! *task-db* 0 #f)))))
					  ;; (vector-set! *task-db* 0 #f)
					  (set! *task-db* #f)))))
			      (close-output-port *default-log-port*)
			      (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
	  (th2 (make-thread (lambda ()
			      (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
			      (if no-hurry
				  (thread-sleep! 5) ;; give the clean up few seconds to do it's stuff
				  (thread-sleep! 2))

       (let* ((send-recieve (lambda ()
			      (mutex-lock! *http-mutex*)
			      ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines)
			      ;;					       ((exn http client-error) e (print e)))
			      (set! res (vector
					 success
					 (db:string->obj 
					  ;; handle-exceptions
					  ;; exn
					  ;; (begin
					  ;;   (set! success #f)
					  ;;   (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
					  ;;   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
					  ;;   (if *runremote*
                                          ;;       (remote-conndat-set! *runremote* #f))
					  ;;   ;; Killing associated server to allow clean retry.")
					  ;;   ;; (tasks:kill-server-run-id run-id)  ;; better to kill the server in the logic that called this routine?
					  ;;   (mutex-unlock! *http-mutex*)
					  ;;   ;;; (signal (make-composite-condition
					  ;;   ;;;          (make-property-condition 'commfail 'message "failed to connect to server")))
					  ;;   ;;; "communications failed"
					  ;;   (db:obj->string #f))
					  (handle-exceptions
					   exn
					   (begin
					     (set! success #f)
					     (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
					     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
					     (if *runremote*
                                                 (remote-conndat-set! *runremote* #f))
					     ;; Killing associated server to allow clean retry.")
					     ;; (tasks:kill-server-run-id run-id)  ;; better to kill the server in the logic that called this routine?
					     (mutex-unlock! *http-mutex*)
					     ;;; (signal (make-composite-condition
					     ;;;          (make-property-condition 'commfail 'message "failed to connect to server")))
					     ;;; "communications failed"
					     (db:obj->string #f))
					   (with-input-from-request ;; was dat
					    fullurl 
					    (list (cons 'key "thekey")
						  (cons 'cmd cmd)
						  (cons 'params sparams))
					    read-string)
                                           transport: 'http)
                                           transport: 'http))
                                         0)) ;; added this speculatively
			      ;; Shouldn't this be a call to the managed call-all-connections stuff above?
			      (close-all-connections!)
			      (mutex-unlock! *http-mutex*)
			      ))
	      (time-out     (lambda ()
			      (thread-sleep! 45)

;; 	     (> rem-time 0))
;; 	(thread-sleep! rem-time)
;; 	(thread-sleep! 4))) ;; fallback for if the math is changed ...

(define (http-transport:server-shutdown server-id port)
  (let ((tdbdat (tasks:open-db)))
    (debug:print-info 0 *default-log-port* "Starting to shutdown the server.")
    ;; need to delete only *my* server entry (future use)
    ;; (if *dbstruct-db* (db:sync-touched *dbstruct-db* *run-id* force-sync: #t)) ;; handled in the watchdog only
    (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up
    ;;
    ;; start_shutdown
    ;;
    (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
    (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up
    (portlogger:open-run-close portlogger:set-port port "released")
    (thread-sleep! 5)
    (debug:print-info 0 *default-log-port* "Max cached queries was    " *max-cache-size*)
    (debug:print-info 0 *default-log-port* "Number of cached writes   " *number-of-writes*)
    (debug:print-info 0 *default-log-port* "Average cached write time "
		      (if (eq? *number-of-writes* 0)
			  "n/a (no writes)"

		(else
		 (pp data))))))
      (if out-file (close-output-port out-port))
      (exit) ;; yes, bending the rules here - need to exit since this is a utility
      ))

(if (args:get-arg "-ping")
    (let* (;; (run-id        (string->number (args:get-arg "-run-id")))
    (let* ((server-id     (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":"
	   (host:port     (args:get-arg "-ping")))
      (server:ping host:port)))
      (server:ping (or server-id host:port) do-exit: #t)))

;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================

;; NOTE: Keep these above the section where the server or client code is setup

     ((> attemptnum 15)
      (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.")
      (exit 1))
     ;; ensure we have a record for our connection for given area
     ((not *runremote*)                     
      (set! *runremote* (make-remote))
      (mutex-unlock! *rmt-mutex*)
      ;; (print "case 1")
      (print "case 1")
      (rmt:send-receive cmd rid params attemptnum: attemptnum))
     ;; ensure we have a homehost record
     ((not (pair? (remote-hh-dat *runremote*)))  ;; have a homehost record?
      (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
      (remote-hh-dat-set! *runremote* (common:get-homehost))
      (mutex-unlock! *rmt-mutex*)
      ;; (print "case 2")
      (print "case 2")
      (rmt:send-receive cmd rid params attemptnum: attemptnum))
     ;; on homehost and this is a read
     ((and (cdr (remote-hh-dat *runremote*))   ;; on homehost
           (member cmd api:read-only-queries)) ;; this is a read
      (mutex-unlock! *rmt-mutex*)
      ;; (print "case 3")
      (print "case 3")
      (rmt:open-qry-close-locally cmd 0 params))
     ;; on homehost and this is a write, we already have a server
     ((and (cdr (remote-hh-dat *runremote*))         ;; on homehost
           (not (member cmd api:read-only-queries))  ;; this is a write
           (remote-server-url *runremote*))          ;; have a server
      (mutex-unlock! *rmt-mutex*)
      ;; (print "case 4")
      (print "case 4")
      (rmt:open-qry-close-locally cmd 0 params))
     ;; no server contact made and this is a write, passively start a server 
     ((and (not (remote-server-url *runremote*))
	   (not (member cmd api:read-only-queries)))
      ;; (print "case 5")
      (print "case 5")
      (let ((serverconn (server:check-if-running *toppath*)))
	(if serverconn
	    (remote-server-url-set! *runremote* serverconn) ;; the string can be consumed by the client setup if needed
	    (if (not (server:start-attempted? *toppath*))
		(server:kind-run *toppath*))))
      (if (cdr (remote-hh-dat *runremote*)) ;; we are on the homehost, just do the call
          (begin
            (mutex-unlock! *rmt-mutex*)
	    (print "case 5.1")
            (rmt:open-qry-close-locally cmd 0 params))
          (begin
            (mutex-unlock! *rmt-mutex*)
	    (print "case 5.2")
	    (tasks:start-and-wait-for-server (tasks:open-db) 0 15)
            (rmt:send-receive cmd rid params attemptnum: attemptnum))))
     ;; if not on homehost ensure we have a connection to a live server
     ;; NOTE: we *have* a homehost record by now
     ((and (not (cdr (remote-hh-dat *runremote*)))        ;; are we on a homehost?
           (not (remote-conndat *runremote*)))            ;; and no connection
      ;; (print "case 6  hh-dat: " (remote-hh-dat *runremote*) " conndat: " (remote-conndat *runremote*))
      (print "case 6  hh-dat: " (remote-hh-dat *runremote*) " conndat: " (remote-conndat *runremote*))
      (mutex-unlock! *rmt-mutex*)
      (tasks:start-and-wait-for-server (tasks:open-db) 0 15)
      (remote-conndat-set! *runremote* (rmt:get-connection-info 0))
      (rmt:send-receive cmd rid params attemptnum: attemptnum))
     ;; all set up if get this far, dispatch the query
     ((cdr (remote-hh-dat *runremote*)) ;; we are on homehost
      (mutex-unlock! *rmt-mutex*)
      ;; (print "case 7")
      (print "case 7")
      (rmt:open-qry-close-locally cmd (if rid rid 0) params))
     ;; reset the connection if it has been unused too long
     ((and (remote-conndat *runremote*)
	   (let ((expire-time (- start-time (remote-server-timeout *runremote*))))
	     (< (http-transport:server-dat-get-last-access (remote-conndat *runremote*)) expire-time)))
      ;; (print "case 8")
      (print "case 8")
      (remote-conndat-set! *runremote* #f))
     ;; not on homehost, do server query
     (else
      (mutex-unlock! *rmt-mutex*)
      ;; (print "case 9")
      (print "case 9")
      (let* ((conninfo (remote-conndat *runremote*))
	     (dat      (case (remote-transport *runremote*)
			 ((http) ;; (condition-case ;; handling here has caused a lot of problems.
			 ((http) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away
                                  (http-transport:client-api-send-receive 0 conninfo cmd params)
                                  ;; ((commfail)(vector #f "communications fail"))
                                  ;; ((exn)(vector #f "other fail" (print-call-chain)))))
                                  ((commfail)(vector #f "communications fail"))
                                  ((exn)(vector #f "other fail" (print-call-chain)))))
                                  )
			 (else
			  (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported")
			  (exit))))
	     (success  (if (vector? dat) (vector-ref dat 0) #f))
	     (res      (if (vector? dat) (vector-ref dat 1) #f)))
	(if (vector? conninfo)(http-transport:server-dat-update-last-access conninfo)) ;; refresh access time
        ;; (print "case 9. conninfo=" conninfo " dat=" dat)
        (print "case 9. conninfo=" conninfo " dat=" dat)
	(if success
	    (case (remote-transport *runremote*)
	      ((http) res)
	      (else
	       (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " is unknown")
	       (exit 1)))
	    (begin
	      (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
	      (remote-conndat-set!    *runremote* #f)
	      (remote-server-url-set! *runremote* #f)
              ;; (print "case 9.1")
              (print "case 9.1")
	      (tasks:start-and-wait-for-server (tasks:open-db) 0 15)
	      (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))))))))

(define (rmt:update-db-stats run-id rawcmd params duration)
  (mutex-lock! *db-stats-mutex*)
  (handle-exceptions
   exn

  (rmt:send-receive 'start-server 0 (list run-id)))

;;======================================================================
;;  M I S C
;;======================================================================

(define (rmt:login run-id)
  (rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
  (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*)))

;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
(define (rmt:login-no-auto-client-setup connection-info)
  (case *transport-type* ;; run-id of 0 is just a placeholder
    ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login 0 (list *toppath* megatest-version *my-client-signature*)))

	#f)))

;; called in megatest.scm, host-port is string hostname:port
;;
;; NOTE: This is NOT called directly from clients as not all transports support a client running
;;       in the same process as the server.
;;
(define (server:ping host:port)
  (let ((tdbdat (tasks:open-db)))
(define (server:ping host-port-in #!key (do-exit #f))
  (let ((host:port (if (number? host-port-in) ;; we were handed a server-id
		       (let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in)))
			 ;; (print "srec: " srec " host-port-in: " host-port-in)
			 (if srec
			     (conc (vector-ref srec 3) ":" (vector-ref srec 4))
			     (conc "no such server-id " host-port-in)))
		       host-port-in)))
    (let* ((host-port (let ((slst (string-split   host:port ":")))
			(if (eq? (length slst) 2)
			    (list (car slst)(string->number (cadr slst)))
			    #f)))
	   (toppath       (launch:setup)))
      ;; (print "host-port=" host-port)
      (if (not host-port)
	  (begin
	    (print "ERROR: bad host:port")
	    (exit 1))
	  (let* ((iface      (if host-port (car host-port) (tasks:hostinfo-get-interface server-db-dat)))
		 (port       (if host-port (cadr host-port)(tasks:hostinfo-get-port      server-db-dat)))
	    (debug:print 0 *default-log-port*  "ERROR: bad host:port")
	    (if do-exit (exit 1)))
	  (let* ((iface      (car host-port))
		 (port       (cadr host-port))
		 (server-dat (http-transport:client-connect iface port))
		 (login-res  (rmt:login-no-auto-client-setup server-dat)))
	    (if (and (list? login-res)
		     (car login-res))
		(begin
		  (print "LOGIN_OK")
		  (exit 0))
		  (if do-exit (exit 0)))
		(begin
		  (print "LOGIN_FAILED")
		  (exit 1))))))))
		  (if do-exit (exit 1)))))))))

;; run ping in separate process, safest way in some cases
;;
(define (server:ping-server ifaceport)
  (with-input-from-pipe 
   (conc (common:get-megatest-exe) " -ping " ifaceport)
   (lambda ()

     (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)
       ;;                       0  1     2         3      4     5          6        7     8          9          10        11     12
       (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res)))
     mdb
     "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id 
        FROM servers WHERE state NOT LIKE 'defunct%' ORDER BY start_time DESC;")
    res))

(define (tasks:get-server-by-id mdb id)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)
       ;;                       0  1     2         3      4     5          6        7     8          9          10        11     12
       (set! res (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)))
     mdb
     "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id 
        FROM servers WHERE id=?;"
     id)
    res))

(define (tasks:get-server-records mdb run-id)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)
       ;;                       0  1     2         3      4     5          6        7     8          9          10        11     12
       (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res)))

		      (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
		      (configf:write-alist tcfg tpath)))
		tcfg))))))
  
;; sort tests by priority and waiton
;; Move test specific stuff to a test unit FIXME one of these days
(define (tests:sort-by-priority-and-waiton test-records)
  (if (eq? (hash-table-size test-records) 0)
      '()
  (let* ((mungepriority (lambda (priority)
			  (if priority
			      (let ((tmp (any->number priority)))
				(if tmp tmp (begin (debug:print-error 0 *default-log-port* "bad priority value " priority ", using 0") 0)))
			      0)))
	 (all-tests      (hash-table-keys test-records))
	 (all-waited-on  (let loop ((hed (car all-tests))
				    (tal (cdr all-tests))
				    (res '()))
			   (let* ((trec    (hash-table-ref test-records hed))
				  (waitons (or (tests:testqueue-get-waitons trec) '())))
			     (if (null? tal)
				 (append res waitons)
				 (loop (car tal)(cdr tal)(append res waitons))))))
	 (sort-fn1 
	  (lambda (a b)
	    (let* ((a-record   (hash-table-ref test-records a))
		   (b-record   (hash-table-ref test-records b))
		   (a-waitons  (or (tests:testqueue-get-waitons a-record) '()))
		   (b-waitons  (or (tests:testqueue-get-waitons b-record) '()))
		   (a-config   (tests:testqueue-get-testconfig  a-record))
		   (b-config   (tests:testqueue-get-testconfig  b-record))
		   (a-raw-pri  (config-lookup a-config "requirements" "priority"))
		   (b-raw-pri  (config-lookup b-config "requirements" "priority"))
		   (a-priority (mungepriority a-raw-pri))
		   (b-priority (mungepriority b-raw-pri)))
	      (tests:testqueue-set-priority! a-record a-priority)
	      (tests:testqueue-set-priority! b-record b-priority)
	      ;; (debug:print 0 *default-log-port* "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons)
	      (cond
	       ;; is 
	       ((member a b-waitons)          ;; is b waiting on a?
		;; (debug:print 0 *default-log-port* "case1")
		#t)
	       ((member b a-waitons)          ;; is a waiting on b?
		;; (debug:print 0 *default-log-port* "case2")
		#f)
	       ((and (not (null? a-waitons))  ;; both have waitons - do not disturb
		     (not (null? b-waitons)))
		;; (debug:print 0 *default-log-port* "case2.1")
		#t)
	       ((and (null? a-waitons)        ;; no waitons for a but b has waitons
		     (not (null? b-waitons)))
		;; (debug:print 0 *default-log-port* "case3")
		#f)
	       ((and (not (null? a-waitons))  ;; a has waitons but b does not
		     (null? b-waitons)) 
		;; (debug:print 0 *default-log-port* "case4")
		#t)
	       ((not (eq? a-priority b-priority)) ;; use
		(> a-priority b-priority))
	       (else
		;; (debug:print 0 *default-log-port* "case5")
		(string>? a b))))))
	 
	 (sort-fn2
	  (lambda (a b)
	    (> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a)))
	       (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records b)))))))
    ;; (let ((dot-res (tests:run-dot (tests:tests->dot test-records) "plain")))
    ;;   (debug:print "dot-res=" dot-res))
    ;; (let ((data (map cdr (filter
    ;;     		  (lambda (x)(equal? "node" (car x)))
    ;;     		  (map string-split (tests:easy-dot test-records "plain"))))))
    ;;   (map car (sort data (lambda (a b)
    ;;     		    (> (string->number (caddr a))(string->number (caddr b)))))))
    ;; ))
    (sort all-tests sort-fn1))) ;; avoid dealing with deleted tests, look at the hash table
      (let* ((mungepriority (lambda (priority)
			      (if priority
				  (let ((tmp (any->number priority)))
				    (if tmp tmp (begin (debug:print-error 0 *default-log-port* "bad priority value " priority ", using 0") 0)))
				  0)))
	     (all-tests      (hash-table-keys test-records))
	     (all-waited-on  (let loop ((hed (car all-tests))
					(tal (cdr all-tests))
					(res '()))
			       (let* ((trec    (hash-table-ref test-records hed))
				      (waitons (or (tests:testqueue-get-waitons trec) '())))
				 (if (null? tal)
				     (append res waitons)
				     (loop (car tal)(cdr tal)(append res waitons))))))
	     (sort-fn1 
	      (lambda (a b)
		(let* ((a-record   (hash-table-ref test-records a))
		       (b-record   (hash-table-ref test-records b))
		       (a-waitons  (or (tests:testqueue-get-waitons a-record) '()))
		       (b-waitons  (or (tests:testqueue-get-waitons b-record) '()))
		       (a-config   (tests:testqueue-get-testconfig  a-record))
		       (b-config   (tests:testqueue-get-testconfig  b-record))
		       (a-raw-pri  (config-lookup a-config "requirements" "priority"))
		       (b-raw-pri  (config-lookup b-config "requirements" "priority"))
		       (a-priority (mungepriority a-raw-pri))
		       (b-priority (mungepriority b-raw-pri)))
		  (tests:testqueue-set-priority! a-record a-priority)
		  (tests:testqueue-set-priority! b-record b-priority)
		  ;; (debug:print 0 *default-log-port* "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons)
		  (cond
		   ;; is 
		   ((member a b-waitons)          ;; is b waiting on a?
		    ;; (debug:print 0 *default-log-port* "case1")
		    #t)
		   ((member b a-waitons)          ;; is a waiting on b?
		    ;; (debug:print 0 *default-log-port* "case2")
		    #f)
		   ((and (not (null? a-waitons))  ;; both have waitons - do not disturb
			 (not (null? b-waitons)))
		    ;; (debug:print 0 *default-log-port* "case2.1")
		    #t)
		   ((and (null? a-waitons)        ;; no waitons for a but b has waitons
			 (not (null? b-waitons)))
		    ;; (debug:print 0 *default-log-port* "case3")
		    #f)
		   ((and (not (null? a-waitons))  ;; a has waitons but b does not
			 (null? b-waitons)) 
		    ;; (debug:print 0 *default-log-port* "case4")
		    #t)
		   ((not (eq? a-priority b-priority)) ;; use
		    (> a-priority b-priority))
		   (else
		    ;; (debug:print 0 *default-log-port* "case5")
		    (string>? a b))))))
	     
	     (sort-fn2
	      (lambda (a b)
		(> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a)))
		   (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records b)))))))
	;; (let ((dot-res (tests:run-dot (tests:tests->dot test-records) "plain")))
	;;   (debug:print "dot-res=" dot-res))
	;; (let ((data (map cdr (filter
	;;     		  (lambda (x)(equal? "node" (car x)))
	;;     		  (map string-split (tests:easy-dot test-records "plain"))))))
	;;   (map car (sort data (lambda (a b)
	;;     		    (> (string->number (caddr a))(string->number (caddr b)))))))
	;; ))
	(sort all-tests sort-fn1)))) ;; avoid dealing with deleted tests, look at the hash table

(define (tests:easy-dot test-records outtype)
  (let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX"))))
    (let ((all-testnames (hash-table-keys test-records))
	  (temp-port     (open-output-file* fd)))
      ;; (format temp-port "This file is ~A.~%" temp-path)
      (format temp-port "digraph tests {\n")

#!/bin/bash

# Usage: rununittest.sh testname debuglevel
#
banner $1

# put megatest on path from correct location
mtbindir=$(readlink -f ../bin)

export PATH="${mtbindir}:$PATH"

# Clean setup
#
dbdir=$(echo /tmp/$USER/megatest_localdb/simplerun/.[a-zA-Z]*/)
dbdir=$(cd simplerun;megatest -show-config -section setup -var linktree)/.db
rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db $dbdir/*.db
echo "dbdir=$dbdir"
rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db $dbdir
rm -rf simplelinks/ simpleruns/ simplerun/db/ $dbdir
mkdir -p simplelinks simpleruns
(cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm)
(cd simplerun;cp ../../altdb.scm .)

# Run the test $1 is the unit test to run
cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1

(delete-file* "logs/1.log")
(define run-id 1)

(test "setup for run" #t (begin (launch:setup)
 				(string? (getenv "MT_RUN_AREA_HOME"))))

(test #f #t (and (server:kind-run *toppath*) #t))
;; NON Server tests go here


(define user    (current-user-name))
(define runname "mytestrun")
(define keys    (rmt:get-keys))
(define runinfo #f)
(define keyvals '(("SYSTEM" "abc")("RELEASE" "def")))
(define header  (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time"))
(test #f #f (db:dbdat-get-path *db*))
(test #f #f (db:get-run-name-from-id *db* run-id))
;; (test #f '("SYSTEM" "RELEASE") (rmt:get-keys))

;; Setup
;;
;; (test #f #f  (not (client:setup run-id)))
;; (test #f #f  (not (hash-table-ref/default *runremote* run-id #f)))

;; Login
;;
(test #f'(#t "successful login")
      (rmt:login run-id))

;; Keys
;;
(test #f '("SYSTEM" "RELEASE")  (rmt:get-keys))

;; No data in db
;; (exit)
;;
(test #f '() (rmt:get-all-run-ids))
(test #f #f  (rmt:get-run-name-from-id run-id))
(test #f 
      (vector
       header
       (vector #f #f #f #f))
      (rmt:get-run-info run-id))

;; Insert data into db
;;
(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user))
;; (test #f #f (rmt:get-runs-by-patt keys runname))
(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" ""))
(define test-one-id #f)
(test #f 1  (let ((test-id (rmt:get-test-id run-id "test-one" "")))
	      (set! test-one-id test-id)
	      test-id))
(define test-one-rec #f)
(test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id)))
		      (set! test-one-rec test-rec)
		      (vector-ref test-rec 2)))

;; With data in db
;;
(print "Using runame=" runname)
(test #f '(1)    (rmt:get-all-run-ids))
(test #f runname (rmt:get-run-name-from-id run-id))
(test #f 
      runname
      (let ((run-info (rmt:get-run-info run-id)))
	(db:get-value-by-header (db:get-rows run-info)
				(db:get-header run-info)
				"runname")))

;; test killing server
;;
(for-each
 (lambda (run-id)
   (test #f #t (and (tasks:kill-server-run-id run-id) #t))
   (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)))
 (list 0 1))

;; Tests to assess reading/writing while servers are starting/stopping
;; NO LONGER APPLICABLE

;; Server tests go here 
;; Server tests go here
(define (server-tests-dont-run-right-now)
(for-each
 (lambda (run-id)
   (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))
   (server:kind-run run-id)
   (test "did server start within 20 seconds?"
	 #t
	 (let loop ((remtries 20)

	       (begin
		 (if (> remtries 0)
		     (begin
		       (thread-sleep! 1.1)
		       (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id)))
		     res)))))
   )
 (list 0 1))
 (list 0 1)))

(define user    (current-user-name))
(define runname "mytestrun")
(define keys    (rmt:get-keys))
(define runinfo #f)
(define keyvals '(("SYSTEM" "abc")("RELEASE" "def")))
(define header  (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time"))

;; Setup
;;
(test #f #f  (not (client:setup run-id)))
(test #f #f  (not (hash-table-ref/default *runremote* run-id #f)))

;; Login
;;
(test #f'(#t "successful login")
      (rmt:login-no-auto-client-setup (hash-table-ref/default *runremote* run-id #f) run-id))
(test #f '(#t "successful login")
      (rmt:login run-id))

;; Keys
;;
(test #f '("SYSTEM" "RELEASE")  (rmt:get-keys))

;; No data in db
;;
(test #f '() (rmt:get-all-run-ids))
(test #f #f  (rmt:get-run-name-from-id run-id))
(test #f 
      (vector
       header
       (vector #f #f #f #f))
      (rmt:get-run-info run-id))

;; Insert data into db
;;
(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user))
;; (test #f #f (rmt:get-runs-by-patt keys runname))
(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" ""))
(define test-one-id #f)
(test #f 30001  (let ((test-id (rmt:get-test-id run-id "test-one" "")))
	      (set! test-one-id test-id)
	      test-id))
(define test-one-rec #f)
(test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id)))
		      (set! test-one-rec test-rec)
		      (vector-ref test-rec 2)))

;; With data in db
;;
(print "Using runame=" runname)
(test #f '(1)    (rmt:get-all-run-ids))
(test #f runname (rmt:get-run-name-from-id run-id))
(test #f 
      runname
      (let ((run-info (rmt:get-run-info run-id)))
	(db:get-value-by-header (db:get-rows run-info)
				(db:get-header run-info)
				"runname")))

(for-each (lambda (run-id)
;; test killing server
;;
(tasks:kill-server-run-id run-id)

(test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))
)
(list 0 1))

;; Tests to assess reading/writing while servers are starting/stopping
(define start-time (current-seconds))
(define (reading-writing-while-server-starting-stopping-dont-run-now)
(let loop ((test-state 'start))
  (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id))
	 (first-dat   (if (not (null? server-dats))
			  (car server-dats)
			  #f)))
    (map (lambda (dat)
	   (apply print (intersperse (vector->list dat) ", ")))

	  (rmt:kill-server run-id)
	  (loop 'server-shutdown))
	 ((shutting-down)
	  (loop test-state))
	 (else (print "Don't know what to do if get here"))))
      ((server-shutdown)
       (loop test-state)))))

)
;;======================================================================
;; END OF TESTS
;;======================================================================


;; (test #f #f (client:setup run-id))

(define keys (rmt:get-keys))

(test #f #t (and (server:kind-run *toppath*) #t))

(test "get all legal tests" (list "test1" "test2") (sort (hash-table-keys (tests:get-all)) string<=?))

(test "register-run" #t (number?
			 (rmt:register-run 
					  '(("SYSTEM" "key1")("RELEASE" "key2"))
					  "myrun" 
					  "new"
					  "n/a" 
					  "bob")))

(test #f #t             (rmt:register-test 1 "nada" ""))
(test #f 30001          (rmt:get-test-id 1 "nada" ""))
(test #f "NOT_STARTED"  (vector-ref (rmt:get-test-info-by-id 1 30001) 3)) ;; "nada" "") 3))
(test #f 1              (rmt:get-test-id 1 "nada" ""))
(test #f "NOT_STARTED"  (vector-ref (rmt:get-test-info-by-id 1 1) 3))

(test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def"))
(test #f "key2" (vector-ref (car (vector-ref (mt:get-runs-by-patt '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1))

(test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))))
(test #f #t (runs:operate-on 'print "%" "%" "%"))

;; force keepgoing
; (hash-table-set! args:arg-hash "-keepgoing" #t)
(hash-table-set! args:arg-hash "-itempatt" "%")
(hash-table-set! args:arg-hash "-testpatt" "%")
(hash-table-set! args:arg-hash "-target" "ubuntu/r1.2") ;; SYSTEM/RELEASE
(hash-table-set! args:arg-hash "-runname" "testrun")
(test "Setup for a run"       #t (begin (launch:setup-for-run) #t))
(test "Setup for a run"       #t (string? (launch:setup)))

(define *tdb* #f)
(define keyvals #f)
(test "target->keyval" #t (let ((kv (keys:target->keyval keys (args:get-arg "-target"))))
			    (print "keyvals=" kv ", keys=" keys)
			    (set! keyvals kv)(list? keyvals)))

   '("ABORT"     "FAIL"      "FAIL"       "FAIL"       "PASS"    "FAIL"    "ABORT"     "AUTO")))


(test "launch-test" #t
      (string? 
       (file-exists?
	;; (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params)
	(launch-test 30001 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table)))))
	(launch-test 1 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table)))))

;;======================================================================
;; M O R E   R E M O T E   C A L  L S
;;======================================================================

(test #f '("COMPLETED" "PASS")
      (begin
	(rmt:set-tests-state-status 1 '("rollup") "COMPLETED" "AUTO" "COMPLETED" "PASS")
	(get-state-status 1 "rollup" "")))
(test #f #t (rmt:top-test-set-per-pf-counts 1 "rollup"))

;;======================================================================
;; T E S T   I T E M M A P
;;======================================================================

(test #f "a/b/c"       (db:multi-pattern-apply   "d/e/f" "d a\ne b\nf c"))
(test #f "blah/foo/bar/baz" (db:convert-test-itempath "blah/baz/bar/foo" "^([^/]+)/([^/]+)/([^/]+)$ \\3/\\2/\\1"))
(define itemmaps (alist->hash-table
		  '(("test1" "ghi def")
		    ("test2" ".*/")
		    ("test3" ".*/ some/"))))

(test #f #t (db:compare-itempaths "abc/def/123" "abc/ghi/123" "ghi def"))
(test #f #f (db:compare-itempaths "some/5" "item/5" ".*/"))
(test #f #t (db:compare-itempaths "some/5" "item/5" ".*/ some/"))
(test #f #t (db:compare-itempaths "test1" "abc/def/123" "abc/ghi/123" itemmaps))
(test #f #f (db:compare-itempaths "test2" "some/5" "item/5" ".*/" itemmaps))
(test #f #t (db:compare-itempaths "test3" "some/5" "item/5" ".*/ some/" itemmaps))

(test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(toplevel)  itemmap: ".*/" "/"))
(test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(normal)    itemmap: ".*/" "/"))
(test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(itemmatch) itemmap: ".*/" "/"))
(test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(itemwait)  itemmap: ".*/" "/"))

(exit 1)