Megatest

# compiled import files
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)

%.import.o : %.import.scm
	csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o

mofiles/%.o : %.scm
	mkdir -p mofiles
	@mkdir -p mofiles
	csc $(CSCOPTS) -J -c $< -o mofiles/$*.o

# module dependencies
mofiles/apimod.o : mofiles/commonmod.o
mofiles/apimod.o : mofiles/servermod.o
mofiles/apimod.o : mofiles/tasksmod.o
mofiles/archivemod.o : mofiles/launchmod.o

    (lambda (p)
      (let loop ((line (read-line p))
                 (result '()))
        (if (eof-object? line)
            (reverse result)
            (loop (read-line p) (cons line result)))))))

;; timeout is hms string: 1h 5m 3s, default is 1 minute
;; timeout is hms string: 1h 5m 3s, default is 10 minutes
;;
(define (server:expiration-timeout)
  (let ((tmo (configf:lookup *configdat* "server" "timeout")))
    (if (and (string? tmo)
	     (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
        (* 3600 (string->number tmo))
	60)))
	600))) ;; default is ten minutes

(define (runs:get-mt-env-alist run-id runname target testname itempath)
  ;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
  `(("MT_TEST_NAME"     . ,testname)
    
    ("MT_ITEMPATH"      . ,itempath)

#!/bin/bash

(killall mtest -v;sleep 1;killall mtest -v -9;rm tests/simplerun/logs/*;rm tests/basicserver.log) &
ck5 make install &&
ck5 make -j install &&
wait  &&
ck5 make unit

     ;; Server? Start up here.
     ;;
     (if (args:get-arg "-server")
	 (if  (not (args:get-arg "-db"))
	      (debug:print 0 *default-log-port* "ERROR: -db required to start server")
	      (let ((tl        (launch:setup))
		    (dbname    (args:get-arg "-db"))) ;; transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
		(rmt:launch dbname)
		(rmt:server-launch dbname)
		(set! *didsomething* #t))))
	 
     ;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
     ;; a specific Megatest area. Detail are being hashed out and this may change.
     ;;
     (if (args:get-arg "-adjutant")
         (begin

	     (< (current-seconds) (rmt:conn-expires conn)))
	conn
	#f)))

(define (rmt:find-main-server apath dbname)
  (let* ((pktsdir     (get-pkts-dir apath))
	 (all-srvpkts (get-all-server-pkts pktsdir *srvpktspec*))
	 (dbpath      (conc apath "/" dbname))
	 (viable-srvs (get-viable-servers all-srvpkts dbpath)))
    (get-the-server viable-srvs)))
	 ;; (dbpath      (conc apath "/" dbname))
	 (viable-srvs (get-viable-servers all-srvpkts dbname)))
    (get-the-server apath viable-srvs)))

;; looks for a connection to main
;; connections for other servers happens by requesting from main
;;
(define (rmt:open-main-connection remote apath)
  (let* ((dbname         (db:run-id->dbname #f))
	 (the-srv        (rmt:find-main-server apath dbname))
	 (start-main-srv (lambda ()
			   ;; srv not ready, delay a little and try again
			   (api:run-server-process apath dbname)
			   (thread-sleep! 2)
			   (thread-sleep! 4)
			   (rmt:open-main-connection remote apath) ;; TODO: Add limit to number of tries
			   )))
    (if the-srv ;; yes, we have a server, now try connecting to it
	(let* ((srv-addr (server-address the-srv))
	       (ipaddr   (alist-ref 'ipaddr the-srv))
	       (port     (alist-ref 'port   the-srv))
	       (fullpath (db:dbname->path apath dbname))

	      res))
	;; no conn yet, start it up
	(begin
	  (rmt:general-open-connection remote apath dbname)
	  (rmt:send-receive-real remote apath dbname rid cmd params)))))

;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future
;; sometime in the future.
;;
;; Purpose - call the main.db server and request a server be started
;; for the given area path and dbname
;;
(define (rmt:send-receive-server-start remote apath dbname)
  (let* ((conn (rmt:get-connection remote apath dbname)))
    (assert conn "FATAL: Unable to connect to db "apath"/"dbname)
    (let* (;; (host    (rmt:conn-ipaddr conn))
	   ;; (port    (rmt:conn-port   conn))
	   ;; (payload (sexpr->string params))

	  (loop (cdr tail)
		(if (equal? dbpath (alist-ref 'dbpath spkt))
		    (cons spkt res)
		    res))))))

;; from viable servers get one that is alive and ready
;;
(define (get-the-server serv-pkts)
(define (get-the-server apath serv-pkts)
  (let loop ((tail serv-pkts))
    (if (null? tail)
	#f
	(let* ((spkt  (car tail))
	       (host  (alist-ref 'ipaddr spkt))
	       (port  (alist-ref 'port spkt))
	       (dbpth (alist-ref 'dbpath spkt))
	       (addr  (server-address spkt)))
	  (if (server-ready? host port dbpth)
	  (if (server-ready? host port (conc apath"/"dbpth))
	      spkt
	      (loop (cdr tail)))))))

;; am I the "first" in line server? I.e. my D card is smallest
;; use Z card as tie breaker
;;
(define (get-best-candidate serv-pkts dbpath)

	     (tries 0))
    ;; first we verify port and interface, update *server-info* in need be.
    (cond
     ((> tries num-tries-allowed)
      (debug:print 0 *default-log-port* "http-transport:keep-running, giving up after trying for several minutes.")
      (exit 1))
     ((not *server-info*)
      (thread-sleep! 1.5)
      (thread-sleep! 0.25)
      (loop *server-info* (+ tries 1)))
     ((not sdat)
      (debug:print 0 *default-log-port* "http-transport:keep-running, impossible, should never get here.")
      (thread-sleep! 1.5)
      (debug:print 0 *default-log-port* "http-transport:keep-running, still no interface, tries="tries)
      (thread-sleep! 0.25)
      (loop *server-info* (+ tries 1)))
     ((or (not (equal? (servdat-host sdat)(servdat-host *server-info*)))
	  (not (equal? (servdat-port sdat)(servdat-port *server-info*))))
      (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info")
      (thread-sleep! 1.5)
      (thread-sleep! 0.25)
      (loop *server-info* (+ tries 1)))
     (else
      (if (not *server-id*)(set! *server-id* (server:mk-signature)))
      (debug:print 0 *default-log-port*
		   "SERVER STARTED: " (servdat-host *server-info*)
		   ":" (servdat-port *server-info*)
		   " AT " (current-seconds) " server-id: " *server-id*)

;; Call this to start the actual server
;;
;; all routes though here end in exit ...
;;
;; This is the point at which servers are started
;;
(define (rmt:launch dbname)
(define (rmt:server-launch dbname)
  ;;(let* ((tmp-area            (common:get-db-tmp-area))
  ;;       (server-start        (conc tmp-area "/.server-start"))
  ;;       (server-started      (conc tmp-area "/.server-started"))
  ;;       (start-time          (common:lazy-modification-time server-start))
  ;;       (started-time        (common:lazy-modification-time server-started))
  ;;       (server-starting     (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting
  ;;       (start-time-old      (> (- (current-seconds) start-time) 5))

(import rmtmod trace http-client apimod dbmod)
(trace-call-sites #t)
(trace
 ;; db:get-dbdat
 ;; rmt:find-main-server
 ;; rmt:send-receive-real
 ;; sexpr->string
;; server-ready?
;; rmt:register-server
;; rmt:open-main-connection
;; rmt:find-main-server
;; get-all-server-pkts
;; get-viable-servers
;; get-best-candidate
;; api:run-server-process
 )

(test #f #t (rmt:remote? (let ((r (make-rmt:remote)))
			   (set! *rmt:remote* r)
			   r)))
(test #f #f (rmt:get-connection *rmt:remote* *toppath* ".db/main.db"))
(test #f #f (rmt:find-main-server *toppath* ".db/main.db"))
(test #f #t (rmt:open-main-connection *rmt:remote* *toppath*))
(pp (hash-table->alist (rmt:remote-conns *rmt:remote*)))
(test #f #t (rmt:conn? (rmt:get-connection *rmt:remote* *toppath* ".db/main.db")))

(define *main*  (rmt:get-connection *rmt:remote* *toppath* ".db/main.db"))

(for-each (lambda (tdat)
	    (test #f tdat (loop-test (rmt:conn-ipaddr *main*)
				     (rmt:conn-port *main*) tdat)))
	  (list 'a
		'(a "b" 123 1.23 )))
(test #f #t (number? (rmt:send-receive 'ping #f 'hello)))
(trace
 rmt:register-server
 )

(define *db* (db:setup #f))
(test #f 'server-started (api:execute-requests *db* 'get-server (list *toppath* ".db/1.db")))
(set! *dbstruct-db* #f)
(test #f 'server-started (rmt:general-open-connection *rmt:remote* *toppath* ".db/1.db"))
(thread-sleep! 2)
(test #f 'server-started (rmt:general-open-connection *rmt:remote* *toppath* ".db/1.db"))